pcptinfo.f

Go to the documentation of this file.

      SUBROUTINE pcptinfo( SUMMRY, NOUT, UPLO, NMAT, NVAL, LDNVAL, NBW,
     $                     BWVAL, LDBWVAL, NNB, NBVAL, LDNBVAL, NNR,
     $                     NRVAL, LDNRVAL, NNBR, NBRVAL, LDNBRVAL,
     $                     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.
*     November 15, 1997
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      CHARACTER*(*)      SUMMRY
      INTEGER            IAM,
     $                   LDBWVAL, LDNBRVAL, LDNBVAL, LDNRVAL, LDNVAL,
     $                   ldpval, ldqval, ngrids, nmat, nnb, nnbr, nbw,
     $                   nprocs, nnr, nout
      REAL               THRESH
*     ..
*     .. Array Arguments ..
      INTEGER            NBRVAL( LDNBRVAL ), NBVAL( LDNBVAL ),
     $                   nrval( ldnrval ), nval( ldnval ),
     $                   bwval( ldbwval),
     $                   pval( ldpval ), qval(ldqval), work( * )
*     ..
*
*  Purpose
*  =======
*
*  PCPTINFO get needed startup information for band 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.
*
*  NBW      (global output) INTEGER
*           The number of different values that can be used for @bw@.
*  BWVAL    (global output) INTEGER array, dimension (LDNVAL)
*           The values of BW (number of subdiagonals 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)
*           Not used (will be returned as all 1s) since proc grid is 1D
*
*  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
*
*  WORK     (local workspace) INTEGER array of dimension >=
*           MAX( 8, LDNVAL+2*LDNBVAL+LDNRVAL+LDNBRVAL+LDPVAL+LDQVAL
*    $              +3*LDNVAL)
*           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.
*
*  =====================================================================
*
*  Code Developer: Andrew J. Cleary, University of Tennessee.
*    Current address: Lawrence Livermore National Labs.
*  This version released: August, 2001.
*
* ======================================================================
*
*     .. Parameters ..
      INTEGER            NIN
      PARAMETER          ( NIN = 11 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, ICTXT
      CHARACTER*79       USRINFO
      REAL               EPS
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_abort, blacs_get, blacs_gridexit,
     $                   blacs_gridinit, blacs_setup, icopy, igebr2d,
     $                   igebs2d, sgebr2d, sgebs2d
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               PSLAMCH
      EXTERNAL           LSAME, PSLAMCH
*     ..
*     .. 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 = 'BLLT.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
.NE..AND..NE.         IF( NOUT0  NOUT6 )
     $      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
.LT..OR..GT.         IF( NMAT1  NMATLDNVAL ) THEN
            WRITE( NOUT, FMT = 9994 ) 'n', LDNVAL
            GO TO 20
         END IF
         READ( NIN, FMT = * ) ( NVAL( I ), I = 1, NMAT )
*
*        Get bandwidths
*
         READ( NIN, FMT = * ) NBW
         NBW = 1
.LT..OR..GT.         IF( NBW1  NBWLDBWVAL ) THEN
            WRITE( NOUT, FMT = 9994 ) 'bw', LDBWVAL
            GO TO 20
         END IF
         READ( NIN, FMT = * ) ( BWVAL( I ), I = 1, NBW )
*
*        Get values of NB
*
         READ( NIN, FMT = * ) NNB
.LT..OR..GT.         IF( NNB1  NNBLDNBVAL ) 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
.LT..OR..GT.         IF( NNR1  NNRLDNRVAL ) 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
.LT..OR..GT.         IF( NNBR1  NNBRLDNBRVAL ) 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
.LT..OR..GT.         IF( NGRIDS1  NGRIDSLDPVAL ) THEN
            WRITE( NOUT, FMT = 9994 ) 'grids', LDPVAL
            GO TO 20
.GT.         ELSE IF( NGRIDSLDQVAL ) THEN
            WRITE( NOUT, FMT = 9994 ) 'grids', LDQVAL
            GO TO 20
         END IF
*
*        Processor grid must be 1D so set PVAL to 1
         DO 8738 I = 1, NGRIDS
            PVAL( I ) = 1
 8738    CONTINUE
*
*        Get values of Q
*
         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 = PSLAMCH( ICTXT, 'eps' )
*
*        Pack information arrays and broadcast
*
         CALL SGEBS2D( ICTXT, 'all', ' ', 1, 1, THRESH, 1 )
         I = 1
         WORK( I ) = NMAT
         I = I+1
         WORK( I ) = NBW
         I = I+1
         WORK( I ) = NNB
         I = I+1
         WORK( I ) = NNR
         I = I+1
         WORK( I ) = NNBR
         I = I+1
         WORK( I ) = NGRIDS
         I = I+1
         IF( LSAME( UPLO, 'l' ) ) THEN
            WORK( I ) = 1
         ELSE
            WORK( I ) = 2
         END IF
         I = I+1
*        Send number of elements to be sent
         CALL IGEBS2D( ICTXT, 'all', ' ', 1, 1, I-1, 1 )
*        Send elements
         CALL IGEBS2D( ICTXT, 'all', ' ', I-1, 1, WORK, I-1 )
*
         I = 1
         CALL ICOPY( NMAT, NVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NBW, BWVAL, 1, WORK( I ), 1 )
         I = I + NBW
         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
         CALL IGEBS2D( ICTXT, 'all', ' ', I-1, 1, WORK, I-1 )
*
*        regurgitate input
*
         WRITE( NOUT, FMT = 9999 )
     $                   'scalapack banded linear systems.'
         WRITE( NOUT, FMT = 9999 ) USRINFO
         WRITE( NOUT, FMT = * )
         WRITE( NOUT, FMT = 9999 )
     $                   'tests of the parallel '//
     $                   'complex single precision band matrix 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 represents ''Upper'//
     $                 ''' or ''Lower'' triangular portion of array A.'
         WRITE( nout, fmt = 9999 )
     $                 'TRANS    : Whether solve is to be done with'//
     $                 ' ''Transpose'' of matrix A (T,C) or not (N).'
         WRITE( nout, fmt = 9999 )
     $                   'N       : The number of rows and columns '//
     $                   'in the matrix A.'
         WRITE( nout, fmt = 9999 )
     $                   'bw      : The number of diagonals '//
     $                   'in the matrix A.'
         WRITE( nout, fmt = 9999 )
     $                   'NB      : The size of the column panels the'//
     $                   ' matrix A is split into. [-1 for default]'
         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 )
     $                   'Fact 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 using sequential operation count.'
         WRITE( nout, fmt = 9999 )
     $                   'MFLOP2  : Rough estimate of speed '//
     $                   'using actual op count (accurate big P,N).'
         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 )
     $                   'bw   ', ( bwval(i), i = 1, min(nbw, 10) )
         IF( nbw.GT.10 )
     $      WRITE( nout, fmt = 9997 ) ( bwval(i), i = 11, nbw )
         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) )
.GT.         IF( NNR10 )
     $      WRITE( NOUT, FMT = 9997 ) ( NRVAL(I), I = 11, NNR )
         WRITE( NOUT, FMT = 9996 )
     $                   'nbrhs', ( NBRVAL(I), I = 1, MIN(NNBR, 10) )
.GT.         IF( NNBR10 )
     $      WRITE( NOUT, FMT = 9997 ) ( NBRVAL(I), I = 11, NNBR )
         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', ' ', 1, 1, I, 1, 0, 0 )
         CALL IGEBR2D( ICTXT, 'all', ' ', I, 1, WORK, I, 0, 0 )
         I = 1
         NMAT = WORK( I )
         I = I+1
         NBW = WORK( I )
         I = I+1
         NNB = WORK( I )
         I = I+1
         NNR = WORK( I )
         I = I+1
         NNBR = WORK( I )
         I = I+1
         NGRIDS = WORK( I )
         I = I+1
.EQ.         IF( WORK( I )  1 ) THEN
            UPLO = 'l'
         ELSE
            UPLO = 'u'
         END IF
         I = I+1
*
         I = NMAT + NBW + 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( NBW, WORK( I ), 1, BWVAL, 1 )
         I = I + NBW
         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 )
.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 PCPTINFO
*
      END