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