pdhrdinfo.f

Go to the documentation of this file.

      SUBROUTINE pdhrdinfo( SUMMRY, NOUT, NMAT, NVAL, NVLO, NVHI,
     $                      LDNVAL, NNB, 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, LDNBVAL, LDNVAL, LDPVAL, LDQVAL,
     $                      NGRIDS, NMAT, NNB, NOUT, NPROCS
      REAL                  THRESH
*     ..
*     .. Array Arguments ..
      CHARACTER*( * )       SUMMRY
      INTEGER               NBVAL( LDNBVAL ), NVAL( LDNVAL ),
     $                      NVHI( LDNVAL ), NVLO( LDNVAL ),
     $                      pval( ldpval ), qval( ldqval ), work( * )
*     ..
*
*  Purpose
*  =======
*
*  PDHRDINFO get the needed startup information for the Hessenberg
*  reduction tests 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, output to screen,
*           NOUT = 0, output to stderr.  Only defined for process 0.
*
*  NMAT     (global output) INTEGER
*           The number of different values that can be used for
*           N, IHI & ILO.
*
*  NVAL     (global output) INTEGER array, dimension (LDNVAL)
*           The values of N (number of rows & columns in matrix).
*
*  NVLO     (global output) INTEGER array, dimension (LDNVAL)
*           The values of ILO.
*
*  NVHI     (global output) INTEGER array, dimension (LDNVAL)
*           The values of IHI.
*
*  LDNVAL   (global input) INTEGER
*           The maximum number of different values that can be used for
*           N, ILO and IHI. LDNVAL >=  NMAT.
*
*  NNB      (global output) INTEGER
*           The number of different values that can be used for NB.
*
*  NBVAL    (global output) INTEGER array, dimension (LDNBVAL)
*           The values of NB (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, 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, 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.
*
*  WORK     (local workspace) INTEGER array, dimension >=
*           3*LDNVAL+LDNBVAL+2*LDPVAL.  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
      DOUBLE PRECISION   EPS
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_abort, blacs_get, blacs_gridexit,
     $                   blacs_gridinit, blacs_setup, icopy, igebr2d,
     $                   igebs2d, sgebr2d, sgebs2d
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   PDLAMCH
      EXTERNAL           PDLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          max, min
*     ..
*     .. 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( unit = nin, file = 'HRD.dat', status = 'OLD' )
         READ( nin, fmt = * )summry
         summry = ' '
*
*        Read in user-supplied info about machine type, compiler, etc.
*
         READ( NIN, FMT = * ) USRINFO
*
*        Read name and unit number for summary output file
*
         READ( NIN, FMT = * ) SUMMRY
         READ( NIN, FMT = * ) NOUT
.NE..AND..NE.         IF( NOUT0  NOUT6 )
     $      OPEN( UNIT = NOUT, FILE = SUMMRY, STATUS = 'unknown' )
*
*        Read and check the parameter values for the tests.
*
*        Get number of matrices
*
         READ( NIN, FMT = * ) NMAT
.LT..OR..GT.         IF( NMAT1.  NMATLDNVAL ) THEN
            WRITE( NOUT, FMT = 9997 ) 'n', LDNVAL
            GO TO 20
         END IF
*
*        Get values of N, ILO, IHI
*
         READ( NIN, FMT = * ) ( NVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( NVLO( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( NVHI( I ), I = 1, NMAT )
*
*        Get values of NB
*
         READ( NIN, FMT = * ) NNB
.LT..OR..GT.         IF( NNB1  NNBLDNBVAL ) THEN
            WRITE( NOUT, FMT = 9997 ) 'nb', LDNBVAL
            GO TO 20
         END IF
         READ( NIN, FMT = * ) ( NBVAL( I ), I = 1, NNB )
*
*        Get number of grids
*
         READ( NIN, FMT = * ) NGRIDS
.LT..OR..GT.         IF( NGRIDS1  NGRIDSLDPVAL ) THEN
            WRITE( NOUT, FMT = 9997 ) 'grids', LDPVAL
            GO TO 20
.GT.         ELSE IF( NGRIDSLDQVAL ) THEN
            WRITE( NOUT, FMT = 9997 ) 'grids', LDQVAL
            GO TO 20
         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.
*
.LT.         IF( NPROCS1 ) 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 = PDLAMCH( ICTXT, 'eps' )
*
*        Pack information arrays and broadcast
*
         CALL SGEBS2D( ICTXT, 'all', ' ', 1, 1, THRESH, 1 )
*
         WORK( 1 ) = NMAT
         WORK( 2 ) = NNB
         WORK( 3 ) = NGRIDS
         CALL IGEBS2D( ICTXT, 'all', ' ', 1, 3, work, 1 )
*
         i = 1
         CALL icopy( nmat, nval, 1, work( i ), 1 )
         i = i + nmat
         CALL icopy( nmat, nvlo, 1, work( i ), 1 )
         i = i + nmat
         CALL icopy( nmat, nvhi, 1, work( i ), 1 )
         i = i + nmat
         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', ' ', 1, i, work, 1 )
*
*        regurgitate input
*
         WRITE( nout, fmt = 9999 )
     $      'ScaLAPACK Reduction routine to Hessenberg form.'
         WRITE( nout, fmt = 9999 ) usrinfo
         WRITE( nout, fmt = * )
         WRITE( nout, fmt = 9999 )
     $               'Tests of the parallel '//
     $               'real double precision Hessenberg '
         WRITE( nout, fmt = 9999 ) 'reduction routines.'
         WRITE( nout, fmt = 9999 )
     $               'The following scaled residual '//
     $               'checks will be computed:'
         WRITE( nout, fmt = 9999 )
     $               ' ||A - Q H Q''|| / (||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 )
     $               'N        : The number of rows and columns '//
     $               'of the matrix A.'
         WRITE( nout, fmt = 9999 )
     $               'NB       : The size of the square blocks'//
     $               ' the matrix A is split into.'
         WRITE( nout, fmt = 9999 )
     $      '         on to the next column of processes.'
         WRITE( nout, fmt = 9999 )
     $               'P        : The number of process rows.'
         WRITE( nout, fmt = 9999 )
     $               'Q        : The number of process columns.'
         WRITE( nout, fmt = 9999 )
     $               'HRD time : Time in seconds to compute HRD '
         WRITE( nout, fmt = 9999 )
     $               'MFLOPS   : Rate of execution for HRD ' //
     $               'reduction.'
         WRITE( nout, fmt = * )
         WRITE( nout, fmt = 9999 )
     $               'The following parameter values will be used:'
         WRITE( nout, fmt = 9995 )
     $               'N    ', ( nval( i ), i = 1, min( nmat, 10 ) )
         IF( nmat.GT.10 )
     $      WRITE( nout, fmt = 9994 ) ( nval( i ), i = 11, nmat )
         WRITE( nout, fmt = 9995 )
     $               'ILO    ', ( nvlo( i ), i = 1, min( nmat, 10 ) )
         IF( nmat.GT.10 )
     $      WRITE( nout, fmt = 9994 ) ( nvlo( i ), i = 11, nmat )
         WRITE( nout, fmt = 9995 )
     $               'IHI    ', ( nvhi( i ), i = 1, min( nmat, 10 ) )
         IF( nmat.GT.10 )
     $      WRITE( nout, fmt = 9994 ) ( nvhi( i ), i = 11, nmat )
         WRITE( nout, fmt = 9995 )
     $               'NB   ', ( nbval( i ), i = 1, min( nnb, 10 ) )
         IF( nnb.GT.10 )
     $      WRITE( nout, fmt = 9994 ) ( nbval( i ), i = 11, nnb )
         WRITE( nout, fmt = 9995 )
     $               'P    ', ( pval( i ), i = 1, min( ngrids, 10 ) )
         IF( ngrids.GT.10 )
     $      WRITE( nout, fmt = 9994 ) ( pval( i ), i = 11, ngrids )
         WRITE( nout, fmt = 9995 )
     $               'Q    ', ( qval( i ), i = 1, min( ngrids, 10 ) )
         IF( ngrids.GT.10 )
     $      WRITE( nout, fmt = 9994 ) ( qval( i ), i = 11, ngrids )
         WRITE( nout, fmt = * )
         WRITE( nout, fmt = 9996 ) eps
         WRITE( nout, fmt = 9993 ) thresh
*
      ELSE
*
*        If in pvm, must participate setting up virtual machine
*
         IF( nprocs.LT.1 )
     $      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 = pdlamch( ictxt, 'eps' )
*
         CALL sgebr2d( ictxt, 'All', ' ', 1, 1, thresh, 1, 0, 0 )
         CALL igebr2d( ictxt, 'All', ' ', 1, 3, work, 1, 0, 0 )
         nmat   = work( 1 )
         nnb    = work( 2 )
         ngrids = work( 3 )
*
         i = 3*nmat + nnb + 2*ngrids
         CALL igebr2d( ictxt, 'All', ' ', 1, i, work, 1, 0, 0 )
*
         i = 1
         CALL icopy( nmat, work( i ), 1, nval, 1 )
         i = i + nmat
         CALL icopy( nmat, work( i ), 1, nvlo, 1 )
         i = i + nmat
         CALL icopy( nmat, work( i ), 1, nvhi, 1 )
         i = i + nmat
         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
*
   20 CONTINUE
      WRITE( nout, fmt = 9998 )
      CLOSE( nin )
      IF( nout.NE.6 .AND. nout.NE.0 )
     $   CLOSE( nout )
      CALL blacs_abort( ictxt, 1 )
*
      stop
*
 9999 FORMAT( a )
 9998 FORMAT( ' ILLEGAL INPUT IN FILE ', 40a, '.  ABORTING RUN.' )
 9997 FORMAT( ' NUMBER OF VALUES OF ', 5a,
     $      ' IS LESS THAN 1 OR GREATER ', 'THAN ', i2 )
 9996 FORMAT( 'Relative machine precision (eps) is taken to be ',
     $      e18.6 )
 9995 FORMAT( 2x, a5, ':        ', 10i6 )
 9994 FORMAT( '              ', 10i6 )
 9993 FORMAT( 'Routines pass computational tests if scaled residual is',
     $      ' less than ', g14.7 )
*
*     End of PDHRDINFO
*
      END