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