OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
pdbrdinfo.f
Go to the documentation of this file.
1 SUBROUTINE pdbrdinfo( SUMMRY, NOUT, NMAT, MVAL, LDMVAL, NVAL,
2 $ LDNVAL, NNB, NBVAL, LDNBVAL, NGRIDS, PVAL,
3 $ LDPVAL, QVAL, LDQVAL, THRESH, WORK, IAM,
4 $ NPROCS )
5*
6* -- ScaLAPACK routine (version 1.7) --
7* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
8* and University of California, Berkeley.
9* May 1, 1997
10*
11* .. Scalar Arguments ..
12 CHARACTER*( * ) SUMMRY
13 INTEGER IAM, LDMVAL, LDNBVAL, LDNVAL, LDPVAL,
14 $ LDQVAL, NGRIDS, NMAT, NNB, NPROCS, NOUT
15 REAL THRESH
16* ..
17* .. Array Arguments ..
18 INTEGER MVAL( LDMVAL ), NBVAL( LDNBVAL ),
19 $ NVAL( LDNVAL ), PVAL( LDPVAL ),
20 $ QVAL( LDQVAL ), WORK( * )
21* ..
22*
23* Purpose
24* =======
25*
26* PDBRDINFO get needed startup information for the bidiagonal
27* reduction and transmits it to all processes.
28*
29* Arguments
30* =========
31*
32* SUMMRY (global output) CHARACTER*(*)
33* Name of output (summary) file (if any). Only defined for
34* process 0.
35*
36* NOUT (global output) INTEGER
37* The unit number for output file. NOUT = 6, output to screen,
38* NOUT = 0, output to stderr. Only defined for process 0.
39*
40* NMAT (global output) INTEGER
41* The number of different values that can be used for M & N.
42*
43* MVAL (global output) INTEGER array, dimension (LDMVAL)
44* The values of M (number of rows in matrix) to run the code
45* with.
46*
47* LDMVAL (global input) INTEGER
48* The maximum number of different values that can be used for
49* M. LDMVAL >= NMAT.
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* LDNVAL (global input) INTEGER
56* The maximum number of different values that can be used for
57* N. LDNVAL >= NMAT.
58*
59* NNB (global output) INTEGER
60* The number of different values that can be used for NB.
61*
62* NBVAL (global output) INTEGER array, dimension (LDNBVAL)
63* The values of NB (blocksize) to run the code with.
64*
65* LDNBVAL (global input) INTEGER
66* The maximum number of different values that can be used for
67* NB, LDNBVAL >= NNB.
68*
69* NGRIDS (global output) INTEGER
70* The number of different values that can be used for P & Q.
71*
72* PVAL (global output) INTEGER array, dimension (LDPVAL)
73* The values of P (number of process rows) to run the code
74* with.
75*
76* LDPVAL (global input) INTEGER
77* The maximum number of different values that can be used for
78* P, LDPVAL >= NGRIDS.
79*
80* QVAL (global output) INTEGER array, dimension (LDQVAL)
81* The values of Q (number of process columns) to run the code
82* with.
83*
84* LDQVAL (global input) INTEGER
85* The maximum number of different values that can be used for
86* Q, LDQVAL >= NGRIDS.
87*
88* THRESH (global output) REAL
89* Indicates what error checks shall be run and printed out:
90* = 0 : Perform no error checking
91* > 0 : report all residuals greater than THRESH.
92*
93* WORK (local workspace) INTEGER array, dimension >=
94* MAX( 5, LDMVAL+LDNVAL+LDNBVAL+LDPVAL+LDQVAL ). Used to pack
95* all input arrays in order to send info in one message.
96*
97* IAM (local input) INTEGER
98* My process number.
99*
100* NPROCS (global input) INTEGER
101* The total number of processes.
102*
103* Note
104* ====
105*
106* For packing the information we assumed that the length in bytes of an
107* integer is equal to the length in bytes of a real single precision.
108*
109* =====================================================================
110*
111* .. Parameters ..
112 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
113 $ LLD_, MB_, M_, NB_, N_, RSRC_
114 PARAMETER ( BLOCK_CYCLIC_2D = 1, dlen_ = 9, dtype_ = 1,
115 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
116 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
117 INTEGER NIN
118 PARAMETER ( NIN = 11 )
119* ..
120* .. Local Scalars ..
121 CHARACTER*79 USRINFO
122 INTEGER I, ICTXT
123 DOUBLE PRECISION EPS
124* ..
125* .. External Subroutines ..
126 EXTERNAL blacs_abort, blacs_get, blacs_gridexit,
127 $ blacs_gridinit, blacs_setup, igebr2d, igebs2d,
128 $ scopy
129* ..
130* .. External Functions ..
131 DOUBLE PRECISION PDLAMCH
132 EXTERNAL PDLAMCH
133* ..
134* .. Intrinsic Functions ..
135 INTRINSIC max, min
136* ..
137* .. Executable Statements ..
138*
139* Process 0 reads the input data, broadcasts to other processes and
140* writes needed information to NOUT
141*
142 IF( iam.EQ.0 ) THEN
143*
144* Open file and skip data file header
145*
146 OPEN( unit = nin, file = 'BRD.dat', status = 'OLD' )
147 READ( nin, fmt = * ) summry
148 summry = ' '
149*
150* Read in user-supplied info about machine type, compiler, etc.
151*
152 READ( nin, fmt = 9999 ) usrinfo
153*
154* Read name and unit number for summary output file
155*
156 READ( nin, fmt = * ) summry
157 READ( nin, fmt = * ) nout
158 IF( nout.NE.0 .AND. nout.NE.6 )
159 $ OPEN( unit = nout, file = summry, status = 'UNKNOWN' )
160*
161* Read and check the parameter values for the tests.
162*
163* Get values of M, N
164*
165 READ( nin, fmt = * ) nmat
166 IF( nmat.LT.1. .OR. nmat.GT.ldmval ) THEN
167 WRITE( nout, fmt = 9997 ) 'M', ldmval
168 GO TO 20
169 END IF
170 READ( nin, fmt = * ) ( mval( i ), i = 1, nmat )
171 READ( nin, fmt = * ) ( nval( i ), i = 1, nmat )
172*
173* Get values of NB
174*
175 READ( nin, fmt = * ) nnb
176 IF( nnb.LT.1 .OR. nnb.GT.ldnbval ) THEN
177 WRITE( nout, fmt = 9997 ) 'NB', ldnbval
178 GO TO 20
179 END IF
180 READ( nin, fmt = * ) ( nbval( i ), i = 1, nnb )
181*
182* Get number of grids
183*
184 READ( nin, fmt = * ) ngrids
185 IF( ngrids.LT.1 .OR. ngrids.GT.ldpval ) THEN
186 WRITE( nout, fmt = 9997 ) 'Grids', ldpval
187 GO TO 20
188 ELSE IF( ngrids.GT.ldqval ) THEN
189 WRITE( nout, fmt = 9997 ) 'Grids', ldqval
190 GO TO 20
191 END IF
192*
193* Get values of P and Q
194*
195 READ( nin, fmt = * ) ( pval( i ), i = 1, ngrids )
196 READ( nin, fmt = * ) ( qval( i ), i = 1, ngrids )
197*
198* Get level of checking
199*
200 READ( nin, fmt = * ) thresh
201*
202* Close input file
203*
204 CLOSE( nin )
205*
206* For pvm only: if virtual machine not set up, allocate it and
207* spawn the correct number of processes.
208*
209 IF( nprocs.LT.1 ) THEN
210 nprocs = 0
211 DO 10 i = 1, ngrids
212 nprocs = max( nprocs, pval( i )*qval( i ) )
213 10 CONTINUE
214 CALL blacs_setup( iam, nprocs )
215 END IF
216*
217* Temporarily define blacs grid to include all processes so
218* information can be broadcast to all processes
219*
220 CALL blacs_get( -1, 0, ictxt )
221 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
222*
223* Compute machine epsilon
224*
225 eps = pdlamch( ictxt, 'eps' )
226*
227* Pack information arrays and broadcast
228*
229 CALL sgebs2d( ictxt, 'All', ' ', 1, 1, thresh, 1 )
230*
231 work( 1 ) = nmat
232 work( 2 ) = nnb
233 work( 3 ) = ngrids
234 CALL igebs2d( ictxt, 'All', ' ', 1, 3, work, 1 )
235*
236 i = 1
237 CALL icopy( nmat, mval, 1, work( i ), 1 )
238 i = i + nmat
239 CALL icopy( nmat, nval, 1, work( i ), 1 )
240 i = i + nmat
241 CALL icopy( nnb, nbval, 1, work( i ), 1 )
242 i = i + nnb
243 CALL icopy( ngrids, pval, 1, work( i ), 1 )
244 i = i + ngrids
245 CALL icopy( ngrids, qval, 1, work( i ), 1 )
246 i = i + ngrids - 1
247 CALL igebs2d( ictxt, 'all', ' ', I, 1, WORK, I )
248*
249* regurgitate input
250*
251 WRITE( NOUT, FMT = 9999 )
252 $ 'scalapack bidiagonal reduction'
253 WRITE( NOUT, FMT = 9999 ) USRINFO
254 WRITE( NOUT, FMT = * )
255 WRITE( NOUT, FMT = 9999 )
256 $ 'tests of the parallel '//
257 $ 'real double precision bidiagonal '
258 WRITE( NOUT, FMT = 9999 ) 'reduction routines.'
259 WRITE( NOUT, FMT = 9999 )
260 $ 'The following scaled residual '//
261 $ 'checks will be computed:'
262 WRITE( NOUT, FMT = 9999 )
263 $ ' ||A - Q B P''|| / (||A|| * eps * N)'
264 WRITE( NOUT, FMT = 9999 )
265 $ 'The matrix A is randomly '//
266 $ 'generated for each test.'
267 WRITE( NOUT, FMT = * )
268 WRITE( NOUT, FMT = 9999 )
269 $ 'An explanation of the input/output '//
270 $ 'parameters follows:'
271 WRITE( NOUT, FMT = 9999 )
272 $ 'TIME : Indicates whether WALL or '//
273 $ 'CPU time was used.'
274 WRITE( NOUT, FMT = 9999 )
275 $ 'M : The number of rows '//
276 $ 'of the matrix A.'
277 WRITE( NOUT, FMT = 9999 )
278 $ 'N : The number of columns '//
279 $ 'of the matrix A.'
280 WRITE( NOUT, FMT = 9999 )
281 $ 'NB : The size of the square blocks'//
282 $ ' the matrix A is split into.'
283 WRITE( NOUT, FMT = 9999 )
284 $ 'P : The number of process rows.'
285 WRITE( NOUT, FMT = 9999 )
286 $ 'Q : The number of process columns.'
287 WRITE( NOUT, FMT = 9999 )
288 $ 'THRESH : If a residual value is less'//
289 $ ' than THRESH, CHECK is flagged as PASSED'
290 WRITE( NOUT, FMT = 9999 )
291 $ 'BRD time : Time in seconds to reduce the'//
292 $ ' matrix'
293 WRITE( NOUT, FMT = 9999 )
294 $ 'MFLOPS : Rate of execution for '//
295 $ 'the bidiagonal reduction.'
296 WRITE( NOUT, FMT = * )
297 WRITE( NOUT, FMT = 9999 )
298 $ 'The following parameter values will be used:'
299 WRITE( NOUT, FMT = 9995 )
300 $ 'M ', ( MVAL( I ), I = 1, MIN( NMAT, 10 ) )
301.GT. IF( NMAT10 )
302 $ WRITE( NOUT, FMT = 9994 ) ( MVAL( I ), I = 11, NMAT )
303 WRITE( NOUT, FMT = 9995 )
304 $ 'N ', ( NVAL( I ), I = 1, MIN( NMAT, 10 ) )
305.GT. IF( NMAT10 )
306 $ WRITE( NOUT, FMT = 9994 ) ( NVAL( I ), I = 11, NMAT )
307 WRITE( NOUT, FMT = 9995 )
308 $ 'NB ', ( NBVAL( I ), I = 1, MIN( NNB, 10 ) )
309.GT. IF( NNB10 )
310 $ WRITE( NOUT, FMT = 9994 )( NBVAL( I ), I = 11, NNB )
311 WRITE( NOUT, FMT = 9995 )
312 $ 'P ', ( PVAL( I ), I = 1, MIN( NGRIDS, 10 ) )
313.GT. IF( NGRIDS10 )
314 $ WRITE( NOUT, FMT = 9994 )( PVAL( I ), I = 11, NGRIDS )
315 WRITE( NOUT, FMT = 9995 )
316 $ 'Q ', ( QVAL( I ), I = 1, MIN( NGRIDS, 10 ) )
317.GT. IF( NGRIDS10 )
318 $ WRITE( NOUT, FMT = 9994 )( QVAL( I ), I = 11, NGRIDS )
319 WRITE( NOUT, FMT = 9999 ) ' '
320 WRITE( NOUT, FMT = 9996 ) EPS
321 WRITE( NOUT, FMT = 9993 ) THRESH
322*
323 ELSE
324*
325* If in pvm, must participate setting up virtual machine
326*
327.LT. IF( NPROCS1 )
328 $ CALL BLACS_SETUP( IAM, NPROCS )
329*
330* Temporarily define blacs grid to include all processes so
331* all processes have needed startup information
332*
333 CALL BLACS_GET( -1, 0, ICTXT )
334 CALL BLACS_GRIDINIT( ICTXT, 'Row-major', 1, NPROCS )
335*
336* Compute machine epsilon
337*
338 EPS = PDLAMCH( ICTXT, 'eps' )
339*
340 CALL SGEBR2D( ICTXT, 'All', ' ', 1, 1, THRESH, 1, 0, 0 )
341 CALL IGEBR2D( ICTXT, 'All', ' ', 1, 3, WORK, 1, 0, 0 )
342 NMAT = WORK( 1 )
343 NNB = WORK( 2 )
344 NGRIDS = WORK( 3 )
345*
346 I = 2*NMAT + NNB + 2*NGRIDS
347 CALL IGEBR2D( ICTXT, 'All', ' ', I, 1, WORK, I, 0, 0 )
348 I = 1
349 CALL ICOPY( NMAT, WORK( I ), 1, MVAL, 1 )
350 I = I + NMAT
351 CALL ICOPY( NMAT, WORK( I ), 1, NVAL, 1 )
352 I = I + NMAT
353 CALL ICOPY( NNB, WORK( I ), 1, NBVAL, 1 )
354 I = I + NNB
355 CALL ICOPY( NGRIDS, WORK( I ), 1, PVAL, 1 )
356 I = I + NGRIDS
357 CALL ICOPY( NGRIDS, WORK( I ), 1, QVAL, 1 )
358*
359 END IF
360*
361 CALL BLACS_GRIDEXIT( ICTXT )
362*
363 RETURN
364*
365 20 CONTINUE
366 WRITE( NOUT, FMT = 9998 )
367 CLOSE( NIN )
368.NE..AND..NE. IF( NOUT6 NOUT0 )
369 $ CLOSE( NOUT )
370 CALL BLACS_ABORT( ICTXT, 1 )
371*
372 STOP
373*
374 9999 FORMAT( A )
375 9998 FORMAT( ' Illegal input in file ', 40A, '. Aborting run.' )
376 9997 FORMAT( ' Number of values of ', 5A,
377 $ ' is less than 1 or greater ', 'than ', I2 )
378 9996 FORMAT( 'Relative machine precision (eps) is taken to be ',
379 $ E18.6 )
380 9995 FORMAT( 2X, A5, ': ', 10I6 )
381 9994 FORMAT( ' ', 10I6 )
382 9993 FORMAT( 'Routines pass computational tests if scaled residual is',
383 $ ' less than ', G12.5 )
384*
385* End of PDBRDINFO
386*
387 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
scopy
subroutine scopy(n, sx, incx, sy, incy)
SCOPY
Definition scopy.f:82
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
blacs_gridexit
subroutine blacs_gridexit(cntxt)
Definition mpi.f:762
pdbrdinfo
subroutine pdbrdinfo(summry, nout, nmat, mval, ldmval, nval, ldnval, nnb, nbval, ldnbval, ngrids, pval, ldpval, qval, ldqval, thresh, work, iam, nprocs)
Definition pdbrdinfo.f:5