ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
psptinfo.f
Go to the documentation of this file.
1  SUBROUTINE psptinfo( 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 * PSPTINFO 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  REAL 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  REAL PSLAMCH
169  EXTERNAL LSAME, PSLAMCH
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  nbw = 1
218  IF( nbw.LT.1 .OR. nbw.GT.ldbwval ) THEN
219  WRITE( nout, fmt = 9994 ) 'BW', ldbwval
220  GO TO 20
221  END IF
222  READ( nin, fmt = * ) ( bwval( i ), i = 1, nbw )
223 *
224 * Get values of NB
225 *
226  READ( nin, fmt = * ) nnb
227  IF( nnb.LT.1 .OR. nnb.GT.ldnbval ) THEN
228  WRITE( nout, fmt = 9994 ) 'NB', ldnbval
229  GO TO 20
230  END IF
231  READ( nin, fmt = * ) ( nbval( i ), i = 1, nnb )
232 *
233 * Get values of NRHS
234 *
235  READ( nin, fmt = * ) nnr
236  IF( nnr.LT.1 .OR. nnr.GT.ldnrval ) THEN
237  WRITE( nout, fmt = 9994 ) 'NRHS', ldnrval
238  GO TO 20
239  END IF
240  READ( nin, fmt = * ) ( nrval( i ), i = 1, nnr )
241 *
242 * Get values of NBRHS
243 *
244  READ( nin, fmt = * ) nnbr
245  IF( nnbr.LT.1 .OR. nnbr.GT.ldnbrval ) THEN
246  WRITE( nout, fmt = 9994 ) 'NBRHS', ldnbrval
247  GO TO 20
248  END IF
249  READ( nin, fmt = * ) ( nbrval( i ), i = 1, nnbr )
250 *
251 * Get number of grids
252 *
253  READ( nin, fmt = * ) ngrids
254  IF( ngrids.LT.1 .OR. ngrids.GT.ldpval ) THEN
255  WRITE( nout, fmt = 9994 ) 'Grids', ldpval
256  GO TO 20
257  ELSE IF( ngrids.GT.ldqval ) THEN
258  WRITE( nout, fmt = 9994 ) 'Grids', ldqval
259  GO TO 20
260  END IF
261 *
262 * Processor grid must be 1D so set PVAL to 1
263  DO 8738 i = 1, ngrids
264  pval( i ) = 1
265  8738 CONTINUE
266 *
267 * Get values of Q
268 *
269  READ( nin, fmt = * ) ( qval( i ), i = 1, ngrids )
270 *
271 * Get level of checking
272 *
273  READ( nin, fmt = * ) thresh
274 *
275 * Close input file
276 *
277  CLOSE( nin )
278 *
279 * For pvm only: if virtual machine not set up, allocate it and
280 * spawn the correct number of processes.
281 *
282  IF( nprocs.LT.1 ) THEN
283  nprocs = 0
284  DO 10 i = 1, ngrids
285  nprocs = max( nprocs, pval( i )*qval( i ) )
286  10 CONTINUE
287  CALL blacs_setup( iam, nprocs )
288  END IF
289 *
290 * Temporarily define blacs grid to include all processes so
291 * information can be broadcast to all processes.
292 *
293  CALL blacs_get( -1, 0, ictxt )
294  CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
295 *
296 * Compute machine epsilon
297 *
298  eps = pslamch( ictxt, 'eps' )
299 *
300 * Pack information arrays and broadcast
301 *
302  CALL sgebs2d( ictxt, 'All', ' ', 1, 1, thresh, 1 )
303  i = 1
304  work( i ) = nmat
305  i = i+1
306  work( i ) = nbw
307  i = i+1
308  work( i ) = nnb
309  i = i+1
310  work( i ) = nnr
311  i = i+1
312  work( i ) = nnbr
313  i = i+1
314  work( i ) = ngrids
315  i = i+1
316  IF( lsame( uplo, 'L' ) ) THEN
317  work( i ) = 1
318  ELSE
319  work( i ) = 2
320  END IF
321  i = i+1
322 * Send number of elements to be sent
323  CALL igebs2d( ictxt, 'All', ' ', 1, 1, i-1, 1 )
324 * Send elements
325  CALL igebs2d( ictxt, 'All', ' ', i-1, 1, work, i-1 )
326 *
327  i = 1
328  CALL icopy( nmat, nval, 1, work( i ), 1 )
329  i = i + nmat
330  CALL icopy( nbw, bwval, 1, work( i ), 1 )
331  i = i + nbw
332  CALL icopy( nnb, nbval, 1, work( i ), 1 )
333  i = i + nnb
334  CALL icopy( nnr, nrval, 1, work( i ), 1 )
335  i = i + nnr
336  CALL icopy( nnbr, nbrval, 1, work( i ), 1 )
337  i = i + nnbr
338  CALL icopy( ngrids, pval, 1, work( i ), 1 )
339  i = i + ngrids
340  CALL icopy( ngrids, qval, 1, work( i ), 1 )
341  i = i + ngrids
342  CALL igebs2d( ictxt, 'All', ' ', i-1, 1, work, i-1 )
343 *
344 * regurgitate input
345 *
346  WRITE( nout, fmt = 9999 )
347  $ 'SCALAPACK banded linear systems.'
348  WRITE( nout, fmt = 9999 ) usrinfo
349  WRITE( nout, fmt = * )
350  WRITE( nout, fmt = 9999 )
351  $ 'Tests of the parallel '//
352  $ 'real single precision band matrix solve '
353  WRITE( nout, fmt = 9999 )
354  $ 'The following scaled residual '//
355  $ 'checks will be computed:'
356  WRITE( nout, fmt = 9999 )
357  $ ' Solve residual = ||Ax - b|| / '//
358  $ '(||x|| * ||A|| * eps * N)'
359  IF( lsame( uplo, 'L' ) ) THEN
360  WRITE( nout, fmt = 9999 )
361  $ ' Factorization residual = ||A - LL''|| /'//
362  $ ' (||A|| * eps * N)'
363  ELSE
364  WRITE( nout, fmt = 9999 )
365  $ ' Factorization residual = ||A - U''U|| /'//
366  $ ' (||A|| * eps * N)'
367  END IF
368  WRITE( nout, fmt = 9999 )
369  $ 'The matrix A is randomly '//
370  $ 'generated for each test.'
371  WRITE( nout, fmt = * )
372  WRITE( nout, fmt = 9999 )
373  $ 'An explanation of the input/output '//
374  $ 'parameters follows:'
375  WRITE( nout, fmt = 9999 )
376  $ 'TIME : Indicates whether WALL or '//
377  $ 'CPU time was used.'
378 *
379  WRITE( nout, fmt = 9999 )
380  $ 'UPLO : Whether data represents ''Upper'//
381  $ ''' or ''Lower'' triangular portion of array A.'
382  WRITE( nout, fmt = 9999 )
383  $ 'TRANS : Whether solve is to be done with'//
384  $ ' ''Transpose'' of matrix A (T,C) or not (N).'
385  WRITE( nout, fmt = 9999 )
386  $ 'N : The number of rows and columns '//
387  $ 'in the matrix A.'
388  WRITE( nout, fmt = 9999 )
389  $ 'bw : The number of diagonals '//
390  $ 'in the matrix A.'
391  WRITE( nout, fmt = 9999 )
392  $ 'NB : The size of the column panels the'//
393  $ ' matrix A is split into. [-1 for default]'
394  WRITE( nout, fmt = 9999 )
395  $ 'NRHS : The total number of RHS to solve'//
396  $ ' for.'
397  WRITE( nout, fmt = 9999 )
398  $ 'NBRHS : The number of RHS to be put on '//
399  $ 'a column of processes before going'
400  WRITE( nout, fmt = 9999 )
401  $ ' on to the next column of processes.'
402  WRITE( nout, fmt = 9999 )
403  $ 'P : The number of process rows.'
404  WRITE( nout, fmt = 9999 )
405  $ 'Q : The number of process columns.'
406  WRITE( nout, fmt = 9999 )
407  $ 'THRESH : If a residual value is less than'//
408  $ ' THRESH, CHECK is flagged as PASSED'
409  WRITE( nout, fmt = 9999 )
410  $ 'Fact time: Time in seconds to factor the'//
411  $ ' matrix'
412  WRITE( nout, fmt = 9999 )
413  $ 'Sol Time: Time in seconds to solve the'//
414  $ ' system.'
415  WRITE( nout, fmt = 9999 )
416  $ 'MFLOPS : Rate of execution for factor '//
417  $ 'and solve using sequential operation count.'
418  WRITE( nout, fmt = 9999 )
419  $ 'MFLOP2 : Rough estimate of speed '//
420  $ 'using actual op count (accurate big P,N).'
421  WRITE( nout, fmt = * )
422  WRITE( nout, fmt = 9999 )
423  $ 'The following parameter values will be used:'
424  WRITE( nout, fmt = 9999 )
425  $ ' UPLO : '//uplo
426  WRITE( nout, fmt = 9996 )
427  $ 'N ', ( nval(i), i = 1, min(nmat, 10) )
428  IF( nmat.GT.10 )
429  $ WRITE( nout, fmt = 9997 ) ( nval(i), i = 11, nmat )
430  WRITE( nout, fmt = 9996 )
431  $ 'bw ', ( bwval(i), i = 1, min(nbw, 10) )
432  IF( nbw.GT.10 )
433  $ WRITE( nout, fmt = 9997 ) ( bwval(i), i = 11, nbw )
434  WRITE( nout, fmt = 9996 )
435  $ 'NB ', ( nbval(i), i = 1, min(nnb, 10) )
436  IF( nnb.GT.10 )
437  $ WRITE( nout, fmt = 9997 ) ( nbval(i), i = 11, nnb )
438  WRITE( nout, fmt = 9996 )
439  $ 'NRHS ', ( nrval(i), i = 1, min(nnr, 10) )
440  IF( nnr.GT.10 )
441  $ WRITE( nout, fmt = 9997 ) ( nrval(i), i = 11, nnr )
442  WRITE( nout, fmt = 9996 )
443  $ 'NBRHS', ( nbrval(i), i = 1, min(nnbr, 10) )
444  IF( nnbr.GT.10 )
445  $ WRITE( nout, fmt = 9997 ) ( nbrval(i), i = 11, nnbr )
446  WRITE( nout, fmt = 9996 )
447  $ 'P ', ( pval(i), i = 1, min(ngrids, 10) )
448  IF( ngrids.GT.10 )
449  $ WRITE( nout, fmt = 9997) ( pval(i), i = 11, ngrids )
450  WRITE( nout, fmt = 9996 )
451  $ 'Q ', ( qval(i), i = 1, min(ngrids, 10) )
452  IF( ngrids.GT.10 )
453  $ WRITE( nout, fmt = 9997 ) ( qval(i), i = 11, ngrids )
454  WRITE( nout, fmt = * )
455  WRITE( nout, fmt = 9995 ) eps
456  WRITE( nout, fmt = 9998 ) thresh
457 *
458  ELSE
459 *
460 * If in pvm, must participate setting up virtual machine
461 *
462  IF( nprocs.LT.1 )
463  $ CALL blacs_setup( iam, nprocs )
464 *
465 * Temporarily define blacs grid to include all processes so
466 * all processes have needed startup information
467 *
468  CALL blacs_get( -1, 0, ictxt )
469  CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
470 *
471 * Compute machine epsilon
472 *
473  eps = pslamch( ictxt, 'eps' )
474 *
475  CALL sgebr2d( ictxt, 'All', ' ', 1, 1, thresh, 1, 0, 0 )
476  CALL igebr2d( ictxt, 'All', ' ', 1, 1, i, 1, 0, 0 )
477  CALL igebr2d( ictxt, 'All', ' ', i, 1, work, i, 0, 0 )
478  i = 1
479  nmat = work( i )
480  i = i+1
481  nbw = work( i )
482  i = i+1
483  nnb = work( i )
484  i = i+1
485  nnr = work( i )
486  i = i+1
487  nnbr = work( i )
488  i = i+1
489  ngrids = work( i )
490  i = i+1
491  IF( work( i ) .EQ. 1 ) THEN
492  uplo = 'L'
493  ELSE
494  uplo = 'U'
495  END IF
496  i = i+1
497 *
498  i = nmat + nbw + nnb + nnr + nnbr + 2*ngrids
499 *
500  CALL igebr2d( ictxt, 'All', ' ', 1, i, work, 1, 0, 0 )
501  i = 1
502  CALL icopy( nmat, work( i ), 1, nval, 1 )
503  i = i + nmat
504  CALL icopy( nbw, work( i ), 1, bwval, 1 )
505  i = i + nbw
506  CALL icopy( nnb, work( i ), 1, nbval, 1 )
507  i = i + nnb
508  CALL icopy( nnr, work( i ), 1, nrval, 1 )
509  i = i + nnr
510  CALL icopy( nnbr, work( i ), 1, nbrval, 1 )
511  i = i + nnbr
512  CALL icopy( ngrids, work( i ), 1, pval, 1 )
513  i = i + ngrids
514  CALL icopy( ngrids, work( i ), 1, qval, 1 )
515 *
516  END IF
517 *
518  CALL blacs_gridexit( ictxt )
519 *
520  RETURN
521 *
522  20 WRITE( nout, fmt = 9993 )
523  CLOSE( nin )
524  IF( nout.NE.6 .AND. nout.NE.0 )
525  $ CLOSE( nout )
526 *
527  CALL blacs_abort( ictxt, 1 )
528  stop
529 *
530  9999 FORMAT( a )
531  9998 FORMAT( 'Routines pass computational tests if scaled residual ',
532  $ 'is less than ', g12.5 )
533  9997 FORMAT( ' ', 10i6 )
534  9996 FORMAT( 2x, a5, ': ', 10i6 )
535  9995 FORMAT( 'Relative machine precision (eps) is taken to be ',
536  $ e18.6 )
537  9994 FORMAT( ' Number of values of ',5a, ' is less than 1 or greater ',
538  $ 'than ', i2 )
539  9993 FORMAT( ' Illegal input in file ',40a,'. Aborting run.' )
540 *
541 * End of PSPTINFO
542 *
543  END
max
#define max(A, B)
Definition: pcgemr.c:180
icopy
subroutine icopy(N, SX, INCX, SY, INCY)
Definition: pblastst.f:1525
psptinfo
subroutine psptinfo(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: psptinfo.f:6
min
#define min(A, B)
Definition: pcgemr.c:181