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