OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
pcqrinfo.f File Reference

Go to the source code of this file.

Functions/Subroutines

subroutine pcqrinfo (summry, nout, nfact, factor, ldfact, nmat, mval, ldmval, nval, ldnval, nnb, mbval, ldmbval, nbval, ldnbval, ngrids, pval, ldpval, qval, ldqval, thresh, work, iam, nprocs)

Function/Subroutine Documentation

◆ pcqrinfo()

subroutine pcqrinfo ( character*(*) summry,
integer nout,
integer nfact,
character*2, dimension( ldfact ) factor,
integer ldfact,
integer nmat,
integer, dimension( ldmval ) mval,
integer ldmval,
integer, dimension( ldnval ) nval,
integer ldnval,
integer nnb,
integer, dimension( ldmbval ) mbval,
integer ldmbval,
integer, dimension( ldnbval ) nbval,
integer ldnbval,
integer ngrids,
integer, dimension( ldpval ) pval,
integer ldpval,
integer, dimension( ldqval ) qval,
integer ldqval,
real thresh,
integer, dimension( * ) work,
integer iam,
integer nprocs )

Definition at line 1 of file pcqrinfo.f.

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* PCQRINFO 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 unitary 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 REAL 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 REAL PSLAMCH
162 EXTERNAL lsamen, pslamch
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.GT. ELSE IF( NMATLDMVAL ) 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.LT..OR..GT. IF( NNB1 NNBLDMBVAL ) THEN
219 WRITE( NOUT, FMT = 9994 ) 'mb', LDMBVAL
220 GO TO 40
221.GT. ELSE IF( NNBLDNBVAL ) 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.LT..OR..GT. IF( NGRIDS1 NGRIDSLDPVAL ) THEN
232 WRITE( NOUT, FMT = 9994 ) 'grids', LDPVAL
233 GO TO 40
234.GT. ELSE IF( NGRIDSLDQVAL ) 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.LT. IF( NPROCS1 ) 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 = PSLAMCH( 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 $ 'complex single 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.GT. IF( NMAT10 )
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.GT. IF( NMAT10 )
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.GT. IF( NNB10 )
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.GT. IF( NNB10 )
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.GT. IF( NGRIDS10 )
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.GT. IF( NGRIDS10 )
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.LT. IF( NPROCS1 )
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 = PSLAMCH( 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.EQ. IF( WORK( K )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 PCQRINFO
494*
the
end diagonal values have been computed in the(sparse) matrix id.SOL
lsamen
logical function lsamen(n, ca, cb)
LSAMEN
Definition lsamen.f:74
icopy
subroutine icopy(n, sx, incx, sy, incy)
ICOPY
Definition icopy.f:75
max
#define max(a, b)
Definition macros.h:21
sgebs2d
subroutine sgebs2d(contxt, scope, top, m, n, a, lda)
Definition mpi.f:1072
blacs_gridinit
subroutine blacs_gridinit(cntxt, c, nprow, npcol)
Definition mpi.f:745
sgebr2d
subroutine sgebr2d(contxt, scope, top, m, n, a, lda)
Definition mpi.f:1113
blacs_gridexit
subroutine blacs_gridexit(cntxt)
Definition mpi.f:762
pslamch
real function pslamch(ictxt, cmach)
Definition pcblastst.f:7455