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