SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
pctrdinfo.f
Go to the documentation of this file.
1 SUBROUTINE pctrdinfo( SUMMRY, NOUT, UPLO, 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 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 IF( nmat.GT.10 )
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 IF( nnb.GT.10 )
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 IF( ngrids.GT.10 )
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 IF( ngrids.GT.10 )
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 IF( nprocs.LT.1 )
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 IF( work( 4 ).EQ.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 IF( nout.NE.6 .AND. nout.NE.0 )
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*
393 END
icopy
subroutine icopy(n, sx, incx, sy, incy)
Definition pblastst.f:1525
max
#define max(A, B)
Definition pcgemr.c:180
min
#define min(A, B)
Definition pcgemr.c:181
pctrdinfo
subroutine pctrdinfo(summry, nout, uplo, nmat, nval, ldnval, nnb, nbval, ldnbval, ngrids, pval, ldpval, qval, ldqval, thresh, work, iam, nprocs)
Definition pctrdinfo.f:4