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