pcqrinfo.f

Go to the documentation of this file.

      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 )
*
*  -- ScaLAPACK routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      INTEGER            IAM, LDFACT, LDMBVAL, LDMVAL, LDNBVAL, LDNVAL,
     $                   LDPVAL, LDQVAL, NFACT, NGRIDS, NMAT, NNB,
     $                   NPROCS, NOUT
      REAL               THRESH
*     ..
*     .. Array Arguments ..
      CHARACTER*2        FACTOR( LDFACT )
      CHARACTER*(*)      SUMMRY
      INTEGER            MBVAL( LDMBVAL ), MVAL( LDMVAL ),
     $                   NBVAL( LDNBVAL ), NVAL( LDNVAL ),
     $                   pval( ldpval ), qval( ldqval ), work( * )
*     ..
*
*  Purpose
*  =======
*
*  PCQRINFO gets needed startup information for the QR factoriza-
*  tion routines and transmits it to all processes.
*
*  Arguments
*  =========
*
*  SUMMRY   (global output) CHARACTER*(*)
*           Name of output (summary) file (if any). Only defined for
*           process 0.
*
*  NOUT     (global output) INTEGER
*           The unit number for output file. NOUT = 6, ouput to screen,
*           NOUT = 0, output to stderr.  Only defined for process 0.
*
*  NFACT    (global output) INTEGER
*           The number of different factorization types to be tested.
*
*  FACTOR   (global output) CHARACTER*2 array of dimension of LDFACT,
*           The factorization types to be tested:
*           if FACTOR(i) = 'QR' then QR factorization,
*           if FACTOR(i) = 'QL' then QL factorization,
*           if FACTOR(i) = 'LQ' then LQ factorization,
*           if FACTOR(i) = 'RQ' then RQ factorization,
*           if FACTOR(i) = 'QP' then QR factorization with column
*                                    pivoting.
*           if FACTOR(i) = 'TZ' then complete unitary factorization.
*
*  LDFACT   (global input) INTEGER
*           The maximum number of different factorization types to be
*           tested.  LDFACT >=  NFACT.
*
*  NMAT     (global output) INTEGER
*           The number of different values that can be used for N.
*
*  MVAL     (global output) INTEGER array of dimension (LDNVAL), the
*           values of M (number of rows in matrix) to run the code
*           with.
*
*  LDMVAL   (global input) INTEGER
*           The maximum number of different values that can be used for
*           M, LDNVAL > =  NMAT.
*
*  NVAL     (global output) INTEGER array of dimension (LDNVAL), the
*           values of N (number of columns in matrix) to run the code
*           with.
*
*  LDNVAL   (global input) INTEGER
*           The maximum number of different values that can be used for
*           N, LDNVAL > =  NMAT.
*
*  NNB      (global output) INTEGER
*           The number of different values that can be used for MB and
*           NB.
*
*  MBVAL    (global output) INTEGER array of dimension (LDMBVAL), the
*           values of MB (row blocksize) to run the code with.
*
*  LDMBVAL  (global input) INTEGER
*           The maximum number of different values that can be used for
*           MB, LDMBVAL >= NNB.
*
*  NBVAL    (global output) INTEGER array of dimension (LDNBVAL), the
*           values of NB (column blocksize) to run the code with.
*
*  LDNBVAL  (global input) INTEGER
*           The maximum number of different values that can be used for
*           NB, LDNBVAL >= NNB.
*
*  NGRIDS   (global output) INTEGER
*           The number of different values that can be used for P & Q.
*
*  PVAL     (global output) INTEGER array of dimension (LDPVAL), the
*           values of P (number of process rows) to run the code with.
*
*  LDPVAL   (global input) INTEGER
*           The maximum number of different values that can be used for
*           P, LDPVAL >= NGRIDS.
*
*  QVAL     (global output) INTEGER array of dimension (LDQVAL), the
*           values of Q (number of process columns) to run the code
*           with.
*
*  LDQVAL   (global input) INTEGER
*           The maximum number of different values that can be used for
*           Q, LDQVAL >= NGRIDS.
*
*  THRESH   (global output) REAL
*           Indicates what error checks shall be run and printed out:
*           < 0 : Perform no error checking
*           > 0 : report all residuals greater than THRESH, perform
*                 factor check only if solve check fails
*
*  WORK     (local workspace) INTEGER array of dimension >=
*           MAX( 4, LDFACT+LDMVAL+LDNVAL+LDMBVAL+LDNBVAL+LDPVAL+LDQVAL )
*           used to pack all input arrays in order to send info in one
*           message.
*
*  IAM      (local input) INTEGER
*           My process number.
*
*  NPROCS   (global input) INTEGER
*           The total number of processes.
*
*  Note
*  ====
*
*  For packing the information we assumed that the length in bytes of an
*  integer is equal to the length in bytes of a real single precision.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
     $                   LLD_, MB_, M_, NB_, N_, RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, dlen_ = 9, dtype_ = 1,
     $                     ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
     $                     rsrc_ = 7, csrc_ = 8, lld_ = 9 )
      INTEGER            NIN
      parameter( nin = 11 )
*     ..
*     .. Local Scalars ..
      CHARACTER*79       USRINFO
      INTEGER            I, ICTXT, K
      REAL               EPS
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_abort, blacs_get, blacs_gridexit,
     $                   blacs_gridinit, blacs_setup, icopy, igebr2d,
     $                   igebs2d, sgebr2d, sgebs2d
*     ..
*     .. External Functions ..
      LOGICAL            LSAMEN
      REAL               PSLAMCH
      EXTERNAL           LSAMEN, PSLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          max
*     ..
*     .. Executable Statements ..
*
*     Process 0 reads the input data, broadcasts to other processes and
*     writes needed information to NOUT
*
      IF( iam.EQ.0 ) THEN
*
*        Open file and skip data file header
*
         OPEN( nin, file='QR.dat', status='OLD' )
         READ( nin, fmt = * ) summry
         summry = ' '
*
*        Read in user-supplied info about machine type, compiler, etc.
*
         READ( nin, fmt = 9999 ) usrinfo
*
*        Read name and unit number for summary output file
*
         READ( nin, fmt = * ) summry
         READ( nin, fmt = * ) nout
         IF( nout.NE.0 .AND. nout.NE.6 )
     $      OPEN( nout, file = summry, status = 'UNKNOWN' )
*
*        Read and check the parameter values for the tests.
*
*        Get the matrix types to be tested
*
         READ( nin, fmt = * ) nfact
         IF( nfact.LT.1 .OR. nfact.GT.ldfact ) THEN
            WRITE( nout, fmt = 9994 ) 'nb of factorization', ldfact
            GO TO 40
         END IF
         READ( nin, fmt = * ) ( factor( i ), i = 1, nfact )
*
*        Get number of matrices and their dimensions
*
         READ( nin, fmt = * ) nmat
         IF( nmat.LT.1 .OR. nmat.GT.ldnval ) THEN
            WRITE( nout, fmt = 9994 ) 'N', ldnval
            GO TO 40
         ELSE IF( nmat.GT.ldmval ) THEN
            WRITE( nout, fmt = 9994 ) 'M', ldmval
            GO TO 40
         END IF
         READ( nin, fmt = * ) ( mval( i ), i = 1, nmat )
         READ( nin, fmt = * ) ( nval( i ), i = 1, nmat )
*
*        Get values of NB
*
         READ( nin, fmt = * ) nnb
         IF( nnb.LT.1 .OR. nnb.GT.ldmbval ) THEN
            WRITE( nout, fmt = 9994 ) 'MB', ldmbval
            GO TO 40
         ELSE IF( nnb.GT.ldnbval ) THEN
            WRITE( nout, fmt = 9994 ) 'NB', ldnbval
            GO TO 40
         END IF
         READ( nin, fmt = * ) ( mbval( i ), i = 1, nnb )
         READ( nin, fmt = * ) ( nbval( i ), i = 1, nnb )
*
*        Get number of grids
*
         READ( nin, fmt = * ) ngrids
         IF( ngrids.LT.1 .OR. ngrids.GT.ldpval ) THEN
            WRITE( nout, fmt = 9994 ) 'Grids', ldpval
            GO TO 40
         ELSE IF( ngrids.GT.ldqval ) THEN
            WRITE( nout, fmt = 9994 ) 'Grids', ldqval
            GO TO 40
         END IF
*
*        Get values of P and Q
*
         READ( nin, fmt = * ) ( pval( i ), i = 1, ngrids )
         READ( nin, fmt = * ) ( qval( i ), i = 1, ngrids )
*
*        Get level of checking
*
         READ( nin, fmt = * ) thresh
*
*        Close input file
*
         CLOSE( nin )
*
*        For pvm only: if virtual machine not set up, allocate it and
*        spawn the correct number of processes.
*
         IF( nprocs.LT.1 ) THEN
            nprocs = 0
            DO 10 i = 1, ngrids
               nprocs = max( nprocs, pval( i ) * qval( i ) )
   10       CONTINUE
            CALL blacs_setup( iam, nprocs )
         END IF
*
*        Temporarily define blacs grid to include all processes so
*        information can be broadcast to all processes
*
         CALL blacs_get( -1, 0, ictxt )
         CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
*
*        Compute machine epsilon
*
         eps = pslamch( ictxt, 'eps' )
*
*        Pack information arrays and broadcast
*
         CALL sgebs2d( ictxt, 'All', ' ', 1, 1, thresh, 1 )
         work( 1 ) = nmat
         work( 2 ) = nnb
         work( 3 ) = ngrids
         work( 4 ) = nfact
         CALL igebs2d( ictxt, 'All', ' ', 4, 1, work, 4 )
*
         i = 1
         DO 20 k = 1, nfact
            IF( lsamen( 2, factor( k ), 'QR' ) ) THEN
               work( i ) = 1
               i = i + 1
            ELSE IF( lsamen( 2, factor( k ), 'QL' ) ) THEN
               work( i ) = 2
               i = i + 1
            ELSE IF( lsamen( 2, factor( k ), 'LQ' ) ) THEN
               work( i ) = 3
               i = i + 1
            ELSE IF( lsamen( 2, factor( k ), 'RQ' ) ) THEN
               work( i ) = 4
               i = i + 1
            ELSE IF( lsamen( 2, factor( k ), 'QP' ) ) THEN
               work( i ) = 5
               i = i + 1
            ELSE IF( lsamen( 2, factor( k ), 'TZ' ) ) THEN
               work( i ) = 6
               i = i + 1
            END IF
   20    CONTINUE
*
         CALL icopy( nmat, mval, 1, work( i ), 1 )
         i = i + nmat
         CALL icopy( nmat, nval, 1, work( i ), 1 )
         i = i + nmat
         CALL icopy( nnb, mbval, 1, work( i ), 1 )
         i = i + nnb
         CALL icopy( nnb, nbval, 1, work( i ), 1 )
         i = i + nnb
         CALL icopy( ngrids, pval, 1, work( i ), 1 )
         i = i + ngrids
         CALL icopy( ngrids, qval, 1, work( i ), 1 )
         i = i + ngrids - 1
         CALL igebs2d( ictxt, 'All', ' ', i, 1, work, i )
*
*        regurgitate input
*
         WRITE( nout, fmt = 9999 )
     $               'ScaLAPACK QR factorizations routines.'
         WRITE( nout, fmt = 9999 ) usrinfo
         WRITE( nout, fmt = * )
         WRITE( nout, fmt = 9999 )
     $               'Tests of the parallel '//
     $               'complex single precision QR factorizations '//
     $               'routines.'
         WRITE( nout, fmt = 9999 )
     $               'The following scaled residual '//
     $               'checks will be computed:'
         WRITE( nout, fmt = 9999 )
     $               ' || A - QR  || / (|| A || * eps * N) and/or'
         WRITE( nout, fmt = 9999 )
     $               ' || A - QL  || / (|| A || * eps * N) and/or'
         WRITE( nout, fmt = 9999 )
     $               ' || A - LQ  || / (|| A || * eps * N) and/or'
         WRITE( nout, fmt = 9999 )
     $               ' || A - RQ  || / (|| A || * eps * N) and/or'
         WRITE( nout, fmt = 9999 )
     $               ' || A - QRP || / (|| A || * eps * N) and/or'
         WRITE( nout, fmt = 9999 )
     $               ' || A - TZ  || / (|| A || * eps * N)'
         WRITE( nout, fmt = 9999 )
     $               'The matrix A is randomly '//
     $               'generated for each test.'
         WRITE( NOUT, FMT = * )
         WRITE( NOUT, FMT = 9999 )
     $               'an explanation of the input/output '//
     $               'parameters follows:'
         WRITE( NOUT, FMT = 9999 )
     $               'time     : indicates whether wall or '//
     $               'cpu time was used.'
*
         WRITE( NOUT, FMT = 9999 )
     $               'm        : the number of rows in the '//
     $               'matrix a.'
         WRITE( NOUT, FMT = 9999 )
     $               'n        : the number of columns in the '//
     $               'matrix a.'
         WRITE( NOUT, FMT = 9999 )
     $               'mb       : the row blocksize of the blocks'//
     $               ' the matrix a is split into.'
         WRITE( NOUT, FMT = 9999 )
     $               'nb       : the column blocksize of the blocks'//
     $               ' the matrix a is split into.'
         WRITE( NOUT, FMT = 9999 )
     $               'p        : the number of process rows.'
         WRITE( NOUT, FMT = 9999 )
     $               'q        : the number of process columns.'
         WRITE( NOUT, FMT = 9999 )
     $               'thresh   : If a residual value is less than'//
     $               ' thresh, check is flagged as passed'
         WRITE( NOUT, FMT = 9999 )
         WRITE( NOUT, FMT = 9999 )
     $               'fact time: time in seconds to factor the'//
     $               ' matrix.'
         WRITE( NOUT, FMT = 9999 )
     $               'mflops   : execution rate of the '//
     $               'factorization.'
         WRITE( NOUT, FMT = * )
         WRITE( NOUT, FMT = 9999 )
     $               'the following parameter values will be used:'
         WRITE( NOUT, FMT = 9996 )
     $               'm    ', ( MVAL( I ), I = 1, MIN( NMAT, 10 ) )
.GT.         IF( NMAT10 )
     $      WRITE( NOUT, FMT = 9997 ) ( MVAL( I ), I = 11, NMAT )
         WRITE( NOUT, FMT = 9996 )
     $               'n    ', ( NVAL( I ), I = 1, MIN( NMAT, 10 ) )
.GT.         IF( NMAT10 )
     $      WRITE( NOUT, FMT = 9997 ) ( NVAL( I ), I = 11, NMAT )
         WRITE( NOUT, FMT = 9996 )
     $               'mb   ', ( MBVAL( I ), I = 1, MIN( NNB, 10 ) )
.GT.         IF( NNB10 )
     $      WRITE( NOUT, FMT = 9997 ) ( MBVAL( I ), I = 11, NNB )
         WRITE( NOUT, FMT = 9996 )
     $               'nb   ', ( NBVAL( I ), I = 1, MIN( NNB, 10 ) )
.GT.         IF( NNB10 )
     $      WRITE( NOUT, FMT = 9997 ) ( NBVAL( I ), I = 11, NNB )
         WRITE( NOUT, FMT = 9996 )
     $               'p    ', ( PVAL( I ), I = 1, MIN( NGRIDS, 10 ) )
.GT.         IF( NGRIDS10 )
     $      WRITE( NOUT, FMT = 9997) ( PVAL( I ), I = 11, NGRIDS )
         WRITE( NOUT, FMT = 9996 )
     $               'q    ', ( QVAL( I ), I = 1, MIN( NGRIDS, 10 ) )
.GT.         IF( NGRIDS10 )
     $      WRITE( NOUT, FMT = 9997 ) ( QVAL( I ), I = 11, NGRIDS )
         WRITE( NOUT, FMT = * )
         WRITE( NOUT, FMT = 9995 ) EPS
         WRITE( NOUT, FMT = 9998 ) THRESH
*
      ELSE
*
*        If in pvm, must participate setting up virtual machine
*
.LT.         IF( NPROCS1 )
     $      CALL BLACS_SETUP( IAM, NPROCS )
*
*        Temporarily define blacs grid to include all processes so
*        all processes have needed startup information
*
         CALL BLACS_GET( -1, 0, ICTXT )
         CALL BLACS_GRIDINIT( ICTXT, 'row-major', 1, NPROCS )
*
*        Compute machine epsilon
*
         EPS = PSLAMCH( ICTXT, 'eps' )
*
         CALL SGEBR2D( ICTXT, 'all', ' ', 1, 1, THRESH, 1, 0, 0 )
         CALL IGEBR2D( ICTXT, 'all', ' ', 4, 1, WORK, 4, 0, 0 )
         NMAT   = WORK( 1 )
         NNB    = WORK( 2 )
         NGRIDS = WORK( 3 )
         NFACT  = WORK( 4 )
*
         I = NFACT + 2*NMAT + 2*NNB + 2*NGRIDS
         CALL IGEBR2D( ICTXT, 'all', ' ', I, 1, WORK, I, 0, 0 )
*
         DO 30 K = 1, NFACT
.EQ.            IF( WORK( K )1 ) THEN
               FACTOR( K ) = 'qr'
.EQ.            ELSE IF( WORK( K )2 ) THEN
               FACTOR( K ) = 'ql'
.EQ.            ELSE IF( WORK( K )3 ) THEN
               FACTOR( K ) = 'lq'
.EQ.            ELSE IF( WORK( K )4 ) THEN
               FACTOR( K ) = 'rq'
.EQ.            ELSE IF( WORK( K )5 ) THEN
               FACTOR( K ) = 'qp'
.EQ.            ELSE IF( WORK( K )6 ) THEN
               FACTOR( K ) = 'tz'
            END IF
   30    CONTINUE
*
         I = NFACT + 1
         CALL ICOPY( NMAT, WORK( I ), 1, MVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, NVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NNB, WORK( I ), 1, MBVAL, 1 )
         I = I + NNB
         CALL ICOPY( NNB, WORK( I ), 1, NBVAL, 1 )
         I = I + NNB
         CALL ICOPY( NGRIDS, WORK( I ), 1, PVAL, 1 )
         I = I + NGRIDS
         CALL ICOPY( NGRIDS, WORK( I ), 1, QVAL, 1 )
*
      END IF
*
      CALL BLACS_GRIDEXIT( ICTXT )
*
      RETURN
*
   40 WRITE( NOUT, FMT = 9993 )
      CLOSE( NIN )
.NE..AND..NE.      IF( NOUT6  NOUT0 )
     $   CLOSE( NOUT )
      CALL BLACS_ABORT( ICTXT, 1 )
*
      STOP
*
 9999 FORMAT( A )
 9998 FORMAT( 'routines pass computational tests if scaled residual ',
     $        'is less than ', G12.5 )
 9997 FORMAT( '                 ', 10I6 )
 9996 FORMAT( 2X, A5, '   :        ', 10I6 )
 9995 FORMAT( 'relative machine precision(eps) is taken to be ',
     $        E18.6 )
 9994 FORMAT( ' number of values of ',5A, ' is less than 1 or greater ',
     $        'than ', I2 )
 9993 FORMAT( ' illegal input in file ',40A,'.  aborting run.' )
*
*     End of PCQRINFO
*
      END