SUBROUTINE VDIMCHK( ICTXT, NOUT, N, MATRIX, IX, JX, DESCX, INCX,
     $                    INFO )
*
*  -- PBLAS test routine (version 1.5) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      CHARACTER          MATRIX
      INTEGER            ICTXT, INCX, INFO, IX, JX, N, NOUT
*     ..
*     .. Array Arguments ..
      INTEGER            DESCX( * )
*     ..
*
*  Purpose
*  =======
*
*  VDIMCHK checks the validity of the input test dimensions. In case of
*  an invalid parameter or discrepancy between the parameters, this
*  routine displays error messages and returns an non-zero error code
*  in INFO.
*
*  Notes
*  =====
*
*  Each global data object is described by an associated description
*  vector.  This vector stores the information required to establish
*  the mapping between an object element and its corresponding process
*  and memory location.
*
*  Let A be a generic term for any 2D block cyclicly distributed array.
*  Such a global array has an associated description vector DESCA.
*  In the following comments, the character _ should be read as
*  "of the global array".
*
*  NOTATION        STORED IN      EXPLANATION
*  --------------- -------------- --------------------------------------
*  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
*                                 DTYPE_A = 1.
*  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
*                                 the BLACS process grid A is distribu-
*                                 ted over. The context itself is glo-
*                                 bal, but the handle (the integer
*                                 value) may vary.
*  M_A    (global) DESCA( M_ )    The number of rows in the global
*                                 array A.
*  N_A    (global) DESCA( N_ )    The number of columns in the global
*                                 array A.
*  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
*                                 the rows of the array.
*  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
*                                 the columns of the array.
*  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
*                                 row of the array A is distributed.
*  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
*                                 first column of the array A is
*                                 distributed.
*  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
*                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
*
*  Let K be the number of rows or columns of a distributed matrix,
*  and assume that its process grid has dimension p x q.
*  LOCr( K ) denotes the number of elements of K that a process
*  would receive if K were distributed over the p processes of its
*  process column.
*  Similarly, LOCc( K ) denotes the number of elements of K that a
*  process would receive if K were distributed over the q processes of
*  its process row.
*  The values of LOCr() and LOCc() may be determined via a call to the
*  ScaLAPACK tool function, NUMROC:
*          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
*          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
*  An upper bound for these quantities may be computed by:
*          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
*          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
*
*  Arguments
*  =========
*
*  ICTXT   (global input) INTEGER
*          The BLACS context handle, indicating the global context of
*          the operation on the matrix. The context itself is global.
*
*  NOUT    (global input) INTEGER
*          The unit number for output file. NOUT = 6, ouput to screen,
*          NOUT = 0, output to stderr.  Only defined for process 0.
*
*  MATRIX  (global input) CHARACTER
*          The one character distributed matrix identifier.
*
*  IX      (global input) INTEGER
*          The row index in the global array X indicating the first
*          row of sub( X ).
*
*  JX      (global input) INTEGER
*          The column index in the global array X indicating the
*          first column of sub( X ).
*
*  DESCX   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix X.
*
*  INCX    (global input) INTEGER
*          The global increment for the elements of X. Only two values
*          of INCX are supported in this version, namely 1 and M_X.
*          INCX must not be zero.
*
*  INFO    (global output) INTEGER
*          = 0: successful exit
*          otherwise an error has been detected.
*
*  =====================================================================
*
*     .. 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 )
*     ..
*     .. Local Scalars ..
      INTEGER         MYCOL, MYROW, NPCOL, NPROW
*     ..
*     .. External Subroutines ..
      EXTERNAL        BLACS_GRIDINFO, IGSUM2D
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
      IF( N.LT.0 ) THEN
         INFO = 1
      END IF
*
      IF( INCX.EQ.DESCX( M_ ) .AND.
     $    DESCX( N_ ).LT.( JX+N-1 ) ) THEN
         INFO = 1
      ELSE IF( INCX.EQ.1 .AND. INCX.NE.DESCX( M_ ) .AND.
     $    DESCX( M_ ).LT.( IX+N-1 ) ) THEN
         INFO = 1
      ELSE
         IF( IX.GT.DESCX( M_ ) ) THEN
            INFO = 1
         ELSE IF( JX.GT.DESCX( N_ ) ) THEN
            INFO = 1
         END IF
      END IF
*
*     Check all processes for an error
*
      CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, 0 )
*
      IF( INFO.NE.0 ) THEN
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
            WRITE( NOUT, FMT = 9999 ) MATRIX
            WRITE( NOUT, FMT = 9998 ) N, MATRIX, IX, MATRIX, JX, MATRIX,
     $                                INCX
            WRITE( NOUT, FMT = 9997 ) MATRIX, DESCX( M_ ), MATRIX,
     $                                DESCX( N_ )
            WRITE( NOUT, FMT = * )
         END IF
      END IF
*
      RETURN
*
 9999 FORMAT( 'Incompatible arguments for matrix ', A1, ':' )
 9998 FORMAT( 'N = ', I6, ', I', A1, ' = ', I6, ', J', A1, ' = ',
     $        I6, ',INC', A1, ' = ', I6 )
 9997 FORMAT( 'DESC', A1, '( M_ ) = ', I6, ', DESC', A1, '( M_ ) = ',
     $        I6, '.' )
*
*     End of VDIMCHK
*
      END
      SUBROUTINE MDIMCHK( ICTXT, NOUT, M, N, MATRIX, IA, JA, DESCA,
     $                    INFO )
*
*  -- PBLAS test routine (version 1.5) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      CHARACTER          MATRIX
      INTEGER            ICTXT, INFO, IA, JA, M, N, NOUT
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * )
*     ..
*
*  Purpose
*  =======
*
*  MDIMCHK checks the validity of the input test dimensions. In case of
*  an invalid parameter or discrepancy between the parameters, this
*  routine displays error messages and returns an non-zero error code
*  in INFO.
*
*  Notes
*  =====
*
*  Each global data object is described by an associated description
*  vector.  This vector stores the information required to establish
*  the mapping between an object element and its corresponding process
*  and memory location.
*
*  Let A be a generic term for any 2D block cyclicly distributed array.
*  Such a global array has an associated description vector DESCA.
*  In the following comments, the character _ should be read as
*  "of the global array".
*
*  NOTATION        STORED IN      EXPLANATION
*  --------------- -------------- --------------------------------------
*  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
*                                 DTYPE_A = 1.
*  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
*                                 the BLACS process grid A is distribu-
*                                 ted over. The context itself is glo-
*                                 bal, but the handle (the integer
*                                 value) may vary.
*  M_A    (global) DESCA( M_ )    The number of rows in the global
*                                 array A.
*  N_A    (global) DESCA( N_ )    The number of columns in the global
*                                 array A.
*  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
*                                 the rows of the array.
*  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
*                                 the columns of the array.
*  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
*                                 row of the array A is distributed.
*  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
*                                 first column of the array A is
*                                 distributed.
*  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
*                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
*
*  Let K be the number of rows or columns of a distributed matrix,
*  and assume that its process grid has dimension p x q.
*  LOCr( K ) denotes the number of elements of K that a process
*  would receive if K were distributed over the p processes of its
*  process column.
*  Similarly, LOCc( K ) denotes the number of elements of K that a
*  process would receive if K were distributed over the q processes of
*  its process row.
*  The values of LOCr() and LOCc() may be determined via a call to the
*  ScaLAPACK tool function, NUMROC:
*          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
*          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
*  An upper bound for these quantities may be computed by:
*          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
*          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
*
*  Arguments
*  =========
*
*  ICTXT   (global input) INTEGER
*          The BLACS context handle, indicating the global context of
*          the operation on the matrix. The context itself is global.
*
*  NOUT    (global input) INTEGER
*          The unit number for output file. NOUT = 6, ouput to screen,
*          NOUT = 0, output to stderr.  Only defined for process 0.
*
*  MATRIX  (global input) CHARACTER
*          The one character distributed matrix identifier.
*
*  IA      (global input) INTEGER
*          The row index in the global array A indicating the first
*          row of sub( A ).
*
*  JA      (global input) INTEGER
*          The column index in the global array A indicating the
*          first column of sub( A ).
*
*  DESCA   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix A.
*
*  INFO    (global output) INTEGER
*          = 0: successful exit
*          otherwise an error has been detected.
*
*  =====================================================================
*
*     .. 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 )
*     ..
*     .. Local Scalars ..
      INTEGER         MYCOL, MYROW, NPCOL, NPROW
*     ..
*     .. External Subroutines ..
      EXTERNAL        BLACS_GRIDINFO, IGSUM2D
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
      IF( M.LT.0 ) THEN
         INFO = 1
      END IF
*
      IF( DESCA( M_ ).LT.( IA+M-1 ) ) THEN
         INFO = 1
      END IF
*
      IF( N.LT.0 ) THEN
         INFO = 1
      END IF
*
      IF( DESCA( N_ ).LT.( JA+N-1 ) ) THEN
         INFO = 1
      END IF
*
*     Check all processes for an error
*
      CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, 0 )
*
      IF( INFO.NE.0 ) THEN
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
            WRITE( NOUT, FMT = 9999 ) MATRIX
            WRITE( NOUT, FMT = 9998 ) M, N, MATRIX, IA, MATRIX, JA
            WRITE( NOUT, FMT = 9997 ) MATRIX, DESCA( M_ ), MATRIX,
     $                                DESCA( N_ )
            WRITE( NOUT, FMT = * )
         END IF
      END IF
*
      RETURN
*
 9999 FORMAT( 'Incompatible arguments for matrix ', A1, ':' )
 9998 FORMAT( 'M = ', I6, ', N = ', I6, ', I', A1, ' = ', I6,
     $        ', J', A1, ' = ', I6, ',INC', A1, ' = ', I6 )
 9997 FORMAT( 'DESC', A1, '( M_ ) = ', I6, ', DESC', A1, '( M_ ) = ',
     $        I6, '.' )
*
*     End of MDIMCHK
*
      END
      SUBROUTINE VDESCCHK( ICTXT, NOUT, MATRIX, DESCX, MX, NX, MBX, NBX,
     $                     RSRCX, CSRCX, INCX, MPX, NQX, IPREPADX,
     $                     IMIDPADX, IPOSTPADX, IGAP, GAPMUL, INFO )
*
*  -- PBLAS test routine (version 1.5) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      CHARACTER          MATRIX
      INTEGER            CSRCX, GAPMUL, ICTXT, IGAP, IMIDPADX, INCX,
     $                   INFO, IPOSTPADX, IPREPADX, MBX, MPX, MX, NBX,
     $                   NOUT, NQX, NX, RSRCX
*     ..
*     .. Array Arguments ..
      INTEGER            DESCX( * )
*     ..
*
*  Purpose
*  =======
*
*  VDESCCHK checks the validity of the input test parameters and
*  initializes the descriptor DESCX and the scalar variables MPX, NQX.
*  In case of an invalid parameter, this routine displays error messages
*  and return an non-zero error code in INFO.
*
*  Notes
*  =====
*
*  Each global data object is described by an associated description
*  vector.  This vector stores the information required to establish
*  the mapping between an object element and its corresponding process
*  and memory location.
*
*  Let A be a generic term for any 2D block cyclicly distributed array.
*  Such a global array has an associated description vector DESCA.
*  In the following comments, the character _ should be read as
*  "of the global array".
*
*  NOTATION        STORED IN      EXPLANATION
*  --------------- -------------- --------------------------------------
*  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
*                                 DTYPE_A = 1.
*  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
*                                 the BLACS process grid A is distribu-
*                                 ted over. The context itself is glo-
*                                 bal, but the handle (the integer
*                                 value) may vary.
*  M_A    (global) DESCA( M_ )    The number of rows in the global
*                                 array A.
*  N_A    (global) DESCA( N_ )    The number of columns in the global
*                                 array A.
*  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
*                                 the rows of the array.
*  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
*                                 the columns of the array.
*  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
*                                 row of the array A is distributed.
*  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
*                                 first column of the array A is
*                                 distributed.
*  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
*                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
*
*  Let K be the number of rows or columns of a distributed matrix,
*  and assume that its process grid has dimension p x q.
*  LOCr( K ) denotes the number of elements of K that a process
*  would receive if K were distributed over the p processes of its
*  process column.
*  Similarly, LOCc( K ) denotes the number of elements of K that a
*  process would receive if K were distributed over the q processes of
*  its process row.
*  The values of LOCr() and LOCc() may be determined via a call to the
*  ScaLAPACK tool function, NUMROC:
*          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
*          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
*  An upper bound for these quantities may be computed by:
*          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
*          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
*
*  Arguments
*  =========
*
*  ICTXT   (global input) INTEGER
*          The BLACS context handle, indicating the global context of
*          the operation on the matrix. The context itself is global.
*
*  NOUT    (global input) INTEGER
*          The unit number for output file. NOUT = 6, ouput to screen,
*          NOUT = 0, output to stderr.  Only defined for process 0.
*
*  MATRIX  (global input) CHARACTER
*          The one character distributed matrix identifier.
*
*  DESCX   (global output) INTEGER array of dimension DLEN_
*          The array descriptor of a distributed matrix to be set.
*
*  MX      (global input) INTEGER
*          The number of rows in the distributed matrix. MX >= 0.
*
*  NX      (global input) INTEGER
*          The number of columns in the distributed matrix. NX >= 0.
*
*  MBX     (global input) INTEGER
*          The blocking factor used to distribute the rows of the
*          matrix. MBX >= 1.
*
*  NBX     (global input) INTEGER
*          The blocking factor used to distribute the columns of the
*          matrix. NBX >= 1.
*
*  RSRCX   (global input) INTEGER
*          The process row over which the first row of the matrix is
*          matrix is distributed. 0 <= RSRCX < NPROW.
*
*  CSRCX   (global input) INTEGER
*          The process column over which the first column of the
*          matrix is distributed. 0 <= CSRCX < NPCOL.
*
*  INCX    (global input) INTEGER
*          The global vector increment. INCX = 1 or MX.
*
*  MPX     (local output) INTEGER
*          On exit, MPX = LOCr( MX ).
*
*  NQX     (local output) INTEGER
*          On exit, NQX = LOCc( NX ).
*
*  IPREPADX  (local output) INTEGER
*          The size of the guard zone to put before the start of
*          padded array.
*
*  IMIDPADX  (local output) INTEGER
*          The ldx-gap of the guard zone to put before the start of
*          padded array.
*
*  IPOSTPADX (local output) INTEGER
*          The size of the guard zone to put after padded array.
*
*  IGAP    (global input) INTEGER
*          The size of the ldx-gap.
*
*  GAPMUL  (global input) INTEGER
*          A constant factor controlling the size of the pre- and post
*          guardzone.
*
*  INFO    (global output) INTEGER
*          = 0: successful exit
*          otherwise an error has been detected.
*
*  =====================================================================
*
*     .. 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 )
*     ..
*     .. Local Scalars ..
      INTEGER            LLDX, MYCOL, MYROW, NPCOL, NPROW
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, DESCINIT, IGSUM2D
*     ..
*     .. External Functions ..
      INTEGER            NUMROC
      EXTERNAL           NUMROC
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
*     Verify global matrix dimensions (M_,N_) are correct
*
      IF( MX.LT.1 ) THEN
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
     $      WRITE( NOUT, FMT = 9999 ) MATRIX, 'M', MATRIX, MX
         INFO = 1
      ELSE IF( NX.LT.1 ) THEN
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
     $      WRITE( NOUT, FMT = 9998 ) MATRIX, 'N', MATRIX, NX
         INFO = 1
      END IF
*
*     Verify if blocking factors (MB_, NB_) are correct
*
      IF( MBX.LT.1 ) THEN
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
     $      WRITE( NOUT, FMT = 9997 ) MATRIX, 'MB', MATRIX, MBX
         INFO = 1
      ELSE IF( NBX.LT.1 ) THEN
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
     $      WRITE( NOUT, FMT = 9996 ) MATRIX, 'NB', MATRIX, NBX
         INFO = 1
      END IF
*
*     Verify if origin process coordinates (RSRC_, CSRC_) are valid
*
      IF( RSRCX.LT.0 .OR. RSRCX.GE.NPROW ) THEN
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
            WRITE( NOUT, FMT = 9995 ) MATRIX
            WRITE( NOUT, FMT = 9993 ) 'RSRC', MATRIX, RSRCX, NPROW
         END IF
         INFO = 1
      ELSE IF( CSRCX.LT.0 .OR. CSRCX.GE.NPCOL ) THEN
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
            WRITE( NOUT, FMT = 9994 ) MATRIX
            WRITE( NOUT, FMT = 9993 ) 'CSRC', MATRIX, CSRCX, NPCOL
         END IF
         INFO = 1
      END IF
*
*     Check input increment value
*
      IF( INCX.NE.1 .AND. INCX.NE.MX ) THEN
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
            WRITE( NOUT, FMT = 9992 ) MATRIX
            WRITE( NOUT, FMT = 9991 ) 'INC', MATRIX, INCX, MATRIX, MX
         END IF
         INFO = 1
      END IF
*
*     Check all processes for an error
*
      CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, 0 )
*
      IF( INFO.NE.0 ) THEN
*
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
            WRITE( NOUT, FMT = 9990 ) MATRIX
            WRITE( NOUT, FMT = * )
         END IF
*
      ELSE
*
*        Compute local testing leading dimension
*
         MPX = NUMROC( MX, MBX, MYROW, RSRCX, NPROW )
         NQX = NUMROC( NX, NBX, MYCOL, CSRCX, NPCOL )
         IPREPADX  = MAX( GAPMUL*NBX, MPX )
         IMIDPADX  = IGAP
         IPOSTPADX = MAX( GAPMUL*NBX, NQX )
         LLDX = MAX( 1, MPX ) + IMIDPADX
*
         CALL DESCINIT( DESCX, MX, NX, MBX, NBX, RSRCX, CSRCX, ICTXT,
     $                  LLDX, INFO )
*
*        Check all processes for an error
*
         CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, 0 )
*
         IF( INFO.NE.0 ) THEN
            IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
               WRITE( NOUT, FMT = 9990 ) MATRIX
               WRITE( NOUT, FMT = * )
            END IF
         END IF
*
      END IF
*
      RETURN
*
 9999 FORMAT( 2X, '>> Invalid matrix ', A1, ' row dimension ', A1, A1,
     $        ': ', I6, ' should be at least 1.' )
 9998 FORMAT( 2X, '>> Invalid matrix ', A1, ' column dimension ', A1,
     $        A1, ': ', I6, ' should be at least 1.' )
 9997 FORMAT( 2X, '>> Invalid matrix ', A1, ' row block size ', A2, A1,
     $        ': ', I6, ' should be at least 1.' )
 9996 FORMAT( 2X, '>> Invalid matrix ', A1, ' column block size ', A2,
     $        A1,': ', I6, ' should be at least 1.' )
 9995 FORMAT( 2X, '>> Invalid matrix ', A1, ' row process source:' )
 9994 FORMAT( 2X, '>> Invalid matrix ', A1, ' column process source:' )
 9993 FORMAT( 2X, '>> ', A4, A1, '= ', I6, ' should be >= 0 and < ', I6,
     $        '.' )
 9992 FORMAT( 2X, '>> Invalid vector ', A1, ' increment:' )
 9991 FORMAT( 2X, '>> ', A3, A1, '= ', I6, ' should be 1 or M', A1,
     $        ' = ', I6, '.' )
 9990 FORMAT( 2X, '>> Invalid matrix ', A1, ' descriptor: going on to ',
     $        'next test case.' )
*
*     End of VDESCCHK
*
      END
      SUBROUTINE MDESCCHK( ICTXT, NOUT, MATRIX, DESCA, MA, NA, MBA, NBA,
     $                     RSRCA, CSRCA, MPA, NQA, IPREPADA, IMIDPADA,
     $                     IPOSTPADA, IGAP, GAPMUL, INFO )
*
*  -- PBLAS test routine (version 1.5) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      CHARACTER          MATRIX
      INTEGER            CSRCA, GAPMUL, ICTXT, IGAP, IMIDPADA, INFO,
     $                   IPOSTPADA, IPREPADA, MBA, MPA, MA, NBA, NOUT,
     $                   NQA, NA, RSRCA
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * )
*     ..
*
*  Purpose
*  =======
*
*  MDESCCHK checks the validity of the input test parameters and
*  initializes the descriptor DESCA and the scalar variables MPA, NQA.
*  In case of an invalid parameter, this routine displays error messages
*  and return an non-zero error code in INFO.
*
*  Notes
*  =====
*
*  Each global data object is described by an associated description
*  vector.  This vector stores the information required to establish
*  the mapping between an object element and its corresponding process
*  and memory location.
*
*  Let A be a generic term for any 2D block cyclicly distributed array.
*  Such a global array has an associated description vector DESCA.
*  In the following comments, the character _ should be read as
*  "of the global array".
*
*  NOTATION        STORED IN      EXPLANATION
*  --------------- -------------- --------------------------------------
*  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
*                                 DTYPE_A = 1.
*  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
*                                 the BLACS process grid A is distribu-
*                                 ted over. The context itself is glo-
*                                 bal, but the handle (the integer
*                                 value) may vary.
*  M_A    (global) DESCA( M_ )    The number of rows in the global
*                                 array A.
*  N_A    (global) DESCA( N_ )    The number of columns in the global
*                                 array A.
*  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
*                                 the rows of the array.
*  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
*                                 the columns of the array.
*  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
*                                 row of the array A is distributed.
*  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
*                                 first column of the array A is
*                                 distributed.
*  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
*                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
*
*  Let K be the number of rows or columns of a distributed matrix,
*  and assume that its process grid has dimension p x q.
*  LOCr( K ) denotes the number of elements of K that a process
*  would receive if K were distributed over the p processes of its
*  process column.
*  Similarly, LOCc( K ) denotes the number of elements of K that a
*  process would receive if K were distributed over the q processes of
*  its process row.
*  The values of LOCr() and LOCc() may be determined via a call to the
*  ScaLAPACK tool function, NUMROC:
*          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
*          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
*  An upper bound for these quantities may be computed by:
*          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
*          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
*
*  Arguments
*  =========
*
*  ICTXT   (global input) INTEGER
*          The BLACS context handle, indicating the global context of
*          the operation on the matrix. The context itself is global.
*
*  NOUT    (global input) INTEGER
*          The unit number for output file. NOUT = 6, ouput to screen,
*          NOUT = 0, output to stderr.  Only defined for process 0.
*
*  MATRIX  (global input) CHARACTER
*          The one character distributed matrix identifier.
*
*  DESCA   (global output) INTEGER array of dimension 8
*          The array descriptor of a distributed matrix to be set.
*
*  MA      (global input) INTEGER
*          The number of rows in the distributed matrix. MA >= 0.
*
*  NA      (global input) INTEGER
*          The number of columns in the distributed matrix. NA >= 0.
*
*  MBA     (global input) INTEGER
*          The blocking factor used to distribute the rows of the
*          matrix. MBA >= 1.
*
*  NBA     (global input) INTEGER
*          The blocking factor used to distribute the columns of the
*          matrix. NBA >= 1.
*
*  RSRCA   (global input) INTEGER
*          The process row over which the first row of the matrix is
*          matrix is distributed. 0 <= RSRCA < NPROW.
*
*  CSRCA   (global input) INTEGER
*          The process column over which the first column of the
*          matrix is distributed. 0 <= CSRCA < NPCOL.
*
*  MPA     (local output) INTEGER
*          On exit, MPA = LOCr( MA ).
*
*  NQA     (local output) INTEGER
*          On exit, NQA = LOCc( NA ).
*
*  IPREPADA  (local output) INTEGER
*          The size of the guard zone to put before the start of
*          padded array.
*
*  IMIDPADA  (local output) INTEGER
*          The lda-gap of the guard zone to put before the start of
*          padded array.
*
*  IPOSTPADA (local output) INTEGER
*          The size of the guard zone to put after padded array.
*
*  IGAP    (global input) INTEGER
*          The size of the ldx-gap.
*
*  GAPMUL  (global input) INTEGER
*          A constant factor controlling the size of the pre- and post
*          guardzone.
*
*  INFO    (global output) INTEGER
*          = 0: successful exit
*          otherwise an error has been detected.
*
*  =====================================================================
*
*     .. 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 )
*     ..
*     .. Local Scalars ..
      INTEGER            LLDA, MYCOL, MYROW, NPCOL, NPROW
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, DESCINIT, IGSUM2D
*     ..
*     .. External Functions ..
      INTEGER            NUMROC
      EXTERNAL           NUMROC
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
*     Verify global matrix dimensions (M_,N_) are correct
*
      IF( MA.LT.1 ) THEN
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
     $      WRITE( NOUT, FMT = 9999 ) MATRIX, 'M', MATRIX, MA
         INFO = 1
      ELSE IF( NA.LT.1 ) THEN
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
     $      WRITE( NOUT, FMT = 9998 ) MATRIX, 'N', MATRIX, NA
         INFO = 1
      END IF
*
*     Verify if blocking factors (MB_, NB_) are correct
*
      IF( MBA.LT.1 ) THEN
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
     $      WRITE( NOUT, FMT = 9997 ) MATRIX, 'MB', MATRIX, MBA
         INFO = 1
      ELSE IF( NBA.LT.1 ) THEN
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
     $      WRITE( NOUT, FMT = 9996 ) MATRIX, 'NB', MATRIX, NBA
         INFO = 1
      END IF
*
*     Verify if origin process coordinates (RSRC_, CSRC_) are valid
*
      IF( RSRCA.LT.0 .OR. RSRCA.GE.NPROW ) THEN
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
            WRITE( NOUT, FMT = 9995 ) MATRIX
            WRITE( NOUT, FMT = 9993 ) 'RSRC', MATRIX, RSRCA, NPROW
         END IF
         INFO = 1
      ELSE IF( CSRCA.LT.0 .OR. CSRCA.GE.NPCOL ) THEN
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
            WRITE( NOUT, FMT = 9994 ) MATRIX
            WRITE( NOUT, FMT = 9993 ) 'CSRC', MATRIX, CSRCA, NPCOL
         END IF
         INFO = 1
      END IF
*
*     Check all processes for an error
*
      CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, 0 )
*
      IF( INFO.NE.0 ) THEN
*
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
            WRITE( NOUT, FMT = 9992 ) MATRIX
            WRITE( NOUT, FMT = * )
         END IF
*
      ELSE
*
*        Compute local testing leading dimension
*
         MPA = NUMROC( MA, MBA, MYROW, RSRCA, NPROW )
         NQA = NUMROC( NA, NBA, MYCOL, CSRCA, NPCOL )
         IPREPADA  = MAX( GAPMUL*NBA, MPA )
         IMIDPADA  = IGAP
         IPOSTPADA = MAX( GAPMUL*NBA, NQA )
         LLDA = MAX( 1, MPA ) + IMIDPADA
*
         CALL DESCINIT( DESCA, MA, NA, MBA, NBA, RSRCA, CSRCA, ICTXT,
     $                  LLDA, INFO )
*
*        Check all processes for an error
*
         CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, 0 )
*
         IF( INFO.NE.0 ) THEN
            IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
               WRITE( NOUT, FMT = 9992 ) MATRIX
               WRITE( NOUT, FMT = * )
            END IF
         END IF
*
      END IF
*
      RETURN
*
 9999 FORMAT( 2X, '>> Invalid matrix ', A1, ' row dimension ', A1, A1,
     $        ': ', I6, ' should be at least 1.' )
 9998 FORMAT( 2X, '>> Invalid matrix ', A1, ' column dimension ', A1,
     $        A1, ': ', I6, ' should be at least 1.' )
 9997 FORMAT( 2X, '>> Invalid matrix ', A1, ' row block size ', A2, A1,
     $        ': ', I6, ' should be at least 1.' )
 9996 FORMAT( 2X, '>> Invalid matrix ', A1, ' column block size ', A2,
     $        A1,': ', I6, ' should be at least 1.' )
 9995 FORMAT( 2X, '>> Invalid matrix ', A1, ' row process source:' )
 9994 FORMAT( 2X, '>> Invalid matrix ', A1, ' column process source:' )
 9993 FORMAT( 2X, '>> ', A4, A1, '= ', I6, ' should be >= 0 and < ', I6,
     $        '.' )
 9992 FORMAT( 2X, '>> Invalid matrix ', A1, ' descriptor: going on to ',
     $        'next test case.' )
*
*     End of MDESCCHK
*
      END
      SUBROUTINE GETERR( CINFO, CABRTFLG )
*
*  -- PBLAS test routine (version 1.5) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      INTEGER            CABRTFLG, CINFO
*     ..
*
*  Purpose
*  =======
*
*  This routine is necessary because of the CRAY C fortran interface
*  and the fact that the usual pberror_ routine has been initially
*  written in C.
*
* ======================================================================
*
*     .. Scalars in Common ..
      INTEGER            INFO, NOUT
      LOGICAL            ABRTFLG
*     ..
*     .. Common blocks ..
      COMMON /INFOC/INFO
      COMMON /PBERRORC/NOUT, ABRTFLG
*     ..
*     .. Executable Statements ..
*
      INFO = CINFO
      IF( ABRTFLG ) THEN
         CABRTFLG = 1
      ELSE
         CABRTFLG = 0
      END IF
*
      RETURN
*
*     End of GETERR
*
      END
      SUBROUTINE PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
*
*  -- PBLAS test routine (version 1.5) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      INTEGER            ICTXT, INFOT, NOUT
      CHARACTER*(*)      SNAME
*     ..
*
*  Purpose
*  =======
*
*  PCHKPBE tests whether PBERROR has detected an error when it should.
*  This routine does a global operation to ensure all processes have
*  detected this error. If an error has been detected an error message
*  is displayed.
*
*  Notes
*  =====
*
*  Each global data object is described by an associated description
*  vector.  This vector stores the information required to establish
*  the mapping between an object element and its corresponding process
*  and memory location.
*
*  Let A be a generic term for any 2D block cyclicly distributed array.
*  Such a global array has an associated description vector DESCA.
*  In the following comments, the character _ should be read as
*  "of the global array".
*
*  NOTATION        STORED IN      EXPLANATION
*  --------------- -------------- --------------------------------------
*  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
*                                 DTYPE_A = 1.
*  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
*                                 the BLACS process grid A is distribu-
*                                 ted over. The context itself is glo-
*                                 bal, but the handle (the integer
*                                 value) may vary.
*  M_A    (global) DESCA( M_ )    The number of rows in the global
*                                 array A.
*  N_A    (global) DESCA( N_ )    The number of columns in the global
*                                 array A.
*  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
*                                 the rows of the array.
*  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
*                                 the columns of the array.
*  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
*                                 row of the array A is distributed.
*  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
*                                 first column of the array A is
*                                 distributed.
*  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
*                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
*
*  Let K be the number of rows or columns of a distributed matrix,
*  and assume that its process grid has dimension p x q.
*  LOCr( K ) denotes the number of elements of K that a process
*  would receive if K were distributed over the p processes of its
*  process column.
*  Similarly, LOCc( K ) denotes the number of elements of K that a
*  process would receive if K were distributed over the q processes of
*  its process row.
*  The values of LOCr() and LOCc() may be determined via a call to the
*  ScaLAPACK tool function, NUMROC:
*          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
*          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
*  An upper bound for these quantities may be computed by:
*          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
*          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
*
*  Arguments
*  =========
*
*  ICTXT   (global input) INTEGER
*          The BLACS context handle, indicating the global context of
*          the operation. The context itself is global.
*
*  NOUT    (global input) INTEGER
*          The unit number for output file. NOUT = 6, ouput to screen,
*          NOUT = 0, output to stderr. Only defined for process 0.
*
*  SNAME   (global input) CHARACTER*(*)
*          The subroutine name calling this subprogram.
*
*  INFOT   (global input) INTEGER
*          INFOT contains the position of the wrong argument. If PBERROR
*          is called it will set INFO to -INFOT. This routine verifies
*          if the error was reported by all processes by doing a global
*          global sum, and assert the result to be NPROW * NPCOL.
*
* ======================================================================
*
*     .. Local Scalars ..
      INTEGER            GERR, MYCOL, MYROW, NPCOL, NPROW
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, IGSUM2D
*     ..
*     .. Scalars in Common ..
      INTEGER            INFO
*     ..
*     .. Common blocks ..
      COMMON             /INFOC/INFO
*     ..
*     .. Executable Statements ..
*
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
      GERR = 0
      IF( INFO.NE.-INFOT )
     $   GERR = 1
*
      CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, GERR, 1, -1, 0 )
*
      IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
         IF( GERR.EQ.( NPROW * NPCOL ) ) THEN
            WRITE( NOUT, FMT = 9999 ) SNAME, INFO, -INFOT
         END IF
      END IF
*
      RETURN
*
 9999 FORMAT( 1X, A7, ': *** ERROR *** ERROR CODE RETURNED = ', I6,
     $        ' SHOULD HAVE BEEN ', I6 )
*
*     End of PCHKPBE
*
      END
      REAL FUNCTION SDIFF( X, Y )
*
*  Auxiliary routine for PBLAS test program.
*
*  -- Written on 10-August-1987.
*     Richard Hanson, Sandia National Labs.
*
*     .. Scalar Arguments ..
      REAL               X, Y
*     ..
*     .. Executable Statements ..
*
      SDIFF = X - Y
*
      RETURN
*
*     End of SDIFF
*
      END
      DOUBLE PRECISION FUNCTION DDIFF( X, Y )
*
*  Auxiliary routine for PBLAS test program.
*
*  -- Written on 10-August-1987.
*     Richard Hanson, Sandia National Labs.
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   X, Y
*     ..
*     .. Executable Statements ..
*
      DDIFF = X - Y
*
      RETURN
*
*     End of DDIFF
*
      END
*  =====================================================================
*     SUBROUTINE LADD
*  =====================================================================
*
      SUBROUTINE LADD( J, K, I )
*
*  -- PBLAS test routine (version 1.5) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Array Arguments ..
      INTEGER            I( 2 ), J( 2 ), K( 2 )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            IPOW16, IPOW15
      PARAMETER          ( IPOW16=2**16, IPOW15=2**15 )
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MOD
*     ..
*     .. Executable Statements ..
*
      I( 1 ) = MOD( K( 1 ) + J( 1 ), IPOW16 )
      I( 2 ) = MOD( ( K( 1 ) + J( 1 ) ) / IPOW16 + K( 2 ) + J( 2 ),
     $              IPOW15 )
*
      RETURN
*
*     End of LADD
*
      END
*
*  =====================================================================
*     SUBROUTINE LMUL
*  =====================================================================
*
      SUBROUTINE LMUL( K, J, I )
*
*  -- PBLAS test routine (version 1.5) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Array Arguments ..
      INTEGER            I( 2 ), J( 2 ), K( 2 )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            IPOW15, IPOW16, IPOW30
      PARAMETER          ( IPOW15=2**15, IPOW16=2**16, IPOW30=2**30 )
*     ..
*     .. Local Scalars ..
      INTEGER            KT, LT
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MOD
*     ..
*     .. Executable Statements ..
*
      KT = K(1) * J(1)
      IF( KT.LT.0 )
     $   KT = ( KT + IPOW30 ) + IPOW30
*
      I( 1 ) = MOD( KT, IPOW16 )
*
      LT = K( 1 ) * J( 2 ) + K( 2 ) * J( 1 )
      IF( LT.LT.0 )
     $   LT = ( LT + IPOW30 ) + IPOW30
*
      KT = KT / IPOW16 + LT
      IF( KT.LT.0 )
     $   KT = ( KT + IPOW30 ) + IPOW30
*
      I( 2 ) = MOD( KT, IPOW15 )
*
      RETURN
*
*     End of LMUL
*
      END
*
*  =====================================================================
*     SUBROUTINE XJUMPM
*  =====================================================================
*
      SUBROUTINE XJUMPM( JUMPM, MULT, IADD, IRANN, IRANM, IAM, ICM )
*
*  -- PBLAS test routine (version 1.5) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      INTEGER            JUMPM
*     ..
*     .. Array Arguments ..
      INTEGER            IADD( 2 ), IAM( 2 ), ICM( 2 ), IRANM( 2 ),
     $                   IRANN( 2 ), MULT( 2 )
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I
*     ..
*     .. Local Arrays ..
      INTEGER            J( 2 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           LADD, LMUL
*     ..
*     .. Executable Statements ..
*
      IF( JUMPM.GT.0 ) THEN
         DO 10 I = 1, 2
            IAM( I ) = MULT( I )
            ICM( I ) = IADD( I )
   10    CONTINUE
         DO 20 I = 1, JUMPM-1
            CALL LMUL( IAM, MULT, J )
            IAM( 1 ) = J( 1 )
            IAM( 2 ) = J( 2 )
            CALL LMUL( ICM, MULT, J )
            CALL LADD( IADD, J, ICM )
   20    CONTINUE
         CALL LMUL( IRANN, IAM, J )
         CALL LADD( J, ICM, IRANM )
      ELSE
         IRANM( 1 ) = IRANN( 1 )
         IRANM( 2 ) = IRANN( 2 )
      END IF
*
      RETURN
*
*     End of XJUMPM
*
      END
*
*  =====================================================================
*     SUBROUTINE SETRAN
*  =====================================================================
*
      SUBROUTINE SETRAN( IRAN, IA, IC )
*
*  -- PBLAS test routine (version 1.5) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Array Arguments ..
      INTEGER            IA( 2 ),  IC( 2 ), IRAN( 2 )
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I
*     ..
*     .. Arrays in Common ..
      INTEGER            IAS( 2 ), ICS( 2 ), IRAND( 2 )
*     ..
*     .. Common Blocks ..
      COMMON /RANCOM/    IRAND, IAS, ICS
      SAVE   /RANCOM/
*     ..
*     .. Executable Statements ..
*
      DO 10 I = 1, 2
         IRAND( I) = IRAN( I )
         IAS( I )   = IA( I )
         ICS( I )   = IC( I )
   10 CONTINUE
*
      RETURN
*
*     End of SETRAN
*
      END
*
*  =====================================================================
*     SUBROUTINE JUMPIT
*  =====================================================================
*
      SUBROUTINE JUMPIT( MULT, IADD, IRANN, IRANM )
*
*  -- PBLAS test routine (version 1.5) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Array Arguments ..
      INTEGER            IADD( 2 ), IRANM( 2 ), IRANN( 2 ), MULT( 2 )
*     ..
*
*  =====================================================================
*
*     .. Local Arrays ..
      INTEGER            J( 2 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           LADD, LMUL
*
*     .. Arrays in Common ..
      INTEGER            IAS( 2 ), ICS( 2 ), IRAND( 2 )
*     ..
*     .. Common Blocks ..
      COMMON /RANCOM/    IRAND, IAS, ICS
      SAVE   /RANCOM/
*     ..
*     .. Executable Statements ..
*
      CALL LMUL( IRANN, MULT, J )
      CALL LADD( J, IADD, IRANM )
*
      IRAND( 1 ) = IRANM( 1 )
      IRAND( 2 ) = IRANM( 2 )
*
      RETURN
*
*     End of JUMPIT
*
      END
*
*  =====================================================================
*     REAL FUNCTION PSRAND
*  =====================================================================
*
      REAL FUNCTION PSRAND( IDUMM )
*
*  -- PBLAS test routine (version 1.5) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      INTEGER            IDUMM
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, TWO
      PARAMETER          ( TWO = 2.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          REAL
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   PDRAN
      EXTERNAL           PDRAN
*     ..
*     .. Executable Statements ..
*
      PSRAND = REAL( ONE - TWO * PDRAN( IDUMM ) )
*
      RETURN
*
*     End of PSRAND
*
      END
*
*  =====================================================================
*     DOUBLE PRECISION FUNCTION PDRAND
*  =====================================================================
*
      DOUBLE PRECISION FUNCTION PDRAND( IDUMM )
*
*  -- PBLAS test routine (version 1.5) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      INTEGER            IDUMM
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, TWO
      PARAMETER          ( TWO = 2.0D+0, ONE = 1.0D+0 )
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   PDRAN
      EXTERNAL           PDRAN
*     ..
*     .. Executable Statements ..
*
      PDRAND = ONE - TWO * PDRAN( IDUMM )
*
      RETURN
*
*     End of PDRAND
*
      END
*
*  =====================================================================
*     DOUBLE PRECISION FUNCTION PDRAN
*  =====================================================================
*
      DOUBLE PRECISION FUNCTION PDRAN( IDUMM )
*
*  -- PBLAS test routine (version 1.5) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      INTEGER            IDUMM
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   DIVFAC, POW16
      PARAMETER          ( DIVFAC=2.147483648D+9, POW16=6.5536D+4 )
*     ..
*     .. Local Arrays ..
      INTEGER            J( 2 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           LADD, LMUL
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE
*     ..
*     .. Arrays in Common ..
      INTEGER            IAS( 2 ), ICS( 2 ), IRAND( 2 )
*     ..
*     .. Common Blocks ..
      COMMON /RANCOM/    IRAND, IAS, ICS
      SAVE   /RANCOM/
*     ..
*     .. Executable Statements ..
*
      PDRAN = ( DBLE( IRAND( 1 ) ) + POW16 * DBLE( IRAND( 2 ) ) ) /
     $        DIVFAC
*
      CALL LMUL( IRAND, IAS, J )
      CALL LADD( J, ICS, IRAND )
*
      RETURN
*
*     End of PDRAN
*
      END