ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pdlltinfo.f
Go to the documentation of this file.
1  SUBROUTINE pdlltinfo( SUMMRY, NOUT, UPLO, NMAT, NVAL, LDNVAL, NNB,
2  $ NBVAL, LDNBVAL, NNR, NRVAL, LDNRVAL, NNBR,
3  $ NBRVAL, LDNBRVAL, NGRIDS, PVAL, LDPVAL,
4  $ QVAL, LDQVAL, THRESH, EST, WORK, IAM,
5  $ NPROCS )
6 *
7 * -- ScaLAPACK routine (version 1.7) --
8 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
9 * and University of California, Berkeley.
10 * May 1, 1997
11 *
12 * .. Scalar Arguments ..
13  LOGICAL EST
14  CHARACTER UPLO
15  CHARACTER*(*) SUMMRY
16  INTEGER IAM, LDNBRVAL, LDNBVAL, LDNRVAL, LDNVAL,
17  $ ldpval, ldqval, ngrids, nmat, nnb, nnbr,
18  $ nprocs, nnr, nout
19  REAL THRESH
20 * ..
21 * .. Array Arguments ..
22  INTEGER NBRVAL( LDNBRVAL ), NBVAL( LDNBVAL ),
23  $ nrval( ldnrval ), nval( ldnval ),
24  $ pval( ldpval ), qval(ldqval), work( * )
25 * ..
26 *
27 * Purpose
28 * =======
29 *
30 * PDLLTINFO get needed startup information for LLt factorization
31 * and transmits it to all processes.
32 *
33 * Arguments
34 * =========
35 *
36 * SUMMRY (global output) CHARACTER*(*)
37 * Name of output (summary) file (if any). Only defined for
38 * process 0.
39 *
40 * NOUT (global output) INTEGER
41 * The unit number for output file. NOUT = 6, ouput to screen,
42 * NOUT = 0, output to stderr. Only defined for process 0.
43 *
44 * UPLO (global output) CHARACTER
45 * Specifies whether the upper or lower triangular part of the
46 * symmetric matrix A is stored.
47 * = 'U': Upper triangular
48 * = 'L': Lower triangular
49 *
50 * NMAT (global output) INTEGER
51 * The number of different values that can be used for N.
52 *
53 * NVAL (global output) INTEGER array, dimension (LDNVAL)
54 * The values of N (number of columns in matrix) to run the
55 * code with.
56 *
57 * LDNVAL (global input) INTEGER
58 * The maximum number of different values that can be used for
59 * N, LDNVAL > = NMAT.
60 *
61 * NNB (global output) INTEGER
62 * The number of different values that can be used for NB.
63 *
64 * NBVAL (global output) INTEGER array, dimension (LDNBVAL)
65 * The values of NB (blocksize) to run the code with.
66 *
67 * LDNBVAL (global input) INTEGER
68 * The maximum number of different values that can be used for
69 * NB, LDNBVAL >= NNB.
70 *
71 * NNR (global output) INTEGER
72 * The number of different values that can be used for NRHS.
73 *
74 * NRVAL (global output) INTEGER array, dimension(LDNRVAL)
75 * The values of NRHS (# of Right Hand Sides) to run the code
76 * with.
77 *
78 * LDNRVAL (global input) INTEGER
79 * The maximum number of different values that can be used for
80 * NRHS, LDNRVAL >= NNR.
81 *
82 * NNBR (global output) INTEGER
83 * The number of different values that can be used for NBRHS.
84 *
85 * NBRVAL (global output) INTEGER array, dimension (LDNBRVAL)
86 * The values of NBRHS (RHS blocksize) to run the code with.
87 *
88 * LDNBRVAL (global input) INTEGER
89 * The maximum number of different values that can be used for
90 * NBRHS, LDNBRVAL >= NBRVAL.
91 *
92 * NGRIDS (global output) INTEGER
93 * The number of different values that can be used for P & Q.
94 *
95 * PVAL (global output) INTEGER array, dimension (LDPVAL)
96 * The values of P (number of process rows) to run the code
97 * with.
98 *
99 * LDPVAL (global input) INTEGER
100 * The maximum number of different values that can be used for
101 * P, LDPVAL >= NGRIDS.
102 *
103 * QVAL (global output) INTEGER array, dimension (LDQVAL)
104 * The values of Q (number of process columns) to run the code
105 * with.
106 *
107 * LDQVAL (global input) INTEGER
108 * The maximum number of different values that can be used for
109 * Q, LDQVAL >= NGRIDS.
110 *
111 * THRESH (global output) REAL
112 * Indicates what error checks shall be run and printed out:
113 * = 0 : Perform no error checking
114 * > 0 : report all residuals greater than THRESH, perform
115 * factor check only if solve check fails
116 *
117 * EST (global output) LOGICAL
118 * Flag indicating if condition estimation and iterative
119 * refinement routines are to be exercised.
120 *
121 * WORK (local workspace) INTEGER array of dimension >=
122 * MAX( 7, LDNVAL+LDNBVAL+LDNRVAL+LDNBRVAL+LDPVAL+LDQVAL)
123 * Used to pack input arrays in order to send info in one
124 * message.
125 *
126 * IAM (local input) INTEGER
127 * My process number.
128 *
129 * NPROCS (global input) INTEGER
130 * The total number of processes.
131 *
132 * ======================================================================
133 *
134 * Note: For packing the information we assumed that the length in bytes
135 * ===== of an integer is equal to the length in bytes of a real single
136 * precision.
137 *
138 * ======================================================================
139 *
140 * .. Parameters ..
141  INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
142  $ LLD_, MB_, M_, NB_, N_, RSRC_
143  PARAMETER ( BLOCK_CYCLIC_2D = 1, dlen_ = 9, dtype_ = 1,
144  $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
145  $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
146  INTEGER NIN
147  parameter( nin = 11 )
148 * ..
149 * .. Local Scalars ..
150  INTEGER I, ICTXT
151  CHARACTER*79 USRINFO
152  DOUBLE PRECISION EPS
153 * ..
154 * .. External Subroutines ..
155  EXTERNAL blacs_abort, blacs_get, blacs_gridexit,
156  $ blacs_gridinit, blacs_setup, icopy, igebr2d,
157  $ igebs2d, sgebr2d, sgebs2d
158 * ..
159 * .. External Functions ..
160  LOGICAL LSAME
161  DOUBLE PRECISION PDLAMCH
162  EXTERNAL LSAME, PDLAMCH
163 * ..
164 * .. Intrinsic Functions ..
165  INTRINSIC max, min
166 * ..
167 * .. Executable Statements ..
168 *
169 * Process 0 reads the input data, broadcasts to other processes and
170 * writes needed information to NOUT
171 *
172  IF( iam.EQ.0 ) THEN
173 *
174 * Open file and skip data file header
175 *
176  OPEN( nin, file = 'LLT.dat', status = 'OLD' )
177  READ( nin, fmt = * ) summry
178  summry = ' '
179 *
180 * Read in user-supplied info about machine type, compiler, etc.
181 *
182  READ( nin, fmt = 9999 ) usrinfo
183 *
184 * Read name and unit number for summary output file
185 *
186  READ( nin, fmt = * ) summry
187  READ( nin, fmt = * ) nout
188  IF( nout.NE.0 .AND. nout.NE.6 )
189  $ OPEN( nout, file = summry, status = 'UNKNOWN' )
190 *
191 * Read and check the parameter values for the tests.
192 *
193 * Get UPLO
194 *
195  READ( nin, fmt = * ) uplo
196 *
197 * Get number of matrices and their dimensions
198 *
199  READ( nin, fmt = * ) nmat
200  IF( nmat.LT.1 .OR. nmat.GT.ldnval ) THEN
201  WRITE( nout, fmt = 9994 ) 'N', ldnval
202  GO TO 20
203  END IF
204  READ( nin, fmt = * ) ( nval( i ), i = 1, nmat )
205 *
206 * Get values of NB
207 *
208  READ( nin, fmt = * ) nnb
209  IF( nnb.LT.1 .OR. nnb.GT.ldnbval ) THEN
210  WRITE( nout, fmt = 9994 ) 'NB', ldnbval
211  GO TO 20
212  END IF
213  READ( nin, fmt = * ) ( nbval( i ), i = 1, nnb )
214 *
215 * Get values of NRHS
216 *
217  READ( nin, fmt = * ) nnr
218  IF( nnr.LT.1 .OR. nnr.GT.ldnrval ) THEN
219  WRITE( nout, fmt = 9994 ) 'NRHS', ldnrval
220  GO TO 20
221  END IF
222  READ( nin, fmt = * ) ( nrval( i ), i = 1, nnr )
223 *
224 * Get values of NBRHS
225 *
226  READ( nin, fmt = * ) nnbr
227  IF( nnbr.LT.1 .OR. nnbr.GT.ldnbrval ) THEN
228  WRITE( nout, fmt = 9994 ) 'NBRHS', ldnbrval
229  GO TO 20
230  END IF
231  READ( nin, fmt = * ) ( nbrval( i ), i = 1, nnbr )
232 *
233 * Get number of grids
234 *
235  READ( nin, fmt = * ) ngrids
236  IF( ngrids.LT.1 .OR. ngrids.GT.ldpval ) THEN
237  WRITE( nout, fmt = 9994 ) 'Grids', ldpval
238  GO TO 20
239  ELSE IF( ngrids.GT.ldqval ) THEN
240  WRITE( nout, fmt = 9994 ) 'Grids', ldqval
241  GO TO 20
242  END IF
243 *
244 * Get values of P and Q
245 *
246  READ( nin, fmt = * ) ( pval( i ), i = 1, ngrids )
247  READ( nin, fmt = * ) ( qval( i ), i = 1, ngrids )
248 *
249 * Get level of checking
250 *
251  READ( nin, fmt = * ) thresh
252 *
253 * Read the flag that indicates whether to test the condition
254 * estimation and iterative refinement routines.
255 *
256  READ( nin, fmt = * ) est
257 *
258 * Close input file
259 *
260  CLOSE( nin )
261 *
262 * For pvm only: if virtual machine not set up, allocate it and
263 * spawn the correct number of processes.
264 *
265  IF( nprocs.LT.1 ) THEN
266  nprocs = 0
267  DO 10 i = 1, ngrids
268  nprocs = max( nprocs, pval( i )*qval( i ) )
269  10 CONTINUE
270  CALL blacs_setup( iam, nprocs )
271  END IF
272 *
273 * Temporarily define blacs grid to include all processes so
274 * information can be broadcast to all processes.
275 *
276  CALL blacs_get( -1, 0, ictxt )
277  CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
278 *
279 * Compute machine epsilon
280 *
281  eps = pdlamch( ictxt, 'eps' )
282 *
283 * Pack information arrays and broadcast
284 *
285  CALL sgebs2d( ictxt, 'All', ' ', 1, 1, thresh, 1 )
286  work( 1 ) = nmat
287  work( 2 ) = nnb
288  work( 3 ) = nnr
289  work( 4 ) = nnbr
290  work( 5 ) = ngrids
291  IF( lsame( uplo, 'L' ) ) THEN
292  work( 6 ) = 1
293  ELSE
294  work( 6 ) = 2
295  END IF
296  IF( est ) THEN
297  work( 7 ) = 1
298  ELSE
299  work( 7 ) = 0
300  END IF
301  CALL igebs2d( ictxt, 'All', ' ', 7, 1, work, 7 )
302 *
303  i = 1
304  CALL icopy( nmat, nval, 1, work( i ), 1 )
305  i = i + nmat
306  CALL icopy( nnb, nbval, 1, work( i ), 1 )
307  i = i + nnb
308  CALL icopy( nnr, nrval, 1, work( i ), 1 )
309  i = i + nnr
310  CALL icopy( nnbr, nbrval, 1, work( i ), 1 )
311  i = i + nnbr
312  CALL icopy( ngrids, pval, 1, work( i ), 1 )
313  i = i + ngrids
314  CALL icopy( ngrids, qval, 1, work( i ), 1 )
315  i = i + ngrids - 1
316  CALL igebs2d( ictxt, 'All', ' ', i, 1, work, i )
317 *
318 * regurgitate input
319 *
320  WRITE( nout, fmt = 9999 )
321  $ 'SCALAPACK Ax=b by LLt factorization.'
322  WRITE( nout, fmt = 9999 ) usrinfo
323  WRITE( nout, fmt = * )
324  WRITE( nout, fmt = 9999 )
325  $ 'Tests of the parallel '//
326  $ 'real double precision LLt factorization '//
327  $ 'and solve.'
328  WRITE( nout, fmt = 9999 )
329  $ 'The following scaled residual '//
330  $ 'checks will be computed:'
331  WRITE( nout, fmt = 9999 )
332  $ ' Solve residual = ||Ax - b|| / '//
333  $ '(||x|| * ||A|| * eps * N)'
334  IF( lsame( uplo, 'L' ) ) THEN
335  WRITE( nout, fmt = 9999 )
336  $ ' Factorization residual = ||A - LL''|| /'//
337  $ ' (||A|| * eps * N)'
338  ELSE
339  WRITE( nout, fmt = 9999 )
340  $ ' Factorization residual = ||A - U''U|| /'//
341  $ ' (||A|| * eps * N)'
342  END IF
343  WRITE( nout, fmt = 9999 )
344  $ 'The matrix A is randomly '//
345  $ 'generated for each test.'
346  WRITE( nout, fmt = * )
347  WRITE( nout, fmt = 9999 )
348  $ 'An explanation of the input/output '//
349  $ 'parameters follows:'
350  WRITE( nout, fmt = 9999 )
351  $ 'TIME : Indicates whether WALL or '//
352  $ 'CPU time was used.'
353 *
354  WRITE( nout, fmt = 9999 )
355  $ 'UPLO : Whether data is stored in ''Upper'//
356  $ ''' or ''Lower'' portion of array A.'
357  WRITE( nout, fmt = 9999 )
358  $ 'N : The number of rows and columns '//
359  $ 'in the matrix A.'
360  WRITE( nout, fmt = 9999 )
361  $ 'NB : The size of the square blocks the'//
362  $ ' matrix A is split into.'
363  WRITE( nout, fmt = 9999 )
364  $ 'NRHS : The total number of RHS to solve'//
365  $ ' for.'
366  WRITE( nout, fmt = 9999 )
367  $ 'NBRHS : The number of RHS to be put on '//
368  $ 'a column of processes before going'
369  WRITE( nout, fmt = 9999 )
370  $ ' on to the next column of processes.'
371  WRITE( nout, fmt = 9999 )
372  $ 'P : The number of process rows.'
373  WRITE( nout, fmt = 9999 )
374  $ 'Q : The number of process columns.'
375  WRITE( nout, fmt = 9999 )
376  $ 'THRESH : If a residual value is less than'//
377  $ ' THRESH, CHECK is flagged as PASSED'
378  WRITE( nout, fmt = 9999 )
379  $ 'LLt time: Time in seconds to factor the'//
380  $ ' matrix'
381  WRITE( nout, fmt = 9999 )
382  $ 'Sol Time: Time in seconds to solve the'//
383  $ ' system.'
384  WRITE( nout, fmt = 9999 )
385  $ 'MFLOPS : Rate of execution for factor '//
386  $ 'and solve.'
387  WRITE( nout, fmt = * )
388  WRITE( nout, fmt = 9999 )
389  $ 'The following parameter values will be used:'
390  WRITE( nout, fmt = 9999 )
391  $ ' UPLO : '//uplo
392  WRITE( nout, fmt = 9996 )
393  $ 'N ', ( nval(i), i = 1, min(nmat, 10) )
394  IF( nmat.GT.10 )
395  $ WRITE( nout, fmt = 9997 ) ( nval(i), i = 11, nmat )
396  WRITE( nout, fmt = 9996 )
397  $ 'NB ', ( nbval(i), i = 1, min(nnb, 10) )
398  IF( nnb.GT.10 )
399  $ WRITE( nout, fmt = 9997 ) ( nbval(i), i = 11, nnb )
400  WRITE( nout, fmt = 9996 )
401  $ 'NRHS ', ( nrval(i), i = 1, min(nnr, 10) )
402  IF( nnr.GT.10 )
403  $ WRITE( nout, fmt = 9997 ) ( nrval(i), i = 11, nnr )
404  WRITE( nout, fmt = 9996 )
405  $ 'NBRHS', ( nbrval(i), i = 1, min(nnbr, 10) )
406  IF( nnbr.GT.10 )
407  $ WRITE( nout, fmt = 9997 ) ( nbrval(i), i = 11, nnbr )
408  WRITE( nout, fmt = 9996 )
409  $ 'P ', ( pval(i), i = 1, min(ngrids, 10) )
410  IF( ngrids.GT.10 )
411  $ WRITE( nout, fmt = 9997) ( pval(i), i = 11, ngrids )
412  WRITE( nout, fmt = 9996 )
413  $ 'Q ', ( qval(i), i = 1, min(ngrids, 10) )
414  IF( ngrids.GT.10 )
415  $ WRITE( nout, fmt = 9997 ) ( qval(i), i = 11, ngrids )
416  WRITE( nout, fmt = * )
417  WRITE( nout, fmt = 9995 ) eps
418  WRITE( nout, fmt = 9998 ) thresh
419 *
420  ELSE
421 *
422 * If in pvm, must participate setting up virtual machine
423 *
424  IF( nprocs.LT.1 )
425  $ CALL blacs_setup( iam, nprocs )
426 *
427 * Temporarily define blacs grid to include all processes so
428 * all processes have needed startup information
429 *
430  CALL blacs_get( -1, 0, ictxt )
431  CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
432 *
433 * Compute machine epsilon
434 *
435  eps = pdlamch( ictxt, 'eps' )
436 *
437  CALL sgebr2d( ictxt, 'All', ' ', 1, 1, thresh, 1, 0, 0 )
438  CALL igebr2d( ictxt, 'All', ' ', 7, 1, work, 7, 0, 0 )
439  nmat = work( 1 )
440  nnb = work( 2 )
441  nnr = work( 3 )
442  nnbr = work( 4 )
443  ngrids = work( 5 )
444  IF( work( 6 ).EQ.1 ) THEN
445  uplo = 'L'
446  ELSE
447  uplo = 'U'
448  END IF
449  IF( work( 7 ).EQ.1 ) THEN
450  est = .true.
451  ELSE
452  est = .false.
453  END IF
454 *
455  i = nmat + nnb + nnr + nnbr + 2*ngrids
456  CALL igebr2d( ictxt, 'All', ' ', 1, i, work, 1, 0, 0 )
457  i = 1
458  CALL icopy( nmat, work( i ), 1, nval, 1 )
459  i = i + nmat
460  CALL icopy( nnb, work( i ), 1, nbval, 1 )
461  i = i + nnb
462  CALL icopy( nnr, work( i ), 1, nrval, 1 )
463  i = i + nnr
464  CALL icopy( nnbr, work( i ), 1, nbrval, 1 )
465  i = i + nnbr
466  CALL icopy( ngrids, work( i ), 1, pval, 1 )
467  i = i + ngrids
468  CALL icopy( ngrids, work( i ), 1, qval, 1 )
469 *
470  END IF
471 *
472  CALL blacs_gridexit( ictxt )
473 *
474  RETURN
475 *
476  20 WRITE( nout, fmt = 9993 )
477  CLOSE( nin )
478  IF( nout.NE.6 .AND. nout.NE.0 )
479  $ CLOSE( nout )
480  CALL blacs_abort( ictxt, 1 )
481  stop
482 *
483  9999 FORMAT( a )
484  9998 FORMAT( 'Routines pass computational tests if scaled residual ',
485  $ 'is less than ', g12.5 )
486  9997 FORMAT( ' ', 10i6 )
487  9996 FORMAT( 2x, a5, ': ', 10i6 )
488  9995 FORMAT( 'Relative machine precision (eps) is taken to be ',
489  $ e18.6 )
490  9994 FORMAT( ' Number of values of ',5a, ' is less than 1 or greater ',
491  $ 'than ', i2 )
492  9993 FORMAT( ' Illegal input in file ',40a,'. Aborting run.' )
493 *
494 * End of PDLLTINFO
495 *
496  END
max
#define max(A, B)
Definition: pcgemr.c:180
pdlltinfo
subroutine pdlltinfo(SUMMRY, NOUT, UPLO, NMAT, NVAL, LDNVAL, NNB, NBVAL, LDNBVAL, NNR, NRVAL, LDNRVAL, NNBR, NBRVAL, LDNBRVAL, NGRIDS, PVAL, LDPVAL, QVAL, LDQVAL, THRESH, EST, WORK, IAM, NPROCS)
Definition: pdlltinfo.f:6
icopy
subroutine icopy(N, SX, INCX, SY, INCY)
Definition: pblastst.f:1525
min
#define min(A, B)
Definition: pcgemr.c:181