ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
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
max
#define max(A, B)
Definition: pcgemr.c:180
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
icopy
subroutine icopy(N, SX, INCX, SY, INCY)
Definition: pblastst.f:1525
min
#define min(A, B)
Definition: pcgemr.c:181