ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pdqrinfo.f
Go to the documentation of this file.
1  SUBROUTINE pdqrinfo( SUMMRY, NOUT, NFACT, FACTOR, LDFACT, NMAT,
2  $ MVAL, LDMVAL, NVAL, LDNVAL, NNB, MBVAL,
3  $ LDMBVAL, NBVAL, LDNBVAL, NGRIDS, PVAL,
4  $ LDPVAL, QVAL, LDQVAL, THRESH, 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  INTEGER IAM, LDFACT, LDMBVAL, LDMVAL, LDNBVAL, LDNVAL,
14  $ LDPVAL, LDQVAL, NFACT, NGRIDS, NMAT, NNB,
15  $ NPROCS, NOUT
16  REAL THRESH
17 * ..
18 * .. Array Arguments ..
19  CHARACTER*2 FACTOR( LDFACT )
20  CHARACTER*(*) SUMMRY
21  INTEGER MBVAL( LDMBVAL ), MVAL( LDMVAL ),
22  $ NBVAL( LDNBVAL ), NVAL( LDNVAL ),
23  $ pval( ldpval ), qval( ldqval ), work( * )
24 * ..
25 *
26 * Purpose
27 * =======
28 *
29 * PDQRINFO gets needed startup information for the QR factoriza-
30 * tion routines and transmits it to all processes.
31 *
32 * Arguments
33 * =========
34 *
35 * SUMMRY (global output) CHARACTER*(*)
36 * Name of output (summary) file (if any). Only defined for
37 * process 0.
38 *
39 * NOUT (global output) INTEGER
40 * The unit number for output file. NOUT = 6, ouput to screen,
41 * NOUT = 0, output to stderr. Only defined for process 0.
42 *
43 * NFACT (global output) INTEGER
44 * The number of different factorization types to be tested.
45 *
46 * FACTOR (global output) CHARACTER*2 array of dimension of LDFACT,
47 * The factorization types to be tested:
48 * if FACTOR(i) = 'QR' then QR factorization,
49 * if FACTOR(i) = 'QL' then QL factorization,
50 * if FACTOR(i) = 'LQ' then LQ factorization,
51 * if FACTOR(i) = 'RQ' then RQ factorization,
52 * if FACTOR(i) = 'QP' then QR factorization with column
53 * pivoting.
54 * if FACTOR(i) = 'TZ' then complete orthogonal factorization.
55 *
56 * LDFACT (global input) INTEGER
57 * The maximum number of different factorization types to be
58 * tested. LDFACT >= NFACT.
59 *
60 * NMAT (global output) INTEGER
61 * The number of different values that can be used for N.
62 *
63 * MVAL (global output) INTEGER array of dimension (LDNVAL), the
64 * values of M (number of rows in matrix) to run the code
65 * with.
66 *
67 * LDMVAL (global input) INTEGER
68 * The maximum number of different values that can be used for
69 * M, LDNVAL > = NMAT.
70 *
71 * NVAL (global output) INTEGER array of dimension (LDNVAL), the
72 * values of N (number of columns in matrix) to run the code
73 * with.
74 *
75 * LDNVAL (global input) INTEGER
76 * The maximum number of different values that can be used for
77 * N, LDNVAL > = NMAT.
78 *
79 * NNB (global output) INTEGER
80 * The number of different values that can be used for MB and
81 * NB.
82 *
83 * MBVAL (global output) INTEGER array of dimension (LDMBVAL), the
84 * values of MB (row blocksize) to run the code with.
85 *
86 * LDMBVAL (global input) INTEGER
87 * The maximum number of different values that can be used for
88 * MB, LDMBVAL >= NNB.
89 *
90 * NBVAL (global output) INTEGER array of dimension (LDNBVAL), the
91 * values of NB (column blocksize) to run the code with.
92 *
93 * LDNBVAL (global input) INTEGER
94 * The maximum number of different values that can be used for
95 * NB, LDNBVAL >= NNB.
96 *
97 * NGRIDS (global output) INTEGER
98 * The number of different values that can be used for P & Q.
99 *
100 * PVAL (global output) INTEGER array of dimension (LDPVAL), the
101 * values of P (number of process rows) to run the code with.
102 *
103 * LDPVAL (global input) INTEGER
104 * The maximum number of different values that can be used for
105 * P, LDPVAL >= NGRIDS.
106 *
107 * QVAL (global output) INTEGER array of dimension (LDQVAL), the
108 * values of Q (number of process columns) to run the code
109 * with.
110 *
111 * LDQVAL (global input) INTEGER
112 * The maximum number of different values that can be used for
113 * Q, LDQVAL >= NGRIDS.
114 *
115 * THRESH (global output) REAL
116 * Indicates what error checks shall be run and printed out:
117 * < 0 : Perform no error checking
118 * > 0 : report all residuals greater than THRESH, perform
119 * factor check only if solve check fails
120 *
121 * WORK (local workspace) INTEGER array of dimension >=
122 * MAX( 4, LDFACT+LDMVAL+LDNVAL+LDMBVAL+LDNBVAL+LDPVAL+LDQVAL )
123 * used to pack all 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 * Note
133 * ====
134 *
135 * For packing the information we assumed that the length in bytes of an
136 * integer is equal to the length in bytes of a real single 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  CHARACTER*79 USRINFO
151  INTEGER I, ICTXT, K
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 LSAMEN
161  DOUBLE PRECISION PDLAMCH
162  EXTERNAL LSAMEN, PDLAMCH
163 * ..
164 * .. Intrinsic Functions ..
165  INTRINSIC max
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='QR.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 the matrix types to be tested
194 *
195  READ( nin, fmt = * ) nfact
196  IF( nfact.LT.1 .OR. nfact.GT.ldfact ) THEN
197  WRITE( nout, fmt = 9994 ) 'nb of factorization', ldfact
198  GO TO 40
199  END IF
200  READ( nin, fmt = * ) ( factor( i ), i = 1, nfact )
201 *
202 * Get number of matrices and their dimensions
203 *
204  READ( nin, fmt = * ) nmat
205  IF( nmat.LT.1 .OR. nmat.GT.ldnval ) THEN
206  WRITE( nout, fmt = 9994 ) 'N', ldnval
207  GO TO 40
208  ELSE IF( nmat.GT.ldmval ) THEN
209  WRITE( nout, fmt = 9994 ) 'M', ldmval
210  GO TO 40
211  END IF
212  READ( nin, fmt = * ) ( mval( i ), i = 1, nmat )
213  READ( nin, fmt = * ) ( nval( i ), i = 1, nmat )
214 *
215 * Get values of NB
216 *
217  READ( nin, fmt = * ) nnb
218  IF( nnb.LT.1 .OR. nnb.GT.ldmbval ) THEN
219  WRITE( nout, fmt = 9994 ) 'MB', ldmbval
220  GO TO 40
221  ELSE IF( nnb.GT.ldnbval ) THEN
222  WRITE( nout, fmt = 9994 ) 'NB', ldnbval
223  GO TO 40
224  END IF
225  READ( nin, fmt = * ) ( mbval( i ), i = 1, nnb )
226  READ( nin, fmt = * ) ( nbval( i ), i = 1, nnb )
227 *
228 * Get number of grids
229 *
230  READ( nin, fmt = * ) ngrids
231  IF( ngrids.LT.1 .OR. ngrids.GT.ldpval ) THEN
232  WRITE( nout, fmt = 9994 ) 'Grids', ldpval
233  GO TO 40
234  ELSE IF( ngrids.GT.ldqval ) THEN
235  WRITE( nout, fmt = 9994 ) 'Grids', ldqval
236  GO TO 40
237  END IF
238 *
239 * Get values of P and Q
240 *
241  READ( nin, fmt = * ) ( pval( i ), i = 1, ngrids )
242  READ( nin, fmt = * ) ( qval( i ), i = 1, ngrids )
243 *
244 * Get level of checking
245 *
246  READ( nin, fmt = * ) thresh
247 *
248 * Close input file
249 *
250  CLOSE( nin )
251 *
252 * For pvm only: if virtual machine not set up, allocate it and
253 * spawn the correct number of processes.
254 *
255  IF( nprocs.LT.1 ) THEN
256  nprocs = 0
257  DO 10 i = 1, ngrids
258  nprocs = max( nprocs, pval( i ) * qval( i ) )
259  10 CONTINUE
260  CALL blacs_setup( iam, nprocs )
261  END IF
262 *
263 * Temporarily define blacs grid to include all processes so
264 * information can be broadcast to all processes
265 *
266  CALL blacs_get( -1, 0, ictxt )
267  CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
268 *
269 * Compute machine epsilon
270 *
271  eps = pdlamch( ictxt, 'eps' )
272 *
273 * Pack information arrays and broadcast
274 *
275  CALL sgebs2d( ictxt, 'All', ' ', 1, 1, thresh, 1 )
276  work( 1 ) = nmat
277  work( 2 ) = nnb
278  work( 3 ) = ngrids
279  work( 4 ) = nfact
280  CALL igebs2d( ictxt, 'All', ' ', 4, 1, work, 4 )
281 *
282  i = 1
283  DO 20 k = 1, nfact
284  IF( lsamen( 2, factor( k ), 'QR' ) ) THEN
285  work( i ) = 1
286  i = i + 1
287  ELSE IF( lsamen( 2, factor( k ), 'QL' ) ) THEN
288  work( i ) = 2
289  i = i + 1
290  ELSE IF( lsamen( 2, factor( k ), 'LQ' ) ) THEN
291  work( i ) = 3
292  i = i + 1
293  ELSE IF( lsamen( 2, factor( k ), 'RQ' ) ) THEN
294  work( i ) = 4
295  i = i + 1
296  ELSE IF( lsamen( 2, factor( k ), 'QP' ) ) THEN
297  work( i ) = 5
298  i = i + 1
299  ELSE IF( lsamen( 2, factor( k ), 'TZ' ) ) THEN
300  work( i ) = 6
301  i = i + 1
302  END IF
303  20 CONTINUE
304 *
305  CALL icopy( nmat, mval, 1, work( i ), 1 )
306  i = i + nmat
307  CALL icopy( nmat, nval, 1, work( i ), 1 )
308  i = i + nmat
309  CALL icopy( nnb, mbval, 1, work( i ), 1 )
310  i = i + nnb
311  CALL icopy( nnb, nbval, 1, work( i ), 1 )
312  i = i + nnb
313  CALL icopy( ngrids, pval, 1, work( i ), 1 )
314  i = i + ngrids
315  CALL icopy( ngrids, qval, 1, work( i ), 1 )
316  i = i + ngrids - 1
317  CALL igebs2d( ictxt, 'All', ' ', i, 1, work, i )
318 *
319 * regurgitate input
320 *
321  WRITE( nout, fmt = 9999 )
322  $ 'ScaLAPACK QR factorizations routines.'
323  WRITE( nout, fmt = 9999 ) usrinfo
324  WRITE( nout, fmt = * )
325  WRITE( nout, fmt = 9999 )
326  $ 'Tests of the parallel '//
327  $ 'real double precision QR factorizations '//
328  $ 'routines.'
329  WRITE( nout, fmt = 9999 )
330  $ 'The following scaled residual '//
331  $ 'checks will be computed:'
332  WRITE( nout, fmt = 9999 )
333  $ ' || A - QR || / (|| A || * eps * N) and/or'
334  WRITE( nout, fmt = 9999 )
335  $ ' || A - QL || / (|| A || * eps * N) and/or'
336  WRITE( nout, fmt = 9999 )
337  $ ' || A - LQ || / (|| A || * eps * N) and/or'
338  WRITE( nout, fmt = 9999 )
339  $ ' || A - RQ || / (|| A || * eps * N) and/or'
340  WRITE( nout, fmt = 9999 )
341  $ ' || A - QRP || / (|| A || * eps * N) and/or'
342  WRITE( nout, fmt = 9999 )
343  $ ' || A - TZ || / (|| A || * eps * N)'
344  WRITE( nout, fmt = 9999 )
345  $ 'The matrix A is randomly '//
346  $ 'generated for each test.'
347  WRITE( nout, fmt = * )
348  WRITE( nout, fmt = 9999 )
349  $ 'An explanation of the input/output '//
350  $ 'parameters follows:'
351  WRITE( nout, fmt = 9999 )
352  $ 'TIME : Indicates whether WALL or '//
353  $ 'CPU time was used.'
354 *
355  WRITE( nout, fmt = 9999 )
356  $ 'M : The number of rows in the '//
357  $ 'matrix A.'
358  WRITE( nout, fmt = 9999 )
359  $ 'N : The number of columns in the '//
360  $ 'matrix A.'
361  WRITE( nout, fmt = 9999 )
362  $ 'MB : The row blocksize of the blocks'//
363  $ ' the matrix A is split into.'
364  WRITE( nout, fmt = 9999 )
365  $ 'NB : The column blocksize of the blocks'//
366  $ ' the matrix A is split into.'
367  WRITE( nout, fmt = 9999 )
368  $ 'P : The number of process rows.'
369  WRITE( nout, fmt = 9999 )
370  $ 'Q : The number of process columns.'
371  WRITE( nout, fmt = 9999 )
372  $ 'THRESH : If a residual value is less than'//
373  $ ' THRESH, CHECK is flagged as PASSED'
374  WRITE( nout, fmt = 9999 )
375  WRITE( nout, fmt = 9999 )
376  $ 'Fact Time: Time in seconds to factor the'//
377  $ ' matrix.'
378  WRITE( nout, fmt = 9999 )
379  $ 'MFLOPS : Execution rate of the '//
380  $ 'factorization.'
381  WRITE( nout, fmt = * )
382  WRITE( nout, fmt = 9999 )
383  $ 'The following parameter values will be used:'
384  WRITE( nout, fmt = 9996 )
385  $ 'M ', ( mval( i ), i = 1, min( nmat, 10 ) )
386  IF( nmat.GT.10 )
387  $ WRITE( nout, fmt = 9997 ) ( mval( i ), i = 11, nmat )
388  WRITE( nout, fmt = 9996 )
389  $ 'N ', ( nval( i ), i = 1, min( nmat, 10 ) )
390  IF( nmat.GT.10 )
391  $ WRITE( nout, fmt = 9997 ) ( nval( i ), i = 11, nmat )
392  WRITE( nout, fmt = 9996 )
393  $ 'MB ', ( mbval( i ), i = 1, min( nnb, 10 ) )
394  IF( nnb.GT.10 )
395  $ WRITE( nout, fmt = 9997 ) ( mbval( i ), i = 11, nnb )
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  $ 'P ', ( pval( i ), i = 1, min( ngrids, 10 ) )
402  IF( ngrids.GT.10 )
403  $ WRITE( nout, fmt = 9997) ( pval( i ), i = 11, ngrids )
404  WRITE( nout, fmt = 9996 )
405  $ 'Q ', ( qval( i ), i = 1, min( ngrids, 10 ) )
406  IF( ngrids.GT.10 )
407  $ WRITE( nout, fmt = 9997 ) ( qval( i ), i = 11, ngrids )
408  WRITE( nout, fmt = * )
409  WRITE( nout, fmt = 9995 ) eps
410  WRITE( nout, fmt = 9998 ) thresh
411 *
412  ELSE
413 *
414 * If in pvm, must participate setting up virtual machine
415 *
416  IF( nprocs.LT.1 )
417  $ CALL blacs_setup( iam, nprocs )
418 *
419 * Temporarily define blacs grid to include all processes so
420 * all processes have needed startup information
421 *
422  CALL blacs_get( -1, 0, ictxt )
423  CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
424 *
425 * Compute machine epsilon
426 *
427  eps = pdlamch( ictxt, 'eps' )
428 *
429  CALL sgebr2d( ictxt, 'All', ' ', 1, 1, thresh, 1, 0, 0 )
430  CALL igebr2d( ictxt, 'All', ' ', 4, 1, work, 4, 0, 0 )
431  nmat = work( 1 )
432  nnb = work( 2 )
433  ngrids = work( 3 )
434  nfact = work( 4 )
435 *
436  i = nfact + 2*nmat + 2*nnb + 2*ngrids
437  CALL igebr2d( ictxt, 'All', ' ', i, 1, work, i, 0, 0 )
438 *
439  DO 30 k = 1, nfact
440  IF( work( k ).EQ.1 ) THEN
441  factor( k ) = 'QR'
442  ELSE IF( work( k ).EQ.2 ) THEN
443  factor( k ) = 'QL'
444  ELSE IF( work( k ).EQ.3 ) THEN
445  factor( k ) = 'LQ'
446  ELSE IF( work( k ).EQ.4 ) THEN
447  factor( k ) = 'RQ'
448  ELSE IF( work( k ).EQ.5 ) THEN
449  factor( k ) = 'QP'
450  ELSE IF( work( k ).EQ.6 ) THEN
451  factor( k ) = 'TZ'
452  END IF
453  30 CONTINUE
454 *
455  i = nfact + 1
456  CALL icopy( nmat, work( i ), 1, mval, 1 )
457  i = i + nmat
458  CALL icopy( nmat, work( i ), 1, nval, 1 )
459  i = i + nmat
460  CALL icopy( nnb, work( i ), 1, mbval, 1 )
461  i = i + nnb
462  CALL icopy( nnb, work( i ), 1, nbval, 1 )
463  i = i + nnb
464  CALL icopy( ngrids, work( i ), 1, pval, 1 )
465  i = i + ngrids
466  CALL icopy( ngrids, work( i ), 1, qval, 1 )
467 *
468  END IF
469 *
470  CALL blacs_gridexit( ictxt )
471 *
472  RETURN
473 *
474  40 WRITE( nout, fmt = 9993 )
475  CLOSE( nin )
476  IF( nout.NE.6 .AND. nout.NE.0 )
477  $ CLOSE( nout )
478  CALL blacs_abort( ictxt, 1 )
479 *
480  stop
481 *
482  9999 FORMAT( a )
483  9998 FORMAT( 'Routines pass computational tests if scaled residual ',
484  $ 'is less than ', g12.5 )
485  9997 FORMAT( ' ', 10i6 )
486  9996 FORMAT( 2x, a5, ' : ', 10i6 )
487  9995 FORMAT( 'Relative machine precision (eps) is taken to be ',
488  $ e18.6 )
489  9994 FORMAT( ' Number of values of ',5a, ' is less than 1 or greater ',
490  $ 'than ', i2 )
491  9993 FORMAT( ' Illegal input in file ',40a,'. Aborting run.' )
492 *
493 * End of PDQRINFO
494 *
495  END
max
#define max(A, B)
Definition: pcgemr.c:180
pdqrinfo
subroutine pdqrinfo(SUMMRY, NOUT, NFACT, FACTOR, LDFACT, NMAT, MVAL, LDMVAL, NVAL, LDNVAL, NNB, MBVAL, LDMBVAL, NBVAL, LDNBVAL, NGRIDS, PVAL, LDPVAL, QVAL, LDQVAL, THRESH, WORK, IAM, NPROCS)
Definition: pdqrinfo.f:6
icopy
subroutine icopy(N, SX, INCX, SY, INCY)
Definition: pblastst.f:1525
min
#define min(A, B)
Definition: pcgemr.c:181