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