OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
pcpbinfo.f
Go to the documentation of this file.
1 SUBROUTINE pcpbinfo( 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* PCPBINFO 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 REAL 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 REAL PSLAMCH
169 EXTERNAL LSAME, PSLAMCH
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 IF( nbw.LT.1 .OR. nbw.GT.ldbwval ) THEN
218 WRITE( nout, fmt = 9994 ) 'BW', ldbwval
219 GO TO 20
220 END IF
221 READ( nin, fmt = * ) ( bwval( i ), i = 1, nbw )
222*
223* Get values of NB
224*
225 READ( nin, fmt = * ) nnb
226 IF( nnb.LT.1 .OR. nnb.GT.ldnbval ) THEN
227 WRITE( nout, fmt = 9994 ) 'NB', ldnbval
228 GO TO 20
229 END IF
230 READ( nin, fmt = * ) ( nbval( i ), i = 1, nnb )
231*
232* Get values of NRHS
233*
234 READ( nin, fmt = * ) nnr
235 IF( nnr.LT.1 .OR. nnr.GT.ldnrval ) THEN
236 WRITE( nout, fmt = 9994 ) 'NRHS', ldnrval
237 GO TO 20
238 END IF
239 READ( nin, fmt = * ) ( nrval( i ), i = 1, nnr )
240*
241* Get values of NBRHS
242*
243 READ( nin, fmt = * ) nnbr
244 IF( nnbr.LT.1 .OR. nnbr.GT.ldnbrval ) THEN
245 WRITE( nout, fmt = 9994 ) 'NBRHS', ldnbrval
246 GO TO 20
247 END IF
248 READ( nin, fmt = * ) ( nbrval( i ), i = 1, nnbr )
249*
250* Get number of grids
251*
252 READ( nin, fmt = * ) ngrids
253 IF( ngrids.LT.1 .OR. ngrids.GT.ldpval ) THEN
254 WRITE( nout, fmt = 9994 ) 'Grids', ldpval
255 GO TO 20
256 ELSE IF( ngrids.GT.ldqval ) THEN
257 WRITE( nout, fmt = 9994 ) 'Grids', ldqval
258 GO TO 20
259 END IF
260*
261* Processor grid must be 1D so set PVAL to 1
262 DO 8738 i = 1, ngrids
263 pval( i ) = 1
264 8738 CONTINUE
265*
266* Get values of Q
267*
268 READ( nin, fmt = * ) ( qval( i ), i = 1, ngrids )
269*
270* Get level of checking
271*
272 READ( nin, fmt = * ) thresh
273*
274* Close input file
275*
276 CLOSE( nin )
277*
278* For pvm only: if virtual machine not set up, allocate it and
279* spawn the correct number of processes.
280*
281 IF( nprocs.LT.1 ) THEN
282 nprocs = 0
283 DO 10 i = 1, ngrids
284 nprocs = max( nprocs, pval( i )*qval( i ) )
285 10 CONTINUE
286 CALL blacs_setup( iam, nprocs )
287 END IF
288*
289* Temporarily define blacs grid to include all processes so
290* information can be broadcast to all processes.
291*
292 CALL blacs_get( -1, 0, ictxt )
293 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
294*
295* Compute machine epsilon
296*
297 eps = pslamch( ictxt, 'eps' )
298*
299* Pack information arrays and broadcast
300*
301 CALL sgebs2d( ictxt, 'All', ' ', 1, 1, thresh, 1 )
302 i = 1
303 work( i ) = nmat
304 i = i+1
305 work( i ) = nbw
306 i = i+1
307 work( i ) = nnb
308 i = i+1
309 work( i ) = nnr
310 i = i+1
311 work( i ) = nnbr
312 i = i+1
313 work( i ) = ngrids
314 i = i+1
315 IF( lsame( uplo, 'L' ) ) THEN
316 work( i ) = 1
317 ELSE
318 work( i ) = 2
319 END IF
320 i = i+1
321* Send number of elements to be sent
322 CALL igebs2d( ictxt, 'All', ' ', 1, 1, i-1, 1 )
323* Send elements
324 CALL igebs2d( ictxt, 'All', ' ', i-1, 1, work, i-1 )
325*
326 i = 1
327 CALL icopy( nmat, nval, 1, work( i ), 1 )
328 i = i + nmat
329 CALL icopy( nbw, bwval, 1, work( i ), 1 )
330 i = i + nbw
331 CALL icopy( nnb, nbval, 1, work( i ), 1 )
332 i = i + nnb
333 CALL icopy( nnr, nrval, 1, work( i ), 1 )
334 i = i + nnr
335 CALL icopy( nnbr, nbrval, 1, work( i ), 1 )
336 i = i + nnbr
337 CALL icopy( ngrids, pval, 1, work( i ), 1 )
338 i = i + ngrids
339 CALL icopy( ngrids, qval, 1, work( i ), 1 )
340 i = i + ngrids
341 CALL igebs2d( ictxt, 'All', ' ', i-1, 1, work, i-1 )
342*
343* regurgitate input
344*
345 WRITE( nout, fmt = 9999 )
346 $ 'SCALAPACK banded linear systems.'
347 WRITE( nout, fmt = 9999 ) usrinfo
348 WRITE( nout, fmt = * )
349 WRITE( nout, fmt = 9999 )
350 $ 'Tests of the parallel '//
351 $ 'complex single precision band matrix solve '
352 WRITE( nout, fmt = 9999 )
353 $ 'The following scaled residual '//
354 $ 'checks will be computed:'
355 WRITE( nout, fmt = 9999 )
356 $ ' Solve residual = ||Ax - b|| / '//
357 $ '(||x|| * ||A|| * eps * N)'
358 IF( lsame( uplo, 'L' ) ) THEN
359 WRITE( nout, fmt = 9999 )
360 $ ' Factorization residual = ||A - LL''|| /'//
361 $ ' (||A|| * eps * N)'
362 ELSE
363 WRITE( nout, fmt = 9999 )
364 $ ' Factorization residual = ||A - U''U|| /'//
365 $ ' (||A|| * eps * N)'
366 END IF
367 WRITE( nout, fmt = 9999 )
368 $ 'The matrix A is randomly '//
369 $ 'generated for each test.'
370 WRITE( nout, fmt = * )
371 WRITE( nout, fmt = 9999 )
372 $ 'an explanation of the input/output '//
373 $ 'parameters follows:'
374 WRITE( NOUT, FMT = 9999 )
375 $ 'time : indicates whether wall or '//
376 $ 'cpu time was used.'
377*
378 WRITE( NOUT, FMT = 9999 )
379 $ 'uplo : whether data represents ''upper'//
380 $ ''' or ''lower'' triangular portion of array a.'
381 WRITE( NOUT, FMT = 9999 )
382 $ 'trans : whether solve is to be done with'//
383 $ ' ''transpose'' of matrix a(t,c) or not(n).'
384 WRITE( NOUT, FMT = 9999 )
385 $ 'n : the number of rows and columns '//
386 $ 'in the matrix a.'
387 WRITE( NOUT, FMT = 9999 )
388 $ 'bw : the number of diagonals '//
389 $ 'in the matrix a.'
390 WRITE( NOUT, FMT = 9999 )
391 $ 'nb : the size of the column panels the'//
392 $ ' matrix a is split into. [-1 for default]'
393 WRITE( NOUT, FMT = 9999 )
394 $ 'nrhs : the total number of rhs to solve'//
395 $ ' for.'
396 WRITE( NOUT, FMT = 9999 )
397 $ 'nbrhs : the number of rhs to be put on '//
398 $ 'a column of processes before going'
399 WRITE( NOUT, FMT = 9999 )
400 $ ' on to the next column of processes.'
401 WRITE( NOUT, FMT = 9999 )
402 $ 'p : the number of process rows.'
403 WRITE( NOUT, FMT = 9999 )
404 $ 'q : the number of process columns.'
405 WRITE( NOUT, FMT = 9999 )
406 $ 'thresh : If a residual value is less than'//
407 $ ' thresh, check is flagged as passed'
408 WRITE( NOUT, FMT = 9999 )
409 $ 'fact time: time in seconds to factor the'//
410 $ ' matrix'
411 WRITE( NOUT, FMT = 9999 )
412 $ 'sol time: time in seconds to solve the'//
413 $ ' system.'
414 WRITE( NOUT, FMT = 9999 )
415 $ 'mflops : rate of execution for factor '//
416 $ 'and solve using sequential operation count.'
417 WRITE( NOUT, FMT = 9999 )
418 $ 'mflop2 : rough estimate of speed '//
419 $ 'using actual op count(accurate big p,n).'
420 WRITE( NOUT, FMT = * )
421 WRITE( NOUT, FMT = 9999 )
422 $ 'the following parameter values will be used:'
423 WRITE( NOUT, FMT = 9999 )
424 $ ' uplo : '//UPLO
425 WRITE( NOUT, FMT = 9996 )
426 $ 'n ', ( NVAL(I), I = 1, MIN(NMAT, 10) )
427.GT. IF( NMAT10 )
428 $ WRITE( NOUT, FMT = 9997 ) ( NVAL(I), I = 11, NMAT )
429 WRITE( NOUT, FMT = 9996 )
430 $ 'bw ', ( BWVAL(I), I = 1, MIN(NBW, 10) )
431.GT. IF( NBW10 )
432 $ WRITE( NOUT, FMT = 9997 ) ( BWVAL(I), I = 11, NBW )
433 WRITE( NOUT, FMT = 9996 )
434 $ 'nb ', ( NBVAL(I), I = 1, MIN(NNB, 10) )
435.GT. IF( NNB10 )
436 $ WRITE( NOUT, FMT = 9997 ) ( NBVAL(I), I = 11, NNB )
437 WRITE( NOUT, FMT = 9996 )
438 $ 'nrhs ', ( NRVAL(I), I = 1, MIN(NNR, 10) )
439.GT. IF( NNR10 )
440 $ WRITE( NOUT, FMT = 9997 ) ( NRVAL(I), I = 11, NNR )
441 WRITE( NOUT, FMT = 9996 )
442 $ 'nbrhs', ( NBRVAL(I), I = 1, MIN(NNBR, 10) )
443.GT. IF( NNBR10 )
444 $ WRITE( NOUT, FMT = 9997 ) ( NBRVAL(I), I = 11, NNBR )
445 WRITE( NOUT, FMT = 9996 )
446 $ 'p ', ( PVAL(I), I = 1, MIN(NGRIDS, 10) )
447.GT. IF( NGRIDS10 )
448 $ WRITE( NOUT, FMT = 9997) ( PVAL(I), I = 11, NGRIDS )
449 WRITE( NOUT, FMT = 9996 )
450 $ 'q ', ( QVAL(I), I = 1, MIN(NGRIDS, 10) )
451.GT. IF( NGRIDS10 )
452 $ WRITE( NOUT, FMT = 9997 ) ( QVAL(I), I = 11, NGRIDS )
453 WRITE( NOUT, FMT = * )
454 WRITE( NOUT, FMT = 9995 ) EPS
455 WRITE( NOUT, FMT = 9998 ) THRESH
456*
457 ELSE
458*
459* If in pvm, must participate setting up virtual machine
460*
461.LT. IF( NPROCS1 )
462 $ CALL BLACS_SETUP( IAM, NPROCS )
463*
464* Temporarily define blacs grid to include all processes so
465* all processes have needed startup information
466*
467 CALL BLACS_GET( -1, 0, ICTXT )
468 CALL BLACS_GRIDINIT( ICTXT, 'row-major', 1, NPROCS )
469*
470* Compute machine epsilon
471*
472 EPS = PSLAMCH( ICTXT, 'eps' )
473*
474 CALL SGEBR2D( ICTXT, 'all', ' ', 1, 1, THRESH, 1, 0, 0 )
475 CALL IGEBR2D( ICTXT, 'all', ' ', 1, 1, I, 1, 0, 0 )
476 CALL IGEBR2D( ICTXT, 'all', ' ', i, 1, work, i, 0, 0 )
477 i = 1
478 nmat = work( i )
479 i = i+1
480 nbw = work( i )
481 i = i+1
482 nnb = work( i )
483 i = i+1
484 nnr = work( i )
485 i = i+1
486 nnbr = work( i )
487 i = i+1
488 ngrids = work( i )
489 i = i+1
490 IF( work( i ) .EQ. 1 ) THEN
491 uplo = 'L'
492 ELSE
493 uplo = 'U'
494 END IF
495 i = i+1
496*
497 i = nmat + nbw + nnb + nnr + nnbr + 2*ngrids
498*
499 CALL igebr2d( ictxt, 'All', ' ', 1, i, work, 1, 0, 0 )
500 i = 1
501 CALL icopy( nmat, work( i ), 1, nval, 1 )
502 i = i + nmat
503 CALL icopy( nbw, work( i ), 1, bwval, 1 )
504 i = i + nbw
505 CALL icopy( nnb, work( i ), 1, nbval, 1 )
506 i = i + nnb
507 CALL icopy( nnr, work( i ), 1, nrval, 1 )
508 i = i + nnr
509 CALL icopy( nnbr, work( i ), 1, nbrval, 1 )
510 i = i + nnbr
511 CALL icopy( ngrids, work( i ), 1, pval, 1 )
512 i = i + ngrids
513 CALL icopy( ngrids, work( i ), 1, qval, 1 )
514*
515 END IF
516*
517 CALL blacs_gridexit( ictxt )
518*
519 RETURN
520*
521 20 WRITE( nout, fmt = 9993 )
522 CLOSE( nin )
523 IF( nout.NE.6 .AND. nout.NE.0 )
524 $ CLOSE( nout )
525*
526 CALL blacs_abort( ictxt, 1 )
527 stop
528*
529 9999 FORMAT( a )
530 9998 FORMAT( 'Routines pass computational tests if scaled residual ',
531 $ 'is less than ', g12.5 )
532 9997 FORMAT( ' ', 10i6 )
533 9996 FORMAT( 2x, a5, ': ', 10i6 )
534 9995 FORMAT( 'Relative machine precision (eps) is taken to be ',
535 $ e18.6 )
536 9994 FORMAT( ' Number of values of ',5a, ' is less than 1 or greater ',
537 $ 'than ', i2 )
538 9993 FORMAT( ' Illegal input in file ',40a,'. Aborting run.' )
539*
540* End of PCPBINFO
541*
542 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
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
split
void split(mapping_t *, PORD_INT, PORD_INT, PORD_INT, PORD_INT *, PORD_INT *, FLOAT *, PORD_INT)