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

Go to the source code of this file.

Functions/Subroutines

subroutine pctrdinfo (summry, nout, uplo, nmat, nval, ldnval, nnb, nbval, ldnbval, ngrids, pval, ldpval, qval, ldqval, thresh, work, iam, nprocs)

Function/Subroutine Documentation

◆ pctrdinfo()

subroutine pctrdinfo ( character*( * ), dimension(*) summry,
integer nout,
character uplo,
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 pctrdinfo.f.

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