OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
psinvinfo.f File Reference

Go to the source code of this file.

Functions/Subroutines

subroutine psinvinfo (summry, nout, nmtyp, mattyp, ldmtyp, nmat, nval, ldnval, nnb, nbval, ldnbval, ngrids, pval, ldpval, qval, ldqval, thresh, work, iam, nprocs)

Function/Subroutine Documentation

◆ psinvinfo()

subroutine psinvinfo ( character*( * ) summry,
integer nout,
integer nmtyp,
character*3, dimension( ldmtyp ) mattyp,
integer ldmtyp,
integer nmat,
integer, dimension( ldnval ) nval,
integer ldnval,
integer nnb,
integer, dimension( ldnbval ) nbval,
integer ldnbval,
integer ngrids,
integer, dimension( ldpval ) pval,
integer ldpval,
integer, dimension( ldqval ) qval,
integer ldqval,
real thresh,
integer, dimension( * ) work,
integer iam,
integer nprocs )

Definition at line 1 of file psinvinfo.f.

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 INTEGER IAM, LDMTYP, LDNBVAL, LDNVAL, LDPVAL, LDQVAL,
13 $ NGRIDS, NMAT, NMTYP, NNB, NOUT, NPROCS
14 REAL THRESH
15* ..
16* .. Array Arguments ..
17 CHARACTER*3 MATTYP( LDMTYP )
18 CHARACTER*( * ) SUMMRY
19 INTEGER NBVAL( LDNBVAL ), NVAL( LDNVAL ),
20 $ PVAL( LDPVAL ), QVAL( LDQVAL ), WORK( * )
21* ..
22*
23* Purpose
24* =======
25*
26* PSINVINFO gets needed startup information for matrix inversion
27* tests 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, ouput to screen,
38* NOUT = 0, output to stderr. Only defined for process 0.
39*
40* NMTYP (global output) INTEGER
41* The number of different matrix types to be tested.
42*
43* MATTYP (global output) CHARACTER*3 array of dimension of LDMTYP,
44* The types of matrix to be generated:
45* if MATTYP(i) = 'GEN' then GENeral matrix,
46* if MATTYP(i) = 'UTR' then Upper TRiangular matrix,
47* if MATTYP(i) = 'LTR' then Lower TRiangular matrix,
48* if MATTYP(i) = 'UPD' then (Upper) symmetric Pos. Definite,
49* if MATTYP(i) = 'LPD' then (Lower) symmetric Pos. Definite,
50*
51* LDMTYP (global input) INTEGER
52* The maximum number of different matrix types to be tested.
53* LDMTYP >= NMTYP.
54*
55* NMAT (global output) INTEGER
56* The number of different values that can be used for N.
57*
58* NVAL (global output) INTEGER array, dimension (LDNVAL)
59* The values of N (number of columns in matrix) to run the
60* code with.
61*
62* LDNVAL (global input) INTEGER
63* The maximum number of different values that can be used for
64* N, LDNVAL >= NMAT.
65*
66* NNB (global output) INTEGER
67* The number of different values that can be used for NB.
68*
69* NBVAL (global output) INTEGER array, dimension (LDNBVAL)
70* The values of NB (blocksize) to run the code with.
71*
72* LDNBVAL (global input) INTEGER
73* The maximum number of different values that can be used for
74* NB, LDNBVAL >= NNB.
75*
76* NGRIDS (global output) INTEGER
77* The number of different values that can be used for P & Q.
78*
79* PVAL (global output) INTEGER array, dimension (LDPVAL)
80* The values of P (number of process rows) to run the code
81* with.
82*
83* LDPVAL (global input) INTEGER
84* The maximum number of different values that can be used for
85* P, LDPVAL >= NGRIDS.
86*
87* QVAL (global output) INTEGER array, dimension (LDQVAL)
88* The values of Q (number of process columns) to run the code
89* with.
90*
91* LDQVAL (global input) INTEGER
92* The maximum number of different values that can be used for
93* Q, LDQVAL >= NGRIDS.
94*
95* THRESH (global output) REAL
96* Indicates what error checks shall be run and printed out:
97* = 0 : Perform no error checking
98* > 0 : report all residuals greater than THRESH.
99*
100* WORK (local workspace) INTEGER array of dimension >=
101* MAX( 4, LDMTYP+LDNVAL+LDNBVAL+LDPVAL+LDQVAL ). Used to pack
102* all input arrays in order to send info in one message.
103*
104* IAM (local input) INTEGER
105* My process number.
106*
107* NPROCS (global input) INTEGER
108* The total number of processes.
109*
110* ======================================================================
111*
112* Note: For packing the information we assumed that the length in bytes
113* ===== of an integer is equal to the length in bytes of a real single
114* precision.
115*
116* ======================================================================
117*
118* .. Parameters ..
119 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
120 $ LLD_, MB_, M_, NB_, N_, RSRC_
121 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
122 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
123 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
124 INTEGER NIN
125 parameter( nin = 11 )
126* ..
127* .. Local Scalars ..
128 CHARACTER*79 USRINFO
129 INTEGER I, ICTXT, K
130 REAL EPS
131* ..
132* .. External Subroutines ..
133 EXTERNAL blacs_abort, blacs_get, blacs_gridexit,
134 $ blacs_gridinit, blacs_setup, icopy, igebr2d,
135 $ igebs2d, sgebr2d, sgebs2d
136* ..
137* .. External Functions ..
138 LOGICAL LSAMEN
139 REAL PSLAMCH
140 EXTERNAL lsamen, pslamch
141* ..
142* .. Intrinsic Functions ..
143 INTRINSIC max, min
144* ..
145* .. Executable Statements ..
146*
147* Process 0 reads the input data, broadcasts to other processes and
148* writes needed information to NOUT
149*
150 IF( iam.EQ.0 ) THEN
151*
152* Open file and skip data file header
153*
154 OPEN( nin, file='INV.dat', status='OLD' )
155 READ( nin, fmt = * ) summry
156 summry = ' '
157*
158* Read in user-supplied info about machine type, compiler, etc.
159*
160 READ( nin, fmt = 9999 ) usrinfo
161*
162* Read name and unit number for summary output file
163*
164 READ( nin, fmt = * ) summry
165 READ( nin, fmt = * ) nout
166 IF( nout.NE.0 .AND. nout.NE.6 )
167 $ OPEN( nout, file = summry, status = 'UNKNOWN' )
168*
169* Read and check the parameter values for the tests.
170*
171* Get the matrix types to be tested
172*
173 READ( nin, fmt = * ) nmtyp
174 IF( nmtyp.LT.1 .OR. nmtyp.GT.ldmtyp ) THEN
175 WRITE( nout, fmt = 9994 ) 'nb of matrix types', ldmtyp
176 GO TO 40
177 END IF
178 READ( nin, fmt = * ) ( mattyp( i ), i = 1, nmtyp )
179*
180* Get number of matrices and their dimensions
181*
182 READ( nin, fmt = * ) nmat
183 IF( nmat.LT.1 .OR. nmat.GT.ldnval ) THEN
184 WRITE( nout, fmt = 9994 ) 'N', ldnval
185 GO TO 40
186 END IF
187 READ( nin, fmt = * ) ( nval( i ), i = 1, nmat )
188*
189* Get values of NB
190*
191 READ( nin, fmt = * ) nnb
192 IF( nnb.LT.1 .OR. nnb.GT.ldnbval ) THEN
193 WRITE( nout, fmt = 9994 ) 'NB', ldnbval
194 GO TO 40
195 END IF
196 READ( nin, fmt = * ) ( nbval( i ), i = 1, nnb )
197*
198* Get number of grids
199*
200 READ( nin, fmt = * ) ngrids
201 IF( ngrids.LT.1 .OR. ngrids.GT.ldpval ) THEN
202 WRITE( nout, fmt = 9994 ) 'Grids', ldpval
203 GO TO 40
204 ELSE IF( ngrids.GT.ldqval ) THEN
205 WRITE( nout, fmt = 9994 ) 'Grids', ldqval
206 GO TO 40
207 END IF
208*
209* Get values of P and Q
210*
211 READ( nin, fmt = * ) ( pval( i ), i = 1, ngrids )
212 READ( nin, fmt = * ) ( qval( i ), i = 1, ngrids )
213*
214* Get level of checking
215*
216 READ( nin, fmt = * ) thresh
217*
218* Close input file
219*
220 CLOSE( nin )
221*
222* For pvm only: if virtual machine not set up, allocate it and
223* spawn the correct number of processes.
224*
225 IF( nprocs.LT.1 ) THEN
226 nprocs = 0
227 DO 10 i = 1, ngrids
228 nprocs = max( nprocs, pval( i ) * qval( i ) )
229 10 CONTINUE
230 CALL blacs_setup( iam, nprocs )
231 END IF
232*
233* Temporarily define blacs grid to include all processes so
234* information can be broadcast to all processes
235*
236 CALL blacs_get( -1, 0, ictxt )
237 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
238*
239* Compute machine epsilon
240*
241 eps = pslamch( ictxt, 'eps' )
242*
243* Pack information arrays and broadcast
244*
245 CALL sgebs2d( ictxt, 'All', ' ', 1, 1, thresh, 1 )
246 work( 1 ) = nmat
247 work( 2 ) = nnb
248 work( 3 ) = ngrids
249 work( 4 ) = nmtyp
250 CALL igebs2d( ictxt, 'All', ' ', 4, 1, work, 4 )
251*
252 i = 1
253 DO 20 k = 1, nmtyp
254 IF( lsamen( 3, mattyp( k ), 'GEN' ) ) THEN
255 work( i ) = 1
256 i = i + 1
257 ELSE IF( lsamen( 3, mattyp( k ), 'UTR' ) ) THEN
258 work( i ) = 2
259 i = i + 1
260 ELSE IF( lsamen( 3, mattyp( k ), 'LTR' ) ) THEN
261 work( i ) = 3
262 i = i + 1
263 ELSE IF( lsamen( 3, mattyp( k ), 'UPD' ) ) THEN
264 work( i ) = 4
265 i = i + 1
266 ELSE IF( lsamen( 3, mattyp( k ), 'LPD' ) ) THEN
267 work( i ) = 5
268 i = i + 1
269 END IF
270 20 CONTINUE
271*
272 CALL icopy( nmat, nval, 1, work( i ), 1 )
273 i = i + nmat
274 CALL icopy( nnb, nbval, 1, work( i ), 1 )
275 i = i + nnb
276 CALL icopy( ngrids, pval, 1, work( i ), 1 )
277 i = i + ngrids
278 CALL icopy( ngrids, qval, 1, work( i ), 1 )
279 i = i + ngrids - 1
280 CALL igebs2d( ictxt, 'All', ' ', i, 1, work, i )
281*
282* regurgitate input
283*
284 WRITE( nout, fmt = 9999 )
285 $ 'SCALAPACK Matrix Inversion routines.'
286 WRITE( nout, fmt = 9999 ) usrinfo
287 WRITE( nout, fmt = * )
288 WRITE( nout, fmt = 9999 )
289 $ 'Tests of the parallel '//
290 $ 'real single precision Matrix Inversion '//
291 $ 'routines.'
292 WRITE( nout, fmt = 9999 )
293 $ 'The following scaled residual '//
294 $ 'checks will be computed:'
295 WRITE( nout, fmt = 9999 )
296 $ ' Inverse residual = ||inv(A)*A - I|| '//
297 $ '/ (||A|| * eps * N)'
298 WRITE( nout, fmt = 9999 )
299 $ 'the matrix a is randomly '//
300 $ 'generated for each test.'
301 WRITE( NOUT, FMT = * )
302 WRITE( NOUT, FMT = 9999 )
303 $ 'an explanation of the input/output '//
304 $ 'parameters follows:'
305 WRITE( NOUT, FMT = 9999 )
306 $ 'time : indicates whether wall or '//
307 $ 'cpu time was used.'
308*
309 WRITE( NOUT, FMT = 9999 )
310 $ 'n : the number of rows and columns '//
311 $ 'of the matrix a.'
312 WRITE( NOUT, FMT = 9999 )
313 $ 'nb : the size of the square blocks'//
314 $ ' the matrix a is split into.'
315 WRITE( NOUT, FMT = 9999 )
316 $ 'p : the number of process rows.'
317 WRITE( NOUT, FMT = 9999 )
318 $ 'q : the number of process columns.'
319 WRITE( NOUT, FMT = 9999 )
320 $ 'thresh : If a residual value is less '//
321 $ 'than thresh, check is flagged as passed.'
322 WRITE( NOUT, FMT = 9999 )
323 $ 'fct time : time in seconds to factor the'//
324 $ ' matrix, if needed.'
325 WRITE( NOUT, FMT = 9999 )
326 $ 'inv time : time in seconds to inverse the'//
327 $ ' matrix.'
328 WRITE( NOUT, FMT = 9999 )
329 $ 'mflops : rate of execution for factor '//
330 $ 'and inverse.'
331 WRITE( NOUT, FMT = * )
332 WRITE( NOUT, FMT = 9999 )
333 $ 'the following parameter values will be used:'
334 WRITE( NOUT, FMT = 9996 )
335 $ 'n ', ( NVAL( I ), I = 1, MIN( NMAT, 10 ) )
336.GT. IF( NMAT10 )
337 $ WRITE( NOUT, FMT = 9997 ) ( NVAL( I ), I = 11, NMAT )
338 WRITE( NOUT, FMT = 9996 )
339 $ 'nb ', ( NBVAL( I ), I = 1, MIN( NNB, 10 ) )
340.GT. IF( NNB10 )
341 $ WRITE( NOUT, FMT = 9997 ) ( NBVAL( I ), I = 11, NNB )
342 WRITE( NOUT, FMT = 9996 )
343 $ 'p ', ( PVAL( I ), I = 1, MIN( NGRIDS, 10 ) )
344.GT. IF( NGRIDS10 )
345 $ WRITE( NOUT, FMT = 9997) ( PVAL( I ), I = 11, NGRIDS )
346 WRITE( NOUT, FMT = 9996 )
347 $ 'q ', ( QVAL( I ), I = 1, MIN( NGRIDS, 10 ) )
348.GT. IF( NGRIDS10 )
349 $ WRITE( NOUT, FMT = 9997 ) ( QVAL( I ), I = 11, NGRIDS )
350 WRITE( NOUT, FMT = 9995 ) EPS
351 WRITE( NOUT, FMT = 9998 ) THRESH
352*
353 ELSE
354*
355* If in pvm, must participate setting up virtual machine
356*
357.LT. IF( NPROCS1 )
358 $ CALL BLACS_SETUP( IAM, NPROCS )
359*
360* Temporarily define blacs grid to include all processes so
361* all processes have needed startup information
362*
363 CALL BLACS_GET( -1, 0, ICTXT )
364 CALL BLACS_GRIDINIT( ICTXT, 'row-major', 1, NPROCS )
365*
366* Compute machine epsilon
367*
368 EPS = PSLAMCH( ICTXT, 'eps' )
369*
370 CALL SGEBR2D( ICTXT, 'all', ' ', 1, 1, THRESH, 1, 0, 0 )
371 CALL IGEBR2D( ICTXT, 'all', ' ', 4, 1, WORK, 4, 0, 0 )
372 NMAT = WORK( 1 )
373 NNB = WORK( 2 )
374 NGRIDS = WORK( 3 )
375 NMTYP = WORK( 4 )
376*
377 I = NMTYP+NMAT+NNB+2*NGRIDS
378 CALL IGEBR2D( ICTXT, 'all', ' ', i, 1, work, i, 0, 0 )
379*
380 DO 30 k = 1, nmtyp
381 IF( work( k ).EQ.1 ) THEN
382 mattyp( k ) = 'GEN'
383 ELSE IF( work( k ).EQ.2 ) THEN
384 mattyp( k ) = 'UTR'
385 ELSE IF( work( k ).EQ.3 ) THEN
386 mattyp( k ) = 'LTR'
387 ELSE IF( work( k ).EQ.4 ) THEN
388 mattyp( k ) = 'UPD'
389 ELSE IF( work( k ).EQ.5 ) THEN
390 mattyp( k ) = 'LPD'
391 END IF
392 30 CONTINUE
393*
394 i = nmtyp + 1
395 CALL icopy( nmat, work( i ), 1, nval, 1 )
396 i = i + nmat
397 CALL icopy( nnb, work( i ), 1, nbval, 1 )
398 i = i + nnb
399 CALL icopy( ngrids, work( i ), 1, pval, 1 )
400 i = i + ngrids
401 CALL icopy( ngrids, work( i ), 1, qval, 1 )
402*
403 END IF
404*
405 CALL blacs_gridexit( ictxt )
406*
407 RETURN
408*
409 40 WRITE( nout, fmt = 9993 )
410 CLOSE( nin )
411 IF( nout.NE.6 .AND. nout.NE.0 )
412 $ CLOSE( nout )
413 CALL blacs_abort( ictxt, 1 )
414*
415 stop
416*
417 9999 FORMAT( a )
418 9998 FORMAT( 'Routines pass computational tests if scaled residual ',
419 $ 'is less than ', g12.5 )
420 9997 FORMAT( ' ', 10i6 )
421 9996 FORMAT( 2x, a5, ' : ', 10i6 )
422 9995 FORMAT( 'Relative machine precision (eps) is taken to be ',
423 $ e18.6 )
424 9994 FORMAT( ' Number of values of ',5a, ' is less than 1 or greater ',
425 $ 'than ', i2 )
426 9993 FORMAT( ' Illegal input in file ',40a,'. Aborting run.' )
427*
428* End of PSINVINFO
429*
the
end diagonal values have been computed in the(sparse) matrix id.SOL
lsamen
logical function lsamen(n, ca, cb)
LSAMEN
Definition lsamen.f:74
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
pslamch
real function pslamch(ictxt, cmach)
Definition pcblastst.f:7455
split
void split(mapping_t *, PORD_INT, PORD_INT, PORD_INT, PORD_INT *, PORD_INT *, FLOAT *, PORD_INT)