pdlltinfo.f

Go to the documentation of this file.

      SUBROUTINE pdlltinfo( SUMMRY, NOUT, UPLO, NMAT, NVAL, LDNVAL, NNB,
     $                      NBVAL, LDNBVAL, NNR, NRVAL, LDNRVAL, NNBR,
     $                      NBRVAL, LDNBRVAL, NGRIDS, PVAL, LDPVAL,
     $                      QVAL, LDQVAL, THRESH, EST, 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 ..
      LOGICAL            EST
      CHARACTER          UPLO
      CHARACTER*(*)      SUMMRY
      INTEGER            IAM, LDNBRVAL, LDNBVAL, LDNRVAL, LDNVAL,
     $                   ldpval, ldqval, ngrids, nmat, nnb, nnbr,
     $                   nprocs, nnr, nout
      REAL               THRESH
*     ..
*     .. Array Arguments ..
      INTEGER            NBRVAL( LDNBRVAL ), NBVAL( LDNBVAL ),
     $                   nrval( ldnrval ), nval( ldnval ),
     $                   pval( ldpval ), qval(ldqval), work( * )
*     ..
*
*  Purpose
*  =======
*
*  PDLLTINFO get needed startup information for LLt factorization
*  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.
*
*  UPLO     (global output) CHARACTER
*           Specifies whether the upper or lower triangular part of the
*           symmetric matrix A is stored.
*           = 'U':  Upper triangular
*           = 'L':  Lower triangular
*
*  NMAT     (global output) INTEGER
*           The number of different values that can be used for N.
*
*  NVAL     (global output) INTEGER array, 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 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.
*
*  NNR      (global output) INTEGER
*           The number of different values that can be used for NRHS.
*
*  NRVAL    (global output) INTEGER array, dimension(LDNRVAL)
*           The values of NRHS (# of Right Hand Sides) to run the code
*           with.
*
*  LDNRVAL  (global input) INTEGER
*           The maximum number of different values that can be used for
*           NRHS, LDNRVAL >= NNR.
*
*  NNBR     (global output) INTEGER
*           The number of different values that can be used for NBRHS.
*
*  NBRVAL   (global output) INTEGER array, dimension (LDNBRVAL)
*           The values of NBRHS (RHS blocksize) to run the code with.
*
*  LDNBRVAL (global input) INTEGER
*           The maximum number of different values that can be used for
*           NBRHS, LDNBRVAL >= NBRVAL.
*
*  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, perform
*                  factor check only if solve check fails
*
*  EST      (global output) LOGICAL
*           Flag indicating if condition estimation and iterative
*           refinement routines are to be exercised.
*
*  WORK     (local workspace) INTEGER array of dimension >=
*             MAX( 7, LDNVAL+LDNBVAL+LDNRVAL+LDNBRVAL+LDPVAL+LDQVAL)
*           Used to pack 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 ..
      INTEGER            I, ICTXT
      CHARACTER*79       USRINFO
      DOUBLE PRECISION   EPS
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_abort, blacs_get, blacs_gridexit,
     $                   blacs_gridinit, blacs_setup, icopy, igebr2d,
     $                   igebs2d, sgebr2d, sgebs2d
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   PDLAMCH
      EXTERNAL           LSAME, 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( nin, file = 'LLT.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 UPLO
*
         READ( nin, fmt = * ) uplo
*
*        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 20
         END IF
         READ( nin, fmt = * ) ( nval( i ), i = 1, nmat )
*
*        Get values of NB
*
         READ( nin, fmt = * ) nnb
         IF( nnb.LT.1 .OR. nnb.GT.ldnbval ) THEN
            WRITE( nout, fmt = 9994 ) 'NB', ldnbval
            GO TO 20
         END IF
         READ( nin, fmt = * ) ( nbval( i ), i = 1, nnb )
*
*        Get values of NRHS
*
         READ( nin, fmt = * ) nnr
         IF( nnr.LT.1 .OR. nnr.GT.ldnrval ) THEN
            WRITE( nout, fmt = 9994 ) 'NRHS', ldnrval
            GO TO 20
         END IF
         READ( nin, fmt = * ) ( nrval( i ), i = 1, nnr )
*
*        Get values of NBRHS
*
         READ( nin, fmt = * ) nnbr
         IF( nnbr.LT.1 .OR. nnbr.GT.ldnbrval ) THEN
            WRITE( nout, fmt = 9994 ) 'NBRHS', ldnbrval
            GO TO 20
         END IF
         READ( nin, fmt = * ) ( nbrval( i ), i = 1, nnbr )
*
*        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 20
         ELSE IF( ngrids.GT.ldqval ) THEN
            WRITE( nout, fmt = 9994 ) '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
*
*        Read the flag that indicates whether to test the condition
*        estimation and iterative refinement routines.
*
         READ( nin, fmt = * ) est
*
*        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 = pdlamch( ictxt, 'eps' )
*
*        Pack information arrays and broadcast
*
         CALL sgebs2d( ictxt, 'All', ' ', 1, 1, thresh, 1 )
         work( 1 ) = nmat
         work( 2 ) = nnb
         work( 3 ) = nnr
         work( 4 ) = nnbr
         work( 5 ) = ngrids
         IF( lsame( uplo, 'L' ) ) THEN
            work( 6 ) = 1
         ELSE
            work( 6 ) = 2
         END IF
         IF( est ) THEN
            work( 7 ) = 1
         ELSE
            work( 7 ) = 0
         END IF
         CALL igebs2d( ictxt, 'All', ' ', 7, 1, work, 7 )
*
         i = 1
         CALL icopy( nmat, nval, 1, work( i ), 1 )
         i = i + nmat
         CALL icopy( nnb, nbval, 1, work( i ), 1 )
         i = i + nnb
         CALL icopy( nnr, nrval, 1, work( i ), 1 )
         i = i + nnr
         CALL icopy( nnbr, nbrval, 1, work( i ), 1 )
         i = i + nnbr
         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 Ax=b by LLt factorization.'
         WRITE( nout, fmt = 9999 ) usrinfo
         WRITE( nout, fmt = * )
         WRITE( nout, fmt = 9999 )
     $                   'Tests of the parallel '//
     $                   'real double precision LLt factorization '//
     $                   'and solve.'
         WRITE( nout, fmt = 9999 )
     $                   'The following scaled residual '//
     $                   'checks will be computed:'
         WRITE( nout, fmt = 9999 )
     $                   ' Solve residual         = ||Ax - b|| / '//
     $                   '(||x|| * ||A|| * eps * N)'
         IF( lsame( uplo, 'L' ) ) THEN
            WRITE( nout, fmt = 9999 )
     $                   ' Factorization residual = ||A - LL''|| /'//
     $                   ' (||A|| * eps * N)'
         ELSE
            WRITE( nout, fmt = 9999 )
     $                   ' Factorization residual = ||A - U''U|| /'//
     $                   ' (||A|| * eps * N)'
         END IF
         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 )
     $                   'UPLO    : Whether data is stored in ''Upper'//
     $                   ''' or ''Lower'' portion of array A.'
         WRITE( nout, fmt = 9999 )
     $                   'N       : The number of rows and columns '//
     $                   'in the matrix A.'
         WRITE( nout, fmt = 9999 )
     $                   'NB      : The size of the square blocks the'//
     $                   ' matrix A is split into.'
         WRITE( nout, fmt = 9999 )
     $                   'NRHS    : The total number of RHS to solve'//
     $                   ' for.'
         WRITE( nout, fmt = 9999 )
     $                   'NBRHS   : The number of RHS to be put on '//
     $                   'a column of processes before going'
         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 )
     $                   'THRESH  : If a residual value is less than'//
     $                   ' THRESH, CHECK is flagged as PASSED'
         WRITE( nout, fmt = 9999 )
     $                   'LLt time: Time in seconds to factor the'//
     $                   ' matrix'
         WRITE( nout, fmt = 9999 )
     $                   'Sol Time: Time in seconds to solve the'//
     $                   ' system.'
         WRITE( nout, fmt = 9999 )
     $                   'MFLOPS  : Rate of execution for factor '//
     $                   'and solve.'
         WRITE( nout, fmt = * )
         WRITE( nout, fmt = 9999 )
     $                   'The following parameter values will be used:'
         WRITE( nout, fmt = 9999 )
     $                   '  UPLO :             '//uplo
         WRITE( nout, fmt = 9996 )
     $                   'N    ', ( nval(i), i = 1, min(nmat, 10) )
         IF( nmat.GT.10 )
     $      WRITE( nout, fmt = 9997 ) ( nval(i), i = 11, nmat )
         WRITE( nout, fmt = 9996 )
     $                   'NB   ', ( nbval(i), i = 1, min(nnb, 10) )
         IF( nnb.GT.10 )
     $      WRITE( nout, fmt = 9997 ) ( nbval(i), i = 11, nnb )
         WRITE( nout, fmt = 9996 )
     $                   'NRHS ', ( nrval(i), i = 1, min(nnr, 10) )
         IF( nnr.GT.10 )
     $      WRITE( nout, fmt = 9997 ) ( nrval(i), i = 11, nnr )
         WRITE( nout, fmt = 9996 )
     $                   'NBRHS', ( nbrval(i), i = 1, min(nnbr, 10) )
         IF( nnbr.GT.10 )
     $      WRITE( nout, fmt = 9997 ) ( nbrval(i), i = 11, nnbr )
         WRITE( nout, fmt = 9996 )
     $                   'P    ', ( pval(i), i = 1, min(ngrids, 10) )
         IF( ngrids.GT.10 )
     $      WRITE( nout, fmt = 9997) ( pval(i), i = 11, ngrids )
         WRITE( nout, fmt = 9996 )
     $                   'Q    ', ( qval(i), i = 1, min(ngrids, 10) )
         IF( ngrids.GT.10 )
     $      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
*
         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', ' ', 7, 1, work, 7, 0, 0 )
         nmat   = work( 1 )
         nnb    = work( 2 )
         nnr    = work( 3 )
         nnbr   = work( 4 )
         ngrids = work( 5 )
         IF( work( 6 ).EQ.1 ) THEN
            uplo = 'L'
         ELSE
            uplo = 'U'
         END IF
         IF( work( 7 ).EQ.1 ) THEN
            est = .true.
         ELSE
            est = .false.
         END IF
*
         i = nmat + nnb + nnr + nnbr + 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( nnb, work( i ), 1, nbval, 1 )
         i = i + nnb
         CALL icopy( nnr, work( i ), 1, nrval, 1 )
         i = i + nnr
         CALL icopy( nnbr, work( i ), 1, nbrval, 1 )
         i = i + nnbr
         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 WRITE( nout, fmt = 9993 )
      CLOSE( nin )
      IF( nout.NE.6 .AND. nout.NE.0 )
     $   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 PDLLTINFO
*
      END