pzblastst.f

Go to the documentation of this file.

      SUBROUTINE pzoptee( ICTXT, NOUT, SUBPTR, SCODE, SNAME )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER            ICTXT, NOUT, SCODE
*     ..
*     .. Array Arguments ..
      CHARACTER*(*)      SNAME
*     ..
*     .. Subroutine Arguments ..
      EXTERNAL           subptr
*     ..
*
*  Purpose
*  =======
*
*  PZOPTEE  tests  whether  the  PBLAS respond correctly to a bad option
*  argument.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  NOUT    (global input) INTEGER
*          On entry, NOUT specifies the unit number for the output file.
*          When NOUT is 6, output to screen,  when  NOUT is 0, output to
*          stderr. NOUT is only defined for process 0.
*
*  SUBPTR  (global input) SUBROUTINE
*          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
*          EXTERNAL in the calling subroutine.
*
*  SCODE   (global input) INTEGER
*          On entry, SCODE specifies the calling sequence code.
*
*  SNAME   (global input) CHARACTER*(*)
*          On entry,  SNAME  specifies  the subroutine name calling this
*          subprogram.
*
*  Calling sequence encodings
*  ==========================
*
*  code Formal argument list                                Examples
*
*  11   (n,      v1,v2)                                     _SWAP, _COPY
*  12   (n,s1,   v1   )                                     _SCAL, _SCAL
*  13   (n,s1,   v1,v2)                                     _AXPY, _DOT_
*  14   (n,s1,i1,v1   )                                     _AMAX
*  15   (n,u1,   v1   )                                     _ASUM, _NRM2
*
*  21   (     trans,     m,n,s1,m1,v1,s2,v2)                _GEMV
*  22   (uplo,             n,s1,m1,v1,s2,v2)                _SYMV, _HEMV
*  23   (uplo,trans,diag,  n,   m1,v1      )                _TRMV, _TRSV
*  24   (                m,n,s1,v1,v2,m1)                   _GER_
*  25   (uplo,             n,s1,v1,   m1)                   _SYR
*  26   (uplo,             n,u1,v1,   m1)                   _HER
*  27   (uplo,             n,s1,v1,v2,m1)                   _SYR2, _HER2
*
*  31   (          transa,transb,     m,n,k,s1,m1,m2,s2,m3) _GEMM
*  32   (side,uplo,                   m,n,  s1,m1,m2,s2,m3) _SYMM, _HEMM
*  33   (     uplo,trans,               n,k,s1,m1,   s2,m3) _SYRK
*  34   (     uplo,trans,               n,k,u1,m1,   u2,m3) _HERK
*  35   (     uplo,trans,               n,k,s1,m1,m2,s2,m3) _SYR2K
*  36   (     uplo,trans,               n,k,s1,m1,m2,u2,m3) _HER2K
*  37   (                             m,n,  s1,m1,   s2,m3) _TRAN_
*  38   (side,uplo,transa,       diag,m,n,  s1,m1,m2      ) _TRMM, _TRSM
*  39   (          trans,             m,n,  s1,m1,   s2,m3) _GEADD
*  40   (     uplo,trans,             m,n,  s1,m1,   s2,m3) _TRADD
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER             APOS
*     ..
*     .. External Subroutines ..
      EXTERNAL            pzchkopt
*     ..
*     .. Executable Statements ..
*
*     Level 2 PBLAS
*
      IF( scode.EQ.21 ) THEN
*
*        Check 1st (and only) option
*
         apos = 1
         CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'A', apos )
*
      ELSE IF( scode.EQ.22 .OR. scode.EQ.25 .OR. scode.EQ.26 .OR.
     $         scode.EQ.27 ) THEN
*
*        Check 1st (and only) option
*
         apos = 1
         CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'u', APOS )
*
.EQ.      ELSE IF( SCODE23 ) THEN
*
*        Check 1st option
*
         APOS = 1
         CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'u', APOS )
*
*        Check 2nd option
*
         APOS = 2
         CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
*
*        Check 3rd option
*
         APOS = 3
         CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'd', APOS )
*
*     Level 3 PBLAS
*
.EQ.      ELSE IF( SCODE31 ) THEN
*
*        Check 1st option
*
         APOS = 1
         CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
*
*        Check 2'nd option
*
         APOS = 2
         CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'b', APOS )
*
.EQ.      ELSE IF( SCODE32 ) THEN
*
*        Check 1st option
*
         APOS = 1
         CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 's', APOS )
*
*        Check 2nd option
*
         APOS = 2
         CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'u', APOS )
*
.EQ..OR..EQ..OR..EQ..OR.      ELSE IF( SCODE33  SCODE34  SCODE35 
.EQ..OR..EQ.     $         SCODE36  SCODE40 ) THEN
*
*        Check 1st option
*
         APOS = 1
         CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'u', APOS )
*
*        Check 2'nd option
*
         APOS = 2
         CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
*
.EQ.      ELSE IF( SCODE38 ) THEN
*
*        Check 1st option
*
         APOS = 1
         CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 's', APOS )
*
*        Check 2nd option
*
         APOS = 2
         CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'u', APOS )
*
*        Check 3rd option
*
         APOS = 3
         CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
*
*        Check 4th option
*
         APOS = 4
         CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'd', APOS )
*
*
.EQ.      ELSE IF( SCODE39 ) THEN
*
*        Check 1st option
*
         APOS = 1
         CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
*
      END IF
*
      RETURN
*
*     End of PZOPTEE
*
      END
      SUBROUTINE PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, ARGNAM,
     $                     ARGPOS )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1         ARGNAM
      INTEGER             ARGPOS, ICTXT, NOUT, SCODE
*     ..
*     .. Array Arguments ..
      CHARACTER*(*)       SNAME
*     ..
*     .. Subroutine Arguments ..
      EXTERNAL            SUBPTR
*     ..
*
*  Purpose
*  =======
*
*  PZCHKOPT tests the option ARGNAM in any PBLAS routine.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  NOUT    (global input) INTEGER
*          On entry, NOUT specifies the unit number for the output file.
*          When NOUT is 6, output to screen,  when  NOUT is 0, output to
*          stderr. NOUT is only defined for process 0.
*
*  SUBPTR  (global input) SUBROUTINE
*          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
*          EXTERNAL in the calling subroutine.
*
*  SCODE   (global input) INTEGER
*          On entry, SCODE specifies the calling sequence code.
*
*  SNAME   (global input) CHARACTER*(*)
*          On entry,  SNAME  specifies  the subroutine name calling this
*          subprogram.
*
*  ARGNAM  (global input) CHARACTER*(*)
*          On entry,  ARGNAM  specifies  the  name  of  the option to be
*          checked. ARGNAM can either be 'D', 'S', 'A', 'B', or 'U'.
*
*  ARGPOS  (global input) INTEGER
*          On entry, ARGPOS indicates the position of the option ARGNAM
*          to be tested.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            INFOT
*     ..
*     .. External Subroutines ..
      EXTERNAL           PCHKPBE, PZCALLSUB, PZSETPBLAS
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Common Blocks ..
      CHARACTER          DIAG, SIDE, TRANSA, TRANSB, UPLO
      COMMON             /PBLASC/DIAG, SIDE, TRANSA, TRANSB, UPLO
*     ..
*     .. Executable Statements ..
*
*     Reiniatilize the dummy arguments to correct values
*
      CALL PZSETPBLAS( ICTXT )
*
      IF( LSAME( ARGNAM, 'd' ) ) THEN
*
*        Generate bad DIAG option
*
         DIAG = '/'
*
      ELSE IF( LSAME( ARGNAM, 's' ) ) THEN
*
*        Generate bad SIDE option
*
         SIDE = '/'
*
      ELSE IF( LSAME( ARGNAM, 'a' ) ) THEN
*
*        Generate bad TRANSA option
*
         TRANSA = '/'
*
      ELSE IF( LSAME( ARGNAM, 'b' ) ) THEN
*
*        Generate bad TRANSB option
*
         TRANSB = '/'
*
      ELSE IF( LSAME( ARGNAM, 'u' ) ) THEN
*
*        Generate bad UPLO option
*
         UPLO = '/'
*
      END IF
*
*     Set INFOT to the position of the bad dimension argument
*
      INFOT = ARGPOS
*
*     Call the PBLAS routine
*
      CALL PZCALLSUB( SUBPTR, SCODE )
      CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
*
      RETURN
*
*     End of PZCHKOPT
*
      END
      SUBROUTINE PZDIMEE( ICTXT, NOUT, SUBPTR, SCODE, SNAME )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER            ICTXT, NOUT, SCODE
*     ..
*     .. Array Arguments ..
      CHARACTER*(*)      SNAME
*     ..
*     .. Subroutine Arguments ..
      EXTERNAL           SUBPTR
*     ..
*
*  Purpose
*  =======
*
*  PZDIMEE  tests whether the PBLAS respond correctly to a bad dimension
*  argument.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  NOUT    (global input) INTEGER
*          On entry, NOUT specifies the unit number for the output file.
*          When NOUT is 6, output to screen,  when  NOUT is 0, output to
*          stderr. NOUT is only defined for process 0.
*
*  SUBPTR  (global input) SUBROUTINE
*          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
*          EXTERNAL in the calling subroutine.
*
*  SCODE   (global input) INTEGER
*          On entry, SCODE specifies the calling sequence code.
*
*  SNAME   (global input) CHARACTER*(*)
*          On entry,  SNAME  specifies  the subroutine name calling this
*          subprogram.
*
*  Calling sequence encodings
*  ==========================
*
*  code Formal argument list                                Examples
*
*  11   (n,      v1,v2)                                     _SWAP, _COPY
*  12   (n,s1,   v1   )                                     _SCAL, _SCAL
*  13   (n,s1,   v1,v2)                                     _AXPY, _DOT_
*  14   (n,s1,i1,v1   )                                     _AMAX
*  15   (n,u1,   v1   )                                     _ASUM, _NRM2
*
*  21   (     trans,     m,n,s1,m1,v1,s2,v2)                _GEMV
*  22   (uplo,             n,s1,m1,v1,s2,v2)                _SYMV, _HEMV
*  23   (uplo,trans,diag,  n,   m1,v1      )                _TRMV, _TRSV
*  24   (                m,n,s1,v1,v2,m1)                   _GER_
*  25   (uplo,             n,s1,v1,   m1)                   _SYR
*  26   (uplo,             n,u1,v1,   m1)                   _HER
*  27   (uplo,             n,s1,v1,v2,m1)                   _SYR2, _HER2
*
*  31   (          transa,transb,     m,n,k,s1,m1,m2,s2,m3) _GEMM
*  32   (side,uplo,                   m,n,  s1,m1,m2,s2,m3) _SYMM, _HEMM
*  33   (     uplo,trans,               n,k,s1,m1,   s2,m3) _SYRK
*  34   (     uplo,trans,               n,k,u1,m1,   u2,m3) _HERK
*  35   (     uplo,trans,               n,k,s1,m1,m2,s2,m3) _SYR2K
*  36   (     uplo,trans,               n,k,s1,m1,m2,u2,m3) _HER2K
*  37   (                             m,n,  s1,m1,   s2,m3) _TRAN_
*  38   (side,uplo,transa,       diag,m,n,  s1,m1,m2      ) _TRMM, _TRSM
*  39   (          trans,             m,n,  s1,m1,   s2,m3) _GEADD
*  40   (     uplo,trans,             m,n,  s1,m1,   s2,m3) _TRADD
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER             APOS
*     ..
*     .. External Subroutines ..
      EXTERNAL            PZCHKDIM
*     ..
*     .. Executable Statements ..
*
*     Level 1 PBLAS
*
.EQ..OR..EQ..OR..EQ..OR.      IF( SCODE11  SCODE12  SCODE13 
.EQ..OR..EQ.     $    SCODE14  SCODE15 ) THEN
*
*        Check 1st (and only) dimension
*
         APOS = 1
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'n', APOS )
*
*     Level 2 PBLAS
*
.EQ.      ELSE IF( SCODE21 ) THEN
*
*        Check 1st dimension
*
         APOS = 2
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'm', APOS )
*
*        Check 2nd dimension
*
         APOS = 3
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'n', APOS )
*
.EQ..OR..EQ..OR..EQ..OR.      ELSE IF( SCODE22  SCODE25  SCODE26 
.EQ.     $         SCODE27 ) THEN
*
*        Check 1st (and only) dimension
*
         APOS = 2
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'n', APOS )
*
.EQ.      ELSE IF( SCODE23 ) THEN
*
*        Check 1st (and only) dimension
*
         APOS = 4
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'n', APOS )
*
.EQ.      ELSE IF( SCODE24 ) THEN
*
*        Check 1st dimension
*
         APOS = 1
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'm', APOS )
*
*        Check 2nd dimension
*
         APOS = 2
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'n', APOS )
*
*     Level 3 PBLAS
*
.EQ.      ELSE IF( SCODE31 ) THEN
*
*        Check 1st dimension
*
         APOS = 3
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'm', APOS )
*
*        Check 2nd dimension
*
         APOS = 4
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'n', APOS )
*
*        Check 3rd dimension
*
         APOS = 5
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'k', APOS )
*
.EQ.      ELSE IF( SCODE32 ) THEN
*
*        Check 1st dimension
*
         APOS = 3
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'm', APOS )
*
*        Check 2nd dimension
*
         APOS = 4
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'n', APOS )
*
.EQ..OR..EQ..OR..EQ..OR.      ELSE IF( SCODE33  SCODE34  SCODE35 
.EQ.     $         SCODE36 ) THEN
*
*        Check 1st dimension
*
         APOS = 3
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'n', APOS )
*
*        Check 2nd dimension
*
         APOS = 4
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'k', APOS )
*
.EQ.      ELSE IF( SCODE37 ) THEN
*
*        Check 1st dimension
*
         APOS = 1
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'm', APOS )
*
*        Check 2nd dimension
*
         APOS = 2
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'n', APOS )
*
.EQ.      ELSE IF( SCODE38 ) THEN
*
*        Check 1st dimension
*
         APOS = 5
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'm', APOS )
*
*        Check 2nd dimension
*
         APOS = 6
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'n', APOS )
*
.EQ.      ELSE IF( SCODE39 ) THEN
*
*        Check 1st dimension
*
         APOS = 2
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'm', APOS )
*
*        Check 2nd dimension
*
         APOS = 3
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'n', APOS )
*
.EQ.      ELSE IF( SCODE40 ) THEN
*
*        Check 1st dimension
*
         APOS = 3
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'm', APOS )
*
*        Check 2nd dimension
*
         APOS = 4
         CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'n', APOS )
*
      END IF
*
      RETURN
*
*     End of PZDIMEE
*
      END
      SUBROUTINE PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, ARGNAM,
     $                     ARGPOS )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1         ARGNAM
      INTEGER             ARGPOS, ICTXT, NOUT, SCODE
*     ..
*     .. Array Arguments ..
      CHARACTER*(*)       SNAME
*     ..
*     .. Subroutine Arguments ..
      EXTERNAL            SUBPTR
*     ..
*
*  Purpose
*  =======
*
*  PZCHKDIM tests the dimension ARGNAM in any PBLAS routine.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  NOUT    (global input) INTEGER
*          On entry, NOUT specifies the unit number for the output file.
*          When NOUT is 6, output to screen,  when  NOUT is 0, output to
*          stderr. NOUT is only defined for process 0.
*
*  SUBPTR  (global input) SUBROUTINE
*          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
*          EXTERNAL in the calling subroutine.
*
*  SCODE   (global input) INTEGER
*          On entry, SCODE specifies the calling sequence code.
*
*  SNAME   (global input) CHARACTER*(*)
*          On entry,  SNAME  specifies  the subroutine name calling this
*          subprogram.
*
*  ARGNAM  (global input) CHARACTER*(*)
*          On entry,  ARGNAM  specifies  the name of the dimension to be
*          checked. ARGNAM can either be 'M', 'N' or 'K'.
*
*  ARGPOS  (global input) INTEGER
*          On entry, ARGPOS indicates the position of the option ARGNAM
*          to be tested.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            INFOT
*     ..
*     .. External Subroutines ..
      EXTERNAL           PCHKPBE, PZCALLSUB, PZSETPBLAS
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Common Blocks ..
      INTEGER            KDIM, MDIM, NDIM
      COMMON             /PBLASN/KDIM, MDIM, NDIM
*     ..
*     .. Executable Statements ..
*
*     Reiniatilize the dummy arguments to correct values
*
      CALL PZSETPBLAS( ICTXT )
*
      IF( LSAME( ARGNAM, 'm' ) ) THEN
*
*        Generate bad MDIM
*
         MDIM = -1
*
      ELSE IF( LSAME( ARGNAM, 'n' ) ) THEN
*
*        Generate bad NDIM
*
         NDIM = -1
*
      ELSE
*
*        Generate bad KDIM
*
         KDIM = -1
*
      END IF
*
*     Set INFOT to the position of the bad dimension argument
*
      INFOT = ARGPOS
*
*     Call the PBLAS routine
*
      CALL PZCALLSUB( SUBPTR, SCODE )
      CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
*
      RETURN
*
*     End of PZCHKDIM
*
      END
      SUBROUTINE PZVECEE( ICTXT, NOUT, SUBPTR, SCODE, SNAME )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER             ICTXT, NOUT, SCODE
*     ..
*     .. Array Arguments ..
      CHARACTER*7         SNAME
*     ..
*     .. Subroutine Arguments ..
      EXTERNAL            SUBPTR
*     ..
*
*  Purpose
*  =======
*
*  PZVECEE  tests  whether  the  PBLAS respond correctly to a bad vector
*  argument.  Each  vector <vec> is described by: <vec>, I<vec>, J<vec>,
*  DESC<vec>,  INC<vec>.   Out   of  all  these,  only  I<vec>,  J<vec>,
*  DESC<vec>, and INC<vec> can be tested.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  NOUT    (global input) INTEGER
*          On entry, NOUT specifies the unit number for the output file.
*          When NOUT is 6, output to screen,  when  NOUT is 0, output to
*          stderr. NOUT is only defined for process 0.
*
*  SUBPTR  (global input) SUBROUTINE
*          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
*          EXTERNAL in the calling subroutine.
*
*  SCODE   (global input) INTEGER
*          On entry, SCODE specifies the calling sequence code.
*
*  SNAME   (global input) CHARACTER*(*)
*          On entry,  SNAME  specifies  the subroutine name calling this
*          subprogram.
*
*  Calling sequence encodings
*  ==========================
*
*  code Formal argument list                                Examples
*
*  11   (n,      v1,v2)                                     _SWAP, _COPY
*  12   (n,s1,   v1   )                                     _SCAL, _SCAL
*  13   (n,s1,   v1,v2)                                     _AXPY, _DOT_
*  14   (n,s1,i1,v1   )                                     _AMAX
*  15   (n,u1,   v1   )                                     _ASUM, _NRM2
*
*  21   (     trans,     m,n,s1,m1,v1,s2,v2)                _GEMV
*  22   (uplo,             n,s1,m1,v1,s2,v2)                _SYMV, _HEMV
*  23   (uplo,trans,diag,  n,   m1,v1      )                _TRMV, _TRSV
*  24   (                m,n,s1,v1,v2,m1)                   _GER_
*  25   (uplo,             n,s1,v1,   m1)                   _SYR
*  26   (uplo,             n,u1,v1,   m1)                   _HER
*  27   (uplo,             n,s1,v1,v2,m1)                   _SYR2, _HER2
*
*  31   (          transa,transb,     m,n,k,s1,m1,m2,s2,m3) _GEMM
*  32   (side,uplo,                   m,n,  s1,m1,m2,s2,m3) _SYMM, _HEMM
*  33   (     uplo,trans,               n,k,s1,m1,   s2,m3) _SYRK
*  34   (     uplo,trans,               n,k,u1,m1,   u2,m3) _HERK
*  35   (     uplo,trans,               n,k,s1,m1,m2,s2,m3) _SYR2K
*  36   (     uplo,trans,               n,k,s1,m1,m2,u2,m3) _HER2K
*  37   (                             m,n,  s1,m1,   s2,m3) _TRAN_
*  38   (side,uplo,transa,       diag,m,n,  s1,m1,m2      ) _TRMM, _TRSM
*  39   (          trans,             m,n,  s1,m1,   s2,m3) _GEADD
*  40   (     uplo,trans,             m,n,  s1,m1,   s2,m3) _TRADD
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER             APOS
*     ..
*     .. External Subroutines ..
      EXTERNAL            PZCHKMAT
*     ..
*     .. Executable Statements ..
*
*     Level 1 PBLAS
*
.EQ.      IF( SCODE11 ) THEN
*
*        Check 1st vector
*
         APOS = 2
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'x', APOS )
*
*        Check 2nd vector
*
         APOS = 7
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'y', APOS )
*
.EQ..OR..EQ.      ELSE IF( SCODE12  SCODE15 ) THEN
*
*        Check 1st (and only) vector
*
         APOS = 3
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'x', APOS )
*
.EQ.      ELSE IF( SCODE13 ) THEN
*
*        Check 1st vector
*
         APOS = 3
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'x', APOS )
*
*        Check 2nd vector
*
         APOS = 8
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'y', APOS )
*
.EQ.      ELSE IF( SCODE14 ) THEN
*
*        Check 1st (and only) vector
*
         APOS = 4
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'x', APOS )
*
*     Level 2 PBLAS
*
.EQ.      ELSE IF( SCODE21 ) THEN
*
*        Check 1st vector
*
         APOS = 9
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'x', APOS )
*
*        Check 2nd vector
*
         APOS = 15
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'y', APOS )
*
.EQ.      ELSE IF( SCODE22 ) THEN
*
*        Check 1st vector
*
         APOS = 8
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'x', APOS )
*
*        Check 2nd vector
*
         APOS = 14
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'y', APOS )
*
.EQ.      ELSE IF( SCODE23 ) THEN
*
*        Check 1st (and only) vector
*
         APOS = 9
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'x', APOS )
*
.EQ..OR..EQ.      ELSE IF( SCODE24  SCODE27 ) THEN
*
*        Check 1st vector
*
         APOS = 4
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'x', APOS )
*
*        Check 2nd vector
*
         APOS = 9
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'y', APOS )
*
.EQ..OR..EQ.      ELSE IF( SCODE26  SCODE27 ) THEN
*
*        Check 1'st (and only) vector
*
         APOS = 4
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'x', APOS )
*
      END IF
*
      RETURN
*
*     End of PZVECEE
*
      END
      SUBROUTINE PZMATEE( ICTXT, NOUT, SUBPTR, SCODE, SNAME )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER             ICTXT, NOUT, SCODE
*     ..
*     .. Array Arguments ..
      CHARACTER*7         SNAME
*     ..
*     .. Subroutine Arguments ..
      EXTERNAL            SUBPTR
*     ..
*
*  Purpose
*  =======
*
*  PZMATEE  tests  whether  the  PBLAS respond correctly to a bad matrix
*  argument.  Each  matrix <mat> is described by: <mat>, I<mat>, J<mat>,
*  and DESC<mat>.  Out  of  all these, only I<vec>, J<vec> and DESC<mat>
*  can be tested.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  NOUT    (global input) INTEGER
*          On entry, NOUT specifies the unit number for the output file.
*          When NOUT is 6, output to screen,  when  NOUT is 0, output to
*          stderr. NOUT is only defined for process 0.
*
*  SUBPTR  (global input) SUBROUTINE
*          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
*          EXTERNAL in the calling subroutine.
*
*  SCODE   (global input) INTEGER
*          On entry, SCODE specifies the calling sequence code.
*
*  SNAME   (global input) CHARACTER*(*)
*          On entry,  SNAME  specifies  the subroutine name calling this
*          subprogram.
*
*  Calling sequence encodings
*  ==========================
*
*  code Formal argument list                                Examples
*
*  11   (n,      v1,v2)                                     _SWAP, _COPY
*  12   (n,s1,   v1   )                                     _SCAL, _SCAL
*  13   (n,s1,   v1,v2)                                     _AXPY, _DOT_
*  14   (n,s1,i1,v1   )                                     _AMAX
*  15   (n,u1,   v1   )                                     _ASUM, _NRM2
*
*  21   (     trans,     m,n,s1,m1,v1,s2,v2)                _GEMV
*  22   (uplo,             n,s1,m1,v1,s2,v2)                _SYMV, _HEMV
*  23   (uplo,trans,diag,  n,   m1,v1      )                _TRMV, _TRSV
*  24   (                m,n,s1,v1,v2,m1)                   _GER_
*  25   (uplo,             n,s1,v1,   m1)                   _SYR
*  26   (uplo,             n,u1,v1,   m1)                   _HER
*  27   (uplo,             n,s1,v1,v2,m1)                   _SYR2, _HER2
*
*  31   (          transa,transb,     m,n,k,s1,m1,m2,s2,m3) _GEMM
*  32   (side,uplo,                   m,n,  s1,m1,m2,s2,m3) _SYMM, _HEMM
*  33   (     uplo,trans,               n,k,s1,m1,   s2,m3) _SYRK
*  34   (     uplo,trans,               n,k,u1,m1,   u2,m3) _HERK
*  35   (     uplo,trans,               n,k,s1,m1,m2,s2,m3) _SYR2K
*  36   (     uplo,trans,               n,k,s1,m1,m2,u2,m3) _HER2K
*  37   (                             m,n,  s1,m1,   s2,m3) _TRAN_
*  38   (side,uplo,transa,       diag,m,n,  s1,m1,m2      ) _TRMM, _TRSM
*  39   (          trans,             m,n,  s1,m1,   s2,m3) _GEADD
*  40   (     uplo,trans,             m,n,  s1,m1,   s2,m3) _TRADD
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER             APOS
*     ..
*     .. External Subroutines ..
      EXTERNAL            PZCHKMAT
*     ..
*     .. Executable Statements ..
*
*     Level 2 PBLAS
*
.EQ..OR..EQ.      IF( SCODE21  SCODE23 ) THEN
*
*        Check 1st (and only) matrix
*
         APOS = 5
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
*
.EQ.      ELSE IF( SCODE22 ) THEN
*
*        Check 1st (and only) matrix
*
         APOS = 4
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
*
.EQ..OR..EQ.      ELSE IF( SCODE24  SCODE27 ) THEN
*
*        Check 1st (and only) matrix
*
         APOS = 14
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
*
.EQ..OR..EQ.      ELSE IF( SCODE25  SCODE26 ) THEN
*
*        Check 1st (and only) matrix
*
         APOS = 9
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
*
*     Level 3 PBLAS
*
.EQ.      ELSE IF( SCODE31 ) THEN
*
*        Check 1st matrix
*
         APOS = 7
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
*
*        Check 2nd matrix
*
         APOS = 11
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'b', APOS )
*
*        Check 3nd matrix
*
         APOS = 16
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'c', APOS )
*
.EQ..OR..EQ..OR..EQ.      ELSE IF( SCODE32  SCODE35  SCODE36 ) THEN
*
*        Check 1st matrix
*
         APOS = 6
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
*
*        Check 2nd matrix
*
         APOS = 10
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'b', APOS )
*
*        Check 3nd matrix
*
         APOS = 15
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'c', APOS )
*
.EQ..OR..EQ.      ELSE IF( SCODE33  SCODE34 ) THEN
*
*        Check 1st matrix
*
         APOS = 6
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
*
*        Check 2nd matrix
*
         APOS = 11
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'c', APOS )
*
.EQ.      ELSE IF( SCODE37 ) THEN
*
*        Check 1st matrix
*
         APOS = 4
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
*
*        Check 2nd matrix
*
         APOS = 9
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'c', APOS )
*
.EQ.      ELSE IF( SCODE38 ) THEN
*
*        Check 1st matrix
*
         APOS = 8
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'a', APOS )
*
*        Check 2nd matrix
*
         APOS = 12
         CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'b', apos )
*
      ELSE IF( scode.EQ.39 ) THEN
*
*        Check 1st matrix
*
         apos = 5
         CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
*
*        Check 2nd matrix
*
         apos = 10
         CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'C', apos )
*
      ELSE IF( scode.EQ.40 ) THEN
*
*        Check 1st matrix
*
         apos = 6
         CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
*
*        Check 2nd matrix
*
         apos = 11
         CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'C', apos )
*
      END IF
*
      RETURN
*
*     End of PZMATEE
*
      END
      SUBROUTINE pzsetpblas( ICTXT )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER            ICTXT
*     ..
*
*  Purpose
*  =======
*
*  PZSETPBLAS initializes *all* the dummy arguments to correct values.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   RSRC_
      parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
     $                   dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
     $                   imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
     $                   rsrc_ = 9, csrc_ = 10, lld_ = 11 )
      DOUBLE PRECISION   RONE
      COMPLEX*16         ONE
      parameter( one = ( 1.0d+0, 0.0d+0 ),
     $                   rone = 1.0d+0 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           pb_descset2
*     ..
*     .. Common Blocks ..
      CHARACTER*1        DIAG, SIDE, TRANSA, TRANSB, UPLO
      INTEGER            IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB,
     $                   JC, JX, JY, KDIM, MDIM, NDIM
      DOUBLE PRECISION   USCLR
      COMPLEX*16         SCLR
      INTEGER            DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
     $                   DESCX( DLEN_ ), DESCY( DLEN_ )
      COMPLEX*16         A( 2, 2 ), B( 2, 2 ), C( 2, 2 ), X( 2 ), Y( 2 )
      COMMON             /pblasc/diag, side, transa, transb, uplo
      COMMON             /pblasd/desca, descb, descc, descx, descy
      COMMON             /pblasi/ia, ib, ic, incx, incy, isclr, ix, iy,
     $                   ja, jb, jc, jx, jy
      COMMON             /pblasm/a, b, c
      COMMON             /pblasn/kdim, mdim, ndim
      COMMON             /pblass/sclr, usclr
      COMMON             /pblasv/x, y
*     ..
*     .. Executable Statements ..
*
*     Set default values for options
*
      diag   = 'N'
      side   = 'L'
      transa = 'N'
      transb = 'N'
      uplo   = 'U'
*
*     Set default values for scalars
*
      kdim   = 1
      mdim   = 1
      ndim   = 1
      isclr  = 1
      sclr   = one
      usclr  = rone
*
*     Set default values for distributed matrix A
*
      a( 1, 1 ) = one
      a( 2, 1 ) = one
      a( 1, 2 ) = one
      a( 2, 2 ) = one
      ia = 1
      ja = 1
      CALL pb_descset2( desca, 2, 2, 1, 1, 1, 1, 0, 0, ictxt, 2 )
*
*     Set default values for distributed matrix B
*
      b( 1, 1 ) = one
      b( 2, 1 ) = one
      b( 1, 2 ) = one
      b( 2, 2 ) = one
      ib = 1
      jb = 1
      CALL pb_descset2( descb, 2, 2, 1, 1, 1, 1, 0, 0, ictxt, 2 )
*
*     Set default values for distributed matrix C
*
      c( 1, 1 ) = one
      c( 2, 1 ) = one
      c( 1, 2 ) = one
      c( 2, 2 ) = one
      ic = 1
      jc = 1
      CALL pb_descset2( descc, 2, 2, 1, 1, 1, 1, 0, 0, ictxt, 2 )
*
*     Set default values for distributed matrix X
*
      x( 1 ) = one
      x( 2 ) = one
      ix = 1
      jx = 1
      CALL pb_descset2( descx, 2, 1, 1, 1, 1, 1, 0, 0, ictxt, 2 )
      incx = 1
*
*     Set default values for distributed matrix Y
*
      y( 1 ) = one
      y( 2 ) = one
      iy = 1
      jy = 1
      CALL pb_descset2( descy, 2, 1, 1, 1, 1, 1, 0, 0, ictxt, 2 )
      incy = 1
*
      RETURN
*
*     End of PZSETPBLAS
*
      END
      SUBROUTINE pzchkmat( ICTXT, NOUT, SUBPTR, SCODE, SNAME, ARGNAM,
     $                     ARGPOS )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1         ARGNAM
      INTEGER             ARGPOS, ICTXT, NOUT, SCODE
*     ..
*     .. Array Arguments ..
      CHARACTER*(*)       SNAME
*     ..
*     .. Subroutine Arguments ..
      EXTERNAL            subptr
*     ..
*
*  Purpose
*  =======
*
*  PZCHKMAT tests the matrix (or vector) ARGNAM in any PBLAS routine.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  NOUT    (global input) INTEGER
*          On entry, NOUT specifies the unit number for the output file.
*          When NOUT is 6, output to screen,  when  NOUT is 0, output to
*          stderr. NOUT is only defined for process 0.
*
*  SUBPTR  (global input) SUBROUTINE
*          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
*          EXTERNAL in the calling subroutine.
*
*  SCODE   (global input) INTEGER
*          On entry, SCODE specifies the calling sequence code.
*
*  SNAME   (global input) CHARACTER*(*)
*          On entry,  SNAME  specifies  the subroutine name calling this
*          subprogram.
*
*  ARGNAM  (global input) CHARACTER*(*)
*          On entry,  ARGNAM  specifies the name of the matrix or vector
*          to be checked.  ARGNAM can either be 'A', 'B' or 'C' when one
*          wants to check a matrix, and 'X' or 'Y' for a vector.
*
*  ARGPOS  (global input) INTEGER
*          On entry, ARGPOS indicates the position of the first argument
*          of the matrix (or vector) ARGNAM.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   dtype_, imb_, inb_, lld_, mb_, m_, nb_, n_,
     $                   rsrc_
      parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
     $                   dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
     $                   imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
     $                   rsrc_ = 9, csrc_ = 10, lld_ = 11 )
      INTEGER             DESCMULT
      parameter( descmult = 100 )
*     ..
*     .. Local Scalars ..
      INTEGER             I, INFOT, NPROW, NPCOL, MYROW, MYCOL
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_gridinfo, pchkpbe, pzcallsub, pzsetpblas
*     ..
*     .. External Functions ..
      LOGICAL             LSAME
      EXTERNAL            lsame
*     ..
*     .. Common Blocks ..
      INTEGER            IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB,
     $                   jc, jx, jy
      INTEGER            DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
     $                   descx( dlen_ ), descy( dlen_ )
      COMMON             /pblasd/desca, descb, descc, descx, descy
      COMMON             /pblasi/ia, ib, ic, incx, incy, isclr, ix, iy,
     $                   ja, jb, jc, jx, jy
*     ..
*     .. Executable Statements ..
*
      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
*
      IF( lsame( argnam, 'A' ) ) THEN
*
*        Check IA. Set all other OK, bad IA
*
         CALL pzsetpblas( ictxt )
         ia    = -1
         infot = argpos + 1
         CALL pzcallsub( subptr, scode )
         CALL pchkpbe( ictxt, nout, sname, infot )
*
*        Check JA. Set all other OK, bad JA
*
         CALL pzsetpblas( ictxt )
         ja    = -1
         infot = argpos + 2
         CALL pzcallsub( subptr, scode )
         CALL pchkpbe( ictxt, nout, sname, infot )
*
*        Check DESCA. Set all other OK, bad DESCA
*
         DO 10 i = 1, dlen_
*
*           Set I'th entry of DESCA to incorrect value, rest ok.
*
            CALL pzsetpblas( ictxt )
            desca( i ) =  -2
            infot = ( ( argpos + 3 ) * descmult ) + i
            CALL pzcallsub( subptr, scode )
            CALL pchkpbe( ictxt, nout, sname, infot )
*
*           Extra tests for RSRCA, CSRCA, LDA
*
            IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
     $          ( i.EQ.lld_ ) ) THEN
*
               CALL pzsetpblas( ictxt )
*
*              Test RSRCA >= NPROW
*
               IF( i.EQ.rsrc_ )
     $            desca( i ) =  nprow
*
*              Test CSRCA >= NPCOL
*
               IF( i.EQ.csrc_ )
     $            desca( i ) =  npcol
*
*              Test LDA >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
*
               IF( i.EQ.lld_ ) THEN
                  IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
                     desca( i ) = 1
                  ELSE
                     desca( i ) = 0
                  END IF
               END IF
*
               infot = ( ( argpos + 3 ) * descmult ) + i
               CALL pzcallsub( subptr, scode )
               CALL pchkpbe( ictxt, nout, sname, infot )
*
            END IF
*
   10    CONTINUE
*
      ELSE IF( lsame( argnam, 'B' ) ) THEN
*
*        Check IB. Set all other OK, bad IB
*
         CALL pzsetpblas( ictxt )
         ib    = -1
         infot = argpos + 1
         CALL pzcallsub( subptr, scode )
         CALL pchkpbe( ictxt, nout, sname, infot )
*
*        Check JB. Set all other OK, bad JB
*
         CALL pzsetpblas( ictxt )
         jb    = -1
         infot = argpos + 2
         CALL pzcallsub( subptr, scode )
         CALL pchkpbe( ictxt, nout, sname, infot )
*
*        Check DESCB. Set all other OK, bad DESCB
*
         DO 20 i = 1, dlen_
*
*           Set I'th entry of DESCB to incorrect value, rest ok.
*
            CALL pzsetpblas( ictxt )
            descb( i ) =  -2
            infot = ( ( argpos + 3 ) * descmult ) + i
            CALL pzcallsub( subptr, scode )
            CALL pchkpbe( ictxt, nout, sname, infot )
*
*           Extra tests for RSRCB, CSRCB, LDB
*
            IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
     $          ( i.EQ.lld_ ) ) THEN
*
               CALL pzsetpblas( ictxt )
*
*              Test RSRCB >= NPROW
*
               IF( i.EQ.rsrc_ )
     $            descb( i ) =  nprow
*
*              Test CSRCB >= NPCOL
*
               IF( i.EQ.csrc_ )
     $            descb( i ) =  npcol
*
*              Test LDB >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
*
               IF( i.EQ.lld_ ) THEN
                  IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
                     descb( i ) = 1
                  ELSE
                     descb( i ) = 0
                  END IF
               END IF
*
               infot = ( ( argpos + 3 ) * descmult ) + i
               CALL pzcallsub( subptr, scode )
               CALL pchkpbe( ictxt, nout, sname, infot )
*
            END IF
*
   20    CONTINUE
*
      ELSE IF( lsame( argnam, 'C' ) ) THEN
*
*        Check IC. Set all other OK, bad IC
*
         CALL pzsetpblas( ictxt )
         ic    = -1
         infot = argpos + 1
         CALL pzcallsub( subptr, scode )
         CALL pchkpbe( ictxt, nout, sname, infot )
*
*        Check JC. Set all other OK, bad JC
*
         CALL pzsetpblas( ictxt )
         jc    = -1
         infot = argpos + 2
         CALL pzcallsub( subptr, scode )
         CALL pchkpbe( ictxt, nout, sname, infot )
*
*        Check DESCC. Set all other OK, bad DESCC
*
         DO 30 i = 1, dlen_
*
*           Set I'th entry of DESCC to incorrect value, rest ok.
*
            CALL pzsetpblas( ictxt )
            descc( i ) =  -2
            infot = ( ( argpos + 3 ) * descmult ) + i
            CALL pzcallsub( subptr, scode )
            CALL pchkpbe( ictxt, nout, sname, infot )
*
*           Extra tests for RSRCC, CSRCC, LDC
*
            IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
     $          ( i.EQ.lld_ ) ) THEN
*
               CALL pzsetpblas( ictxt )
*
*              Test RSRCC >= NPROW
*
               IF( i.EQ.rsrc_ )
     $            descc( i ) =  nprow
*
*              Test CSRCC >= NPCOL
*
               IF( i.EQ.csrc_ )
     $            descc( i ) =  npcol
*
*              Test LDC >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
*
               IF( i.EQ.lld_ ) THEN
                  IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
                     descc( i ) = 1
                  ELSE
                     descc( i ) = 0
                  END IF
               END IF
*
               infot = ( ( argpos + 3 ) * descmult ) + i
               CALL pzcallsub( subptr, scode )
               CALL pchkpbe( ictxt, nout, sname, infot )
*
            END IF
*
   30    CONTINUE
*
      ELSE IF( lsame( argnam, 'X' ) ) THEN
*
*        Check IX. Set all other OK, bad IX
*
         CALL pzsetpblas( ictxt )
         ix    = -1
         infot = argpos + 1
         CALL pzcallsub( subptr, scode )
         CALL pchkpbe( ictxt, nout, sname, infot )
*
*        Check JX. Set all other OK, bad JX
*
         CALL pzsetpblas( ictxt )
         jx    = -1
         infot = argpos + 2
         CALL pzcallsub( subptr, scode )
         CALL pchkpbe( ictxt, nout, sname, infot )
*
*        Check DESCX. Set all other OK, bad DESCX
*
         DO 40 i = 1, dlen_
*
*           Set I'th entry of DESCX to incorrect value, rest ok.
*
            CALL pzsetpblas( ictxt )
            descx( i ) =  -2
            infot = ( ( argpos + 3 ) * descmult ) + i
            CALL pzcallsub( subptr, scode )
            CALL pchkpbe( ictxt, nout, sname, infot )
*
*           Extra tests for RSRCX, CSRCX, LDX
*
            IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
     $          ( i.EQ.lld_ ) ) THEN
*
               CALL pzsetpblas( ictxt )
*
*              Test RSRCX >= NPROW
*
               IF( i.EQ.rsrc_ )
     $            descx( i ) =  nprow
*
*              Test CSRCX >= NPCOL
*
               IF( i.EQ.csrc_ )
     $            descx( i ) =  npcol
*
*              Test LDX >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
*
               IF( i.EQ.lld_ ) THEN
                  IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
                     descx( i ) = 1
                  ELSE
                     descx( i ) = 0
                  END IF
               END IF
*
               infot = ( ( argpos + 3 ) * descmult ) + i
               CALL pzcallsub( subptr, scode )
               CALL pchkpbe( ictxt, nout, sname, infot )
*
            END IF
*
   40    CONTINUE
*
*        Check INCX. Set all other OK, bad INCX
*
         CALL pzsetpblas( ictxt )
         incx  =  -1
         infot = argpos + 4
         CALL pzcallsub( subptr, scode )
         CALL pchkpbe( ictxt, nout, sname, infot )
*
      ELSE
*
*        Check IY. Set all other OK, bad IY
*
         CALL pzsetpblas( ictxt )
         iy    = -1
         infot = argpos + 1
         CALL pzcallsub( subptr, scode )
         CALL pchkpbe( ictxt, nout, sname, infot )
*
*        Check JY. Set all other OK, bad JY
*
         CALL pzsetpblas( ictxt )
         jy    = -1
         infot = argpos + 2
         CALL pzcallsub( subptr, scode )
         CALL pchkpbe( ictxt, nout, sname, infot )
*
*        Check DESCY. Set all other OK, bad DESCY
*
         DO 50 i = 1, dlen_
*
*           Set I'th entry of DESCY to incorrect value, rest ok.
*
            CALL pzsetpblas( ictxt )
            descy( i ) =  -2
            infot = ( ( argpos + 3 ) * descmult ) + i
            CALL pzcallsub( subptr, scode )
            CALL pchkpbe( ictxt, nout, sname, infot )
*
*           Extra tests for RSRCY, CSRCY, LDY
*
            IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
     $          ( i.EQ.lld_ ) ) THEN
*
               CALL pzsetpblas( ictxt )
*
*              Test RSRCY >= NPROW
*
               IF( i.EQ.rsrc_ )
     $            descy( i ) = nprow
*
*              Test CSRCY >= NPCOL
*
               IF( i.EQ.csrc_ )
     $            descy( i ) = npcol
*
*              Test LDY >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
*
               IF( i.EQ.lld_ ) THEN
                  IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
                     descy( i ) = 1
                  ELSE
                     descy( i ) = 0
                  END IF
               END IF
*
               infot = ( ( argpos + 3 ) * descmult ) + i
               CALL pzcallsub( subptr, scode )
               CALL pchkpbe( ictxt, nout, sname, infot )
*
            END IF
*
   50    CONTINUE
*
*        Check INCY. Set all other OK, bad INCY
*
         CALL pzsetpblas( ictxt )
         incy =  -1
         infot = argpos + 4
         CALL pzcallsub( subptr, scode )
         CALL pchkpbe( ictxt, nout, sname, infot )
*
      END IF
*
      RETURN
*
*     End of PZCHKMAT
*
      END
      SUBROUTINE pzcallsub( SUBPTR, SCODE )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER             SCODE
*     ..
*     .. Subroutine Arguments ..
      EXTERNAL            subptr
*     ..
*
*  Purpose
*  =======
*
*  PZCALLSUB calls the subroutine SUBPTR with the calling sequence iden-
*  tified by SCODE.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  SUBPTR  (global input) SUBROUTINE
*          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
*          EXTERNAL in the calling subroutine.
*
*  SCODE   (global input) INTEGER
*          On entry, SCODE specifies the calling sequence code.
*
*  Calling sequence encodings
*  ==========================
*
*  code Formal argument list                                Examples
*
*  11   (n,      v1,v2)                                     _SWAP, _COPY
*  12   (n,s1,   v1   )                                     _SCAL, _SCAL
*  13   (n,s1,   v1,v2)                                     _AXPY, _DOT_
*  14   (n,s1,i1,v1   )                                     _AMAX
*  15   (n,u1,   v1   )                                     _ASUM, _NRM2
*
*  21   (     trans,     m,n,s1,m1,v1,s2,v2)                _GEMV
*  22   (uplo,             n,s1,m1,v1,s2,v2)                _SYMV, _HEMV
*  23   (uplo,trans,diag,  n,   m1,v1      )                _TRMV, _TRSV
*  24   (                m,n,s1,v1,v2,m1)                   _GER_
*  25   (uplo,             n,s1,v1,   m1)                   _SYR
*  26   (uplo,             n,u1,v1,   m1)                   _HER
*  27   (uplo,             n,s1,v1,v2,m1)                   _SYR2, _HER2
*
*  31   (          transa,transb,     m,n,k,s1,m1,m2,s2,m3) _GEMM
*  32   (side,uplo,                   m,n,  s1,m1,m2,s2,m3) _SYMM, _HEMM
*  33   (     uplo,trans,               n,k,s1,m1,   s2,m3) _SYRK
*  34   (     uplo,trans,               n,k,u1,m1,   u2,m3) _HERK
*  35   (     uplo,trans,               n,k,s1,m1,m2,s2,m3) _SYR2K
*  36   (     uplo,trans,               n,k,s1,m1,m2,u2,m3) _HER2K
*  37   (                             m,n,  s1,m1,   s2,m3) _TRAN_
*  38   (side,uplo,transa,       diag,m,n,  s1,m1,m2      ) _TRMM, _TRSM
*  39   (          trans,             m,n,  s1,m1,   s2,m3) _GEADD
*  40   (     uplo,trans,             m,n,  s1,m1,   s2,m3) _TRADD
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   dtype_, imb_, inb_, lld_, mb_, m_, nb_, n_,
     $                   rsrc_
      parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
     $                   dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
     $                   imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
     $                   rsrc_ = 9, csrc_ = 10, lld_ = 11 )
*     ..
*     .. Common Blocks ..
      CHARACTER*1        DIAG, SIDE, TRANSA, TRANSB, UPLO
      INTEGER            IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB,
     $                   jc, jx, jy, kdim, mdim, ndim
      DOUBLE PRECISION   USCLR
      COMPLEX*16         SCLR
      INTEGER            DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
     $                   descx( dlen_ ), descy( dlen_ )
      COMPLEX*16         A( 2, 2 ), B( 2, 2 ), C( 2, 2 ), X( 2 ), Y( 2 )
      COMMON             /pblasc/diag, side, transa, transb, uplo
      COMMON             /pblasd/desca, descb, descc, descx, descy
      COMMON             /pblasi/ia, ib, ic, incx, incy, isclr, ix, iy,
     $                   ja, jb, jc, jx, jy
      COMMON             /pblasm/a, b, c
      COMMON             /pblasn/kdim, mdim, ndim
      COMMON             /pblass/sclr, usclr
      COMMON             /pblasv/x, y
*     ..
*     .. Executable Statements ..
*
*     Level 1 PBLAS
*
      IF( scode.EQ.11 ) THEN
*
         CALL subptr( ndim, x, ix, jx, descx, incx, y, iy, jy, descy,
     $                incy )
*
      ELSE IF( scode.EQ.12 ) THEN
*
         CALL subptr( ndim, sclr, x, ix, jx, descx, incx )
*
      ELSE IF( scode.EQ.13 ) THEN
*
         CALL subptr( ndim, sclr, x, ix, jx, descx, incx, y, iy, jy,
     $                descy, incy )
*
      ELSE IF( scode.EQ.14 ) THEN
*
         CALL subptr( ndim, sclr, isclr, x, ix, jx, descx, incx )
*
      ELSE IF( scode.EQ.15 ) THEN
*
         CALL subptr( ndim, usclr, x, ix, jx, descx, incx )
*
*     Level 2 PBLAS
*
      ELSE IF( scode.EQ.21 ) THEN
*
         CALL subptr( transa, mdim, ndim, sclr, a, ia, ja, desca, x, ix,
     $                jx, descx, incx, sclr, y, iy, jy, descy, incy )
*
      ELSE IF( scode.EQ.22 ) THEN
*
         CALL subptr( uplo, ndim, sclr, a, ia, ja, desca, x, ix, jx,
     $                descx, incx, sclr, y, iy, jy, descy, incy )
*
      ELSE IF( scode.EQ.23 ) THEN
*
         CALL subptr( uplo, transa, diag, ndim, a, ia, ja, desca, x, ix,
     $                jx, descx, incx )
*
      ELSE IF( scode.EQ.24 ) THEN
*
         CALL subptr( mdim, ndim, sclr, x, ix, jx, descx, incx, y, iy,
     $                jy, descy, incy, a, ia, ja, desca )
*
      ELSE IF( scode.EQ.25 ) THEN
*
         CALL subptr( uplo, ndim, sclr, x, ix, jx, descx, incx, a, ia,
     $                ja, desca )
*
      ELSE IF( scode.EQ.26 ) THEN
*
         CALL subptr( uplo, ndim, usclr, x, ix, jx, descx, incx, a, ia,
     $                ja, desca )
*
      ELSE IF( scode.EQ.27 ) THEN
*
         CALL subptr( uplo, ndim, sclr, x, ix, jx, descx, incx, y, iy,
     $                jy, descy, incy, a, ia, ja, desca )
*
*     Level 3 PBLAS
*
      ELSE IF( scode.EQ.31 ) THEN
*
         CALL subptr( transa, transb, mdim, ndim, kdim, sclr, a, ia, ja,
     $                desca, b, ib, jb, descb, sclr, c, ic, jc, descc )
*
      ELSE IF( scode.EQ.32 ) THEN
*
         CALL subptr( side, uplo, mdim, ndim, sclr, a, ia, ja, desca, b,
     $                ib, jb, descb, sclr, c, ic, jc, descc )
*
      ELSE IF( scode.EQ.33 ) THEN
*
         CALL subptr( uplo, transa, ndim, kdim, sclr, a, ia, ja, desca,
     $                sclr, c, ic, jc, descc )
*
      ELSE IF( scode.EQ.34 ) THEN
*
         CALL subptr( uplo, transa, ndim, kdim, usclr, a, ia, ja, desca,
     $                usclr, c, ic, jc, descc )
*
      ELSE IF( scode.EQ.35 ) THEN
*
         CALL subptr( uplo, transa, ndim, kdim, sclr, a, ia, ja, desca,
     $                b, ib, jb, descb, sclr, c, ic, jc, descc )
*
      ELSE IF( scode.EQ.36 ) THEN
*
         CALL subptr( uplo, transa, ndim, kdim, sclr, a, ia, ja, desca,
     $                b, ib, jb, descb, usclr, c, ic, jc, descc )
*
      ELSE IF( scode.EQ.37 ) THEN
*
         CALL subptr( mdim, ndim, sclr, a, ia, ja, desca, sclr, c, ic,
     $                jc, descc )
*
      ELSE IF( scode.EQ.38 ) THEN
*
         CALL subptr( side, uplo, transa, diag, mdim, ndim, sclr, a, ia,
     $                ja, desca, b, ib, jb, descb )
*
      ELSE IF( scode.EQ.39 ) THEN
*
         CALL subptr( transa, mdim, ndim, sclr, a, ia, ja, desca, sclr,
     $                c, ic, jc, descc )
*
      ELSE IF( scode.EQ.40 ) THEN
*
         CALL subptr( uplo, transa, mdim, ndim, sclr, a, ia, ja, desca,
     $                sclr, c, ic, jc, descc )
*
      END IF
*
      RETURN
*
*     End of PZCALLSUB
*
      END
      SUBROUTINE pzerrset( ERR, ERRMAX, XTRUE, X )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   ERR, ERRMAX
      COMPLEX*16         X, XTRUE
*     ..
*
*  Purpose
*  =======
*
*  PZERRSET  computes the absolute difference ERR = |XTRUE - X| and com-
*  pares it with zero. ERRMAX accumulates the absolute error difference.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ERR     (local output) DOUBLE PRECISION
*          On exit, ERR specifies the absolute difference |XTRUE - X|.
*
*  ERRMAX  (local input/local output) DOUBLE PRECISION
*          On entry,  ERRMAX  specifies  a previously computed error. On
*          exit ERRMAX is the accumulated error MAX( ERRMAX, ERR ).
*
*  XTRUE   (local input) COMPLEX*16
*          On entry, XTRUE specifies the true value.
*
*  X       (local input) COMPLEX*16
*          On entry, X specifies the value to be compared to XTRUE.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. External Functions ..
      DOUBLE PRECISION   PDDIFF
      EXTERNAL           pddiff
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, dble, dimag, max
*     ..
*     .. Executable Statements ..
*
      err = abs( pddiff( dble( xtrue ), dble( x ) ) )
      err = max( err, abs( pddiff( dimag( xtrue ), dimag( x ) ) ) )
*
      errmax = max( errmax, err )
*
      RETURN
*
*     End of PZERRSET
*
      END
      SUBROUTINE pzchkvin( ERRMAX, N, X, PX, IX, JX, DESCX, INCX,
     $                     INFO )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER            INCX, INFO, IX, JX, N
      DOUBLE PRECISION   ERRMAX
*     ..
*     .. Array Arguments ..
      INTEGER            DESCX( * )
      COMPLEX*16         PX( * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*  PZCHKVIN  checks that the submatrix sub( PX ) remained unchanged. The
*  local  array  entries are compared element by element, and their dif-
*  ference  is tested against 0.0 as well as the epsilon machine. Notice
*  that  this difference should be numerically exactly the zero machine,
*  but  because of the possible fluctuation of some of the data we flag-
*  ged differently a difference less than twice the epsilon machine. The
*  largest error is also returned.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ERRMAX  (global output) DOUBLE PRECISION
*          On exit,  ERRMAX  specifies the largest absolute element-wise
*          difference between sub( X ) and sub( PX ).
*
*  N       (global input) INTEGER
*          On entry,  N  specifies  the  length of the subvector operand
*          sub( X ). N must be at least zero.
*
*  X       (local input) COMPLEX*16 array
*          On entry, X is an array of  dimension  (DESCX( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PX.
*
*  PX      (local input) COMPLEX*16 array
*          On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
*          array contains the local entries of the matrix PX.
*
*  IX      (global input) INTEGER
*          On entry, IX  specifies X's global row index, which points to
*          the beginning of the submatrix sub( X ).
*
*  JX      (global input) INTEGER
*          On entry, JX  specifies X's global column index, which points
*          to the beginning of the submatrix sub( X ).
*
*  DESCX   (global and local input) INTEGER array
*          On entry, DESCX  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix X.
*
*  INCX    (global input) INTEGER
*          On entry,  INCX   specifies  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
*          On exit, if INFO = 0, no error has been found,
*          If INFO > 0, the maximum abolute error found is in (0,eps],
*          If INFO < 0, the maximum abolute error found is in (eps,+oo).
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   rsrc_
      parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
     $                   dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
     $                   imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
     $                   rsrc_ = 9, csrc_ = 10, lld_ = 11 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0d+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            COLREP, ROWREP
      INTEGER            I, IB, ICTXT, ICURCOL, ICURROW, IIX, IN, IXCOL,
     $                   ixrow, j, jb, jjx, jn, kk, ldpx, ldx, ll,
     $                   mycol, myrow, npcol, nprow
      DOUBLE PRECISION   ERR, EPS
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_gridinfo, dgamx2d, pb_infog2l, pzerrset
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   PDLAMCH
      EXTERNAL           PDLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, dble, dimag, max, min, mod
*     ..
*     .. Executable Statements ..
*
      info = 0
      errmax = zero
*
*     Quick return if possible
*
      IF( n.LE.0 )
     $   RETURN
*
      ictxt = descx( ctxt_ )
      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
*
      eps = pdlamch( ictxt, 'eps' )
*
      CALL pb_infog2l( ix, jx, descx, nprow, npcol, myrow, mycol, iix,
     $                 jjx, ixrow, ixcol )
*
      ldx    = descx( m_ )
      ldpx   = descx( lld_ )
      rowrep = ( ixrow.EQ.-1 )
      colrep = ( ixcol.EQ.-1 )
*
      IF( n.EQ.1 ) THEN
*
         IF( ( myrow.EQ.ixrow .OR. rowrep ) .AND.
     $       ( mycol.EQ.ixcol .OR. colrep ) )
     $      CALL pzerrset( err, errmax, x( ix+(jx-1)*ldx ),
     $                     px( iix+(jjx-1)*ldpx ) )
*
      ELSE IF( incx.EQ.descx( m_ ) ) THEN
*
*        sub( X ) is a row vector
*
         jb = descx( inb_ ) - jx + 1
         IF( jb.LE.0 )
     $      jb = ( ( -jb ) / descx( nb_ ) + 1 ) * descx( nb_ ) + jb
         jb = min( jb, n )
         jn = jx + jb - 1
*
         IF( myrow.EQ.ixrow .OR. rowrep ) THEN
*
            icurcol = ixcol
            IF( mycol.EQ.icurcol .OR. colrep ) THEN
               DO 10 j = jx, jn
                  CALL pzerrset( err, errmax, x( ix+(j-1)*ldx ),
     $                           px( iix+(jjx-1)*ldpx ) )
                  jjx = jjx + 1
   10          CONTINUE
            END IF
            icurcol = mod( icurcol+1, npcol )
*
            DO 30 j = jn+1, jx+n-1, descx( nb_ )
               jb = min( jx+n-j, descx( nb_ ) )
*
               IF( mycol.EQ.icurcol .OR. colrep ) THEN
*
                  DO 20 kk = 0, jb-1
                     CALL pzerrset( err, errmax, x( ix+(j+kk-1)*ldx ),
     $                              px( iix+(jjx+kk-1)*ldpx ) )
   20             CONTINUE
*
                  jjx = jjx + jb
*
               END IF
*
               icurcol = mod( icurcol+1, npcol )
*
   30       CONTINUE
*
         END IF
*
      ELSE
*
*        sub( X ) is a column vector
*
         ib = descx( imb_ ) - ix + 1
         IF( ib.LE.0 )
     $      ib = ( ( -ib ) / descx( mb_ ) + 1 ) * descx( mb_ ) + ib
         ib = min( ib, n )
         in = ix + ib - 1
*
         IF( mycol.EQ.ixcol .OR. colrep ) THEN
*
            icurrow = ixrow
            IF( myrow.EQ.icurrow .OR. rowrep ) THEN
               DO 40 i = ix, in
                  CALL pzerrset( err, errmax, x( i+(jx-1)*ldx ),
     $                           px( iix+(jjx-1)*ldpx ) )
                  iix = iix + 1
   40          CONTINUE
            END IF
            icurrow = mod( icurrow+1, nprow )
*
            DO 60 i = in+1, ix+n-1, descx( mb_ )
               ib = min( ix+n-i, descx( mb_ ) )
*
               IF( myrow.EQ.icurrow .OR. rowrep ) THEN
*
                  DO 50 kk = 0, ib-1
                     CALL pzerrset( err, errmax, x( i+kk+(jx-1)*ldx ),
     $                              px( iix+kk+(jjx-1)*ldpx ) )
   50             CONTINUE
*
                  iix = iix + ib
*
               END IF
*
               icurrow = mod( icurrow+1, nprow )
*
   60       CONTINUE
*
         END IF
*
      END IF
*
      CALL dgamx2d( ictxt, 'All', ' ', 1, 1, errmax, 1, kk, ll, -1,
     $              -1, -1 )
*
      IF( errmax.GT.zero .AND. errmax.LE.eps ) THEN
         info = 1
      ELSE IF( errmax.GT.eps ) THEN
         info = -1
      END IF
*
      RETURN
*
*     End of PZCHKVIN
*
      END
      SUBROUTINE pzchkvout( N, X, PX, IX, JX, DESCX, INCX, INFO )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER            INCX, INFO, IX, JX, N
*     ..
*     .. Array Arguments ..
      INTEGER            DESCX( * )
      COMPLEX*16         PX( * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*  PZCHKVOUT  checks  that the matrix PX \ sub( PX ) remained unchanged.
*  The  local array  entries  are compared element by element, and their
*  difference  is tested against 0.0 as well as the epsilon machine. No-
*  tice that this  difference should be numerically exactly the zero ma-
*  chine, but because  of  the  possible movement of some of the data we
*  flagged differently a difference less than twice the epsilon machine.
*  The largest error is reported.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  N       (global input) INTEGER
*          On entry,  N  specifies  the  length of the subvector operand
*          sub( X ). N must be at least zero.
*
*  X       (local input) COMPLEX*16 array
*          On entry, X is an array of  dimension  (DESCX( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PX.
*
*  PX      (local input) COMPLEX*16 array
*          On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
*          array contains the local entries of the matrix PX.
*
*  IX      (global input) INTEGER
*          On entry, IX  specifies X's global row index, which points to
*          the beginning of the submatrix sub( X ).
*
*  JX      (global input) INTEGER
*          On entry, JX  specifies X's global column index, which points
*          to the beginning of the submatrix sub( X ).
*
*  DESCX   (global and local input) INTEGER array
*          On entry, DESCX  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix X.
*
*  INCX    (global input) INTEGER
*          On entry,  INCX   specifies  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
*          On exit, if INFO = 0, no error has been found,
*          If INFO > 0, the maximum abolute error found is in (0,eps],
*          If INFO < 0, the maximum abolute error found is in (eps,+oo).
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   rsrc_
      parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
     $                   dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
     $                   imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
     $                   rsrc_ = 9, csrc_ = 10, lld_ = 11 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0d+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            COLREP, ROWREP
      INTEGER            I, IB, ICTXT, ICURCOL, ICURROW, II, IMBX, INBX,
     $                   j, jb, jj, kk, ldpx, ldx, ll, mbx, mpall,
     $                   mycol, mycoldist, myrow, myrowdist, nbx, npcol,
     $                   nprow, nqall
      DOUBLE PRECISION   EPS, ERR, ERRMAX
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_gridinfo, dgamx2d, pzerrset
*     ..
*     .. External Functions ..
      INTEGER            PB_NUMROC
      DOUBLE PRECISION   PDLAMCH
      EXTERNAL           pdlamch, pb_numroc
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, dble, dimag, max, min, mod
*     ..
*     .. Executable Statements ..
*
      info = 0
      errmax = zero
*
*     Quick return if possible
*
      IF( ( descx( m_ ).LE.0 ).OR.( descx( n_ ).LE.0 ) )
     $   RETURN
*
*     Start the operations
*
      ictxt = descx( ctxt_ )
      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
*
      eps = pdlamch( ictxt, 'eps' )
*
      mpall   = pb_numroc( descx( m_ ), 1, descx( imb_ ), descx( mb_ ),
     $                     myrow, descx( rsrc_ ), nprow )
      nqall   = pb_numroc( descx( n_ ), 1, descx( inb_ ), descx( nb_ ),
     $                     mycol, descx( csrc_ ), npcol )
*
      mbx     = descx( mb_ )
      nbx     = descx( nb_ )
      ldx     = descx( m_ )
      ldpx    = descx( lld_ )
      icurrow = descx( rsrc_ )
      icurcol = descx( csrc_ )
      rowrep  = ( icurrow.EQ.-1 )
      colrep  = ( icurcol.EQ.-1 )
      IF( myrow.EQ.icurrow .OR. rowrep ) THEN
         imbx = descx( imb_ )
      ELSE
         imbx = mbx
      END IF
      IF( mycol.EQ.icurcol .OR. colrep ) THEN
         inbx = descx( inb_ )
      ELSE
         inbx = nbx
      END IF
      IF( rowrep ) THEN
         myrowdist = 0
      ELSE
         myrowdist = mod( myrow - icurrow + nprow, nprow )
      END IF
      IF( colrep ) THEN
         mycoldist = 0
      ELSE
         mycoldist = mod( mycol - icurcol + npcol, npcol )
      END IF
      ii = 1
      jj = 1
*
      IF( incx.EQ.descx( m_ ) ) THEN
*
*        sub( X ) is a row vector
*
         IF( myrow.EQ.icurrow .OR. rowrep ) THEN
*
            i = 1
            IF( mycoldist.EQ.0 ) THEN
               j = 1
            ELSE
               j = descx( inb_ ) + ( mycoldist - 1 ) * nbx + 1
            END IF
            jb = min( max( 0, descx( n_ ) - j + 1 ), inbx )
            ib = min( descx( m_ ), descx( imb_ ) )
*
            DO 20 kk = 0, jb-1
               DO 10 ll = 0, ib-1
                  IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR. j+kk.GT.jx+n-1 )
     $               CALL pzerrset( err, errmax,
     $                              x( i+ll+(j+kk-1)*ldx ),
     $                              px( ii+ll+(jj+kk-1)*ldpx ) )
   10          CONTINUE
   20       CONTINUE
            IF( colrep ) THEN
               j = j + inbx
            ELSE
               j = j + inbx + ( npcol - 1 ) * nbx
            END IF
*
            DO 50 jj = inbx+1, nqall, nbx
               jb = min( nqall-jj+1, nbx )
*
               DO 40 kk = 0, jb-1
                  DO 30 ll = 0, ib-1
                     IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR.
     $                   j+kk.GT.jx+n-1 )
     $                  CALL pzerrset( err, errmax,
     $                                 x( i+ll+(j+kk-1)*ldx ),
     $                                 px( ii+ll+(jj+kk-1)*ldpx ) )
   30             CONTINUE
   40          CONTINUE
*
               IF( colrep ) THEN
                  j = j + nbx
               ELSE
                  j = j + npcol * nbx
               END IF
*
   50       CONTINUE
*
            ii = ii + ib
*
         END IF
*
         icurrow = mod( icurrow + 1, nprow )
*
         DO 110 i = descx( imb_ ) + 1, descx( m_ ), mbx
            ib = min( descx( m_ ) - i + 1, mbx )
*
            IF( myrow.EQ.icurrow .OR. rowrep ) THEN
*
               IF( mycoldist.EQ.0 ) THEN
                  j = 1
               ELSE
                  j = descx( inb_ ) + ( mycoldist - 1 ) * nbx + 1
               END IF
*
               jj = 1
               jb = min( max( 0, descx( n_ ) - j + 1 ), inbx )
               DO 70 kk = 0, jb-1
                  DO 60 ll = 0, ib-1
                     IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR.
     $                   j+kk.GT.jx+n-1 )
     $                  CALL pzerrset( err, errmax,
     $                                 x( i+ll+(j+kk-1)*ldx ),
     $                                 px( ii+ll+(jj+kk-1)*ldpx ) )
   60             CONTINUE
   70          CONTINUE
               IF( colrep ) THEN
                  j = j + inbx
               ELSE
                  j = j + inbx + ( npcol - 1 ) * nbx
               END IF
*
               DO 100 jj = inbx+1, nqall, nbx
                  jb = min( nqall-jj+1, nbx )
*
                  DO 90 kk = 0, jb-1
                     DO 80 ll = 0, ib-1
                        IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR.
     $                      j+kk.GT.jx+n-1 )
     $                     CALL pzerrset( err, errmax,
     $                                    x( i+ll+(j+kk-1)*ldx ),
     $                                    px( ii+ll+(jj+kk-1)*ldpx ) )
   80                CONTINUE
   90             CONTINUE
*
                  IF( colrep ) THEN
                     j = j + nbx
                  ELSE
                     j = j + npcol * nbx
                  END IF
*
  100          CONTINUE
*
               ii = ii + ib
*
            END IF
*
            icurrow = mod( icurrow + 1, nprow )
*
  110    CONTINUE
*
      ELSE
*
*        sub( X ) is a column vector
*
         IF( mycol.EQ.icurcol .OR. colrep ) THEN
*
            j = 1
            IF( myrowdist.EQ.0 ) THEN
               i = 1
            ELSE
               i = descx( imb_ ) + ( myrowdist - 1 ) * mbx + 1
            END IF
            ib = min( max( 0, descx( m_ ) - i + 1 ), imbx )
            jb = min( descx( n_ ), descx( inb_ ) )
*
            DO 130 kk = 0, jb-1
               DO 120 ll = 0, ib-1
                  IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR. i+ll.GT.ix+n-1 )
     $               CALL pzerrset( err, errmax,
     $                              x( i+ll+(j+kk-1)*ldx ),
     $                              px( ii+ll+(jj+kk-1)*ldpx ) )
  120          CONTINUE
  130       CONTINUE
            IF( rowrep ) THEN
               i = i + imbx
            ELSE
               i = i + imbx + ( nprow - 1 ) * mbx
            END IF
*
            DO 160 ii = imbx+1, mpall, mbx
               ib = min( mpall-ii+1, mbx )
*
               DO 150 kk = 0, jb-1
                  DO 140 ll = 0, ib-1
                     IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR.
     $                   i+ll.GT.ix+n-1 )
     $                  CALL pzerrset( err, errmax,
     $                                 x( i+ll+(j+kk-1)*ldx ),
     $                                 px( ii+ll+(jj+kk-1)*ldpx ) )
  140             CONTINUE
  150          CONTINUE
*
               IF( rowrep ) THEN
                  i = i + mbx
               ELSE
                  i = i + nprow * mbx
               END IF
*
  160       CONTINUE
*
            jj = jj + jb
*
         END IF
*
         icurcol = mod( icurcol + 1, npcol )
*
         DO 220 j = descx( inb_ ) + 1, descx( n_ ), nbx
            jb = min( descx( n_ ) - j + 1, nbx )
*
            IF( mycol.EQ.icurcol .OR. colrep ) THEN
*
               IF( myrowdist.EQ.0 ) THEN
                  i = 1
               ELSE
                  i = descx( imb_ ) + ( myrowdist - 1 ) * mbx + 1
               END IF
*
               ii = 1
               ib = min( max( 0, descx( m_ ) - i + 1 ), imbx )
               DO 180 kk = 0, jb-1
                  DO 170 ll = 0, ib-1
                     IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR.
     $                   i+ll.GT.ix+n-1 )
     $                  CALL pzerrset( err, errmax,
     $                                 x( i+ll+(j+kk-1)*ldx ),
     $                                 px( ii+ll+(jj+kk-1)*ldpx ) )
  170             CONTINUE
  180          CONTINUE
               IF( rowrep ) THEN
                  i = i + imbx
               ELSE
                  i = i + imbx + ( nprow - 1 ) * mbx
               END IF
*
               DO 210 ii = imbx+1, mpall, mbx
                  ib = min( mpall-ii+1, mbx )
*
                  DO 200 kk = 0, jb-1
                     DO 190 ll = 0, ib-1
                        IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR.
     $                      i+ll.GT.ix+n-1 )
     $                     CALL pzerrset( err, errmax,
     $                                    x( i+ll+(j+kk-1)*ldx ),
     $                                    px( ii+ll+(jj+kk-1)*ldpx ) )
  190                CONTINUE
  200             CONTINUE
*
                  IF( rowrep ) THEN
                     i = i + mbx
                  ELSE
                     i = i + nprow * mbx
                  END IF
*
  210          CONTINUE
*
               jj = jj + jb
*
            END IF
*
            icurcol = mod( icurcol + 1, npcol )
*
  220    CONTINUE
*
      END IF
*
      CALL dgamx2d( ictxt, 'All', ' ', 1, 1, errmax, 1, kk, ll, -1,
     $              -1, -1 )
*
      IF( errmax.GT.zero .AND. errmax.LE.eps ) THEN
         info = 1
      ELSE IF( errmax.GT.eps ) THEN
         info = -1
      END IF
*
      RETURN
*
*     End of PZCHKVOUT
*
      END
      SUBROUTINE pzchkmin( ERRMAX, M, N, A, PA, IA, JA, DESCA, INFO )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER            IA, INFO, JA, M, N
      DOUBLE PRECISION   ERRMAX
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * )
      COMPLEX*16         PA( * ), A( * )
*     ..
*
*  Purpose
*  =======
*
*  PZCHKMIN  checks that the submatrix sub( PA ) remained unchanged. The
*  local  array  entries are compared element by element, and their dif-
*  ference  is tested against 0.0 as well as the epsilon machine. Notice
*  that  this difference should be numerically exactly the zero machine,
*  but  because of the possible fluctuation of some of the data we flag-
*  ged differently a difference less than twice the epsilon machine. The
*  largest error is also returned.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ERRMAX  (global output) DOUBLE PRECISION
*          On exit,  ERRMAX  specifies the largest absolute element-wise
*          difference between sub( A ) and sub( PA ).
*
*  M       (global input) INTEGER
*          On entry,  M  specifies  the  number of rows of the submatrix
*          operand sub( A ). M must be at least zero.
*
*  N       (global input) INTEGER
*          On entry, N  specifies the number of columns of the submatrix
*          operand sub( A ). N must be at least zero.
*
*  A       (local input) COMPLEX*16 array
*          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PA.
*
*  PA      (local input) COMPLEX*16 array
*          On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
*          array contains the local entries of the matrix PA.
*
*  IA      (global input) INTEGER
*          On entry, IA  specifies A's global row index, which points to
*          the beginning of the submatrix sub( A ).
*
*  JA      (global input) INTEGER
*          On entry, JA  specifies A's global column index, which points
*          to the beginning of the submatrix sub( A ).
*
*  DESCA   (global and local input) INTEGER array
*          On entry, DESCA  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix A.
*
*  INFO    (global output) INTEGER
*          On exit, if INFO = 0, no error has been found,
*          If INFO > 0, the maximum abolute error found is in (0,eps],
*          If INFO < 0, the maximum abolute error found is in (eps,+oo).
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   rsrc_
      parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
     $                   dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
     $                   imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
     $                   rsrc_ = 9, csrc_ = 10, lld_ = 11 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0d+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            COLREP, ROWREP
      INTEGER            H, I, IACOL, IAROW, IB, ICTXT, ICURCOL,
     $                   icurrow, ii, iia, in, j, jb, jj, jja, jn, k,
     $                   kk, lda, ldpa, ll, mycol, myrow, npcol, nprow
      DOUBLE PRECISION   ERR, EPS
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_gridinfo, dgamx2d, pb_infog2l, pzerrset
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   PDLAMCH
      EXTERNAL           PDLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, dble, dimag, max, min, mod
*     ..
*     .. Executable Statements ..
*
      info   = 0
      errmax = zero
*
*     Quick return if posssible
*
      IF( ( m.EQ.0 ).OR.( n.EQ.0 ) )
     $   RETURN
*
*     Start the operations
*
      ictxt = desca( ctxt_ )
      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
*
      eps = pdlamch( ictxt, 'eps' )
*
      CALL pb_infog2l( ia, ja, desca, nprow, npcol, myrow, mycol, iia,
     $                 jja, iarow, iacol )
*
      ii      = iia
      jj      = jja
      lda     = desca( m_ )
      ldpa    = desca( lld_ )
      icurrow = iarow
      icurcol = iacol
      rowrep  = ( iarow.EQ.-1 )
      colrep  = ( iacol.EQ.-1 )
*
*     Handle the first block of column separately
*
      jb = desca( inb_ ) - ja  + 1
      IF( jb.LE.0 )
     $   jb = ( ( -jb ) / desca( nb_ ) + 1 ) * desca( nb_ ) + jb
      jb = min( jb, n )
      jn = ja + jb - 1
*
      IF( mycol.EQ.icurcol .OR. colrep ) THEN
*
         DO 40 h = 0, jb-1
            ib = desca( imb_ ) - ia  + 1
            IF( ib.LE.0 )
     $         ib = ( ( -ib ) / desca( mb_ ) + 1 ) * desca( mb_ ) + ib
            ib = min( ib, m )
            in = ia + ib - 1
            IF( myrow.EQ.icurrow .OR. rowrep ) THEN
               DO 10 k = 0, ib-1
                  CALL pzerrset( err, errmax, a( ia+k+(ja+h-1)*lda ),
     $                           pa( ii+k+(jj+h-1)*ldpa ) )
   10          CONTINUE
               ii = ii + ib
            END IF
            icurrow = mod( icurrow+1, nprow )
*
*           Loop over remaining block of rows
*
            DO 30 i = in+1, ia+m-1, desca( mb_ )
               ib = min( desca( mb_ ), ia+m-i )
               IF( myrow.EQ.icurrow .OR. rowrep ) THEN
                  DO 20 k = 0, ib-1
                     CALL pzerrset( err, errmax, a( i+k+(ja+h-1)*lda ),
     $                              pa( ii+k+(jj+h-1)*ldpa ) )
   20             CONTINUE
                  ii = ii + ib
               END IF
               icurrow = mod( icurrow+1, nprow )
   30       CONTINUE
*
            ii = iia
            icurrow = iarow
   40    CONTINUE
*
         jj = jj + jb
*
      END IF
*
      icurcol = mod( icurcol+1, npcol )
*
*     Loop over remaining column blocks
*
      DO 90 j = jn+1, ja+n-1, desca( nb_ )
         jb = min(  desca( nb_ ), ja+n-j )
         IF( mycol.EQ.icurcol .OR. colrep ) THEN
            DO 80 h = 0, jb-1
               ib = desca( imb_ ) - ia  + 1
               IF( ib.LE.0 )
     $            ib = ( ( -ib ) / desca( mb_ ) + 1 )*desca( mb_ ) + ib
               ib = min( ib, m )
               in = ia + ib - 1
               IF( myrow.EQ.icurrow .OR. rowrep ) THEN
                  DO 50 k = 0, ib-1
                     CALL pzerrset( err, errmax, a( ia+k+(j+h-1)*lda ),
     $                              pa( ii+k+(jj+h-1)*ldpa ) )
   50             CONTINUE
                  ii = ii + ib
               END IF
               icurrow = mod( icurrow+1, nprow )
*
*              Loop over remaining block of rows
*
               DO 70 i = in+1, ia+m-1, desca( mb_ )
                  ib = min( desca( mb_ ), ia+m-i )
                  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
                     DO 60 k = 0, ib-1
                        CALL pzerrset( err, errmax,
     $                                 a( i+k+(j+h-1)*lda ),
     $                                 pa( ii+k+(jj+h-1)*ldpa ) )
   60                CONTINUE
                     ii = ii + ib
                  END IF
                  icurrow = mod( icurrow+1, nprow )
   70          CONTINUE
*
               ii = iia
               icurrow = iarow
   80       CONTINUE
*
            jj = jj + jb
         END IF
*
         icurcol = mod( icurcol+1, npcol )
*
   90 CONTINUE
*
      CALL dgamx2d( ictxt, 'All', ' ', 1, 1, errmax, 1, kk, ll, -1,
     $              -1, -1 )
*
      IF( errmax.GT.zero .AND. errmax.LE.eps ) THEN
         info = 1
      ELSE IF( errmax.GT.eps ) THEN
         info = -1
      END IF
*
      RETURN
*
*     End of PZCHKMIN
*
      END
      SUBROUTINE pzchkmout( M, N, A, PA, IA, JA, DESCA, INFO )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER            IA, INFO, JA, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * )
      COMPLEX*16         A( * ), PA( * )
*     ..
*
*  Purpose
*  =======
*
*  PZCHKMOUT  checks  that the matrix PA \ sub( PA ) remained unchanged.
*  The  local array  entries  are compared element by element, and their
*  difference  is tested against 0.0 as well as the epsilon machine. No-
*  tice that this  difference should be numerically exactly the zero ma-
*  chine, but because  of  the  possible movement of some of the data we
*  flagged differently a difference less than twice the epsilon machine.
*  The largest error is reported.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  M       (global input) INTEGER
*          On entry,  M  specifies  the  number of rows of the submatrix
*          sub( PA ). M must be at least zero.
*
*  N       (global input) INTEGER
*          On entry, N specifies the  number of columns of the submatrix
*          sub( PA ). N must be at least zero.
*
*  A       (local input) COMPLEX*16 array
*          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PA.
*
*  PA      (local input) COMPLEX*16 array
*          On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
*          array contains the local entries of the matrix PA.
*
*  IA      (global input) INTEGER
*          On entry, IA  specifies A's global row index, which points to
*          the beginning of the submatrix sub( A ).
*
*  JA      (global input) INTEGER
*          On entry, JA  specifies A's global column index, which points
*          to the beginning of the submatrix sub( A ).
*
*  DESCA   (global and local input) INTEGER array
*          On entry, DESCA  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix A.
*
*  INFO    (global output) INTEGER
*          On exit, if INFO = 0, no error has been found,
*          If INFO > 0, the maximum abolute error found is in (0,eps],
*          If INFO < 0, the maximum abolute error found is in (eps,+oo).
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   rsrc_
      parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
     $                   dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
     $                   imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
     $                   rsrc_ = 9, csrc_ = 10, lld_ = 11 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0d+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            COLREP, ROWREP
      INTEGER            I, IB, ICTXT, ICURCOL, II, IMBA, J, JB, JJ, KK,
     $                   lda, ldpa, ll, mpall, mycol, myrow, myrowdist,
     $                   npcol, nprow
      DOUBLE PRECISION   EPS, ERR, ERRMAX
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_gridinfo, dgamx2d, pzerrset
*     ..
*     .. External Functions ..
      INTEGER            PB_NUMROC
      DOUBLE PRECISION   PDLAMCH
      EXTERNAL           pdlamch, pb_numroc
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          max, min, mod
*     ..
*     .. Executable Statements ..
*
      info = 0
      errmax = zero
*
*     Quick return if possible
*
      IF( ( desca( m_ ).LE.0 ).OR.( desca( n_ ).LE.0 ) )
     $   RETURN
*
*     Start the operations
*
      ictxt = desca( ctxt_ )
      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
*
      eps = pdlamch( ictxt, 'eps' )
*
      mpall = pb_numroc( desca( m_ ), 1, desca( imb_ ), desca( mb_ ),
     $                   myrow, desca( rsrc_ ), nprow )
*
      lda    = desca( m_ )
      ldpa   = desca( lld_ )
*
      ii = 1
      jj = 1
      rowrep  = ( desca( rsrc_ ).EQ.-1 )
      colrep  = ( desca( csrc_ ).EQ.-1 )
      icurcol = desca( csrc_ )
      IF( myrow.EQ.desca( rsrc_ ) .OR. rowrep ) THEN
         imba = desca( imb_ )
      ELSE
         imba = desca( mb_ )
      END IF
      IF( rowrep ) THEN
         myrowdist = 0
      ELSE
         myrowdist = mod( myrow - desca( rsrc_ ) + nprow, nprow )
      END IF
*
      IF( mycol.EQ.icurcol .OR. colrep ) THEN
*
         j = 1
         IF( myrowdist.EQ.0 ) THEN
            i = 1
         ELSE
            i = desca( imb_ ) + ( myrowdist - 1 ) * desca( mb_ ) + 1
         END IF
         ib = min( max( 0, desca( m_ ) - i + 1 ), imba )
         jb = min( desca( n_ ), desca( inb_ ) )
*
         DO 20 kk = 0, jb-1
            DO 10 ll = 0, ib-1
               IF( i+ll.LT.ia .OR. i+ll.GT.ia+m-1 .OR.
     $             j+kk.LT.ja .OR. j+kk.GT.ja+n-1 )
     $            CALL pzerrset( err, errmax, a( i+ll+(j+kk-1)*lda ),
     $                           pa( ii+ll+(jj+kk-1)*ldpa ) )
   10       CONTINUE
   20    CONTINUE
         IF( rowrep ) THEN
            i = i + imba
         ELSE
            i = i + imba + ( nprow - 1 ) * desca( mb_ )
         END IF
*
         DO 50 ii = imba + 1, mpall, desca( mb_ )
            ib = min( mpall-ii+1, desca( mb_ ) )
*
            DO 40 kk = 0, jb-1
               DO 30 ll = 0, ib-1
                  IF( i+ll.LT.ia .OR. i+ll.GT.ia+m-1 .OR.
     $                j+kk.LT.ja .OR. j+kk.GT.ja+n-1 )
     $               CALL pzerrset( err, errmax,
     $                              a( i+ll+(j+kk-1)*lda ),
     $                              pa( ii+ll+(jj+kk-1)*ldpa ) )
   30          CONTINUE
   40       CONTINUE
*
            IF( rowrep ) THEN
               i = i + desca( mb_ )
            ELSE
               i = i + nprow * desca( mb_ )
            END IF
*
   50    CONTINUE
*
         jj = jj + jb
*
      END IF
*
      icurcol = mod( icurcol + 1, npcol )
*
      DO 110 j = desca( inb_ ) + 1, desca( n_ ), desca( nb_ )
         jb = min( desca( n_ ) - j + 1, desca( nb_ ) )
*
         IF( mycol.EQ.icurcol .OR. colrep ) THEN
*
            IF( myrowdist.EQ.0 ) THEN
               i = 1
            ELSE
               i = desca( imb_ ) + ( myrowdist - 1 ) * desca( mb_ ) + 1
            END IF
*
            ii = 1
            ib = min( max( 0, desca( m_ ) - i + 1 ), imba )
            DO 70 kk = 0, jb-1
               DO 60 ll = 0, ib-1
                  IF( i+ll.LT.ia .OR. i+ll.GT.ia+m-1 .OR.
     $                j+kk.LT.ja .OR. j+kk.GT.ja+n-1 )
     $               CALL pzerrset( err, errmax,
     $                              a( i+ll+(j+kk-1)*lda ),
     $                              pa( ii+ll+(jj+kk-1)*ldpa ) )
   60          CONTINUE
   70       CONTINUE
            IF( rowrep ) THEN
               i = i + imba
            ELSE
               i = i + imba + ( nprow - 1 ) * desca( mb_ )
            END IF
*
            DO 100 ii = imba+1, mpall, desca( mb_ )
               ib = min( mpall-ii+1, desca( mb_ ) )
*
               DO 90 kk = 0, jb-1
                  DO 80 ll = 0, ib-1
                     IF( i+ll.LT.ia .OR. i+ll.GT.ia+m-1 .OR.
     $                   j+kk.LT.ja .OR. j+kk.GT.ja+n-1 )
     $                  CALL pzerrset( err, errmax,
     $                                 a( i+ll+(j+kk-1)*lda ),
     $                                 pa( ii+ll+(jj+kk-1)*ldpa ) )
   80             CONTINUE
   90          CONTINUE
*
               IF( rowrep ) THEN
                  i = i + desca( mb_ )
               ELSE
                  i = i + nprow * desca( mb_ )
               END IF
*
  100       CONTINUE
*
            jj = jj + jb
*
         END IF
*
         icurcol = mod( icurcol + 1, npcol )
*                                                           INSERT MODE
  110 CONTINUE
*
      CALL dgamx2d( ictxt, 'All', ' ', 1, 1, errmax, 1, kk, ll, -1,
     $              -1, -1 )
*
      IF( errmax.GT.zero .AND. errmax.LE.eps ) THEN
         info = 1
      ELSE IF( errmax.GT.eps ) THEN
         info = -1
      END IF
*
      RETURN
*
*     End of PZCHKMOUT
*
      END
      SUBROUTINE pzmprnt( ICTXT, NOUT, M, N, A, LDA, IRPRNT, ICPRNT,
     $                    CMATNM )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER            ICPRNT, ICTXT, IRPRNT, LDA, M, N, NOUT
*     ..
*     .. Array Arguments ..
      CHARACTER*(*)      CMATNM
      COMPLEX*16         A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  PZMPRNT prints to the standard output an array A of size m by n. Only
*  the process of coordinates ( IRPRNT, ICPRNT ) is printing.
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  NOUT    (global input) INTEGER
*          On entry, NOUT specifies the unit number for the output file.
*          When NOUT is 6, output to screen,  when  NOUT is 0, output to
*          stderr. NOUT is only defined for process 0.
*
*  M       (global input) INTEGER
*          On entry, M  specifies the number of rows of the matrix A.  M
*          must be at least zero.
*
*  N       (global input) INTEGER
*          On entry, N  specifies the number of columns of the matrix A.
*          N must be at least zero.
*
*  A       (local input) COMPLEX*16 array
*          On entry,  A  is an array of dimension (LDA,N). The leading m
*          by n part of this array is printed.
*
*  LDA     (local input) INTEGER
*          On entry, LDA  specifies the leading dimension of  the  local
*          array A to be printed. LDA must be at least MAX( 1, M ).
*
*  IRPRNT  (global input) INTEGER
*          On entry, IRPRNT  specifies the process row coordinate of the
*          printing process.
*
*  ICPRNT  (global input) INTEGER
*          On entry,  ICPRNT  specifies the process column coordinate of
*          the printing process.
*
*  CMATNM  (global input) CHARACTER*(*)
*          On entry, CMATNM specifies the identifier of the matrix to be
*          printed.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, J, MYCOL, MYROW, NPCOL, NPROW
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_gridinfo
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          dble, dimag
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( ( m.LE.0 ).OR.( n.LE.0 ) )
     $   RETURN
*
*     Get grid parameters
*
      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
*
      IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
*
         WRITE( nout, fmt = * )
         DO 20 j = 1, n
*
            DO 10 i = 1, m
*
               WRITE( nout, fmt = 9999 ) cmatnm, i, j,
     $                         dble( a( i, j ) ), dimag( a( i, j ) )
*
   10       CONTINUE
*
   20    CONTINUE
*
      END IF
*
 9999 FORMAT( 1x, a, '(', i6, ',', i6, ')=', d30.18, '+i*(',
     $        d30.18, ')' )
*
      RETURN
*
*     End of PZMPRNT
*
      END
      SUBROUTINE pzvprnt( ICTXT, NOUT, N, X, INCX, IRPRNT, ICPRNT,
     $                    CVECNM )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER            ICPRNT, ICTXT, INCX, IRPRNT, N, NOUT
*     ..
*     .. Array Arguments ..
      CHARACTER*(*)      CVECNM
      COMPLEX*16         X( * )
*     ..
*
*  Purpose
*  =======
*
*  PZVPRNT  prints  to the standard output an vector x of length n. Only
*  the process of coordinates ( IRPRNT, ICPRNT ) is printing.
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  NOUT    (global input) INTEGER
*          On entry, NOUT specifies the unit number for the output file.
*          When NOUT is 6, output to screen,  when  NOUT is 0, output to
*          stderr. NOUT is only defined for process 0.
*
*  N       (global input) INTEGER
*          On entry, N  specifies the length of the vector X.  N must be
*          at least zero.
*
*  X       (global input) COMPLEX*16 array
*          On   entry,   X   is   an   array   of   dimension  at  least
*          ( 1 + ( n - 1 )*abs( INCX ) ).  Before  entry,  the incremen-
*          ted array X must contain the vector x.
*
*  INCX    (global input) INTEGER.
*          On entry, INCX specifies the increment for the elements of X.
*          INCX must not be zero.
*
*  IRPRNT  (global input) INTEGER
*          On entry, IRPRNT  specifies the process row coordinate of the
*          printing process.
*
*  ICPRNT  (global input) INTEGER
*          On entry,  ICPRNT  specifies the process column coordinate of
*          the printing process.
*
*  CVECNM  (global input) CHARACTER*(*)
*          On entry, CVECNM specifies the identifier of the vector to be
*          printed.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, MYCOL, MYROW, NPCOL, NPROW
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          dble, dimag
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( n.LE.0 )
     $   RETURN
*
*     Get grid parameters
*
      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
*
      IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
*
         WRITE( nout, fmt = * )
         DO 10 i = 1, 1 + ( n-1 )*incx, incx
*
            WRITE( nout, fmt = 9999 ) cvecnm, i, dble( x( i ) ),
     $                                dimag( x( i ) )
*
   10    CONTINUE
*
      END IF
*
 9999 FORMAT( 1x, a, '(', i6, ')=', d30.18, '+i*(', d30.18, ')' )
*
      RETURN
*
*     End of PZVPRNT
*
      END
      SUBROUTINE pzmvch( ICTXT, TRANS, M, N, ALPHA, A, IA, JA, DESCA,
     $                   X, IX, JX, DESCX, INCX, BETA, Y, PY, IY, JY,
     $                   DESCY, INCY, G, ERR, INFO )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1        TRANS
      INTEGER            IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
     $                   JY, M, N
      DOUBLE PRECISION   ERR
      COMPLEX*16         ALPHA, BETA
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * ), DESCX( * ), DESCY( * )
      DOUBLE PRECISION   G( * )
      COMPLEX*16         A( * ), PY( * ), X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  PZMVCH checks the results of the computational tests.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  TRANS   (global input) CHARACTER*1
*          On entry,  TRANS  specifies which matrix-vector product is to
*          be computed as follows:
*             If TRANS = 'T',
*                sub( Y ) = BETA * sub( Y ) + sub( A )**T  * sub( X ),
*             else if TRANS = 'C',
*                sub( Y ) = BETA * sub( Y ) + sub( A )**H  * sub( X ),
*             otherwise
*                sub( Y ) = BETA * sub( Y ) + sub( A )     * sub( X ).
*
*  M       (global input) INTEGER
*          On entry,  M  specifies  the  number of rows of the submatrix
*          operand matrix A. M must be at least zero.
*
*  N       (global input) INTEGER
*          On entry,  N  specifies  the  number of columns of the subma-
*          trix operand matrix A. N must be at least zero.
*
*  ALPHA   (global input) COMPLEX*16
*          On entry, ALPHA specifies the scalar alpha.
*
*  A       (local input) COMPLEX*16 array
*          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PA.
*
*  IA      (global input) INTEGER
*          On entry, IA  specifies A's global row index, which points to
*          the beginning of the submatrix sub( A ).
*
*  JA      (global input) INTEGER
*          On entry, JA  specifies A's global column index, which points
*          to the beginning of the submatrix sub( A ).
*
*  DESCA   (global and local input) INTEGER array
*          On entry, DESCA  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix A.
*
*  X       (local input) COMPLEX*16 array
*          On entry, X is an array of  dimension  (DESCX( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PX.
*
*  IX      (global input) INTEGER
*          On entry, IX  specifies X's global row index, which points to
*          the beginning of the submatrix sub( X ).
*
*  JX      (global input) INTEGER
*          On entry, JX  specifies X's global column index, which points
*          to the beginning of the submatrix sub( X ).
*
*  DESCX   (global and local input) INTEGER array
*          On entry, DESCX  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix X.
*
*  INCX    (global input) INTEGER
*          On entry,  INCX   specifies  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.
*
*  BETA    (global input) COMPLEX*16
*          On entry, BETA specifies the scalar beta.
*
*  Y       (local input/local output) COMPLEX*16 array
*          On entry, Y is an array of  dimension  (DESCY( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PY.
*
*  PY      (local input) COMPLEX*16 array
*          On entry, PY is an array of dimension (DESCY( LLD_ ),*). This
*          array contains the local entries of the matrix PY.
*
*  IY      (global input) INTEGER
*          On entry, IY  specifies Y's global row index, which points to
*          the beginning of the submatrix sub( Y ).
*
*  JY      (global input) INTEGER
*          On entry, JY  specifies Y's global column index, which points
*          to the beginning of the submatrix sub( Y ).
*
*  DESCY   (global and local input) INTEGER array
*          On entry, DESCY  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix Y.
*
*  INCY    (global input) INTEGER
*          On entry,  INCY   specifies  the  global  increment  for  the
*          elements of  Y.  Only two values of  INCY   are  supported in
*          this version, namely 1 and M_Y. INCY  must not be zero.
*
*  G       (workspace) DOUBLE PRECISION array
*          On entry, G is an array of dimension at least MAX( M, N ).  G
*          is used to compute the gauges.
*
*  ERR     (global output) DOUBLE PRECISION
*          On exit, ERR specifies the largest error in absolute value.
*
*  INFO    (global output) INTEGER
*          On exit, if INFO <> 0, the result is less than half accurate.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
     $                   dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
     $                   imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
     $                   rsrc_ = 9, csrc_ = 10, lld_ = 11 )
      DOUBLE PRECISION   RZERO, RONE
      PARAMETER          ( RZERO = 0.0d+0, rone = 1.0d+0 )
      COMPLEX*16         ZERO, ONE
      PARAMETER          ( ZERO = ( 0.0d+0, 0.0d+0 ),
     $                   one = ( 1.0d+0, 0.0d+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            COLREP, CTRAN, ROWREP, TRAN
      INTEGER            I, IB, ICURCOL, ICURROW, IIY, IN, IOFFA, IOFFX,
     $                   ioffy, iycol, iyrow, j, jb, jjy, jn, kk, lda,
     $                   ldpy, ldx, ldy, ml, mycol, myrow, nl, npcol,
     $                   nprow
      DOUBLE PRECISION   EPS, ERRI, GTMP
      COMPLEX*16         C, TBETA, YTMP
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_gridinfo, dgamx2d, igsum2d, pb_infog2l
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   PDLAMCH
      EXTERNAL           LSAME, PDLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, dble, dconjg, dimag, max, min, mod, sqrt
*     ..
*     .. Statement Functions ..
      DOUBLE PRECISION   ABS1
      ABS1( C ) = abs( dble( c ) ) + abs( dimag( c ) )
*     ..
*     .. Executable Statements ..
*
      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
*
      eps = pdlamch( ictxt, 'eps' )
*
      IF( m.EQ.0 .OR. n.EQ.0 ) THEN
         tbeta = one
      ELSE
         tbeta = beta
      END IF
*
      tran = lsame( trans, 'T' )
      ctran = lsame( trans, 'C' )
      IF( tran.OR.ctran ) THEN
         ml = n
         nl = m
      ELSE
         ml = m
         nl = n
      END IF
*
      lda = max( 1, desca( m_ ) )
      ldx = max( 1, descx( m_ ) )
      ldy = max( 1, descy( m_ ) )
*
*     Compute expected result in Y using data in A, X and Y.
*     Compute gauges in G. This part of the computation is performed
*     by every process in the grid.
*
      ioffy = iy + ( jy - 1 ) * ldy
      DO 40 i = 1, ml
         ytmp = zero
         gtmp = rzero
         ioffx = ix + ( jx - 1 ) * ldx
         IF( tran )THEN
            ioffa = ia + ( ja + i - 2 ) * lda
            DO 10 j = 1, nl
               ytmp = ytmp + a( ioffa ) * x( ioffx )
               gtmp = gtmp + abs1( a( ioffa ) ) * abs1( x( ioffx ) )
               ioffa = ioffa + 1
               ioffx = ioffx + incx
   10       CONTINUE
         ELSE IF( ctran )THEN
            ioffa = ia + ( ja + i - 2 ) * lda
            DO 20 j = 1, nl
               ytmp = ytmp + dconjg( a( ioffa ) ) * x( ioffx )
               gtmp = gtmp + abs1( a( ioffa ) ) * abs1( x( ioffx ) )
               ioffa = ioffa + 1
               ioffx = ioffx + incx
   20       CONTINUE
         ELSE
            ioffa = ia + i - 1 + ( ja - 1 ) * lda
            DO 30 j = 1, nl
               ytmp = ytmp + a( ioffa ) * x( ioffx )
               gtmp = gtmp + abs1( a( ioffa ) ) * abs1( x( ioffx ) )
               ioffa = ioffa + lda
               ioffx = ioffx + incx
   30       CONTINUE
         END IF
         g( i ) = abs1( alpha )*gtmp + abs1( tbeta )*abs1( y( ioffy ) )
         y( ioffy ) = alpha * ytmp + tbeta * y( ioffy )
         ioffy = ioffy + incy
   40 CONTINUE
*
*     Compute the error ratio for this result.
*
      err  = rzero
      info = 0
      ldpy = descy( lld_ )
      ioffy = iy + ( jy - 1 ) * ldy
      CALL pb_infog2l( iy, jy, descy, nprow, npcol, myrow, mycol, iiy,
     $                 jjy, iyrow, iycol )
      icurrow = iyrow
      icurcol = iycol
      rowrep  = ( iyrow.EQ.-1 )
      colrep  = ( iycol.EQ.-1 )
*
      IF( incy.EQ.descy( m_ ) ) THEN
*
*        sub( Y ) is a row vector
*
         jb = descy( inb_ ) - jy + 1
         IF( jb.LE.0 )
     $      jb = ( ( -jb ) / descy( nb_ ) + 1 ) * descy( nb_ ) + jb
         jb = min( jb, ml )
         jn = jy + jb - 1
*
         DO 50 j = jy, jn
*
            IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
     $          ( mycol.EQ.icurcol .OR. colrep ) ) THEN
               erri = abs( py( iiy+(jjy-1)*ldpy ) - y( ioffy ) ) / eps
               IF( g( j-jy+1 ).NE.rzero )
     $            erri = erri / g( j-jy+1 )
               err = max( err, erri )
               IF( err*sqrt( eps ).GE.rone )
     $            info = 1
               jjy = jjy + 1
            END IF
*
            ioffy = ioffy + incy
*
   50    CONTINUE
*
         icurcol = mod( icurcol+1, npcol )
*
         DO 70 j = jn+1, jy+ml-1, descy( nb_ )
            jb = min( jy+ml-j, descy( nb_ ) )
*
            DO 60 kk = 0, jb-1
*
               IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
     $             ( mycol.EQ.icurcol .OR. colrep ) ) THEN
                  erri = abs( py( iiy+(jjy-1)*ldpy ) - y( ioffy ) )/eps
                  IF( g( j+kk-jy+1 ).NE.rzero )
     $               erri = erri / g( j+kk-jy+1 )
                  err = max( err, erri )
                  IF( err*sqrt( eps ).GE.rone )
     $               info = 1
                  jjy = jjy + 1
               END IF
*
               ioffy = ioffy + incy
*
   60       CONTINUE
*
            icurcol = mod( icurcol+1, npcol )
*
   70    CONTINUE
*
      ELSE
*
*        sub( Y ) is a column vector
*
         ib = descy( imb_ ) - iy + 1
         IF( ib.LE.0 )
     $      ib = ( ( -ib ) / descy( mb_ ) + 1 ) * descy( mb_ ) + ib
         ib = min( ib, ml )
         in = iy + ib - 1
*
         DO 80 i = iy, in
*
            IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
     $          ( mycol.EQ.icurcol .OR. colrep ) ) THEN
               erri = abs( py( iiy+(jjy-1)*ldpy ) - y( ioffy ) ) / eps
               IF( g( i-iy+1 ).NE.rzero )
     $            erri = erri / g( i-iy+1 )
               err = max( err, erri )
               IF( err*sqrt( eps ).GE.rone )
     $            info = 1
               iiy = iiy + 1
            END IF
*
            ioffy = ioffy + incy
*
   80    CONTINUE
*
         icurrow = mod( icurrow+1, nprow )
*
         DO 100 i = in+1, iy+ml-1, descy( mb_ )
            ib = min( iy+ml-i, descy( mb_ ) )
*
            DO 90 kk = 0, ib-1
*
               IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
     $             ( mycol.EQ.icurcol .OR. colrep ) ) THEN
                  erri = abs( py( iiy+(jjy-1)*ldpy ) - y( ioffy ) )/eps
                  IF( g( i+kk-iy+1 ).NE.rzero )
     $               erri = erri / g( i+kk-iy+1 )
                  err = max( err, erri )
                  IF( err*sqrt( eps ).GE.rone )
     $               info = 1
                  iiy = iiy + 1
               END IF
*
               ioffy = ioffy + incy
*
   90       CONTINUE
*
            icurrow = mod( icurrow+1, nprow )
*
  100    CONTINUE
*
      END IF
*
*     If INFO = 0, all results are at least half accurate.
*
      CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, mycol )
      CALL dgamx2d( ictxt, 'All', ' ', 1, 1, err, 1, i, j, -1, -1,
     $              mycol )
*
      RETURN
*
*     End of PZMVCH
*
      END
      SUBROUTINE pzvmch( ICTXT, TRANS, UPLO, M, N, ALPHA, X, IX, JX,
     $                     DESCX, INCX, Y, IY, JY, DESCY, INCY, A, PA,
     $                     IA, JA, DESCA, G, ERR, INFO )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1        TRANS, UPLO
      INTEGER            IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
     $                   JY, M, N
      DOUBLE PRECISION   ERR
      COMPLEX*16         ALPHA
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * ), DESCX( * ), DESCY( * )
      DOUBLE PRECISION   G( * )
      COMPLEX*16         A( * ), PA( * ), X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  PZVMCH checks the results of the computational tests.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  TRANS   (global input) CHARACTER*1
*          On entry,  TRANS  specifies  the operation to be performed in
*          the complex cases:
*             if TRANS = 'C',
*                sub( A ) := sub( A ) + alpha * sub( X ) * sub( Y )**H,
*             otherwise
*                sub( A ) := sub( A ) + alpha * sub( X ) * sub( Y )**T.
*
*  UPLO    (global input) CHARACTER*1
*          On entry, UPLO specifies which part of the submatrix sub( A )
*          is to be referenced as follows:
*             If UPLO = 'L', only the lower triangular part,
*             If UPLO = 'U', only the upper triangular part,
*             else the entire matrix is to be referenced.
*
*  M       (global input) INTEGER
*          On entry,  M  specifies  the  number of rows of the submatrix
*          operand matrix A. M must be at least zero.
*
*  N       (global input) INTEGER
*          On entry,  N  specifies  the  number of columns of the subma-
*          trix operand matrix A. N must be at least zero.
*
*  ALPHA   (global input) COMPLEX*16
*          On entry, ALPHA specifies the scalar alpha.
*
*  X       (local input) COMPLEX*16 array
*          On entry, X is an array of  dimension  (DESCX( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PX.
*
*  IX      (global input) INTEGER
*          On entry, IX  specifies X's global row index, which points to
*          the beginning of the submatrix sub( X ).
*
*  JX      (global input) INTEGER
*          On entry, JX  specifies X's global column index, which points
*          to the beginning of the submatrix sub( X ).
*
*  DESCX   (global and local input) INTEGER array
*          On entry, DESCX  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix X.
*
*  INCX    (global input) INTEGER
*          On entry,  INCX   specifies  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.
*
*  Y       (local input) COMPLEX*16 array
*          On entry, Y is an array of  dimension  (DESCY( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PY.
*
*  IY      (global input) INTEGER
*          On entry, IY  specifies Y's global row index, which points to
*          the beginning of the submatrix sub( Y ).
*
*  JY      (global input) INTEGER
*          On entry, JY  specifies Y's global column index, which points
*          to the beginning of the submatrix sub( Y ).
*
*  DESCY   (global and local input) INTEGER array
*          On entry, DESCY  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix Y.
*
*  INCY    (global input) INTEGER
*          On entry,  INCY   specifies  the  global  increment  for  the
*          elements of  Y.  Only two values of  INCY   are  supported in
*          this version, namely 1 and M_Y. INCY  must not be zero.
*
*  A       (local input/local output) COMPLEX*16 array
*          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PA.
*
*  PA      (local input) COMPLEX*16 array
*          On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
*          array contains the local entries of the matrix PA.
*
*  IA      (global input) INTEGER
*          On entry, IA  specifies A's global row index, which points to
*          the beginning of the submatrix sub( A ).
*
*  JA      (global input) INTEGER
*          On entry, JA  specifies A's global column index, which points
*          to the beginning of the submatrix sub( A ).
*
*  DESCA   (global and local input) INTEGER array
*          On entry, DESCA  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix A.
*
*  G       (workspace) DOUBLE PRECISION array
*          On entry, G is an array of dimension at least MAX( M, N ).  G
*          is used to compute the gauges.
*
*  ERR     (global output) DOUBLE PRECISION
*          On exit, ERR specifies the largest error in absolute value.
*
*  INFO    (global output) INTEGER
*          On exit, if INFO <> 0, the result is less than half accurate.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
     $                   dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
     $                   imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
     $                   rsrc_ = 9, csrc_ = 10, lld_ = 11 )
      DOUBLE PRECISION   ZERO, ONE
      parameter( zero = 0.0d+0, one = 1.0d+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            COLREP, CTRAN, LOWER, ROWREP, UPPER
      INTEGER            I, IACOL, IAROW, IB, IBEG, ICURROW, IEND, IIA,
     $                   IN, IOFFA, IOFFX, IOFFY, J, JJA, KK, LDA, LDPA,
     $                   LDX, LDY, MYCOL, MYROW, NPCOL, NPROW
      DOUBLE PRECISION   EPS, ERRI, GTMP
      COMPLEX*16         ATMP, C
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_gridinfo, dgamx2d, igsum2d, pb_infog2l
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   PDLAMCH
      EXTERNAL           lsame, pdlamch
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, dble, dconjg, dimag, max, min, mod, sqrt
*     ..
*     .. Statement Functions ..
      DOUBLE PRECISION   ABS1
      abs1( c ) = abs( dble( c ) ) + abs( dimag( c ) )
*     ..
*     .. Executable Statements ..
*
      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
*
      eps = pdlamch( ictxt, 'eps' )
*
      ctran = lsame( trans, 'C' )
      upper = lsame( uplo, 'U' )
      lower = lsame( uplo, 'L' )
*
      lda = max( 1, desca( m_ ) )
      ldx = max( 1, descx( m_ ) )
      ldy = max( 1, descy( m_ ) )
*
*     Compute expected result in A using data in A, X and Y.
*     Compute gauges in G. This part of the computation is performed
*     by every process in the grid.
*
      DO 70 j = 1, n
*
         ioffy = iy + ( jy - 1 ) * ldy + ( j - 1 ) * incy
*
         IF( lower ) THEN
            ibeg = j
            iend = m
            DO 10 i = 1, j-1
               g( i ) = zero
   10       CONTINUE
         ELSE IF( upper ) THEN
            ibeg = 1
            iend = j
            DO 20 i = j+1, m
               g( i ) = zero
   20       CONTINUE
         ELSE
            ibeg = 1
            iend = m
         END IF
*
         DO 30 i = ibeg, iend
*
            ioffx = ix + ( jx - 1 ) * ldx + ( i - 1 ) * incx
            ioffa = ia + i - 1 + ( ja + j - 2 ) * lda
            IF( ctran ) THEN
               atmp = x( ioffx ) * dconjg( y( ioffy ) )
            ELSE
               atmp = x( ioffx ) * y( ioffy )
            END IF
            gtmp = abs1( x( ioffx ) ) * abs1( y( ioffy ) )
            g( i ) = abs1( alpha ) * gtmp + abs1( a( ioffa ) )
            a( ioffa ) = alpha * atmp + a( ioffa )
*
   30    CONTINUE
*
*        Compute the error ratio for this result.
*
         info = 0
         err  = zero
         ldpa = desca( lld_ )
         ioffa = ia + ( ja + j - 2 ) * lda
         CALL pb_infog2l( ia, ja+j-1, desca, nprow, npcol, myrow, mycol,
     $                    iia, jja, iarow, iacol )
         rowrep = ( iarow.EQ.-1 )
         colrep = ( iacol.EQ.-1 )
*
         IF( mycol.EQ.iacol .OR. colrep ) THEN
*
            icurrow = iarow
            ib = desca( imb_ ) - ia + 1
            IF( ib.LE.0 )
     $         ib = ( ( -ib ) / desca( mb_ ) + 1 ) * desca( mb_ ) + ib
            ib = min( ib, m )
            in = ia + ib - 1
*
            DO 40 i = ia, in
*
               IF( myrow.EQ.icurrow .OR. rowrep ) THEN
                  erri = abs( pa( iia+(jja-1)*ldpa ) - a( ioffa ) )/eps
                  IF( g( i-ia+1 ).NE.zero )
     $               erri = erri / g( i-ia+1 )
                  err = max( err, erri )
                  IF( err*sqrt( eps ).GE.one )
     $               info = 1
                  iia = iia + 1
               END IF
*
               ioffa = ioffa + 1
*
   40       CONTINUE
*
            icurrow = mod( icurrow+1, nprow )
*
            DO 60 i = in+1, ia+m-1, desca( mb_ )
               ib = min( ia+m-i, desca( mb_ ) )
*
               DO 50 kk = 0, ib-1
*
                  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
                     erri = abs( pa( iia+(jja-1)*ldpa )-a( ioffa ) )/eps
                     IF( g( i+kk-ia+1 ).NE.zero )
     $                  erri = erri / g( i+kk-ia+1 )
                     err = max( err, erri )
                     IF( err*sqrt( eps ).GE.one )
     $                  info = 1
                     iia = iia + 1
                  END IF
*
                  ioffa = ioffa + 1
*
   50          CONTINUE
*
               icurrow = mod( icurrow+1, nprow )
*
   60       CONTINUE
*
         END IF
*
*        If INFO = 0, all results are at least half accurate.
*
         CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, mycol )
         CALL dgamx2d( ictxt, 'All', ' ', 1, 1, err, 1, i, j, -1, -1,
     $                 mycol )
         IF( info.NE.0 )
     $      GO TO 80
*
   70 CONTINUE
*
   80 CONTINUE
*
      RETURN
*
*     End of PZVMCH
*
      END
      SUBROUTINE pzvmch2( ICTXT, UPLO, M, N, ALPHA, X, IX, JX, DESCX,
     $                    INCX, Y, IY, JY, DESCY, INCY, A, PA, IA,
     $                    JA, DESCA, G, ERR, INFO )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1        UPLO
      INTEGER            IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
     $                   JY, M, N
      DOUBLE PRECISION   ERR
      COMPLEX*16         ALPHA
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * ), DESCX( * ), DESCY( * )
      DOUBLE PRECISION   G( * )
      COMPLEX*16         A( * ), PA( * ), X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  PZVMCH2 checks the results of the computational tests.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  UPLO    (global input) CHARACTER*1
*          On entry, UPLO specifies which part of the submatrix sub( A )
*          is to be referenced as follows:
*             If UPLO = 'L', only the lower triangular part,
*             If UPLO = 'U', only the upper triangular part,
*             else the entire matrix is to be referenced.
*
*  M       (global input) INTEGER
*          On entry,  M  specifies  the  number of rows of the submatrix
*          operand matrix A. M must be at least zero.
*
*  N       (global input) INTEGER
*          On entry,  N  specifies  the  number of columns of the subma-
*          trix operand matrix A. N must be at least zero.
*
*  ALPHA   (global input) COMPLEX*16
*          On entry, ALPHA specifies the scalar alpha.
*
*  X       (local input) COMPLEX*16 array
*          On entry, X is an array of  dimension  (DESCX( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PX.
*
*  IX      (global input) INTEGER
*          On entry, IX  specifies X's global row index, which points to
*          the beginning of the submatrix sub( X ).
*
*  JX      (global input) INTEGER
*          On entry, JX  specifies X's global column index, which points
*          to the beginning of the submatrix sub( X ).
*
*  DESCX   (global and local input) INTEGER array
*          On entry, DESCX  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix X.
*
*  INCX    (global input) INTEGER
*          On entry,  INCX   specifies  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.
*
*  Y       (local input) COMPLEX*16 array
*          On entry, Y is an array of  dimension  (DESCY( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PY.
*
*  IY      (global input) INTEGER
*          On entry, IY  specifies Y's global row index, which points to
*          the beginning of the submatrix sub( Y ).
*
*  JY      (global input) INTEGER
*          On entry, JY  specifies Y's global column index, which points
*          to the beginning of the submatrix sub( Y ).
*
*  DESCY   (global and local input) INTEGER array
*          On entry, DESCY  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix Y.
*
*  INCY    (global input) INTEGER
*          On entry,  INCY   specifies  the  global  increment  for  the
*          elements of  Y.  Only two values of  INCY   are  supported in
*          this version, namely 1 and M_Y. INCY  must not be zero.
*
*  A       (local input/local output) COMPLEX*16 array
*          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PA.
*
*  PA      (local input) COMPLEX*16 array
*          On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
*          array contains the local entries of the matrix PA.
*
*  IA      (global input) INTEGER
*          On entry, IA  specifies A's global row index, which points to
*          the beginning of the submatrix sub( A ).
*
*  JA      (global input) INTEGER
*          On entry, JA  specifies A's global column index, which points
*          to the beginning of the submatrix sub( A ).
*
*  DESCA   (global and local input) INTEGER array
*          On entry, DESCA  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix A.
*
*  G       (workspace) DOUBLE PRECISION array
*          On entry, G is an array of dimension at least MAX( M, N ).  G
*          is used to compute the gauges.
*
*  ERR     (global output) DOUBLE PRECISION
*          On exit, ERR specifies the largest error in absolute value.
*
*  INFO    (global output) INTEGER
*          On exit, if INFO <> 0, the result is less than half accurate.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
     $                   dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
     $                   imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
     $                   rsrc_ = 9, csrc_ = 10, lld_ = 11 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0d+0, one = 1.0d+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            COLREP, LOWER, ROWREP, UPPER
      INTEGER            I, IACOL, IAROW, IB, IBEG, ICURROW, IEND, IIA,
     $                   in, ioffa, ioffxi, ioffxj, ioffyi, ioffyj, j,
     $                   jja, kk, lda, ldpa, ldx, ldy, mycol, myrow,
     $                   npcol, nprow
      DOUBLE PRECISION   EPS, ERRI, GTMP
      COMPLEX*16         C, ATMP
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_gridinfo, dgamx2d, igsum2d, pb_infog2l
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   PDLAMCH
      EXTERNAL           LSAME, PDLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, dble, dconjg, dimag, max, min, mod, sqrt
*     ..
*     .. Statement Functions ..
      DOUBLE PRECISION   ABS1
      ABS1( C ) = abs( dble( c ) ) + abs( dimag( c ) )
*     ..
*     .. Executable Statements ..
*
      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
*
      eps = pdlamch( ictxt, 'eps' )
*
      upper = lsame( uplo, 'U' )
      lower = lsame( uplo, 'L' )
*
      lda = max( 1, desca( m_ ) )
      ldx = max( 1, descx( m_ ) )
      ldy = max( 1, descy( m_ ) )
*
*     Compute expected result in A using data in A, X and Y.
*     Compute gauges in G. This part of the computation is performed
*     by every process in the grid.
*
      DO 70 j = 1, n
*
         ioffxj = ix + ( jx - 1 ) * ldx + ( j - 1 ) * incx
         ioffyj = iy + ( jy - 1 ) * ldy + ( j - 1 ) * incy
*
         IF( lower ) THEN
            ibeg = j
            iend = m
            DO 10 i = 1, j-1
               g( i ) = zero
   10       CONTINUE
         ELSE IF( upper ) THEN
            ibeg = 1
            iend = j
            DO 20 i = j+1, m
               g( i ) = zero
   20       CONTINUE
         ELSE
            ibeg = 1
            iend = m
         END IF
*
         DO 30 i = ibeg, iend
            ioffa = ia + i - 1 + ( ja + j - 2 ) * lda
            ioffxi = ix + ( jx - 1 ) * ldx + ( i - 1 ) * incx
            ioffyi = iy + ( jy - 1 ) * ldy + ( i - 1 ) * incy
            atmp = alpha * x( ioffxi ) * dconjg( y( ioffyj ) )
            atmp = atmp + y( ioffyi ) * dconjg( alpha * x( ioffxj ) )
            gtmp = abs1( alpha * x( ioffxi ) ) * abs1( y( ioffyj ) )
            gtmp = gtmp + abs1( y( ioffyi ) ) *
     $                    abs1( dconjg( alpha * x( ioffxj ) ) )
            g( i ) = gtmp + abs1( a( ioffa ) )
            a( ioffa ) = a( ioffa ) + atmp
*
   30    CONTINUE
*
*        Compute the error ratio for this result.
*
         info = 0
         err  = zero
         ldpa = desca( lld_ )
         ioffa = ia + ( ja + j - 2 ) * lda
         CALL pb_infog2l( ia, ja+j-1, desca, nprow, npcol, myrow, mycol,
     $                    iia, jja, iarow, iacol )
         rowrep = ( iarow.EQ.-1 )
         colrep = ( iacol.EQ.-1 )
*
         IF( mycol.EQ.iacol .OR. colrep ) THEN
*
            icurrow = iarow
            ib = desca( imb_ ) - ia + 1
            IF( ib.LE.0 )
     $         ib = ( ( -ib ) / desca( mb_ ) + 1 ) * desca( mb_ ) + ib
            ib = min( ib, m )
            in = ia + ib - 1
*
            DO 40 i = ia, in
*
               IF( myrow.EQ.icurrow .OR. rowrep ) THEN
                  erri = abs( pa( iia+(jja-1)*ldpa ) - a( ioffa ) )/eps
                  IF( g( i-ia+1 ).NE.zero )
     $               erri = erri / g( i-ia+1 )
                  err = max( err, erri )
                  IF( err*sqrt( eps ).GE.one )
     $               info = 1
                  iia = iia + 1
               END IF
*
               ioffa = ioffa + 1
*
   40       CONTINUE
*
            icurrow = mod( icurrow+1, nprow )
*
            DO 60 i = in+1, ia+m-1, desca( mb_ )
               ib = min( ia+m-i, desca( mb_ ) )
*
               DO 50 kk = 0, ib-1
*
                  IF( myrow.EQ.icurrow .OR. rowrep ) THEN
                     erri = abs( pa( iia+(jja-1)*ldpa )-a( ioffa ) )/eps
                     IF( g( i+kk-ia+1 ).NE.zero )
     $                  erri = erri / g( i+kk-ia+1 )
                     err = max( err, erri )
                     IF( err*sqrt( eps ).GE.one )
     $                  info = 1
                     iia = iia + 1
                  END IF
*
                  ioffa = ioffa + 1
*
   50          CONTINUE
*
               icurrow = mod( icurrow+1, nprow )
*
   60       CONTINUE
*
         END IF
*
*        If INFO = 0, all results are at least half accurate.
*
         CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, mycol )
         CALL dgamx2d( ictxt, 'All', ' ', 1, 1, err, 1, i, j, -1, -1,
     $                 mycol )
         IF( info.NE.0 )
     $      GO TO 80
*
   70 CONTINUE
*
   80 CONTINUE
*
      RETURN
*
*     End of PZVMCH2
*
      END
      SUBROUTINE pzmmch( ICTXT, TRANSA, TRANSB, M, N, K, ALPHA, A, IA,
     $                   JA, DESCA, B, IB, JB, DESCB, BETA, C, PC, IC,
     $                   JC, DESCC, CT, G, ERR, INFO )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1        TRANSA, TRANSB
      INTEGER            IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, M, N
      DOUBLE PRECISION   ERR
      COMPLEX*16         ALPHA, BETA
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * ), DESCB( * ), DESCC( * )
      DOUBLE PRECISION   G( * )
      COMPLEX*16         A( * ), B( * ), C( * ), CT( * ), PC( * )
*     ..
*
*  Purpose
*  =======
*
*  PZMMCH checks the results of the computational tests.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  TRANSA  (global input) CHARACTER*1
*          On entry, TRANSA specifies if the matrix  operand  A is to be
*          transposed.
*
*  TRANSB  (global input) CHARACTER*1
*          On entry, TRANSB specifies if the matrix  operand  B is to be
*          transposed.
*
*  M       (global input) INTEGER
*          On entry, M specifies the number of rows of C.
*
*  N       (global input) INTEGER
*          On entry, N specifies the number of columns of C.
*
*  K       (global input) INTEGER
*          On entry, K specifies the number of columns (resp. rows) of A
*          when  TRANSA = 'N'  (resp. TRANSA <> 'N')  in PxGEMM, PxSYRK,
*          PxSYR2K, PxHERK and PxHER2K.
*
*  ALPHA   (global input) COMPLEX*16
*          On entry, ALPHA specifies the scalar alpha.
*
*  A       (local input) COMPLEX*16 array
*          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PA.
*
*  IA      (global input) INTEGER
*          On entry, IA  specifies A's global row index, which points to
*          the beginning of the submatrix sub( A ).
*
*  JA      (global input) INTEGER
*          On entry, JA  specifies A's global column index, which points
*          to the beginning of the submatrix sub( A ).
*
*  DESCA   (global and local input) INTEGER array
*          On entry, DESCA  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix A.
*
*  B       (local input) COMPLEX*16 array
*          On entry, B is an array of  dimension  (DESCB( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PB.
*
*  IB      (global input) INTEGER
*          On entry, IB  specifies B's global row index, which points to
*          the beginning of the submatrix sub( B ).
*
*  JB      (global input) INTEGER
*          On entry, JB  specifies B's global column index, which points
*          to the beginning of the submatrix sub( B ).
*
*  DESCB   (global and local input) INTEGER array
*          On entry, DESCB  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix B.
*
*  BETA    (global input) COMPLEX*16
*          On entry, BETA specifies the scalar beta.
*
*  C       (local input/local output) COMPLEX*16 array
*          On entry, C is an array of  dimension  (DESCC( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PC.
*
*  PC      (local input) COMPLEX*16 array
*          On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
*          array contains the local pieces of the matrix PC.
*
*  IC      (global input) INTEGER
*          On entry, IC  specifies C's global row index, which points to
*          the beginning of the submatrix sub( C ).
*
*  JC      (global input) INTEGER
*          On entry, JC  specifies C's global column index, which points
*          to the beginning of the submatrix sub( C ).
*
*  DESCC   (global and local input) INTEGER array
*          On entry, DESCC  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix C.
*
*  CT      (workspace) COMPLEX*16 array
*          On entry, CT is an array of dimension at least MAX(M,N,K). CT
*          holds a copy of the current column of C.
*
*  G       (workspace) DOUBLE PRECISION array
*          On entry, G  is  an array of dimension at least MAX(M,N,K). G
*          is used to compute the gauges.
*
*  ERR     (global output) DOUBLE PRECISION
*          On exit, ERR specifies the largest error in absolute value.
*
*  INFO    (global output) INTEGER
*          On exit, if INFO <> 0, the result is less than half accurate.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, dlen_ = 11,
     $                   dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
     $                   imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
     $                   rsrc_ = 9, csrc_ = 10, lld_ = 11 )
      DOUBLE PRECISION   RZERO, RONE
      PARAMETER          ( RZERO = 0.0d+0, rone = 1.0d+0 )
      COMPLEX*16         ZERO
      PARAMETER          ( ZERO = ( 0.0d+0, 0.0d+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            COLREP, CTRANA, CTRANB, ROWREP, TRANA, TRANB
      INTEGER            I, IBB, ICCOL, ICROW, ICURROW, IIC, IN, IOFFA,
     $                   ioffb, ioffc, j, jjc, kk, lda, ldb, ldc, ldpc,
     $                   mycol, myrow, npcol, nprow
      DOUBLE PRECISION   EPS, ERRI
      COMPLEX*16         Z
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_gridinfo, dgamx2d, igsum2d, pb_infog2l
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   PDLAMCH
      EXTERNAL           lsame, pdlamch
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, dble, dconjg, dimag, max, min, mod, sqrt
*     ..
*     .. Statement Functions ..
      DOUBLE PRECISION   ABS1
      abs1( z ) = abs( dble( z ) ) + abs( dimag( z ) )
*     ..
*     .. Executable Statements ..
*
      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
*
      eps = pdlamch( ictxt, 'eps' )
*
      trana = lsame( transa, 'T' ).OR.lsame( transa, 'C' )
      tranb = lsame( transb, 't.OR.' )LSAME( TRANSB, 'c' )
      CTRANA = LSAME( TRANSA, 'c' )
      CTRANB = LSAME( TRANSB, 'c' )
*
      LDA = MAX( 1, DESCA( M_ ) )
      LDB = MAX( 1, DESCB( M_ ) )
      LDC = MAX( 1, DESCC( M_ ) )
*
*     Compute expected result in C using data in A, B and C.
*     Compute gauges in G. This part of the computation is performed
*     by every process in the grid.
*
      DO 240 J = 1, N
*
         IOFFC = IC + ( JC + J - 2 ) * LDC
         DO 10 I = 1, M
            CT( I ) = ZERO
            G( I )  = RZERO
   10    CONTINUE
*
.NOT..AND..NOT.         IF( TRANA  TRANB ) THEN
            DO 30 KK = 1, K
               IOFFB = IB + KK - 1 + ( JB + J - 2 ) * LDB
               DO 20 I = 1, M
                  IOFFA = IA + I - 1 + ( JA + KK - 2 ) * LDA
                  CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB )
                  G( I ) = G( I ) + ABS( A( IOFFA ) ) *
     $                     ABS( B( IOFFB ) )
   20          CONTINUE
   30       CONTINUE
.AND..NOT.         ELSE IF( TRANA  TRANB ) THEN
            IF( CTRANA ) THEN
               DO 50 KK = 1, K
                  IOFFB = IB + KK - 1 + ( JB + J - 2 ) * LDB
                  DO 40 I = 1, M
                     IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA
                     CT( I ) = CT( I ) + DCONJG( A( IOFFA ) ) *
     $                                   B( IOFFB )
                     G( I ) = G( I ) + ABS1( A( IOFFA ) ) *
     $                        ABS1( B( IOFFB ) )
   40             CONTINUE
   50          CONTINUE
            ELSE
               DO 70 KK = 1, K
                  IOFFB = IB + KK - 1 + ( JB + J - 2 ) * LDB
                  DO 60 I = 1, M
                     IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA
                     CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB )
                     G( I ) = G( I ) + ABS1( A( IOFFA ) ) *
     $                        ABS1( B( IOFFB ) )
   60             CONTINUE
   70          CONTINUE
            END IF
.NOT..AND.         ELSE IF( TRANA  TRANB ) THEN
            IF( CTRANB ) THEN
               DO 90 KK = 1, K
                  IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB
                  DO 80 I = 1, M
                     IOFFA = IA + I - 1 + ( JA + KK - 2 ) * LDA
                     CT( I ) = CT( I ) + A( IOFFA ) *
     $                                   DCONJG( B( IOFFB ) )
                     G( I ) = G( I ) + ABS1( A( IOFFA ) ) *
     $                        ABS1( B( IOFFB ) )
   80             CONTINUE
   90          CONTINUE
            ELSE
               DO 110 KK = 1, K
                  IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB
                  DO 100 I = 1, M
                     IOFFA = IA + I - 1 + ( JA + KK - 2 ) * LDA
                     CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB )
                     G( I ) = G( I ) + ABS1( A( IOFFA ) ) *
     $                        ABS1( B( IOFFB ) )
  100             CONTINUE
  110          CONTINUE
            END IF
.AND.         ELSE IF( TRANA  TRANB ) THEN
            IF( CTRANA ) THEN
               IF( CTRANB ) THEN
                  DO 130 KK = 1, K
                     IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB
                     DO 120 I = 1, M
                        IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA
                        CT( I ) = CT( I ) + DCONJG( A( IOFFA ) ) *
     $                                      DCONJG( B( IOFFB ) )
                        G( I ) = G( I ) + ABS1( A( IOFFA ) ) *
     $                           ABS1( B( IOFFB ) )
  120                CONTINUE
  130             CONTINUE
               ELSE
                  DO 150 KK = 1, K
                     IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB
                     DO 140 I = 1, M
                        IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA
                        CT( I ) = CT( I ) + DCONJG( A( IOFFA ) ) *
     $                                      B( IOFFB )
                        G( I ) = G( I ) + ABS1( A( IOFFA ) ) *
     $                           ABS1( B( IOFFB ) )
  140                CONTINUE
  150             CONTINUE
               END IF
            ELSE
               IF( CTRANB ) THEN
                  DO 170 KK = 1, K
                     IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB
                     DO 160 I = 1, M
                        IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA
                        CT( I ) = CT( I ) + A( IOFFA ) *
     $                                      DCONJG( B( IOFFB ) )
                        G( I ) = G( I ) + ABS1( A( IOFFA ) ) *
     $                           ABS1( B( IOFFB ) )
  160                CONTINUE
  170             CONTINUE
               ELSE
                  DO 190 KK = 1, K
                     IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB
                     DO 180 I = 1, M
                        IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA
                        CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB )
                        G( I ) = G( I ) + ABS1( A( IOFFA ) ) *
     $                           ABS1( B( IOFFB ) )
  180                CONTINUE
  190             CONTINUE
               END IF
            END IF
         END IF
*
         DO 200 I = 1, M
            CT( I ) = ALPHA*CT( I ) + BETA * C( IOFFC )
            G( I ) = ABS1( ALPHA )*G( I ) +
     $               ABS1( BETA )*ABS1( C( IOFFC ) )
            C( IOFFC ) = CT( I )
            IOFFC      = IOFFC + 1
  200    CONTINUE
*
*        Compute the error ratio for this result.
*
         ERR  = RZERO
         INFO = 0
         LDPC = DESCC( LLD_ )
         IOFFC = IC + ( JC + J - 2 ) * LDC
         CALL PB_INFOG2L( IC, JC+J-1, DESCC, NPROW, NPCOL, MYROW, MYCOL,
     $                    IIC, JJC, ICROW, ICCOL )
         ICURROW = ICROW
.EQ.         ROWREP  = ( ICROW-1 )
.EQ.         COLREP  = ( ICCOL-1 )
*
.EQ..OR.         IF( MYCOLICCOL  COLREP ) THEN
*
            IBB = DESCC( IMB_ ) - IC + 1
.LE.            IF( IBB0 )
     $         IBB = ( ( -IBB ) / DESCC( MB_ ) + 1 )*DESCC( MB_ ) + IBB
            IBB = MIN( IBB, M )
            IN = IC + IBB - 1
*
            DO 210 I = IC, IN
*
.EQ..OR.               IF( MYROWICURROW  ROWREP ) THEN
                  ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
     $                        C( IOFFC ) ) / EPS
.NE.                  IF( G( I-IC+1 )RZERO )
     $               ERRI = ERRI / G( I-IC+1 )
                  ERR = MAX( ERR, ERRI )
.GE.                  IF( ERR*SQRT( EPS )RONE )
     $               INFO = 1
                  IIC = IIC + 1
               END IF
*
               IOFFC = IOFFC + 1
*
  210       CONTINUE
*
            ICURROW = MOD( ICURROW+1, NPROW )
*
            DO 230 I = IN+1, IC+M-1, DESCC( MB_ )
               IBB = MIN( IC+M-I, DESCC( MB_ ) )
*
               DO 220 KK = 0, IBB-1
*
.EQ..OR.                  IF( MYROWICURROW  ROWREP ) THEN
                     ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
     $                           C( IOFFC ) )/EPS
.NE.                     IF( G( I+KK-IC+1 )RZERO )
     $                  ERRI = ERRI / G( I+KK-IC+1 )
                     ERR = MAX( ERR, ERRI )
.GE.                     IF( ERR*SQRT( EPS )RONE )
     $                  INFO = 1
                     IIC = IIC + 1
                  END IF
*
                  IOFFC = IOFFC + 1
*
  220          CONTINUE
*
               ICURROW = MOD( ICURROW+1, NPROW )
*
  230       CONTINUE
*
         END IF
*
*        If INFO = 0, all results are at least half accurate.
*
         CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, INFO, 1, -1, MYCOL )
         CALL DGAMX2D( ICTXT, 'all', ' ', 1, 1, ERR, 1, I, J, -1, -1,
     $                 MYCOL )
.NE.         IF( INFO0 )
     $      GO TO 250
*
  240 CONTINUE
*
  250 CONTINUE
*
      RETURN
*
*     End of PZMMCH
*
      END
      SUBROUTINE PZMMCH1( ICTXT, UPLO, TRANS, N, K, ALPHA, A, IA, JA,
     $                    DESCA, BETA, C, PC, IC, JC, DESCC, CT, G,
     $                    ERR, INFO )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1        TRANS, UPLO
      INTEGER            IA, IC, ICTXT, INFO, JA, JC, K, N
      DOUBLE PRECISION   ERR
      COMPLEX*16         ALPHA, BETA
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * ), DESCC( * )
      DOUBLE PRECISION   G( * )
      COMPLEX*16         A( * ), C( * ), CT( * ), PC( * )
*     ..
*
*  Purpose
*  =======
*
*  PZMMCH1 checks the results of the computational tests.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  UPLO    (global input) CHARACTER*1
*          On entry,  UPLO  specifies which part of C should contain the
*          result.
*
*  TRANS   (global input) CHARACTER*1
*          On entry,  TRANS  specifies  whether  the  matrix A has to be
*          transposed or not before computing the matrix-matrix product.
*
*  N       (global input) INTEGER
*          On entry, N  specifies  the order  the submatrix operand C. N
*          must be at least zero.
*
*  K       (global input) INTEGER
*          On entry, K specifies the number of columns (resp. rows) of A
*          when  TRANS = 'N'  (resp. TRANS <> 'N').  K  must be at least
*          zero.
*
*  ALPHA   (global input) COMPLEX*16
*          On entry, ALPHA specifies the scalar alpha.
*
*  A       (local input) COMPLEX*16 array
*          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PA.
*
*  IA      (global input) INTEGER
*          On entry, IA  specifies A's global row index, which points to
*          the beginning of the submatrix sub( A ).
*
*  JA      (global input) INTEGER
*          On entry, JA  specifies A's global column index, which points
*          to the beginning of the submatrix sub( A ).
*
*  DESCA   (global and local input) INTEGER array
*          On entry, DESCA  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix A.
*
*  BETA    (global input) COMPLEX*16
*          On entry, BETA specifies the scalar beta.
*
*  C       (local input/local output) COMPLEX*16 array
*          On entry, C is an array of  dimension  (DESCC( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PC.
*
*  PC      (local input) COMPLEX*16 array
*          On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
*          array contains the local pieces of the matrix PC.
*
*  IC      (global input) INTEGER
*          On entry, IC  specifies C's global row index, which points to
*          the beginning of the submatrix sub( C ).
*
*  JC      (global input) INTEGER
*          On entry, JC  specifies C's global column index, which points
*          to the beginning of the submatrix sub( C ).
*
*  DESCC   (global and local input) INTEGER array
*          On entry, DESCC  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix C.
*
*  CT      (workspace) COMPLEX*16 array
*          On entry, CT is an array of dimension at least MAX(M,N,K). CT
*          holds a copy of the current column of C.
*
*  G       (workspace) DOUBLE PRECISION array
*          On entry, G  is  an array of dimension at least MAX(M,N,K). G
*          is used to compute the gauges.
*
*  ERR     (global output) DOUBLE PRECISION
*          On exit, ERR specifies the largest error in absolute value.
*
*  INFO    (global output) INTEGER
*          On exit, if INFO <> 0, the result is less than half accurate.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
     $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
     $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
     $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
      DOUBLE PRECISION   RZERO, RONE
      PARAMETER          ( RZERO = 0.0D+0, RONE = 1.0D+0 )
      COMPLEX*16         ZERO
      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            COLREP, HTRAN, NOTRAN, ROWREP, TRAN, UPPER
      INTEGER            I, IBB, IBEG, ICCOL, ICROW, ICURROW, IEND, IIC,
     $                   IN, IOFFAK, IOFFAN, IOFFC, J, JJC, KK, LDA,
     $                   LDC, LDPC, MYCOL, MYROW, NPCOL, NPROW
      DOUBLE PRECISION   EPS, ERRI
      COMPLEX*16         Z
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   PDLAMCH
      EXTERNAL           LSAME, PDLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD, SQRT
*     ..
*     .. Statement Functions ..
      DOUBLE PRECISION   ABS1
      ABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
*     ..
*     .. Executable Statements ..
*
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
      EPS = PDLAMCH( ICTXT, 'eps' )
*
      UPPER  = LSAME( UPLO,  'u' )
      NOTRAN = LSAME( TRANS, 'n' )
      TRAN   = LSAME( TRANS, 't' )
      HTRAN  = LSAME( TRANS, 'h' )
*
      LDA = MAX( 1, DESCA( M_ ) )
      LDC = MAX( 1, DESCC( M_ ) )
*
*     Compute expected result in C using data in A, B and C.
*     Compute gauges in G. This part of the computation is performed
*     by every process in the grid.
*
      DO 140 J = 1, N
*
         IF( UPPER ) THEN
            IBEG = 1
            IEND = J
         ELSE
            IBEG = J
            IEND = N
         END IF
*
         DO 10 I = 1, N
            CT( I ) = ZERO
            G( I )  = RZERO
   10    CONTINUE
*
         IF( NOTRAN ) THEN
            DO 30 KK = 1, K
               IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA
               DO 20 I = IBEG, IEND
                  IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA
                  CT( I ) = CT( I ) + A( IOFFAK ) * A( IOFFAN )
                  G( I ) = G( I ) + ABS1( A( IOFFAK ) ) *
     $                     ABS1( A( IOFFAN ) )
   20          CONTINUE
   30       CONTINUE
         ELSE IF( TRAN ) THEN
            DO 50 KK = 1, K
               IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA
               DO 40 I = IBEG, IEND
                  IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA
                  CT( I ) = CT( I ) + A( IOFFAK ) * A( IOFFAN )
                  G( I ) = G( I ) + ABS1( A( IOFFAK ) ) *
     $                     ABS1( A( IOFFAN ) )
   40          CONTINUE
   50       CONTINUE
         ELSE IF( HTRAN ) THEN
            DO 70 KK = 1, K
               IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA
               DO 60 I = IBEG, IEND
                  IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA
                  CT( I ) = CT( I ) + A( IOFFAN ) *
     $                      DCONJG( A( IOFFAK ) )
                  G( I ) = G( I ) + ABS1( A( IOFFAK ) ) *
     $                     ABS1( A( IOFFAN ) )
   60          CONTINUE
   70       CONTINUE
         ELSE
            DO 90 KK = 1, K
               IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA
               DO 80 I = IBEG, IEND
                  IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA
                  CT( I ) = CT( I ) + DCONJG( A( IOFFAN ) ) *
     $                      A( IOFFAK )
                  G( I ) = G( I ) + ABS1( DCONJG( A( IOFFAN ) ) ) *
     $                     ABS1( A( IOFFAK ) )
   80          CONTINUE
   90       CONTINUE
         END IF
*
         IOFFC = IC + IBEG - 1 + ( JC + J - 2 ) * LDC
*
         DO 100 I = IBEG, IEND
            CT( I ) = ALPHA*CT( I ) + BETA * C( IOFFC )
            G( I ) = ABS1( ALPHA )*G( I ) +
     $               ABS1( BETA )*ABS1( C( IOFFC ) )
            C( IOFFC ) = CT( I )
            IOFFC = IOFFC + 1
  100    CONTINUE
*
*        Compute the error ratio for this result.
*
         ERR  = RZERO
         INFO = 0
         LDPC = DESCC( LLD_ )
         IOFFC = IC + ( JC + J - 2 ) * LDC
         CALL PB_INFOG2L( IC, JC+J-1, DESCC, NPROW, NPCOL, MYROW, MYCOL,
     $                    IIC, JJC, ICROW, ICCOL )
         ICURROW = ICROW
.EQ.         ROWREP  = ( ICROW-1 )
.EQ.         COLREP  = ( ICCOL-1 )
*
.EQ..OR.         IF( MYCOLICCOL  COLREP ) THEN
*
            IBB = DESCC( IMB_ ) - IC + 1
.LE.            IF( IBB0 )
     $         IBB = ( ( -IBB ) / DESCC( MB_ ) + 1 )*DESCC( MB_ ) + IBB
            IBB = MIN( IBB, N )
            IN = IC + IBB - 1
*
            DO 110 I = IC, IN
*
.EQ..OR.               IF( MYROWICURROW  ROWREP ) THEN
                  ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
     $                        C( IOFFC ) ) / EPS
.NE.                  IF( G( I-IC+1 )RZERO )
     $               ERRI = ERRI / G( I-IC+1 )
                  ERR = MAX( ERR, ERRI )
.GE.                  IF( ERR*SQRT( EPS )RONE )
     $               INFO = 1
                  IIC = IIC + 1
               END IF
*
               IOFFC = IOFFC + 1
*
  110       CONTINUE
*
            ICURROW = MOD( ICURROW+1, NPROW )
*
            DO 130 I = IN+1, IC+N-1, DESCC( MB_ )
               IBB = MIN( IC+N-I, DESCC( MB_ ) )
*
               DO 120 KK = 0, IBB-1
*
.EQ..OR.                  IF( MYROWICURROW  ROWREP ) THEN
                     ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
     $                           C( IOFFC ) )/EPS
.NE.                     IF( G( I+KK-IC+1 )RZERO )
     $                  ERRI = ERRI / G( I+KK-IC+1 )
                     ERR = MAX( ERR, ERRI )
.GE.                     IF( ERR*SQRT( EPS )RONE )
     $                  INFO = 1
                     IIC = IIC + 1
                  END IF
*
                  IOFFC = IOFFC + 1
*
  120          CONTINUE
*
               ICURROW = MOD( ICURROW+1, NPROW )
*
  130       CONTINUE
*
         END IF
*
*        If INFO = 0, all results are at least half accurate.
*
         CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, INFO, 1, -1, MYCOL )
         CALL DGAMX2D( ICTXT, 'all', ' ', 1, 1, ERR, 1, I, J, -1, -1,
     $                 MYCOL )
.NE.         IF( INFO0 )
     $      GO TO 150
*
  140 CONTINUE
*
  150 CONTINUE
*
      RETURN
*
*     End of PZMMCH1
*
      END
      SUBROUTINE PZMMCH2( ICTXT, UPLO, TRANS, N, K, ALPHA, A, IA, JA,
     $                    DESCA, B, IB, JB, DESCB, BETA, C, PC, IC,
     $                    JC, DESCC, CT, G, ERR, INFO )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1        TRANS, UPLO
      INTEGER            IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, N
      DOUBLE PRECISION   ERR
      COMPLEX*16         ALPHA, BETA
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * ), DESCB( * ), DESCC( * )
      DOUBLE PRECISION   G( * )
      COMPLEX*16         A( * ), B( * ), C( * ), CT( * ),
     $                   PC( * )
*     ..
*
*  Purpose
*  =======
*
*  PZMMCH2 checks the results of the computational tests.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  UPLO    (global input) CHARACTER*1
*          On entry,  UPLO  specifies which part of C should contain the
*          result.
*
*  TRANS   (global input) CHARACTER*1
*          On entry,  TRANS  specifies whether the matrices A and B have
*          to  be  transposed  or not before computing the matrix-matrix
*          product.
*
*  N       (global input) INTEGER
*          On entry, N  specifies  the order  the submatrix operand C. N
*          must be at least zero.
*
*  K       (global input) INTEGER
*          On entry, K specifies the number of columns (resp. rows) of A
*          and B when  TRANS = 'N' (resp. TRANS <> 'N').  K  must  be at
*          least zero.
*
*  ALPHA   (global input) COMPLEX*16
*          On entry, ALPHA specifies the scalar alpha.
*
*  A       (local input) COMPLEX*16 array
*          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PA.
*
*  IA      (global input) INTEGER
*          On entry, IA  specifies A's global row index, which points to
*          the beginning of the submatrix sub( A ).
*
*  JA      (global input) INTEGER
*          On entry, JA  specifies A's global column index, which points
*          to the beginning of the submatrix sub( A ).
*
*  DESCA   (global and local input) INTEGER array
*          On entry, DESCA  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix A.
*
*  B       (local input) COMPLEX*16 array
*          On entry, B is an array of  dimension  (DESCB( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PB.
*
*  IB      (global input) INTEGER
*          On entry, IB  specifies B's global row index, which points to
*          the beginning of the submatrix sub( B ).
*
*  JB      (global input) INTEGER
*          On entry, JB  specifies B's global column index, which points
*          to the beginning of the submatrix sub( B ).
*
*  DESCB   (global and local input) INTEGER array
*          On entry, DESCB  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix B.
*
*  BETA    (global input) COMPLEX*16
*          On entry, BETA specifies the scalar beta.
*
*  C       (local input/local output) COMPLEX*16 array
*          On entry, C is an array of  dimension  (DESCC( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PC.
*
*  PC      (local input) COMPLEX*16 array
*          On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
*          array contains the local pieces of the matrix PC.
*
*  IC      (global input) INTEGER
*          On entry, IC  specifies C's global row index, which points to
*          the beginning of the submatrix sub( C ).
*
*  JC      (global input) INTEGER
*          On entry, JC  specifies C's global column index, which points
*          to the beginning of the submatrix sub( C ).
*
*  DESCC   (global and local input) INTEGER array
*          On entry, DESCC  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix C.
*
*  CT      (workspace) COMPLEX*16 array
*          On entry, CT is an array of dimension at least MAX(M,N,K). CT
*          holds a copy of the current column of C.
*
*  G       (workspace) DOUBLE PRECISION array
*          On entry, G  is  an array of dimension at least MAX(M,N,K). G
*          is used to compute the gauges.
*
*  ERR     (global output) DOUBLE PRECISION
*          On exit, ERR specifies the largest error in absolute value.
*
*  INFO    (global output) INTEGER
*          On exit, if INFO <> 0, the result is less than half accurate.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
     $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
     $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
     $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
      DOUBLE PRECISION   RZERO, RONE
      PARAMETER          ( RZERO = 0.0D+0, RONE = 1.0D+0 )
      COMPLEX*16         ZERO
      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            COLREP, HTRAN, NOTRAN, ROWREP, TRAN, UPPER
      INTEGER            I, IBB, IBEG, ICCOL, ICROW, ICURROW, IEND, IIC,
     $                   IN, IOFFAK, IOFFAN, IOFFBK, IOFFBN, IOFFC, J,
     $                   JJC, KK, LDA, LDB, LDC, LDPC, MYCOL, MYROW,
     $                   NPCOL, NPROW
      DOUBLE PRECISION   EPS, ERRI
      COMPLEX*16         Z
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   PDLAMCH
      EXTERNAL           LSAME, PDLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD, SQRT
*     ..
*     .. Statement Functions ..
      DOUBLE PRECISION   ABS1
      ABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
*     ..
*     .. Executable Statements ..
*
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
      EPS = PDLAMCH( ICTXT, 'eps' )
*
      UPPER = LSAME( UPLO, 'u' )
      HTRAN = LSAME( TRANS, 'h' )
      NOTRAN = LSAME( TRANS, 'n' )
      TRAN = LSAME( TRANS, 't' )
*
      LDA = MAX( 1, DESCA( M_ ) )
      LDB = MAX( 1, DESCB( M_ ) )
      LDC = MAX( 1, DESCC( M_ ) )
*
*     Compute expected result in C using data in A, B and C.
*     Compute gauges in G. This part of the computation is performed
*     by every process in the grid.
*
      DO 140 J = 1, N
*
         IF( UPPER ) THEN
            IBEG = 1
            IEND = J
         ELSE
            IBEG = J
            IEND = N
         END IF
*
         DO 10 I = 1, N
            CT( I ) = ZERO
            G( I )  = RZERO
   10    CONTINUE
*
         IF( NOTRAN ) THEN
            DO 30 KK = 1, K
               IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA
               IOFFBK = IB + J - 1 + ( JB + KK - 2 ) * LDB
               DO 20 I = IBEG, IEND
                  IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA
                  IOFFBN = IB + I - 1 + ( JB + KK - 2 ) * LDB
                  CT( I ) = CT( I ) + ALPHA * (
     $                      A( IOFFAN ) * B( IOFFBK ) +
     $                      B( IOFFBN ) * A( IOFFAK ) )
                  G( I ) = G( I ) + ABS( ALPHA ) * (
     $                     ABS1( A( IOFFAN ) ) * ABS1( B( IOFFBK ) ) +
     $                     ABS1( B( IOFFBN ) ) * ABS1( A( IOFFAK ) ) )
   20          CONTINUE
   30       CONTINUE
         ELSE IF( TRAN ) THEN
            DO 50 KK = 1, K
               IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA
               IOFFBK = IB + KK - 1 + ( JB + J - 2 ) * LDB
               DO 40 I = IBEG, IEND
                  IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA
                  IOFFBN = IB + KK - 1 + ( JB + I - 2 ) * LDB
                  CT( I ) = CT( I ) + ALPHA * (
     $                      A( IOFFAN ) * B( IOFFBK ) +
     $                      B( IOFFBN ) * A( IOFFAK ) )
                  G( I ) = G( I ) + ABS( ALPHA ) * (
     $                     ABS1( A( IOFFAN ) ) * ABS1( B( IOFFBK ) ) +
     $                     ABS1( B( IOFFBN ) ) * ABS1( A( IOFFAK ) ) )
   40          CONTINUE
   50       CONTINUE
         ELSE IF( HTRAN ) THEN
            DO 70 KK = 1, K
               IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA
               IOFFBK = IB + J - 1 + ( JB + KK - 2 ) * LDB
               DO 60 I = IBEG, IEND
                  IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA
                  IOFFBN = IB + I - 1 + ( JB + KK - 2 ) * LDB
                  CT( I ) = CT( I ) +
     $                ALPHA * A( IOFFAN ) * DCONJG( B( IOFFBK ) ) +
     $                B( IOFFBN ) * DCONJG( ALPHA * A( IOFFAK ) )
                  G( I ) = G( I ) + ABS1( ALPHA ) * (
     $                     ABS1( A( IOFFAN ) ) * ABS1( B( IOFFBK ) ) +
     $                     ABS1( B( IOFFBN ) ) * ABS1( A( IOFFAK ) ) )
   60          CONTINUE
   70       CONTINUE
         ELSE
            DO 90 KK = 1, K
               IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA
               IOFFBK = IB + KK - 1 + ( JB + J - 2 ) * LDB
               DO 80 I = IBEG, IEND
                  IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA
                  IOFFBN = IB + KK - 1 + ( JB + I - 2 ) * LDB
                  CT( I ) = CT( I ) +
     $                   ALPHA * DCONJG( A( IOFFAN ) ) * B( IOFFBK ) +
     $                   DCONJG( ALPHA * B( IOFFBN ) ) * A( IOFFAK )
                  G( I ) = G( I ) + ABS1( ALPHA ) * (
     $                   ABS1( DCONJG( A( IOFFAN ) ) * B( IOFFBK ) ) +
     $                   ABS1( DCONJG( B( IOFFBN ) ) * A( IOFFAK ) ) )
   80          CONTINUE
   90       CONTINUE
         END IF
*
         IOFFC = IC + IBEG - 1 + ( JC + J - 2 ) * LDC
*
         DO 100 I = IBEG, IEND
            CT( I ) = CT( I ) + BETA * C( IOFFC )
            G( I ) = G( I ) + ABS1( BETA )*ABS1( C( IOFFC ) )
            C( IOFFC ) = CT( I )
            IOFFC = IOFFC + 1
  100    CONTINUE
*
*        Compute the error ratio for this result.
*
         ERR  = RZERO
         INFO = 0
         LDPC = DESCC( LLD_ )
         IOFFC = IC + ( JC + J - 2 ) * LDC
         CALL PB_INFOG2L( IC, JC+J-1, DESCC, NPROW, NPCOL, MYROW, MYCOL,
     $                    IIC, JJC, ICROW, ICCOL )
         ICURROW = ICROW
.EQ.         ROWREP  = ( ICROW-1 )
.EQ.         COLREP  = ( ICCOL-1 )
*
.EQ..OR.         IF( MYCOLICCOL  COLREP ) THEN
*
            IBB = DESCC( IMB_ ) - IC + 1
.LE.            IF( IBB0 )
     $         IBB = ( ( -IBB ) / DESCC( MB_ ) + 1 )*DESCC( MB_ ) + IBB
            IBB = MIN( IBB, N )
            IN = IC + IBB - 1
*
            DO 110 I = IC, IN
*
.EQ..OR.               IF( MYROWICURROW  ROWREP ) THEN
                  ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
     $                        C( IOFFC ) ) / EPS
.NE.                  IF( G( I-IC+1 )RZERO )
     $               ERRI = ERRI / G( I-IC+1 )
                  ERR = MAX( ERR, ERRI )
.GE.                  IF( ERR*SQRT( EPS )RONE )
     $               INFO = 1
                  IIC = IIC + 1
               END IF
*
               IOFFC = IOFFC + 1
*
  110       CONTINUE
*
            ICURROW = MOD( ICURROW+1, NPROW )
*
            DO 130 I = IN+1, IC+N-1, DESCC( MB_ )
               IBB = MIN( IC+N-I, DESCC( MB_ ) )
*
               DO 120 KK = 0, IBB-1
*
.EQ..OR.                  IF( MYROWICURROW  ROWREP ) THEN
                     ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
     $                           C( IOFFC ) )/EPS
.NE.                     IF( G( I+KK-IC+1 )RZERO )
     $                  ERRI = ERRI / G( I+KK-IC+1 )
                     ERR = MAX( ERR, ERRI )
.GE.                     IF( ERR*SQRT( EPS )RONE )
     $                  INFO = 1
                     IIC = IIC + 1
                  END IF
*
                  IOFFC = IOFFC + 1
*
  120          CONTINUE
*
               ICURROW = MOD( ICURROW+1, NPROW )
*
  130       CONTINUE
*
         END IF
*
*        If INFO = 0, all results are at least half accurate.
*
         CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, INFO, 1, -1, MYCOL )
         CALL DGAMX2D( ICTXT, 'all', ' ', 1, 1, ERR, 1, I, J, -1, -1,
     $                 MYCOL )
.NE.         IF( INFO0 )
     $      GO TO 150
*
  140 CONTINUE
*
  150 CONTINUE
*
      RETURN
*
*     End of PZMMCH2
*
      END
      SUBROUTINE PZMMCH3( UPLO, TRANS, M, N, ALPHA, A, IA, JA, DESCA,
     $                    BETA, C, PC, IC, JC, DESCC, ERR, INFO )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1        TRANS, UPLO
      INTEGER            IA, IC, INFO, JA, JC, M, N
      DOUBLE PRECISION   ERR
      COMPLEX*16         ALPHA, BETA
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * ), DESCC( * )
      COMPLEX*16         A( * ), C( * ), PC( * )
*     ..
*
*  Purpose
*  =======
*
*  PZMMCH3 checks the results of the computational tests.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  UPLO    (global input) CHARACTER*1
*          On entry,  UPLO  specifies which part of C should contain the
*          result.
*
*  TRANS   (global input) CHARACTER*1
*          On entry,  TRANS  specifies  whether  the  matrix A has to be
*          transposed  or not  before computing the  matrix-matrix addi-
*          tion.
*
*  M       (global input) INTEGER
*          On entry, M specifies the number of rows of C.
*
*  N       (global input) INTEGER
*          On entry, N specifies the number of columns of C.
*
*  ALPHA   (global input) COMPLEX*16
*          On entry, ALPHA specifies the scalar alpha.
*
*  A       (local input) COMPLEX*16 array
*          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PA.
*
*  IA      (global input) INTEGER
*          On entry, IA  specifies A's global row index, which points to
*          the beginning of the submatrix sub( A ).
*
*  JA      (global input) INTEGER
*          On entry, JA  specifies A's global column index, which points
*          to the beginning of the submatrix sub( A ).
*
*  DESCA   (global and local input) INTEGER array
*          On entry, DESCA  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix A.
*
*  BETA    (global input) COMPLEX*16
*          On entry, BETA specifies the scalar beta.
*
*  C       (local input/local output) COMPLEX*16 array
*          On entry, C is an array of  dimension  (DESCC( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PC.
*
*  PC      (local input) COMPLEX*16 array
*          On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
*          array contains the local pieces of the matrix PC.
*
*  IC      (global input) INTEGER
*          On entry, IC  specifies C's global row index, which points to
*          the beginning of the submatrix sub( C ).
*
*  JC      (global input) INTEGER
*          On entry, JC  specifies C's global column index, which points
*          to the beginning of the submatrix sub( C ).
*
*  DESCC   (global and local input) INTEGER array
*          On entry, DESCC  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix C.
*
*  ERR     (global output) DOUBLE PRECISION
*          On exit, ERR specifies the largest error in absolute value.
*
*  INFO    (global output) INTEGER
*          On exit, if INFO <> 0, the result is less than half accurate.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
     $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
     $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
     $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            COLREP, CTRAN, LOWER, NOTRAN, ROWREP, UPPER
      INTEGER            I, ICCOL, ICROW, ICTXT, IIC, IOFFA, IOFFC, J,
     $                   JJC, LDA, LDC, LDPC, MYCOL, MYROW, NPCOL,
     $                   NPROW
      DOUBLE PRECISION   ERR0, ERRI, PREC
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L,
     $                   PZERRAXPBY
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   PDLAMCH
      EXTERNAL           LSAME, PDLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DCONJG, MAX
*     ..
*     .. Executable Statements ..
*
      ICTXT = DESCC( CTXT_ )
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
      PREC   = PDLAMCH( ICTXT, 'eps' )
*
      UPPER  = LSAME( UPLO,  'u' )
      LOWER  = LSAME( UPLO,  'l' )
      NOTRAN = LSAME( TRANS, 'n' )
      CTRAN  = LSAME( TRANS, 'c' )
*
*     Compute expected result in C using data in A and C. This part of
*     the computation is performed by every process in the grid.
*
      INFO   = 0
      ERR    = ZERO
*
      LDA    = MAX( 1, DESCA( M_   ) )
      LDC    = MAX( 1, DESCC( M_   ) )
      LDPC   = MAX( 1, DESCC( LLD_ ) )
.EQ.      ROWREP = ( DESCC( RSRC_ )-1 )
.EQ.      COLREP = ( DESCC( CSRC_ )-1 )
*
      IF( NOTRAN ) THEN
*
         DO 20 J = JC, JC + N - 1
*
            IOFFC = IC + ( J  - 1          ) * LDC
            IOFFA = IA + ( JA - 1 + J - JC ) * LDA
*
            DO 10 I = IC, IC + M - 1
*
               IF( UPPER ) THEN
.GE.                  IF( ( J - JC )( I - IC ) ) THEN
                     CALL PZERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
     $                                C( IOFFC ), PREC )
                  ELSE
                     ERRI = ZERO
                  END IF
               ELSE IF( LOWER ) THEN
.LE.                  IF( ( J - JC )( I - IC ) ) THEN
                     CALL PZERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
     $                                C( IOFFC ), PREC )
                  ELSE
                     ERRI = ZERO
                  END IF
               ELSE
                  CALL PZERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
     $                             C( IOFFC ), PREC )
               END IF
*
               CALL PB_INFOG2L( I, J, DESCC, NPROW, NPCOL, MYROW, MYCOL,
     $                          IIC, JJC, ICROW, ICCOL )
.EQ..OR..AND.               IF( ( MYROWICROW  ROWREP ) 
.EQ..OR.     $             ( MYCOLICCOL  COLREP ) ) THEN
                  ERR0 = ABS( PC( IIC+(JJC-1)*LDPC )-C( IOFFC ) )
.GT.                  IF( ERR0ERRI )
     $               INFO = 1
                  ERR = MAX( ERR, ERR0 )
               END IF
*
               IOFFA = IOFFA + 1
               IOFFC = IOFFC + 1
*
   10       CONTINUE
*
   20    CONTINUE
*
      ELSE IF( CTRAN ) THEN
*
         DO 40 J = JC, JC + N - 1
*
            IOFFC = IC +              ( J  - 1 ) * LDC
            IOFFA = IA + ( J - JC ) + ( JA - 1 ) * LDA
*
            DO 30 I = IC, IC + M - 1
*
               IF( UPPER ) THEN
.GE.                  IF( ( J - JC )( I - IC ) ) THEN
                     CALL PZERRAXPBY( ERRI, ALPHA, DCONJG( A( IOFFA ) ),
     $                                BETA, C( IOFFC ), PREC )
                  ELSE
                     ERRI = ZERO
                  END IF
               ELSE IF( LOWER ) THEN
.LE.                  IF( ( J - JC )( I - IC ) ) THEN
                     CALL PZERRAXPBY( ERRI, ALPHA, DCONJG( A( IOFFA ) ),
     $                                BETA, C( IOFFC ), PREC )
                  ELSE
                     ERRI = ZERO
                  END IF
               ELSE
                  CALL PZERRAXPBY( ERRI, ALPHA, DCONJG( A( IOFFA ) ),
     $                             BETA, C( IOFFC ), PREC )
               END IF
*
               CALL PB_INFOG2L( I, J, DESCC, NPROW, NPCOL, MYROW, MYCOL,
     $                          IIC, JJC, ICROW, ICCOL )
.EQ..OR..AND.               IF( ( MYROWICROW  ROWREP ) 
.EQ..OR.     $             ( MYCOLICCOL  COLREP ) ) THEN
                  ERR0 = ABS( PC( IIC+(JJC-1)*LDPC )-C( IOFFC ) )
.GT.                  IF( ERR0ERRI )
     $               INFO = 1
                  ERR = MAX( ERR, ERR0 )
               END IF
*
               IOFFC = IOFFC + 1
               IOFFA = IOFFA + LDA
*
   30       CONTINUE
*
   40    CONTINUE
*
      ELSE
*
         DO 60 J = JC, JC + N - 1
*
            IOFFC = IC +              ( J  - 1 ) * LDC
            IOFFA = IA + ( J - JC ) + ( JA - 1 ) * LDA
*
            DO 50 I = IC, IC + M - 1
*
               IF( UPPER ) THEN
.GE.                  IF( ( J - JC )( I - IC ) ) THEN
                     CALL PZERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
     $                                C( IOFFC ), PREC )
                  ELSE
                     ERRI = ZERO
                  END IF
               ELSE IF( LOWER ) THEN
.LE.                  IF( ( J - JC )( I - IC ) ) THEN
                     CALL PZERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
     $                                C( IOFFC ), PREC )
                  ELSE
                     ERRI = ZERO
                  END IF
               ELSE
                  CALL PZERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
     $                             C( IOFFC ), PREC )
               END IF
*
               CALL PB_INFOG2L( I, J, DESCC, NPROW, NPCOL, MYROW, MYCOL,
     $                          IIC, JJC, ICROW, ICCOL )
.EQ..OR..AND.               IF( ( MYROWICROW  ROWREP ) 
.EQ..OR.     $             ( MYCOLICCOL  COLREP ) ) THEN
                  ERR0 = ABS( PC( IIC+(JJC-1)*LDPC )-C( IOFFC ) )
.GT.                  IF( ERR0ERRI )
     $               INFO = 1
                  ERR = MAX( ERR, ERR0 )
               END IF
*
               IOFFC = IOFFC + 1
               IOFFA = IOFFA + LDA
*
   50       CONTINUE
*
   60    CONTINUE
*
      END IF
*
*     If INFO = 0, all results are at least half accurate.
*
      CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, INFO, 1, -1, MYCOL )
      CALL DGAMX2D( ICTXT, 'all', ' ', 1, 1, ERR, 1, I, J, -1, -1,
     $              MYCOL )
*
      RETURN
*
*     End of PZMMCH3
*
      END
      SUBROUTINE PZERRAXPBY( ERRBND, ALPHA, X, BETA, Y, PREC )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   ERRBND, PREC
      COMPLEX*16         ALPHA, BETA, X, Y
*     ..
*
*  Purpose
*  =======
*
*  PZERRAXPBY  serially  computes  y := beta*y + alpha * x and returns a
*  scaled relative acceptable error bound on the result.
*
*  Arguments
*  =========
*
*  ERRBND  (global output) DOUBLE PRECISION
*          On exit, ERRBND  specifies the scaled relative acceptable er-
*          ror bound.
*
*  ALPHA   (global input) COMPLEX*16
*          On entry, ALPHA specifies the scalar alpha.
*
*  X       (global input) COMPLEX*16
*          On entry, X  specifies the scalar x to be scaled.
*
*  BETA    (global input) COMPLEX*16
*          On entry, BETA specifies the scalar beta.
*
*  Y       (global input/global output) COMPLEX*16
*          On entry,  Y  specifies  the scalar y to be added. On exit, Y
*          contains the resulting scalar y.
*
*  PREC    (global input) DOUBLE PRECISION
*          On entry, PREC specifies the machine precision.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, TWO, ZERO
      PARAMETER          ( ONE = 1.0D+0, TWO = 2.0D+0,
     $                   ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   ADDBND, FACT, SUMINEG, SUMIPOS, SUMRNEG,
     $                   SUMRPOS
      COMPLEX*16         TMP
*     ..
*     .. Intrinsic Functions ..
*     ..
*     .. Executable Statements ..
*
      SUMIPOS = ZERO
      SUMINEG = ZERO
      SUMRPOS = ZERO
      SUMRNEG = ZERO
      FACT = ONE + TWO * PREC
      ADDBND = TWO * TWO * TWO * PREC
*
      TMP = ALPHA * X
.GE.      IF( DBLE( TMP )ZERO ) THEN
         SUMRPOS = SUMRPOS + DBLE( TMP ) * FACT
      ELSE
         SUMRNEG = SUMRNEG - DBLE( TMP ) * FACT
      END IF
.GE.      IF( DIMAG( TMP )ZERO ) THEN
         SUMIPOS = SUMIPOS + DIMAG( TMP ) * FACT
      ELSE
         SUMINEG = SUMINEG - DIMAG( TMP ) * FACT
      END IF
*
      TMP = BETA * Y
.GE.      IF( DBLE( TMP )ZERO ) THEN
         SUMRPOS = SUMRPOS + DBLE( TMP ) * FACT
      ELSE
         SUMRNEG = SUMRNEG - DBLE( TMP ) * FACT
      END IF
.GE.      IF( DIMAG( TMP )ZERO ) THEN
         SUMIPOS = SUMIPOS + DIMAG( TMP ) * FACT
      ELSE
         SUMINEG = SUMINEG - DIMAG( TMP ) * FACT
      END IF
*
      Y = ( BETA * Y ) + ( ALPHA * X )
*
      ERRBND = ADDBND * MAX( MAX( SUMRPOS, SUMRNEG ),
     $                       MAX( SUMIPOS, SUMINEG ) )
*
      RETURN
*
*     End of PZERRAXPBY
*
      END
      SUBROUTINE PZIPSET( TOGGLE, N, A, IA, JA, DESCA )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1        TOGGLE
      INTEGER            IA, JA, N
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * )
      COMPLEX*16         A( * )
*     ..
*
*  Purpose
*  =======
*
*  PZIPSET  sets the imaginary part of the diagonal entries of an n by n
*  matrix sub( A )  denoting  A( IA:IA+N-1, JA:JA+N-1 ). This is used to
*  test the  PBLAS routines  for  complex Hermitian  matrices, which are
*  either  not supposed to access or use the imaginary parts of the dia-
*  gonals, or supposed to set  them to zero. The  value  used to set the
*  imaginary part of the diagonals depends on the value of TOGGLE.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  TOGGLE  (global input) CHARACTER*1
*          On entry,  TOGGLE  specifies the set-value to be used as fol-
*          lows:
*             If TOGGLE = 'Z' or 'z', the  imaginary  part of the diago-
*                                     nals are set to zero,
*             If TOGGLE = 'B' or 'b', the  imaginary  part of the diago-
*                                     nals are set to a large value.
*
*  N       (global input) INTEGER
*          On entry,  N  specifies  the  order of sub( A ). N must be at
*          least zero.
*
*  A       (local input/local output) pointer to COMPLEX*16
*          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
*          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
*          the local entries of the matrix  A. On exit, the diagonals of
*          sub( A ) have been updated as specified by TOGGLE.
*
*  IA      (global input) INTEGER
*          On entry, IA  specifies A's global row index, which points to
*          the beginning of the submatrix sub( A ).
*
*  JA      (global input) INTEGER
*          On entry, JA  specifies A's global column index, which points
*          to the beginning of the submatrix sub( A ).
*
*  DESCA   (global and local input) INTEGER array
*          On entry, DESCA  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix A.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
     $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
     $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
     $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            COLREP, GODOWN, GOLEFT, ROWREP
      INTEGER            I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW,
     $                   IMB1, IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP,
     $                   JJA, JOFFA, JOFFD, LCMT, LCMT00, LDA, LDAP1,
     $                   LMBLOC, LNBLOC, LOW, MB, MBLKD, MBLKS, MBLOC,
     $                   MRCOL, MRROW, MYCOL, MYROW, NB, NBLKD, NBLKS,
     $                   NBLOC, NP, NPCOL, NPROW, NQ, PMB, QNB, UPP
      DOUBLE PRECISION   ALPHA, ATMP
*     ..
*     .. Local Arrays ..
      INTEGER            DESCA2( DLEN_ )
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
     $                   PB_DESCTRANS
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   PDLAMCH
      EXTERNAL           LSAME, PDLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DCMPLX, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Convert descriptor
*
      CALL PB_DESCTRANS( DESCA, DESCA2 )
*
*     Get grid parameters
*
      ICTXT = DESCA2( CTXT_ )
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
.LE.      IF( N0 )
     $   RETURN
*
      IF( LSAME( TOGGLE, 'z' ) ) THEN
         ALPHA = ZERO
      ELSE IF( LSAME( TOGGLE, 'b' ) ) THEN
         ALPHA = PDLAMCH( ICTXT, 'epsilon' )
         ALPHA = ALPHA / PDLAMCH( ICTXT, 'safe minimum' )
      END IF
*
      CALL PB_AINFOG2L( N, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
     $                  MYCOL, IMB1, INB1, NP, NQ, IIA, JJA, IAROW,
     $                  IACOL, MRROW, MRCOL )
*
.LE..OR..LE.      IF( NP0  NQ0 )
     $   RETURN
*
*     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
*     ILOW, LOW, IUPP, and UPP.
*
      MB = DESCA2( MB_ )
      NB = DESCA2( NB_ )
      CALL PB_BINFO( 0, NP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL,
     $               LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
     $               LNBLOC, ILOW, LOW, IUPP, UPP )
*
      IOFFA  = IIA - 1
      JOFFA  = JJA - 1
.EQ.      ROWREP = ( DESCA2( RSRC_ )-1 )
.EQ.      COLREP = ( DESCA2( CSRC_ )-1 )
      LDA    = DESCA2( LLD_ )
      LDAP1  = LDA + 1
*
      IF( ROWREP ) THEN
         PMB = MB
      ELSE
         PMB = NPROW * MB
      END IF
      IF( COLREP ) THEN
         QNB = NB
      ELSE
         QNB = NPCOL * NB
      END IF
*
*     Handle the first block of rows or columns separately, and update
*     LCMT00, MBLKS and NBLKS.
*
.GT.      GODOWN = ( LCMT00IUPP )
.LT.      GOLEFT = ( LCMT00ILOW )
*
.NOT..AND..NOT.      IF( GODOWN  GOLEFT ) THEN
*
*        LCMT00 >= ILOW && LCMT00 <= IUPP
*
.GE.         IF( LCMT000 ) THEN
            IJOFFA = IOFFA + LCMT00 + ( JOFFA - 1 ) * LDA
            DO 10 I = 1, MIN( INBLOC, MAX( 0, IMBLOC - LCMT00 ) )
               ATMP = DBLE( A( IJOFFA + I*LDAP1 ) )
               A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA )
   10       CONTINUE
         ELSE
            IJOFFA = IOFFA + ( JOFFA - LCMT00 - 1 ) * LDA
            DO 20 I = 1, MIN( IMBLOC, MAX( 0, INBLOC + LCMT00 ) )
               ATMP = DBLE( A( IJOFFA + I*LDAP1 ) )
               A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA )
   20       CONTINUE
         END IF
.LT.         GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) )ILOW )
.NOT.         GODOWN = GOLEFT
*
      END IF
*
      IF( GODOWN ) THEN
*
         LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
         MBLKS  = MBLKS - 1
         IOFFA  = IOFFA + IMBLOC
*
   30    CONTINUE
.GT..AND..GT.         IF( MBLKS0  LCMT00UPP ) THEN
            LCMT00 = LCMT00 - PMB
            MBLKS  = MBLKS - 1
            IOFFA  = IOFFA + MB
            GO TO 30
         END IF
*
.LE.         IF( MBLKS0 )
     $      RETURN
*
         LCMT  = LCMT00
         MBLKD = MBLKS
         IOFFD = IOFFA
*
         MBLOC = MB
   40    CONTINUE
.GT..AND..GE.         IF( MBLKD0  LCMTILOW ) THEN
.EQ.            IF( MBLKD1 )
     $         MBLOC = LMBLOC
.GE.            IF( LCMT0 ) THEN
               IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
               DO 50 I = 1, MIN( INBLOC, MAX( 0, MBLOC - LCMT ) )
                  ATMP = DBLE( A( IJOFFA + I*LDAP1 ) )
                  A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA )
   50          CONTINUE
            ELSE
               IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
               DO 60 I = 1, MIN( MBLOC, MAX( 0, INBLOC + LCMT ) )
                  ATMP = DBLE( A( IJOFFA + I*LDAP1 ) )
                  A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA )
   60          CONTINUE
            END IF
            LCMT00 = LCMT
            LCMT   = LCMT - PMB
            MBLKS  = MBLKD
            MBLKD  = MBLKD - 1
            IOFFA  = IOFFD
            IOFFD  = IOFFD + MBLOC
            GO TO 40
         END IF
*
         LCMT00 = LCMT00 + LOW - ILOW + QNB
         NBLKS  = NBLKS - 1
         JOFFA  = JOFFA + INBLOC
*
      ELSE IF( GOLEFT ) THEN
*
         LCMT00 = LCMT00 + LOW - ILOW + QNB
         NBLKS  = NBLKS - 1
         JOFFA  = JOFFA + INBLOC
*
   70    CONTINUE
.GT..AND..LT.         IF( NBLKS0  LCMT00LOW ) THEN
            LCMT00 = LCMT00 + QNB
            NBLKS  = NBLKS - 1
            JOFFA  = JOFFA + NB
            GO TO 70
         END IF
*
.LE.         IF( NBLKS0 )
     $      RETURN
*
         LCMT  = LCMT00
         NBLKD = NBLKS
         JOFFD = JOFFA
*
         NBLOC = NB
   80    CONTINUE
.GT..AND..LE.         IF( NBLKD0  LCMTIUPP ) THEN
.EQ.            IF( NBLKD1 )
     $         NBLOC = LNBLOC
.GE.            IF( LCMT0 ) THEN
               IJOFFA = IOFFA + LCMT + ( JOFFD - 1 ) * LDA
               DO 90 I = 1, MIN( NBLOC, MAX( 0, IMBLOC - LCMT ) )
                  ATMP = DBLE( A( IJOFFA + I*LDAP1 ) )
                  A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA )
   90          CONTINUE
            ELSE
               IJOFFA = IOFFA + ( JOFFD - LCMT - 1 ) * LDA
               DO 100 I = 1, MIN( IMBLOC, MAX( 0, NBLOC + LCMT ) )
                  ATMP = DBLE( A( IJOFFA + I*LDAP1 ) )
                  A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA )
  100          CONTINUE
            END IF
            LCMT00 = LCMT
            LCMT   = LCMT + QNB
            NBLKS  = NBLKD
            NBLKD  = NBLKD - 1
            JOFFA  = JOFFD
            JOFFD  = JOFFD + NBLOC
            GO TO 80
         END IF
*
         LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
         MBLKS  = MBLKS - 1
         IOFFA  = IOFFA + IMBLOC
*
      END IF
*
      NBLOC = NB
  110 CONTINUE
.GT.      IF( NBLKS0 ) THEN
.EQ.         IF( NBLKS1 )
     $      NBLOC = LNBLOC
  120    CONTINUE
.GT..AND..GT.         IF( MBLKS0  LCMT00UPP ) THEN
            LCMT00 = LCMT00 - PMB
            MBLKS  = MBLKS - 1
            IOFFA  = IOFFA + MB
            GO TO 120
         END IF
*
.LE.         IF( MBLKS0 )
     $      RETURN
*
         LCMT  = LCMT00
         MBLKD = MBLKS
         IOFFD = IOFFA
*
         MBLOC = MB
  130    CONTINUE
.GT..AND..GE.         IF( MBLKD0  LCMTLOW ) THEN
.EQ.            IF( MBLKD1 )
     $         MBLOC = LMBLOC
.GE.            IF( LCMT0 ) THEN
               IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
               DO 140 I = 1, MIN( NBLOC, MAX( 0, MBLOC - LCMT ) )
                  ATMP = DBLE( A( IJOFFA + I*LDAP1 ) )
                  A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA )
  140          CONTINUE
            ELSE
               IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
               DO 150 I = 1, MIN( MBLOC, MAX( 0, NBLOC + LCMT ) )
                  ATMP = DBLE( A( IJOFFA + I*LDAP1 ) )
                  A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA )
  150          CONTINUE
            END IF
            LCMT00 = LCMT
            LCMT   = LCMT - PMB
            MBLKS  = MBLKD
            MBLKD  = MBLKD - 1
            IOFFA  = IOFFD
            IOFFD  = IOFFD + MBLOC
            GO TO 130
         END IF
*
         LCMT00 = LCMT00 + QNB
         NBLKS  = NBLKS - 1
         JOFFA  = JOFFA + NBLOC
         GO TO 110
*
      END IF
*
      RETURN
*
*     End of PZIPSET
*
      END
      DOUBLE PRECISION   FUNCTION PDLAMCH( ICTXT, CMACH )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1        CMACH
      INTEGER            ICTXT
*     ..
*
*  Purpose
*  =======
*
*
*     .. Local Scalars ..
      CHARACTER*1        TOP
      INTEGER            IDUMM
      DOUBLE PRECISION   TEMP
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGAMN2D, DGAMX2D, PB_TOPGET
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, LSAME
*     ..
*     .. Executable Statements ..
*
      TEMP = DLAMCH( CMACH )
*
      IF( LSAME( CMACH, 'e.OR.' )LSAME( CMACH, 's.OR.' )
     $    LSAME( CMACH, 'm.OR.' )LSAME( CMACH, 'u' ) ) THEN
         CALL PB_TOPGET( ICTXT, 'combine', 'all', TOP )
         IDUMM = 0
         CALL DGAMX2D( ICTXT, 'all', TOP, 1, 1, TEMP, 1, IDUMM,
     $                 IDUMM, -1, -1, IDUMM )
      ELSE IF( LSAME( CMACH, 'l.OR.' )LSAME( CMACH, 'o' ) ) THEN
         CALL PB_TOPGET( ICTXT, 'combine', 'all', TOP )
         IDUMM = 0
         CALL DGAMN2D( ICTXT, 'all', TOP, 1, 1, TEMP, 1, IDUMM,
     $                 IDUMM, -1, -1, IDUMM )
      END IF
*
      PDLAMCH = TEMP
*
      RETURN
*
*     End of PDLAMCH
*
      END
      SUBROUTINE PZLASET( UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1        UPLO
      INTEGER            IA, JA, M, N
      COMPLEX*16         ALPHA, BETA
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * )
      COMPLEX*16         A( * )
*     ..
*
*  Purpose
*  =======
*
*  PZLASET  initializes an m by n submatrix A(IA:IA+M-1,JA:JA+N-1) deno-
*  ted  by  sub( A )  to beta on the diagonal and alpha on the offdiago-
*  nals.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  UPLO    (global input) CHARACTER*1
*          On entry, UPLO specifies the part  of  the submatrix sub( A )
*          to be set:
*             = 'L' or 'l':   Lower triangular part is set; the strictly
*                      upper triangular part of sub( A ) is not changed;
*             = 'U' or 'u':   Upper triangular part is set; the strictly
*                      lower triangular part of sub( A ) is not changed;
*             Otherwise:  All of the matrix sub( A ) is set.
*
*  M       (global input) INTEGER
*          On entry,  M  specifies the number of rows of  the  submatrix
*          sub( A ). M  must be at least zero.
*
*  N       (global input) INTEGER
*          On entry, N  specifies the number of columns of the submatrix
*          sub( A ). N must be at least zero.
*
*  ALPHA   (global input) COMPLEX*16
*          On entry,  ALPHA  specifies the scalar alpha, i.e., the cons-
*          tant to which the offdiagonal elements are to be set.
*
*  BETA    (global input) COMPLEX*16
*          On entry, BETA  specifies the scalar beta, i.e., the constant
*          to which the diagonal elements are to be set.
*
*  A       (local input/local output) COMPLEX*16 array
*          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
*          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
*          the local entries of the matrix  A  to be  set.  On exit, the
*          leading m by n submatrix sub( A ) is set as follows:
*
*          if UPLO = 'U',  A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=j-1, 1<=j<=N,
*          if UPLO = 'L',  A(IA+i-1,JA+j-1) = ALPHA, j+1<=i<=M, 1<=j<=N,
*          otherwise,      A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=M,   1<=j<=N,
*                                                      and IA+i.NE.JA+j,
*          and, for all UPLO,  A(IA+i-1,JA+i-1) = BETA,  1<=i<=min(M,N).
*
*  IA      (global input) INTEGER
*          On entry, IA  specifies A's global row index, which points to
*          the beginning of the submatrix sub( A ).
*
*  JA      (global input) INTEGER
*          On entry, JA  specifies A's global column index, which points
*          to the beginning of the submatrix sub( A ).
*
*  DESCA   (global and local input) INTEGER array
*          On entry, DESCA  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix A.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
     $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
     $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
     $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
*     ..
*     .. Local Scalars ..
      LOGICAL            GODOWN, GOLEFT, ISCOLREP, ISROWREP, LOWER,
     $                   UPPER
      INTEGER            IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1,
     $                   IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP, JJA,
     $                   JJMAX, JOFFA, JOFFD, LCMT, LCMT00, LDA, LMBLOC,
     $                   LNBLOC, LOW, M1, MB, MBLKD, MBLKS, MBLOC, MP,
     $                   MRCOL, MRROW, MYCOL, MYROW, N1, NB, NBLKD,
     $                   NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB, QNB, TMP1,
     $                   UPP
*     ..
*     .. Local Arrays ..
      INTEGER            DESCA2( DLEN_ )
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
     $                   PB_DESCTRANS, PB_ZLASET
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MIN
*     ..
*     .. Executable Statements ..
*
.EQ..OR..EQ.      IF( M0  N0 )
     $   RETURN
*
*     Convert descriptor
*
      CALL PB_DESCTRANS( DESCA, DESCA2 )
*
*     Get grid parameters
*
      ICTXT = DESCA2( CTXT_ )
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
      CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
     $                  MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
     $                  IACOL, MRROW, MRCOL )
*
.LE..OR..LE.      IF( MP0  NQ0 )
     $   RETURN
*
.LT.      ISROWREP = ( DESCA2( RSRC_ )0 )
.LT.      ISCOLREP = ( DESCA2( CSRC_ )0 )
      LDA      = DESCA2( LLD_ )
*
.NOT.      UPPER = ( LSAME( UPLO, 'l' ) )
.NOT.      LOWER = ( LSAME( UPLO, 'u' ) )
*
.AND..AND..EQ..OR.      IF( ( ( LOWERUPPER )( ALPHABETA ) )
.AND.     $    (   ISROWREP          ISCOLREP        ) ) THEN
.GT..AND..GT.         IF( ( MP0 )( NQ0 ) )
     $      CALL PB_ZLASET( UPLO, MP, NQ, 0, ALPHA, BETA,
     $                      A( IIA + ( JJA - 1 ) * LDA ), LDA )
         RETURN
      END IF
*
*     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
*     ILOW, LOW, IUPP, and UPP.
*
      MB = DESCA2( MB_ )
      NB = DESCA2( NB_ )
      CALL PB_BINFO( 0, MP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL,
     $               LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
     $               LNBLOC, ILOW, LOW, IUPP, UPP )
*
      IOFFA = IIA - 1
      JOFFA = JJA - 1
      IIMAX = IOFFA + MP
      JJMAX = JOFFA + NQ
*
      IF( ISROWREP ) THEN
         PMB = MB
      ELSE
         PMB = NPROW * MB
      END IF
      IF( ISCOLREP ) THEN
         QNB = NB
      ELSE
         QNB = NPCOL * NB
      END IF
*
      M1 = MP
      N1 = NQ
*
*     Handle the first block of rows or columns separately, and update
*     LCMT00, MBLKS and NBLKS.
*
.GT.      GODOWN = ( LCMT00IUPP )
.LT.      GOLEFT = ( LCMT00ILOW )
*
.NOT..AND..NOT.      IF( GODOWN  GOLEFT ) THEN
*
*        LCMT00 >= ILOW && LCMT00 <= IUPP
*
.LT.         GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) )ILOW )
.NOT.         GODOWN = GOLEFT
*
         CALL PB_ZLASET( UPLO, IMBLOC, INBLOC, LCMT00, ALPHA, BETA,
     $                   A( IIA+JOFFA*LDA ), LDA )
         IF( GODOWN ) THEN
.AND..GT.            IF( UPPER  NQINBLOC )
     $         CALL PB_ZLASET( 'all', IMBLOC, NQ-INBLOC, 0, ALPHA,
     $                         ALPHA, A( IIA+(JOFFA+INBLOC)*LDA ), LDA )
            IIA = IIA + IMBLOC
            M1  = M1 - IMBLOC
         ELSE
.AND..GT.            IF( LOWER  MPIMBLOC )
     $         CALL PB_ZLASET( 'all', MP-IMBLOC, INBLOC, 0, ALPHA,
     $                         ALPHA, A( IIA+IMBLOC+JOFFA*LDA ), LDA )
            JJA = JJA + INBLOC
            N1  = N1 - INBLOC
         END IF
*
      END IF
*
      IF( GODOWN ) THEN
*
         LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
         MBLKS  = MBLKS - 1
         IOFFA  = IOFFA + IMBLOC
*
   10    CONTINUE
.GT..AND..GT.         IF( MBLKS0  LCMT00UPP ) THEN
            LCMT00 = LCMT00 - PMB
            MBLKS  = MBLKS - 1
            IOFFA  = IOFFA + MB
            GO TO 10
         END IF
*
         TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
.AND..GT.         IF( UPPER  TMP10 ) THEN
            CALL PB_ZLASET( 'all', TMP1, N1, 0, ALPHA, ALPHA,
     $                      A( IIA+JOFFA*LDA ), LDA )
            IIA = IIA + TMP1
            M1  = M1 - TMP1
         END IF
*
.LE.         IF( MBLKS0 )
     $      RETURN
*
         LCMT  = LCMT00
         MBLKD = MBLKS
         IOFFD = IOFFA
*
         MBLOC = MB
   20    CONTINUE
.GT..AND..GE.         IF( MBLKD0  LCMTILOW ) THEN
.EQ.            IF( MBLKD1 )
     $         MBLOC = LMBLOC
            CALL PB_ZLASET( UPLO, MBLOC, INBLOC, LCMT, ALPHA, BETA,
     $                      A( IOFFD+1+JOFFA*LDA ), LDA )
            LCMT00 = LCMT
            LCMT   = LCMT - PMB
            MBLKS  = MBLKD
            MBLKD  = MBLKD - 1
            IOFFA  = IOFFD
            IOFFD  = IOFFD + MBLOC
            GO TO 20
         END IF
*
         TMP1 = M1 - IOFFD + IIA - 1
.AND..GT.         IF( LOWER  TMP10 )
     $      CALL PB_ZLASET( 'all', TMP1, INBLOC, 0, ALPHA, ALPHA,
     $                      A( IOFFD+1+JOFFA*LDA ), LDA )
*
         TMP1   = IOFFA - IIA + 1
         M1     = M1 - TMP1
         N1     = N1 - INBLOC
         LCMT00 = LCMT00 + LOW - ILOW + QNB
         NBLKS  = NBLKS - 1
         JOFFA  = JOFFA + INBLOC
*
.AND..GT..AND..GT.         IF( UPPER  TMP10  N10 )
     $      CALL PB_ZLASET( 'all', TMP1, N1, 0, ALPHA, ALPHA,
     $                      A( IIA+JOFFA*LDA ), LDA )
*
         IIA = IOFFA + 1
         JJA = JOFFA + 1
*
      ELSE IF( GOLEFT ) THEN
*
         LCMT00 = LCMT00 + LOW - ILOW + QNB
         NBLKS  = NBLKS - 1
         JOFFA  = JOFFA + INBLOC
*
   30    CONTINUE
.GT..AND..LT.         IF( NBLKS0  LCMT00LOW ) THEN
            LCMT00 = LCMT00 + QNB
            NBLKS  = NBLKS - 1
            JOFFA  = JOFFA + NB
            GO TO 30
         END IF
*
         TMP1 = MIN( JOFFA, JJMAX ) - JJA + 1
.AND..GT.         IF( LOWER  TMP10 ) THEN
            CALL PB_ZLASET( 'all', M1, TMP1, 0, ALPHA, ALPHA,
     $                      A( IIA+(JJA-1)*LDA ), LDA )
            JJA = JJA + TMP1
            N1  = N1 - TMP1
         END IF
*
.LE.         IF( NBLKS0 )
     $      RETURN
*
         LCMT  = LCMT00
         NBLKD = NBLKS
         JOFFD = JOFFA
*
         NBLOC = NB
   40    CONTINUE
.GT..AND..LE.         IF( NBLKD0  LCMTIUPP ) THEN
.EQ.            IF( NBLKD1 )
     $         NBLOC = LNBLOC
            CALL PB_ZLASET( UPLO, IMBLOC, NBLOC, LCMT, ALPHA, BETA,
     $                      A( IIA+JOFFD*LDA ), LDA )
            LCMT00 = LCMT
            LCMT   = LCMT + QNB
            NBLKS  = NBLKD
            NBLKD  = NBLKD - 1
            JOFFA  = JOFFD
            JOFFD  = JOFFD + NBLOC
            GO TO 40
         END IF
*
         TMP1 = N1 - JOFFD + JJA - 1
.AND..GT.         IF( UPPER  TMP10 )
     $      CALL PB_ZLASET( 'all', IMBLOC, TMP1, 0, ALPHA, ALPHA,
     $                      A( IIA+JOFFD*LDA ), LDA )
*
         TMP1   = JOFFA - JJA + 1
         M1     = M1 - IMBLOC
         N1     = N1 - TMP1
         LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
         MBLKS  = MBLKS - 1
         IOFFA  = IOFFA + IMBLOC
*
.AND..GT..AND..GT.         IF( LOWER  M10  TMP10 )
     $      CALL PB_ZLASET( 'all', M1, TMP1, 0, ALPHA, ALPHA,
     $                      A( IOFFA+1+(JJA-1)*LDA ), LDA )
*
         IIA = IOFFA + 1
         JJA = JOFFA + 1
*
      END IF
*
      NBLOC = NB
   50 CONTINUE
.GT.      IF( NBLKS0 ) THEN
.EQ.         IF( NBLKS1 )
     $      NBLOC = LNBLOC
   60    CONTINUE
.GT..AND..GT.         IF( MBLKS0  LCMT00UPP ) THEN
            LCMT00 = LCMT00 - PMB
            MBLKS  = MBLKS - 1
            IOFFA  = IOFFA + MB
            GO TO 60
         END IF
*
         TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
.AND..GT.         IF( UPPER  TMP10 ) THEN
            CALL PB_ZLASET( 'all', TMP1, N1, 0, ALPHA, ALPHA,
     $                      A( IIA+JOFFA*LDA ), LDA )
            IIA = IIA + TMP1
            M1  = M1 - TMP1
         END IF
*
.LE.         IF( MBLKS0 )
     $      RETURN
*
         LCMT  = LCMT00
         MBLKD = MBLKS
         IOFFD = IOFFA
*
         MBLOC = MB
   70    CONTINUE
.GT..AND..GE.         IF( MBLKD0  LCMTLOW ) THEN
.EQ.            IF( MBLKD1 )
     $         MBLOC = LMBLOC
            CALL PB_ZLASET( UPLO, MBLOC, NBLOC, LCMT, ALPHA, BETA,
     $                      A( IOFFD+1+JOFFA*LDA ), LDA )
            LCMT00 = LCMT
            LCMT   = LCMT - PMB
            MBLKS  = MBLKD
            MBLKD  = MBLKD - 1
            IOFFA  = IOFFD
            IOFFD  = IOFFD + MBLOC
            GO TO 70
         END IF
*
         TMP1 = M1 - IOFFD + IIA - 1
.AND..GT.         IF( LOWER  TMP10 )
     $      CALL PB_ZLASET( 'all', TMP1, NBLOC, 0, ALPHA, ALPHA,
     $                      A( IOFFD+1+JOFFA*LDA ), LDA )
*
         TMP1   = MIN( IOFFA, IIMAX )  - IIA + 1
         M1     = M1 - TMP1
         N1     = N1 - NBLOC
         LCMT00 = LCMT00 + QNB
         NBLKS  = NBLKS - 1
         JOFFA  = JOFFA + NBLOC
*
.AND..GT..AND..GT.         IF( UPPER  TMP10  N10 )
     $      CALL PB_ZLASET( 'all', TMP1, N1, 0, ALPHA, ALPHA,
     $                      A( IIA+JOFFA*LDA ), LDA )
*
         IIA = IOFFA + 1
         JJA = JOFFA + 1
*
         GO TO 50
*
      END IF
*
      RETURN
*
*     End of PZLASET
*
      END
      SUBROUTINE PZLASCAL( TYPE, M, N, ALPHA, A, IA, JA, DESCA )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1        TYPE
      INTEGER            IA, JA, M, N
      COMPLEX*16         ALPHA
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * )
      COMPLEX*16         A( * )
*     ..
*
*  Purpose
*  =======
*
*  PZLASCAL  scales the  m by n submatrix A(IA:IA+M-1,JA:JA+N-1) denoted
*  by sub( A ) by the scalar alpha. TYPE  specifies if sub( A ) is full,
*  upper triangular, lower triangular or upper Hessenberg.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  TYPE    (global input) CHARACTER*1
*          On entry,  TYPE  specifies the type of the input submatrix as
*          follows:
*             = 'L' or 'l':  sub( A ) is a lower triangular matrix,
*             = 'U' or 'u':  sub( A ) is an upper triangular matrix,
*             = 'H' or 'h':  sub( A ) is an upper Hessenberg matrix,
*             otherwise sub( A ) is a  full matrix.
*
*  M       (global input) INTEGER
*          On entry,  M  specifies the number of rows of  the  submatrix
*          sub( A ). M  must be at least zero.
*
*  N       (global input) INTEGER
*          On entry, N  specifies the number of columns of the submatrix
*          sub( A ). N  must be at least zero.
*
*  ALPHA   (global input) COMPLEX*16
*          On entry, ALPHA specifies the scalar alpha.
*
*  A       (local input/local output) COMPLEX*16 array
*          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
*          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
*          the local entries of the matrix  A.
*          On exit, the local entries of this array corresponding to the
*          to  the entries of the submatrix sub( A ) are  overwritten by
*          the local entries of the m by n scaled submatrix.
*
*  IA      (global input) INTEGER
*          On entry, IA  specifies A's global row index, which points to
*          the beginning of the submatrix sub( A ).
*
*  JA      (global input) INTEGER
*          On entry, JA  specifies A's global column index, which points
*          to the beginning of the submatrix sub( A ).
*
*  DESCA   (global and local input) INTEGER array
*          On entry, DESCA  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix A.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
     $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
     $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
     $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
*     ..
*     .. Local Scalars ..
      CHARACTER*1        UPLO
      LOGICAL            GODOWN, GOLEFT, LOWER, UPPER
      INTEGER            IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1,
     $                   IMBLOC, INB1, INBLOC, IOFFA, IOFFD, ITYPE,
     $                   IUPP, JJA, JJMAX, JOFFA, JOFFD, LCMT, LCMT00,
     $                   LDA, LMBLOC, LNBLOC, LOW, M1, MB, MBLKD, MBLKS,
     $                   MBLOC, MP, MRCOL, MRROW, MYCOL, MYROW, N1, NB,
     $                   NBLKD, NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB,
     $                   QNB, TMP1, UPP
*     ..
*     .. Local Arrays ..
      INTEGER            DESCA2( DLEN_ )
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
     $                   PB_DESCTRANS, PB_INFOG2L, PB_ZLASCAL
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            PB_NUMROC
      EXTERNAL           LSAME, PB_NUMROC
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MIN
*     ..
*     .. Executable Statements ..
*
*     Convert descriptor
*
      CALL PB_DESCTRANS( DESCA, DESCA2 )
*
*     Get grid parameters
*
      ICTXT = DESCA2( CTXT_ )
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
*     Quick return if possible
*
.EQ..OR..EQ.      IF( M0  N0 )
     $   RETURN
*
      IF( LSAME( TYPE, 'l' ) ) THEN
         ITYPE = 1
         UPLO  = TYPE
         UPPER = .FALSE.
         LOWER = .TRUE.
         IOFFD = 0
      ELSE IF( LSAME( TYPE, 'u' ) ) THEN
         ITYPE = 2
         UPLO  = TYPE
         UPPER = .TRUE.
         LOWER = .FALSE.
         IOFFD = 0
      ELSE IF( LSAME( TYPE, 'h' ) ) THEN
         ITYPE = 3
         UPLO  = 'u'
         UPPER = .TRUE.
         LOWER = .FALSE.
         IOFFD = 1
      ELSE
         ITYPE = 0
         UPLO  = 'a'
         UPPER = .TRUE.
         LOWER = .TRUE.
         IOFFD = 0
      END IF
*
*     Compute local indexes
*
.EQ.      IF( ITYPE0 ) THEN
*
*        Full matrix
*
         CALL PB_INFOG2L( IA, JA, DESCA2, NPROW, NPCOL, MYROW, MYCOL,
     $                    IIA, JJA, IAROW, IACOL )
         MP = PB_NUMROC( M, IA, DESCA2( IMB_ ), DESCA2( MB_ ), MYROW,
     $                   DESCA2( RSRC_ ), NPROW )
         NQ = PB_NUMROC( N, JA, DESCA2( INB_ ), DESCA2( NB_ ), MYCOL,
     $                   DESCA2( CSRC_ ), NPCOL )
*
.LE..OR..LE.         IF( MP0  NQ0 )
     $      RETURN
*
         LDA   = DESCA2( LLD_ )
         IOFFA = IIA + ( JJA - 1 ) * LDA
*
         CALL PB_ZLASCAL( 'all', MP, NQ, 0, ALPHA, A( IOFFA ), LDA )
*
      ELSE
*
*        Trapezoidal matrix
*
         CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
     $                     MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
     $                     IACOL, MRROW, MRCOL )
*
.LE..OR..LE.         IF( MP0  NQ0 )
     $      RETURN
*
*        Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
*        LNBLOC, ILOW, LOW, IUPP, and UPP.
*
         MB  = DESCA2( MB_ )
         NB  = DESCA2( NB_ )
         LDA = DESCA2( LLD_ )
*
         CALL PB_BINFO( IOFFD, MP, NQ, IMB1, INB1, MB, NB, MRROW,
     $                  MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC,
     $                  LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP )
*
         M1    = MP
         N1    = NQ
         IOFFA = IIA - 1
         JOFFA = JJA - 1
         IIMAX = IOFFA + MP
         JJMAX = JOFFA + NQ
*
.LT.         IF( DESCA2( RSRC_ )0 ) THEN
            PMB = MB
         ELSE
            PMB = NPROW * MB
         END IF
.LT.         IF( DESCA2( CSRC_ )0 ) THEN
            QNB = NB
         ELSE
            QNB = NPCOL * NB
         END IF
*
*        Handle the first block of rows or columns separately, and
*        update LCMT00, MBLKS and NBLKS.
*
.GT.         GODOWN = ( LCMT00IUPP )
.LT.         GOLEFT = ( LCMT00ILOW )
*
.NOT..AND..NOT.         IF( GODOWN  GOLEFT ) THEN
*
*           LCMT00 >= ILOW && LCMT00 <= IUPP
*
.LT.            GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) )ILOW )
.NOT.            GODOWN = GOLEFT
*
            CALL PB_ZLASCAL( UPLO, IMBLOC, INBLOC, LCMT00, ALPHA,
     $                       A( IIA+JOFFA*LDA ), LDA )
            IF( GODOWN ) THEN
.AND..GT.               IF( UPPER  NQINBLOC )
     $            CALL PB_ZLASCAL( 'all', IMBLOC, NQ-INBLOC, 0, ALPHA,
     $                             A( IIA+(JOFFA+INBLOC)*LDA ), LDA )
               IIA = IIA + IMBLOC
               M1  = M1 - IMBLOC
            ELSE
.AND..GT.               IF( LOWER  MPIMBLOC )
     $            CALL PB_ZLASCAL( 'all', MP-IMBLOC, INBLOC, 0, ALPHA,
     $                             A( IIA+IMBLOC+JOFFA*LDA ), LDA )
               JJA = JJA + INBLOC
               N1  = N1 - INBLOC
            END IF
*
         END IF
*
         IF( GODOWN ) THEN
*
            LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
            MBLKS  = MBLKS - 1
            IOFFA  = IOFFA + IMBLOC
*
   10       CONTINUE
.GT..AND..GT.            IF( MBLKS0  LCMT00UPP ) THEN
               LCMT00 = LCMT00 - PMB
               MBLKS  = MBLKS - 1
               IOFFA  = IOFFA + MB
               GO TO 10
            END IF
*
            TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
.AND..GT.            IF( UPPER  TMP10 ) THEN
               CALL PB_ZLASCAL( 'all', TMP1, N1, 0, ALPHA,
     $                          A( IIA+JOFFA*LDA ), LDA )
               IIA = IIA + TMP1
               M1  = M1 - TMP1
            END IF
*
.LE.            IF( MBLKS0 )
     $         RETURN
*
            LCMT  = LCMT00
            MBLKD = MBLKS
            IOFFD = IOFFA
*
            MBLOC = MB
   20       CONTINUE
.GT..AND..GE.            IF( MBLKD0  LCMTILOW ) THEN
.EQ.               IF( MBLKD1 )
     $            MBLOC = LMBLOC
               CALL PB_ZLASCAL( UPLO, MBLOC, INBLOC, LCMT, ALPHA,
     $                          A( IOFFD+1+JOFFA*LDA ), LDA )
               LCMT00 = LCMT
               LCMT   = LCMT - PMB
               MBLKS  = MBLKD
               MBLKD  = MBLKD - 1
               IOFFA  = IOFFD
               IOFFD  = IOFFD + MBLOC
               GO TO 20
            END IF
*
            TMP1 = M1 - IOFFD + IIA - 1
.AND..GT.            IF( LOWER  TMP10 )
     $         CALL PB_ZLASCAL( 'all', TMP1, INBLOC, 0, ALPHA,
     $                          A( IOFFD+1+JOFFA*LDA ), LDA )
*
            TMP1   = IOFFA - IIA + 1
            M1     = M1 - TMP1
            N1     = N1 - INBLOC
            LCMT00 = LCMT00 + LOW - ILOW + QNB
            NBLKS  = NBLKS - 1
            JOFFA  = JOFFA + INBLOC
*
.AND..GT..AND..GT.            IF( UPPER  TMP10  N10 )
     $         CALL PB_ZLASCAL( 'all', TMP1, N1, 0, ALPHA,
     $                          A( IIA+JOFFA*LDA ), LDA )
*
            IIA = IOFFA + 1
            JJA = JOFFA + 1
*
         ELSE IF( GOLEFT ) THEN
*
            LCMT00 = LCMT00 + LOW - ILOW + QNB
            NBLKS  = NBLKS - 1
            JOFFA  = JOFFA + INBLOC
*
   30       CONTINUE
.GT..AND..LT.            IF( NBLKS0  LCMT00LOW ) THEN
               LCMT00 = LCMT00 + QNB
               NBLKS  = NBLKS - 1
               JOFFA  = JOFFA + NB
               GO TO 30
            END IF
*
            TMP1 = MIN( JOFFA, JJMAX ) - JJA + 1
.AND..GT.            IF( LOWER  TMP10 ) THEN
               CALL PB_ZLASCAL( 'all', M1, TMP1, 0, ALPHA,
     $                          A( IIA+(JJA-1)*LDA ), LDA )
               JJA = JJA + TMP1
               N1  = N1 - TMP1
            END IF
*
.LE.            IF( NBLKS0 )
     $         RETURN
*
            LCMT  = LCMT00
            NBLKD = NBLKS
            JOFFD = JOFFA
*
            NBLOC = NB
   40       CONTINUE
.GT..AND..LE.            IF( NBLKD0  LCMTIUPP ) THEN
.EQ.               IF( NBLKD1 )
     $            NBLOC = LNBLOC
               CALL PB_ZLASCAL( UPLO, IMBLOC, NBLOC, LCMT, ALPHA,
     $                          A( IIA+JOFFD*LDA ), LDA )
               LCMT00 = LCMT
               LCMT   = LCMT + QNB
               NBLKS  = NBLKD
               NBLKD  = NBLKD - 1
               JOFFA  = JOFFD
               JOFFD  = JOFFD + NBLOC
               GO TO 40
            END IF
*
            TMP1 = N1 - JOFFD + JJA - 1
.AND..GT.            IF( UPPER  TMP10 )
     $         CALL PB_ZLASCAL( 'all', IMBLOC, TMP1, 0, ALPHA,
     $                          A( IIA+JOFFD*LDA ), LDA )
*
            TMP1   = JOFFA - JJA + 1
            M1     = M1 - IMBLOC
            N1     = N1 - TMP1
            LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
            MBLKS  = MBLKS - 1
            IOFFA  = IOFFA + IMBLOC
*
.AND..GT..AND..GT.            IF( LOWER  M10  TMP10 )
     $         CALL PB_ZLASCAL( 'all', M1, TMP1, 0, ALPHA,
     $                          A( IOFFA+1+(JJA-1)*LDA ), LDA )
*
            IIA = IOFFA + 1
            JJA = JOFFA + 1
*
         END IF
*
         NBLOC = NB
   50    CONTINUE
.GT.         IF( NBLKS0 ) THEN
.EQ.            IF( NBLKS1 )
     $         NBLOC = LNBLOC
   60       CONTINUE
.GT..AND..GT.            IF( MBLKS0  LCMT00UPP ) THEN
               LCMT00 = LCMT00 - PMB
               MBLKS  = MBLKS - 1
               IOFFA  = IOFFA + MB
               GO TO 60
            END IF
*
            TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
.AND..GT.            IF( UPPER  TMP10 ) THEN
               CALL PB_ZLASCAL( 'all', TMP1, N1, 0, ALPHA,
     $                          A( IIA+JOFFA*LDA ), LDA )
               IIA = IIA + TMP1
               M1  = M1 - TMP1
            END IF
*
.LE.            IF( MBLKS0 )
     $         RETURN
*
            LCMT  = LCMT00
            MBLKD = MBLKS
            IOFFD = IOFFA
*
            MBLOC = MB
   70       CONTINUE
.GT..AND..GE.            IF( MBLKD0  LCMTLOW ) THEN
.EQ.               IF( MBLKD1 )
     $            MBLOC = LMBLOC
               CALL PB_ZLASCAL( UPLO, MBLOC, NBLOC, LCMT, ALPHA,
     $                          A( IOFFD+1+JOFFA*LDA ), LDA )
               LCMT00 = LCMT
               LCMT   = LCMT - PMB
               MBLKS  = MBLKD
               MBLKD  = MBLKD - 1
               IOFFA  = IOFFD
               IOFFD  = IOFFD + MBLOC
               GO TO 70
            END IF
*
            TMP1 = M1 - IOFFD + IIA - 1
.AND..GT.            IF( LOWER  TMP10 )
     $         CALL PB_ZLASCAL( 'all', TMP1, NBLOC, 0, ALPHA,
     $                          A( IOFFD+1+JOFFA*LDA ), LDA )
*
            TMP1   = MIN( IOFFA, IIMAX )  - IIA + 1
            M1     = M1 - TMP1
            N1     = N1 - NBLOC
            LCMT00 = LCMT00 + QNB
            NBLKS  = NBLKS - 1
            JOFFA  = JOFFA + NBLOC
*
.AND..GT..AND..GT.            IF( UPPER  TMP10  N10 )
     $         CALL PB_ZLASCAL( 'all', TMP1, N1, 0, ALPHA,
     $                          A( IIA+JOFFA*LDA ), LDA )
*
            IIA = IOFFA + 1
            JJA = JOFFA + 1
*
            GO TO 50
*
         END IF
*
      END IF
*
      RETURN
*
*     End of PZLASCAL
*
      END
      SUBROUTINE PZLAGEN( INPLACE, AFORM, DIAG, OFFA, M, N, IA, JA,
     $                    DESCA, IASEED, A, LDA )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      LOGICAL            INPLACE
      CHARACTER*1        AFORM, DIAG
      INTEGER            IA, IASEED, JA, LDA, M, N, OFFA
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * )
      COMPLEX*16         A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  PZLAGEN  generates  (or regenerates)  a  submatrix  sub( A ) denoting
*  A(IA:IA+M-1,JA:JA+N-1).
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  INPLACE (global input) LOGICAL
*          On entry, INPLACE specifies if the matrix should be generated
*          in place or not. If INPLACE is .TRUE., the local random array
*          to be generated  will start in memory at the local memory lo-
*          cation A( 1, 1 ),  otherwise it will start at the local posi-
*          tion induced by IA and JA.
*
*  AFORM   (global input) CHARACTER*1
*          On entry, AFORM specifies the type of submatrix to be genera-
*          ted as follows:
*             AFORM = 'S', sub( A ) is a symmetric matrix,
*             AFORM = 'H', sub( A ) is a Hermitian matrix,
*             AFORM = 'T', sub( A ) is overrwritten  with  the transpose
*                          of what would normally be generated,
*             AFORM = 'C', sub( A ) is overwritten  with  the  conjugate
*                          transpose  of  what would normally be genera-
*                          ted.
*             AFORM = 'N', a random submatrix is generated.
*
*  DIAG    (global input) CHARACTER*1
*          On entry, DIAG specifies if the generated submatrix is diago-
*          nally dominant or not as follows:
*             DIAG = 'D' : sub( A ) is diagonally dominant,
*             DIAG = 'N' : sub( A ) is not diagonally dominant.
*
*  OFFA    (global input) INTEGER
*          On entry, OFFA  specifies  the  offdiagonal of the underlying
*          matrix A(1:DESCA(M_),1:DESCA(N_)) of interest when the subma-
*          trix is symmetric, Hermitian or diagonally dominant. OFFA = 0
*          specifies the main diagonal,  OFFA > 0  specifies a subdiago-
*          nal,  and OFFA < 0 specifies a superdiagonal (see further de-
*          tails).
*
*  M       (global input) INTEGER
*          On entry, M specifies the global number of matrix rows of the
*          submatrix sub( A ) to be generated. M must be at least zero.
*
*  N       (global input) INTEGER
*          On entry,  N specifies the global number of matrix columns of
*          the  submatrix  sub( A )  to be generated. N must be at least
*          zero.
*
*  IA      (global input) INTEGER
*          On entry, IA  specifies A's global row index, which points to
*          the beginning of the submatrix sub( A ).
*
*  JA      (global input) INTEGER
*          On entry, JA  specifies A's global column index, which points
*          to the beginning of the submatrix sub( A ).
*
*  DESCA   (global and local input) INTEGER array
*          On entry, DESCA  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix A.
*
*  IASEED  (global input) INTEGER
*          On entry, IASEED  specifies  the  seed number to generate the
*          matrix A. IASEED must be at least zero.
*
*  A       (local output) COMPLEX*16 array
*          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
*          at least Lc( 1, JA+N-1 ).  On  exit, this array  contains the
*          local entries of the randomly generated submatrix sub( A ).
*
*  LDA     (local input) INTEGER
*          On entry,  LDA  specifies  the local leading dimension of the
*          array A. When INPLACE is .FALSE., LDA is usually DESCA(LLD_).
*          This restriction is however not enforced, and this subroutine
*          requires only that LDA >= MAX( 1, Mp ) where
*
*          Mp = PB_NUMROC( M, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ).
*
*          PB_NUMROC  is  a ScaLAPACK tool function; MYROW, MYCOL, NPROW
*          and NPCOL  can  be determined by calling the BLACS subroutine
*          BLACS_GRIDINFO.
*
*  Further Details
*  ===============
*
*  OFFD  is  tied  to  the matrix described by  DESCA, as opposed to the
*  piece that is currently  (re)generated.  This is a global information
*  independent from the distribution  parameters.  Below are examples of
*  the meaning of OFFD for a global 7 by 5 matrix:
*
*  ---------------------------------------------------------------------
*  OFFD   |  0 -1 -2 -3 -4         0 -1 -2 -3 -4          0 -1 -2 -3 -4
*  -------|-------------------------------------------------------------
*         |     | OFFD=-1          |   OFFD=0                 OFFD=2
*         |     V                  V
*  0      |  .  d  .  .  .      -> d  .  .  .  .          .  .  .  .  .
*  1      |  .  .  d  .  .         .  d  .  .  .          .  .  .  .  .
*  2      |  .  .  .  d  .         .  .  d  .  .       -> d  .  .  .  .
*  3      |  .  .  .  .  d         .  .  .  d  .          .  d  .  .  .
*  4      |  .  .  .  .  .         .  .  .  .  d          .  .  d  .  .
*  5      |  .  .  .  .  .         .  .  .  .  .          .  .  .  d  .
*  6      |  .  .  .  .  .         .  .  .  .  .          .  .  .  .  d
*  ---------------------------------------------------------------------
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
     $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
     $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
     $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
      INTEGER            JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
     $                   JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
     $                   JMP_NQINBLOC, JMP_NQNB, JMP_ROW
      PARAMETER          ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3,
     $                   JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6,
     $                   JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9,
     $                   JMP_NQNB = 10, JMP_NQINBLOC = 11,
     $                   JMP_LEN = 11 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            DIAGDO, SYMM, HERM, NOTRAN
      INTEGER            CSRC, I, IACOL, IAROW, ICTXT, IIA, ILOCBLK,
     $                   ILOCOFF, ILOW, IMB, IMB1, IMBLOC, IMBVIR, INB,
     $                   INB1, INBLOC, INBVIR, INFO, IOFFDA, ITMP, IUPP,
     $                   IVIR, JJA, JLOCBLK, JLOCOFF, JVIR, LCMT00,
     $                   LMBLOC, LNBLOC, LOW, MAXMN, MB, MBLKS, MP,
     $                   MRCOL, MRROW, MYCDIST, MYCOL, MYRDIST, MYROW,
     $                   NB, NBLKS, NPCOL, NPROW, NQ, NVIR, RSRC, UPP
      COMPLEX*16         ALPHA
*     ..
*     .. Local Arrays ..
      INTEGER            DESCA2( DLEN_ ), IMULADD( 4, JMP_LEN ),
     $                   IRAN( 2 ), JMP( JMP_LEN ), MULADD0( 4 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
     $                   PB_CHKMAT, PB_DESCTRANS, PB_INITJMP,
     $                   PB_INITMULADD, PB_JUMP, PB_JUMPIT, PB_LOCINFO,
     $                   PB_SETLOCRAN, PB_SETRAN, PB_ZLAGEN, PXERBLA,
     $                   PZLADOM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DCMPLX, MAX, MIN
*     ..
*     .. Data Statements ..
      DATA               ( MULADD0( I ), I = 1, 4 ) / 20077, 16838,
     $                   12345, 0 /
*     ..
*     .. Executable Statements ..
*
*     Convert descriptor
*
      CALL PB_DESCTRANS( DESCA, DESCA2 )
*
*     Test the input arguments
*
      ICTXT = DESCA2( CTXT_ )
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
*     Test the input parameters
*
      INFO = 0
.EQ.      IF( NPROW-1 ) THEN
         INFO = -( 1000 + CTXT_ )
      ELSE
         SYMM   = LSAME( AFORM, 's' )
         HERM   = LSAME( AFORM, 'h' )
         NOTRAN = LSAME( AFORM, 'n' )
         DIAGDO = LSAME( DIAG, 'd' )
.NOT..OR..OR..AND.         IF( ( SYMMHERMNOTRAN ) 
.NOT.     $       ( LSAME( AFORM, 't.AND.' )    ) 
.NOT.     $       ( LSAME( AFORM, 'c' )    ) ) THEN
            INFO = -2
.NOT..AND.         ELSE IF( ( DIAGDO ) 
.NOT.     $            ( LSAME( DIAG, 'n' ) ) ) THEN
            INFO = -3
         END IF
         CALL PB_CHKMAT( ICTXT, M, 5, N, 6, IA, JA, DESCA2, 10, INFO )
      END IF
*
.NE.      IF( INFO0 ) THEN
         CALL PXERBLA( ICTXT, 'pzlagen', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
.LE..OR..LE.      IF( ( M0 )( N0 ) )
     $   RETURN
*
*     Start the operations
*
      MB   = DESCA2( MB_   )
      NB   = DESCA2( NB_   )
      IMB  = DESCA2( IMB_  )
      INB  = DESCA2( INB_  )
      RSRC = DESCA2( RSRC_ )
      CSRC = DESCA2( CSRC_ )
*
*     Figure out local information about the distributed matrix operand
*
      CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
     $                  MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
     $                  IACOL, MRROW, MRCOL )
*
*     Decide where the entries shall be stored in memory
*
      IF( INPLACE ) THEN
         IIA = 1
         JJA = 1
      END IF
*
*     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
*     ILOW, LOW, IUPP, and UPP.
*
      IOFFDA = JA + OFFA - IA
      CALL PB_BINFO( IOFFDA, MP, NQ, IMB1, INB1, MB, NB, MRROW,
     $               MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC,
     $               LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP )
*
*     Initialize ILOCBLK, ILOCOFF, MYRDIST, JLOCBLK, JLOCOFF, MYCDIST
*     This values correspond to the square virtual underlying matrix
*     of size MAX( M_ + MAX( 0, -OFFA ), N_ + MAX( 0, OFFA ) ) used
*     to set up the random sequence. For practical purposes, the size
*     of this virtual matrix is upper bounded by M_ + N_ - 1.
*
      ITMP   = MAX( 0, -OFFA )
      IVIR   = IA  + ITMP
      IMBVIR = IMB + ITMP
      NVIR   = DESCA2( M_ ) + ITMP
*
      CALL PB_LOCINFO( IVIR, IMBVIR, MB, MYROW, RSRC, NPROW, ILOCBLK,
     $                 ILOCOFF, MYRDIST )
*
      ITMP   = MAX( 0, OFFA )
      JVIR   = JA  + ITMP
      INBVIR = INB + ITMP
      NVIR   = MAX( MAX( NVIR, DESCA2( N_ ) + ITMP ),
     $              DESCA2( M_ ) + DESCA2( N_ ) - 1 )
*
      CALL PB_LOCINFO( JVIR, INBVIR, NB, MYCOL, CSRC, NPCOL, JLOCBLK,
     $                 JLOCOFF, MYCDIST )
*
.OR..OR.      IF( SYMM  HERM  NOTRAN ) THEN
*
         CALL PB_INITJMP( .TRUE., NVIR, IMBVIR, INBVIR, IMBLOC, INBLOC,
     $                    MB, NB, RSRC, CSRC, NPROW, NPCOL, 2, JMP )
*
*        Compute constants to jump JMP( * ) numbers in the sequence
*
         CALL PB_INITMULADD( MULADD0, JMP, IMULADD )
*
*        Compute and set the random value corresponding to A( IA, JA )
*
         CALL PB_SETLOCRAN( IASEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF,
     $                      MYRDIST, MYCDIST, NPROW, NPCOL, JMP,
     $                      IMULADD, IRAN )
*
         CALL PB_ZLAGEN( 'lower', AFORM, A( IIA, JJA ), LDA, LCMT00,
     $                   IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC,
     $                   NB, LNBLOC, JMP, IMULADD )
*
      END IF
*
.OR..OR..NOT.      IF( SYMM  HERM  (  NOTRAN ) ) THEN
*
         CALL PB_INITJMP( .FALSE., NVIR, IMBVIR, INBVIR, IMBLOC, INBLOC,
     $                    MB, NB, RSRC, CSRC, NPROW, NPCOL, 2, JMP )
*
*        Compute constants to jump JMP( * ) numbers in the sequence
*
         CALL PB_INITMULADD( MULADD0, JMP, IMULADD )
*
*        Compute and set the random value corresponding to A( IA, JA )
*
         CALL PB_SETLOCRAN( IASEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF,
     $                      MYRDIST, MYCDIST, NPROW, NPCOL, JMP,
     $                      IMULADD, IRAN )
*
         CALL PB_ZLAGEN( 'upper', AFORM, A( IIA, JJA ), LDA, LCMT00,
     $                   IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC,
     $                   NB, LNBLOC, JMP, IMULADD )
*
      END IF
*
      IF( DIAGDO ) THEN
*
         MAXMN = MAX( DESCA2( M_ ), DESCA2( N_ ) )
         IF( HERM ) THEN
            ALPHA = DCMPLX( DBLE( 2 * MAXMN ), ZERO )
         ELSE
            ALPHA = DCMPLX( DBLE( NVIR ), DBLE( MAXMN ) )
         END IF
*
.GE.         IF( IOFFDA0 ) THEN
            CALL PZLADOM( INPLACE, MIN( MAX( 0, M-IOFFDA ), N ), ALPHA,
     $                    A, MIN( IA+IOFFDA, IA+M-1 ), JA, DESCA )
         ELSE
            CALL PZLADOM( INPLACE, MIN( M, MAX( 0, N+IOFFDA ) ), ALPHA,
     $                    A, IA, MIN( JA-IOFFDA, JA+N-1 ), DESCA )
         END IF
*
      END IF
*
      RETURN
*
*     End of PZLAGEN
*
      END
      SUBROUTINE PZLADOM( INPLACE, N, ALPHA, A, IA, JA, DESCA )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      LOGICAL            INPLACE
      INTEGER            IA, JA, N
      COMPLEX*16         ALPHA
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * )
      COMPLEX*16         A( * )
*     ..
*
*  Purpose
*  =======
*
*  PZLADOM  adds alpha to the diagonal entries  of  an  n by n submatrix
*  sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ).
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  INPLACE (global input) LOGICAL
*          On entry, INPLACE specifies if the matrix should be generated
*          in place or not. If INPLACE is .TRUE., the local random array
*          to be generated  will start in memory at the local memory lo-
*          cation A( 1, 1 ),  otherwise it will start at the local posi-
*          tion induced by IA and JA.
*
*  N       (global input) INTEGER
*          On entry,  N  specifies  the  global  order  of the submatrix
*          sub( A ) to be modified. N must be at least zero.
*
*  ALPHA   (global input) COMPLEX*16
*          On entry, ALPHA specifies the scalar alpha.
*
*  A       (local input/local output) COMPLEX*16 array
*          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
*          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
*          the local entries of the matrix A. On exit, the local entries
*          of this array corresponding to the main diagonal of  sub( A )
*          have been updated.
*
*  IA      (global input) INTEGER
*          On entry, IA  specifies A's global row index, which points to
*          the beginning of the submatrix sub( A ).
*
*  JA      (global input) INTEGER
*          On entry, JA  specifies A's global column index, which points
*          to the beginning of the submatrix sub( A ).
*
*  DESCA   (global and local input) INTEGER array
*          On entry, DESCA  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix A.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
     $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
     $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
     $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
*     ..
*     .. Local Scalars ..
      LOGICAL            GODOWN, GOLEFT
      INTEGER            I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW,
     $                   IMB1, IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP,
     $                   JJA, JOFFA, JOFFD, LCMT, LCMT00, LDA, LDAP1,
     $                   LMBLOC, LNBLOC, LOW, MB, MBLKD, MBLKS, MBLOC,
     $                   MRCOL, MRROW, MYCOL, MYROW, NB, NBLKD, NBLKS,
     $                   NBLOC, NP, NPCOL, NPROW, NQ, PMB, QNB, UPP
      COMPLEX*16         ATMP
*     ..
*     .. Local Scalars ..
      INTEGER            DESCA2( DLEN_ )
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
     $                   PB_DESCTRANS
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Convert descriptor
*
      CALL PB_DESCTRANS( DESCA, DESCA2 )
*
*     Get grid parameters
*
      ICTXT = DESCA2( CTXT_ )
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
.EQ.      IF( N0 )
     $   RETURN
*
      CALL PB_AINFOG2L( N, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
     $                  MYCOL, IMB1, INB1, NP, NQ, IIA, JJA, IAROW,
     $                  IACOL, MRROW, MRCOL )
*
*     Decide where the entries shall be stored in memory
*
      IF( INPLACE ) THEN
         IIA = 1
         JJA = 1
      END IF
*
*     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
*     ILOW, LOW, IUPP, and UPP.
*
      MB = DESCA2( MB_ )
      NB = DESCA2( NB_ )
*
      CALL PB_BINFO( 0, NP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL,
     $               LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
     $               LNBLOC, ILOW, LOW, IUPP, UPP )
*
      IOFFA  = IIA - 1
      JOFFA  = JJA - 1
      LDA    = DESCA2( LLD_ )
      LDAP1  = LDA + 1
*
.LT.      IF( DESCA2( RSRC_ )0 ) THEN
         PMB = MB
      ELSE
         PMB = NPROW * MB
      END IF
.LT.      IF( DESCA2( CSRC_ )0 ) THEN
         QNB = NB
      ELSE
         QNB = NPCOL * NB
      END IF
*
*     Handle the first block of rows or columns separately, and update
*     LCMT00, MBLKS and NBLKS.
*
.GT.      GODOWN = ( LCMT00IUPP )
.LT.      GOLEFT = ( LCMT00ILOW )
*
.NOT..AND..NOT.      IF( GODOWN  GOLEFT ) THEN
*
*        LCMT00 >= ILOW && LCMT00 <= IUPP
*
.GE.         IF( LCMT000 ) THEN
            IJOFFA = IOFFA+LCMT00 + ( JOFFA - 1 ) * LDA
            DO 10 I = 1, MIN( INBLOC, MAX( 0, IMBLOC - LCMT00 ) )
               ATMP = A( IJOFFA + I*LDAP1 )
               A( IJOFFA + I*LDAP1 ) = ALPHA +
     $                                 DCMPLX( ABS( DBLE(  ATMP ) ),
     $                                         ABS( DIMAG( ATMP ) ) )
   10       CONTINUE
         ELSE
            IJOFFA = IOFFA + ( JOFFA - LCMT00 - 1 ) * LDA
            DO 20 I = 1, MIN( IMBLOC, MAX( 0, INBLOC + LCMT00 ) )
               ATMP = A( IJOFFA + I*LDAP1 )
               A( IJOFFA + I*LDAP1 ) = ALPHA +
     $                                 DCMPLX( ABS( DBLE(  ATMP ) ),
     $                                         ABS( DIMAG( ATMP ) ) )
   20       CONTINUE
         END IF
.LT.         GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) )ILOW )
.NOT.         GODOWN = GOLEFT
*
      END IF
*
      IF( GODOWN ) THEN
*
         LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
         MBLKS  = MBLKS - 1
         IOFFA  = IOFFA + IMBLOC
*
   30    CONTINUE
.GT..AND..GT.         IF( MBLKS0  LCMT00UPP ) THEN
            LCMT00 = LCMT00 - PMB
            MBLKS  = MBLKS - 1
            IOFFA  = IOFFA + MB
            GO TO 30
         END IF
*
         LCMT  = LCMT00
         MBLKD = MBLKS
         IOFFD = IOFFA
*
         MBLOC = MB
   40    CONTINUE
.GT..AND..GE.         IF( MBLKD0  LCMTILOW ) THEN
.EQ.            IF( MBLKD1 )
     $         MBLOC = LMBLOC
.GE.            IF( LCMT0 ) THEN
               IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
               DO 50 I = 1, MIN( INBLOC, MAX( 0, MBLOC - LCMT ) )
                  ATMP = A( IJOFFA + I*LDAP1 )
                  A( IJOFFA + I*LDAP1 ) = ALPHA +
     $                                    DCMPLX( ABS( DBLE(  ATMP ) ),
     $                                            ABS( DIMAG( ATMP ) ) )
   50          CONTINUE
            ELSE
               IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
               DO 60 I = 1, MIN( MBLOC, MAX( 0, INBLOC + LCMT ) )
                  ATMP = A( IJOFFA + I*LDAP1 )
                  A( IJOFFA + I*LDAP1 ) = ALPHA +
     $                                    DCMPLX( ABS( DBLE(  ATMP ) ),
     $                                            ABS( DIMAG( ATMP ) ) )
   60          CONTINUE
            END IF
            LCMT00 = LCMT
            LCMT   = LCMT - PMB
            MBLKS  = MBLKD
            MBLKD  = MBLKD - 1
            IOFFA  = IOFFD
            IOFFD  = IOFFD + MBLOC
            GO TO 40
         END IF
*
         LCMT00 = LCMT00 + LOW - ILOW + QNB
         NBLKS  = NBLKS - 1
         JOFFA  = JOFFA + INBLOC
*
      ELSE IF( GOLEFT ) THEN
*
         LCMT00 = LCMT00 + LOW - ILOW + QNB
         NBLKS  = NBLKS - 1
         JOFFA  = JOFFA + INBLOC
*
   70    CONTINUE
.GT..AND..LT.         IF( NBLKS0  LCMT00LOW ) THEN
            LCMT00 = LCMT00 + QNB
            NBLKS  = NBLKS - 1
            JOFFA  = JOFFA + NB
            GO TO 70
         END IF
*
         LCMT  = LCMT00
         NBLKD = NBLKS
         JOFFD = JOFFA
*
         NBLOC = NB
   80    CONTINUE
.GT..AND..LE.         IF( NBLKD0  LCMTIUPP ) THEN
.EQ.            IF( NBLKD1 )
     $         NBLOC = LNBLOC
.GE.            IF( LCMT0 ) THEN
               IJOFFA = IOFFA + LCMT + ( JOFFD - 1 ) * LDA
               DO 90 I = 1, MIN( NBLOC, MAX( 0, IMBLOC - LCMT ) )
                  ATMP = A( IJOFFA + I*LDAP1 )
                  A( IJOFFA + I*LDAP1 ) = ALPHA +
     $                                    DCMPLX( ABS( DBLE(  ATMP ) ),
     $                                            ABS( DIMAG( ATMP ) ) )
   90          CONTINUE
            ELSE
               IJOFFA = IOFFA + ( JOFFD - LCMT - 1 ) * LDA
               DO 100 I = 1, MIN( IMBLOC, MAX( 0, NBLOC + LCMT ) )
                  ATMP = A( IJOFFA + I*LDAP1 )
                  A( IJOFFA + I*LDAP1 ) = ALPHA +
     $                                    DCMPLX( ABS( DBLE(  ATMP ) ),
     $                                            ABS( DIMAG( ATMP ) ) )
  100          CONTINUE
            END IF
            LCMT00 = LCMT
            LCMT   = LCMT + QNB
            NBLKS  = NBLKD
            NBLKD  = NBLKD - 1
            JOFFA  = JOFFD
            JOFFD  = JOFFD + NBLOC
            GO TO 80
         END IF
*
         LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
         MBLKS  = MBLKS - 1
         IOFFA  = IOFFA + IMBLOC
*
      END IF
*
      NBLOC = NB
  110 CONTINUE
.GT.      IF( NBLKS0 ) THEN
.EQ.         IF( NBLKS1 )
     $      NBLOC = LNBLOC
  120    CONTINUE
.GT..AND..GT.         IF( MBLKS0  LCMT00UPP ) THEN
            LCMT00 = LCMT00 - PMB
            MBLKS  = MBLKS - 1
            IOFFA  = IOFFA + MB
            GO TO 120
         END IF
*
         LCMT  = LCMT00
         MBLKD = MBLKS
         IOFFD = IOFFA
*
         MBLOC = MB
  130    CONTINUE
.GT..AND..GE.         IF( MBLKD0  LCMTLOW ) THEN
.EQ.            IF( MBLKD1 )
     $         MBLOC = LMBLOC
.GE.            IF( LCMT0 ) THEN
               IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
               DO 140 I = 1, MIN( NBLOC, MAX( 0, MBLOC - LCMT ) )
                  ATMP = A( IJOFFA + I*LDAP1 )
                  A( IJOFFA + I*LDAP1 ) = ALPHA +
     $                                    DCMPLX( ABS( DBLE(  ATMP ) ),
     $                                            ABS( DIMAG( ATMP ) ) )
  140          CONTINUE
            ELSE
               IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
               DO 150 I = 1, MIN( MBLOC, MAX( 0, NBLOC + LCMT ) )
                  ATMP = A( IJOFFA + I*LDAP1 )
                  A( IJOFFA + I*LDAP1 ) = ALPHA +
     $                                    DCMPLX( ABS( DBLE(  ATMP ) ),
     $                                            ABS( DIMAG( ATMP ) ) )
  150          CONTINUE
            END IF
            LCMT00 = LCMT
            LCMT   = LCMT - PMB
            MBLKS  = MBLKD
            MBLKD  = MBLKD - 1
            IOFFA  = IOFFD
            IOFFD  = IOFFD + MBLOC
            GO TO 130
         END IF
*
         LCMT00 = LCMT00 + QNB
         NBLKS  = NBLKS - 1
         JOFFA  = JOFFA + NBLOC
         GO TO 110
*
      END IF
*
      RETURN
*
*     End of PZLADOM
*
      END
      SUBROUTINE PB_PZLAPRNT( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT,
     $                        CMATNM, NOUT, WORK )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER            IA, ICPRNT, IRPRNT, JA, M, N, NOUT
*     ..
*     .. Array Arguments ..
      CHARACTER*(*)      CMATNM
      INTEGER            DESCA( * )
      COMPLEX*16         A( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  PB_PZLAPRNT  prints to the standard output a submatrix sub( A ) deno-
*  ting A(IA:IA+M-1,JA:JA+N-1). The local pieces are sent and printed by
*  the process of coordinates (IRPRNT, ICPRNT).
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  M       (global input) INTEGER
*          On entry,  M  specifies the number of rows of  the  submatrix
*          sub( A ). M  must be at least zero.
*
*  N       (global input) INTEGER
*          On entry, N  specifies the number of columns of the submatrix
*          sub( A ). N must be at least zero.
*
*  A       (local input) COMPLEX*16 array
*          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
*          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
*          the local entries of the matrix A.
*
*  IA      (global input) INTEGER
*          On entry, IA  specifies A's global row index, which points to
*          the beginning of the submatrix sub( A ).
*
*  JA      (global input) INTEGER
*          On entry, JA  specifies A's global column index, which points
*          to the beginning of the submatrix sub( A ).
*
*  DESCA   (global and local input) INTEGER array
*          On entry, DESCA  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix A.
*
*  IRPRNT  (global input) INTEGER
*          On entry, IRPRNT specifies the row index of the printing pro-
*          cess.
*
*  ICPRNT  (global input) INTEGER
*          On entry, ICPRNT specifies the  column  index of the printing
*          process.
*
*  CMATNM  (global input) CHARACTER*(*)
*          On entry, CMATNM is the name of the matrix to be printed.
*
*  NOUT    (global input) INTEGER
*          On entry, NOUT specifies the output unit number. When NOUT is
*          equal to 6, the submatrix is printed on the screen.
*
*  WORK    (local workspace) COMPLEX*16 array
*          On entry, WORK is a work array of dimension at least equal to
*          MAX( IMB_A, MB_A ).
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
     $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
     $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
     $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
*     ..
*     .. Local Scalars ..
      INTEGER            MYCOL, MYROW, NPCOL, NPROW, PCOL, PROW
*     ..
*     .. Local Arrays ..
      INTEGER            DESCA2( DLEN_ )
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, PB_DESCTRANS, PB_PZLAPRN2
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
.LE..OR..LE.      IF( ( M0 )( N0 ) )
     $   RETURN
*
*     Convert descriptor
*
      CALL PB_DESCTRANS( DESCA, DESCA2 )
*
      CALL BLACS_GRIDINFO( DESCA2( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
*
.GE.      IF( DESCA2( RSRC_ )0 ) THEN
.GE.         IF( DESCA2( CSRC_ )0 ) THEN
            CALL PB_PZLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT, ICPRNT,
     $                        CMATNM, NOUT, DESCA2( RSRC_ ),
     $                        DESCA2( CSRC_ ), WORK )
         ELSE
            DO 10 PCOL = 0, NPCOL - 1
.EQ..AND..EQ.               IF( ( MYROWIRPRNT )( MYCOLICPRNT ) )
     $            WRITE( NOUT, * ) 'colum-replicated array -- ' ,
     $                             'copy in process column: ', PCOL
               CALL PB_PZLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT,
     $                           ICPRNT, CMATNM, NOUT, DESCA2( RSRC_ ),
     $                           PCOL, WORK )
   10       CONTINUE
         END IF
      ELSE
.GE.         IF( DESCA2( CSRC_ )0 ) THEN
            DO 20 PROW = 0, NPROW - 1
.EQ..AND..EQ.               IF( ( MYROWIRPRNT )( MYCOLICPRNT ) )
     $            WRITE( NOUT, * ) 'row-replicated array -- ' ,
     $                             'copy in process row: ', PROW
               CALL PB_PZLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT,
     $                           ICPRNT, CMATNM, NOUT, PROW,
     $                           DESCA2( CSRC_ ), WORK )
   20       CONTINUE
         ELSE
            DO 40 PROW = 0, NPROW - 1
               DO 30 PCOL = 0, NPCOL - 1
.EQ..AND..EQ.                  IF( ( MYROWIRPRNT )( MYCOLICPRNT ) )
     $               WRITE( NOUT, * ) 'replicated array -- ' ,
     $                      'copy in process(', PROW, ',', PCOL, ')'
                  CALL PB_PZLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT,
     $                              ICPRNT, CMATNM, NOUT, PROW, PCOL,
     $                              WORK )
   30          CONTINUE
   40       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of PB_PZLAPRNT
*
      END
      SUBROUTINE PB_PZLAPRN2( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT,
     $                        CMATNM, NOUT, PROW, PCOL, WORK )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER            IA, ICPRNT, IRPRNT, JA, M, N, NOUT, PCOL, PROW
*     ..
*     .. Array Arguments ..
      CHARACTER*(*)      CMATNM
      INTEGER            DESCA( * )
      COMPLEX*16         A( * ), WORK( * )
*     ..
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
     $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
     $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
     $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
*     ..
*     .. Local Scalars ..
      LOGICAL            AISCOLREP, AISROWREP
      INTEGER            H, I, IACOL, IAROW, IB, ICTXT, ICURCOL,
     $                   ICURROW, II, IIA, IN, J, JB, JJ, JJA, JN, K,
     $                   LDA, LDW, MYCOL, MYROW, NPCOL, NPROW
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_BARRIER, BLACS_GRIDINFO, PB_INFOG2L,
     $                   ZGERV2D, ZGESD2D
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DIMAG, MIN
*     ..
*     .. Executable Statements ..
*
*     Get grid parameters
*
      ICTXT = DESCA( CTXT_ )
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
      CALL PB_INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL,
     $                 IIA, JJA, IAROW, IACOL )
      II = IIA
      JJ = JJA
.LT.      IF( DESCA( RSRC_ )0 ) THEN
         AISROWREP = .TRUE.
         IAROW     = PROW
         ICURROW   = PROW
      ELSE
         AISROWREP = .FALSE.
         ICURROW   = IAROW
      END IF
.LT.      IF( DESCA( CSRC_ )0 ) THEN
         AISCOLREP = .TRUE.
         IACOL     = PCOL
         ICURCOL   = PCOL
      ELSE
         AISCOLREP = .FALSE.
         ICURCOL   = IACOL
      END IF
      LDA = DESCA( LLD_ )
      LDW = MAX( DESCA( IMB_ ), DESCA( MB_ ) )
*
*     Handle the first block of column separately
*
      JB = DESCA( INB_ ) - JA + 1
.LE.      IF( JB0 )
     $   JB = ( (-JB) / DESCA( NB_ ) + 1 ) * DESCA( NB_ ) + JB
      JB = MIN( JB, N )
      JN = JA+JB-1
      DO 60 H = 0, JB-1
         IB = DESCA( IMB_ ) - IA + 1
.LE.         IF( IB0 )
     $      IB = ( (-IB) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
         IB = MIN( IB, M )
         IN = IA+IB-1
.EQ..AND..EQ.         IF( ICURROWIRPRNT  ICURCOLICPRNT ) THEN
.EQ..AND..EQ.            IF( MYROWIRPRNT  MYCOLICPRNT ) THEN
               DO 10 K = 0, IB-1
                  WRITE( NOUT, FMT = 9999 )
     $                   CMATNM, IA+K, JA+H,
     $                   DBLE( A( II+K+(JJ+H-1)*LDA ) ),
     $                   DIMAG( A( II+K+(JJ+H-1)*LDA ) )
   10          CONTINUE
            END IF
         ELSE
.EQ..AND..EQ.            IF( MYROWICURROW  MYCOLICURCOL ) THEN
               CALL ZGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ), LDA,
     $                       IRPRNT, ICPRNT )
.EQ..AND..EQ.            ELSE IF( MYROWIRPRNT  MYCOLICPRNT ) THEN
               CALL ZGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW, ICURCOL )
               DO 20 K = 1, IB
                  WRITE( NOUT, FMT = 9999 )
     $                   CMATNM, IA+K-1, JA+H, DBLE( WORK( K ) ),
     $                   DIMAG( WORK( K ) )
   20          CONTINUE
            END IF
         END IF
.EQ.         IF( MYROWICURROW )
     $      II = II + IB
.NOT.         IF( AISROWREP )
     $      ICURROW = MOD( ICURROW+1, NPROW )
         CALL BLACS_BARRIER( ICTXT, 'all' )
*
*        Loop over remaining block of rows
*
         DO 50 I = IN+1, IA+M-1, DESCA( MB_ )
            IB = MIN( DESCA( MB_ ), IA+M-I )
.EQ..AND..EQ.            IF( ICURROWIRPRNT  ICURCOLICPRNT ) THEN
.EQ..AND..EQ.               IF( MYROWIRPRNT  MYCOLICPRNT ) THEN
                  DO 30 K = 0, IB-1
                     WRITE( NOUT, FMT = 9999 )
     $                      CMATNM, I+K, JA+H,
     $                      DBLE( A( II+K+(JJ+H-1)*LDA ) ),
     $                      DIMAG( A( II+K+(JJ+H-1)*LDA ) )
   30             CONTINUE
               END IF
            ELSE
.EQ..AND..EQ.               IF( MYROWICURROW  MYCOLICURCOL ) THEN
                  CALL ZGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ),
     $                          LDA, IRPRNT, ICPRNT )
.EQ..AND..EQ.               ELSE IF( MYROWIRPRNT  MYCOLICPRNT ) THEN
                  CALL ZGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW,
     $                          ICURCOL )
                  DO 40 K = 1, IB
                     WRITE( NOUT, FMT = 9999 )
     $                      CMATNM, I+K-1, JA+H, DBLE( WORK( K ) ),
     $                      DIMAG( WORK( K ) )
   40             CONTINUE
               END IF
            END IF
.EQ.            IF( MYROWICURROW )
     $         II = II + IB
.NOT.            IF( AISROWREP )
     $         ICURROW = MOD( ICURROW+1, NPROW )
            CALL BLACS_BARRIER( ICTXT, 'all' )
   50    CONTINUE
*
         II = IIA
         ICURROW = IAROW
   60 CONTINUE
*
.EQ.      IF( MYCOLICURCOL )
     $   JJ = JJ + JB
.NOT.      IF( AISCOLREP )
     $   ICURCOL = MOD( ICURCOL+1, NPCOL )
      CALL BLACS_BARRIER( ICTXT, 'all' )
*
*     Loop over remaining column blocks
*
      DO 130 J = JN+1, JA+N-1, DESCA( NB_ )
         JB = MIN(  DESCA( NB_ ), JA+N-J )
         DO 120 H = 0, JB-1
            IB = DESCA( IMB_ )-IA+1
.LE.            IF( IB0 )
     $         IB = ( (-IB) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
            IB = MIN( IB, M )
            IN = IA+IB-1
.EQ..AND..EQ.            IF( ICURROWIRPRNT  ICURCOLICPRNT ) THEN
.EQ..AND..EQ.               IF( MYROWIRPRNT  MYCOLICPRNT ) THEN
                  DO 70 K = 0, IB-1
                     WRITE( NOUT, FMT = 9999 )
     $                      CMATNM, IA+K, J+H,
     $                      DBLE( A( II+K+(JJ+H-1)*LDA ) ),
     $                      DIMAG( A( II+K+(JJ+H-1)*LDA ) )
   70             CONTINUE
               END IF
            ELSE
.EQ..AND..EQ.               IF( MYROWICURROW  MYCOLICURCOL ) THEN
                  CALL ZGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ),
     $                          LDA, IRPRNT, ICPRNT )
.EQ..AND..EQ.               ELSE IF( MYROWIRPRNT  MYCOLICPRNT ) THEN
                  CALL ZGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW,
     $                          ICURCOL )
                  DO 80 K = 1, IB
                     WRITE( NOUT, FMT = 9999 )
     $                      CMATNM, IA+K-1, J+H, DBLE( WORK( K ) ),
     $                      DIMAG( WORK( K ) )
   80             CONTINUE
               END IF
            END IF
.EQ.            IF( MYROWICURROW )
     $         II = II + IB
            ICURROW = MOD( ICURROW+1, NPROW )
            CALL BLACS_BARRIER( ICTXT, 'all' )
*
*           Loop over remaining block of rows
*
            DO 110 I = IN+1, IA+M-1, DESCA( MB_ )
               IB = MIN( DESCA( MB_ ), IA+M-I )
.EQ..AND..EQ.               IF( ICURROWIRPRNT  ICURCOLICPRNT ) THEN
.EQ..AND..EQ.                  IF( MYROWIRPRNT  MYCOLICPRNT ) THEN
                     DO 90 K = 0, IB-1
                        WRITE( NOUT, FMT = 9999 )
     $                         CMATNM, I+K, J+H,
     $                         DBLE( A( II+K+(JJ+H-1)*LDA ) ),
     $                         DIMAG( A( II+K+(JJ+H-1)*LDA ) )
   90                CONTINUE
                  END IF
               ELSE
.EQ..AND..EQ.                  IF( MYROWICURROW  MYCOLICURCOL ) THEN
                     CALL ZGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ),
     $                             LDA, IRPRNT, ICPRNT )
.EQ..AND..EQ.                   ELSE IF( MYROWIRPRNT  MYCOLICPRNT ) THEN
                     CALL ZGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW,
     $                             ICURCOL )
                     DO 100 K = 1, IB
                        WRITE( NOUT, FMT = 9999 )
     $                         CMATNM, I+K-1, J+H, DBLE( WORK( K ) ),
     $                         DIMAG( WORK( K ) )
  100                CONTINUE
                  END IF
               END IF
.EQ.               IF( MYROWICURROW )
     $            II = II + IB
.NOT.               IF( AISROWREP )
     $            ICURROW = MOD( ICURROW+1, NPROW )
               CALL BLACS_BARRIER( ICTXT, 'all' )
  110       CONTINUE
*
            II = IIA
            ICURROW = IAROW
  120    CONTINUE
*
.EQ.         IF( MYCOLICURCOL )
     $      JJ = JJ + JB
.NOT.         IF( AISCOLREP )
     $      ICURCOL = MOD( ICURCOL+1, NPCOL )
         CALL BLACS_BARRIER( ICTXT, 'all' )
*
  130 CONTINUE
*
 9999 FORMAT( 1X, A, '(', I6, ',', I6, ')=', D30.18, '+i*(',
     $        D30.18, ')' )
*
      RETURN
*
*     End of PB_PZLAPRN2
*
      END
      SUBROUTINE PB_ZFILLPAD( ICTXT, M, N, A, LDA, IPRE, IPOST, CHKVAL )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER            ICTXT, IPOST, IPRE, LDA, M, N
      COMPLEX*16         CHKVAL
*     ..
*     .. Array Arguments ..
      COMPLEX*16         A( * )
*     ..
*
*  Purpose
*  =======
*
*  PB_ZFILLPAD surrounds a two dimensional local array with a guard-zone
*  initialized to the value CHKVAL. The user may later call the  routine
*  PB_ZCHEKPAD to discover if the guardzone has been violated. There are
*  three guardzones. The first is a buffer of size  IPRE  that is before
*  the start of the array. The second is the buffer of size IPOST  which
*  is after the end of the array to be padded. Finally, there is a guard
*  zone inside every column of the array to be padded, in  the  elements
*  of A(M+1:LDA, J).
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  M       (local input) INTEGER
*          On entry, M  specifies the number of rows in the local  array
*          A.  M must be at least zero.
*
*  N       (local input) INTEGER
*          On entry, N  specifies the number of columns in the local ar-
*          ray A. N must be at least zero.
*
*  A       (local input/local output) COMPLEX*16 array
*          On entry,  A  is an array of dimension (LDA,N). On exit, this
*          array is the padded array.
*
*  LDA     (local input) INTEGER
*          On entry,  LDA  specifies  the leading dimension of the local
*          array to be padded. LDA must be at least MAX( 1, M ).
*
*  IPRE    (local input) INTEGER
*          On entry, IPRE specifies the size of  the  guard zone  to put
*          before the start of the padded array.
*
*  IPOST   (local input) INTEGER
*          On entry, IPOST specifies the size of the  guard zone  to put
*          after the end of the padded array.
*
*  CHKVAL  (local input) COMPLEX*16
*          On entry, CHKVAL specifies the value to pad the array with.
*
*  -- Written on April 1, 1998 by
*     R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, J, K
*     ..
*     .. Executable Statements ..
*
*     Put check buffer in front of A
*
.GT.      IF( IPRE0 ) THEN
         DO 10 I = 1, IPRE
            A( I ) = CHKVAL
   10    CONTINUE
      ELSE
         WRITE( *, FMT = '(a)' )
     $          'warning no pre-guardzone in pb_zfillpad'
      END IF
*
*     Put check buffer in back of A
*
.GT.      IF( IPOST0 ) THEN
         J = IPRE+LDA*N+1
         DO 20 I = J, J+IPOST-1
            A( I ) = CHKVAL
   20    CONTINUE
      ELSE
         WRITE( *, FMT = '(a)' )
     $          'warning no post-guardzone in pb_zfillpad'
      END IF
*
*     Put check buffer in all (LDA-M) gaps
*
.GT.      IF( LDAM ) THEN
         K = IPRE + M + 1
         DO 40 J = 1, N
            DO 30 I = K, K + ( LDA - M ) - 1
               A( I ) = CHKVAL
   30       CONTINUE
            K = K + LDA
   40    CONTINUE
      END IF
*
      RETURN
*
*     End of PB_ZFILLPAD
*
      END
      SUBROUTINE PB_ZCHEKPAD( ICTXT, MESS, M, N, A, LDA, IPRE, IPOST,
     $                        CHKVAL )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER            ICTXT, IPOST, IPRE, LDA, M, N
      COMPLEX*16         CHKVAL
*     ..
*     .. Array Arguments ..
      CHARACTER*(*)      MESS
      COMPLEX*16         A( * )
*     ..
*
*  Purpose
*  =======
*
*  PB_ZCHEKPAD checks that the padding around a local array has not been
*  overwritten since the call to PB_ZFILLPAD.  Three types of errors are
*  reported:
*
*  1) Overwrite in pre-guardzone.  This indicates a memory overwrite has
*  occurred in the  first  IPRE  elements which form a buffer before the
*  beginning of A. Therefore, the error message:
*     'Overwrite in  pre-guardzone: loc(  5) =         18.00000'
*  tells that the 5th element of the IPRE long buffer has been overwrit-
*  ten with the value 18, where it should still have the value CHKVAL.
*
*  2) Overwrite in post-guardzone. This indicates a memory overwrite has
*  occurred in the last IPOST elements which form a buffer after the end
*  of A. Error reports are refered from the end of A.  Therefore,
*     'Overwrite in post-guardzone: loc( 19) =         24.00000'
*  tells  that the  19th element after the end of A was overwritten with
*  the value 24, where it should still have the value of CHKVAL.
*
*  3) Overwrite in lda-m gap.  Tells you elements between M and LDA were
*  overwritten.  So,
*     'Overwrite in lda-m gap: A( 12,  3) =         22.00000'
*  tells  that the element at the 12th row and 3rd column of A was over-
*  written with the value of 22, where it should still have the value of
*  CHKVAL.
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  MESS    (local input) CHARACTER*(*)
*          On entry, MESS is a ttring containing a user-defined message.
*
*  M       (local input) INTEGER
*          On entry, M  specifies the number of rows in the local  array
*          A.  M must be at least zero.
*
*  N       (local input) INTEGER
*          On entry, N  specifies the number of columns in the local ar-
*          ray A. N must be at least zero.
*
*  A       (local input) COMPLEX*16 array
*          On entry,  A  is an array of dimension (LDA,N).
*
*  LDA     (local input) INTEGER
*          On entry,  LDA  specifies  the leading dimension of the local
*          array to be padded. LDA must be at least MAX( 1, M ).
*
*  IPRE    (local input) INTEGER
*          On entry, IPRE specifies the size of  the  guard zone  to put
*          before the start of the padded array.
*
*  IPOST   (local input) INTEGER
*          On entry, IPOST specifies the size of the  guard zone  to put
*          after the end of the padded array.
*
*  CHKVAL  (local input) COMPLEX*16
*          On entry, CHKVAL specifies the value to pad the array with.
*
*
*  -- Written on April 1, 1998 by
*     R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Local Scalars ..
      CHARACTER*1        TOP
      INTEGER            I, IAM, IDUMM, INFO, J, K, MYCOL, MYROW, NPCOL,
     $                   NPROW
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, IGAMX2D, PB_TOPGET
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DIMAG
*     ..
*     .. Executable Statements ..
*
*     Get grid parameters
*
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
      IAM  = MYROW*NPCOL + MYCOL
      INFO = -1
*
*     Check buffer in front of A
*
.GT.      IF( IPRE0 ) THEN
         DO 10 I = 1, IPRE
.NE.            IF( A( I )CHKVAL ) THEN
               WRITE( *, FMT = 9998 ) MYROW, MYCOL, MESS, ' pre', I,
     $                                DBLE( A( I ) ), DIMAG( A( I ) )
               INFO = IAM
            END IF
   10    CONTINUE
      ELSE
         WRITE( *, FMT = * ) 'warning no pre-guardzone in pb_zchekpad'
      END IF
*
*     Check buffer after A
*
.GT.      IF( IPOST0 ) THEN
         J = IPRE+LDA*N+1
         DO 20 I = J, J+IPOST-1
.NE.            IF( A( I )CHKVAL ) THEN
               WRITE( *, FMT = 9998 ) MYROW, MYCOL, MESS, 'post',
     $                                I-J+1, DBLE( A( I ) ),
     $                                DIMAG( A( I ) )
               INFO = IAM
            END IF
   20    CONTINUE
      ELSE
         WRITE( *, FMT = * )
     $          'warning no post-guardzone buffer in pb_zchekpad'
      END IF
*
*     Check all (LDA-M) gaps
*
.GT.      IF( LDAM ) THEN
         K = IPRE + M + 1
         DO 40 J = 1, N
            DO 30 I = K, K + (LDA-M) - 1
.NE.               IF( A( I )CHKVAL ) THEN
                  WRITE( *, FMT = 9997 ) MYROW, MYCOL, MESS,
     $               I-IPRE-LDA*(J-1), J, DBLE( A( I ) ),
     $               DIMAG( A( I ) )
                  INFO = IAM
               END IF
   30       CONTINUE
            K = K + LDA
   40    CONTINUE
      END IF
*
      CALL PB_TOPGET( ICTXT, 'combine', 'all', TOP )
      CALL IGAMX2D( ICTXT, 'all', TOP, 1, 1, INFO, 1, IDUMM, IDUMM, -1,
     $              0, 0 )
.EQ..AND..GE.      IF( IAM0  INFO0 ) THEN
         WRITE( *, FMT = 9999 ) INFO / NPCOL, MOD( INFO, NPCOL ), MESS
      END IF
*
 9999 FORMAT( '{', I5, ',', I5, '}:  memory overwrite in ', A )
 9998 FORMAT( '{', I5, ',', I5, '}:  ', A, ' memory overwrite in ',
     $        A4, '-guardzone: loc(', I3, ') = ', G20.7, '+ i*',
     $        G20.7 )
 9997 FORMAT( '{', I5, ',', I5, '}: ', A, ' memory overwrite in ',
     $        'lda-m gap: loc(', I3, ',', I3, ') = ', G20.7,
     $        '+ i*', G20.7 )
*
      RETURN
*
*     End of PB_ZCHEKPAD
*
      END
      SUBROUTINE PB_ZLASET( UPLO, M, N, IOFFD, ALPHA, BETA, A, LDA )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1        UPLO
      INTEGER            IOFFD, LDA, M, N
      COMPLEX*16         ALPHA, BETA
*     ..
*     .. Array Arguments ..
      COMPLEX*16         A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  PB_ZLASET initializes a two-dimensional array A to beta on the diago-
*  nal specified by IOFFD and alpha on the offdiagonals.
*
*  Arguments
*  =========
*
*  UPLO    (global input) CHARACTER*1
*          On entry,  UPLO  specifies  which trapezoidal part of the ar-
*          ray A is to be set as follows:
*             = 'L' or 'l':   Lower triangular part is set; the strictly
*                             upper triangular part of A is not changed,
*             = 'U' or 'u':   Upper triangular part is set; the strictly
*                             lower triangular part of A is not changed,
*             = 'D' or 'd'    Only the diagonal of A is set,
*             Otherwise:      All of the array A is set.
*
*  M       (input) INTEGER
*          On entry,  M  specifies the number of rows of the array A.  M
*          must be at least zero.
*
*  N       (input) INTEGER
*          On entry,  N  specifies the number of columns of the array A.
*          N must be at least zero.
*
*  IOFFD   (input) INTEGER
*          On entry, IOFFD specifies the position of the offdiagonal de-
*          limiting the upper and lower trapezoidal part of A as follows
*          (see the notes below):
*
*             IOFFD = 0  specifies the main diagonal A( i, i ),
*                        with i = 1 ... MIN( M, N ),
*             IOFFD > 0  specifies the subdiagonal   A( i+IOFFD, i ),
*                        with i = 1 ... MIN( M-IOFFD, N ),
*             IOFFD < 0  specifies the superdiagonal A( i, i-IOFFD ),
*                        with i = 1 ... MIN( M, N+IOFFD ).
*
*  ALPHA   (input) COMPLEX*16
*          On entry,  ALPHA specifies the value to which the offdiagonal
*          array elements are set to.
*
*  BETA    (input) COMPLEX*16
*          On entry, BETA  specifies the value to which the diagonal ar-
*          ray elements are set to.
*
*  A       (input/output) COMPLEX*16 array
*          On entry, A is an array of dimension  (LDA,N).  Before  entry
*          with UPLO = 'U' or 'u', the leading m by n part of the  array
*          A  must  contain  the upper trapezoidal part of the matrix as
*          specified by IOFFD to be set, and  the  strictly lower trape-
*          zoidal  part of A is not referenced; When IUPLO = 'L' or 'l',
*          the leading m by n part of  the  array  A  must  contain  the
*          lower trapezoidal part of the matrix as specified by IOFFD to
*          be set,  and  the  strictly  upper  trapezoidal part of  A is
*          not referenced.
*
*  LDA     (input) INTEGER
*          On entry, LDA specifies the leading dimension of the array A.
*          LDA must be at least max( 1, M ).
*
*  Notes
*  =====
*                           N                                    N
*             ----------------------------                  -----------
*            |       d                    |                |           |
*          M |         d        'U'       |                |      'U'  |
*            |  'L'     'D'               |                |d          |
*            |             d              |              M |  d        |
*             ----------------------------                 |   'D'     |
*                                                          |      d    |
*               IOFFD < 0                                  | 'L'    d  |
*                                                          |          d|
*                  N                                       |           |
*             -----------                                   -----------
*            |    d   'U'|
*            |      d    |                                   IOFFD > 0
*          M |       'D' |
*            |          d|                              N
*            |  'L'      |                 ----------------------------
*            |           |                |          'U'               |
*            |           |                |d                           |
*            |           |                | 'D'                        |
*            |           |                |    d                       |
*            |           |                |'L'   d                     |
*             -----------                  ----------------------------
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, J, JTMP, MN
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
.LE..OR..LE.      IF( M0  N0 )
     $   RETURN
*
*     Start the operations
*
      IF( LSAME( UPLO, 'l' ) ) THEN
*
*        Set the diagonal to BETA and the strictly lower triangular
*        part of the array to ALPHA.
*
         MN = MAX( 0, -IOFFD )
         DO 20 J = 1, MIN( MN, N )
            DO 10 I = 1, M
               A( I, J ) = ALPHA
   10       CONTINUE
   20    CONTINUE
         DO 40 J = MN + 1, MIN( M - IOFFD, N )
            JTMP = J + IOFFD
            A( JTMP, J ) = BETA
            DO 30 I = JTMP + 1, M
               A( I, J ) = ALPHA
   30       CONTINUE
   40    CONTINUE
*
      ELSE IF( LSAME( UPLO, 'u' ) ) THEN
*
*        Set the diagonal to BETA and the strictly upper triangular
*        part of the array to ALPHA.
*
         MN = MIN( M - IOFFD, N )
         DO 60 J = MAX( 0, -IOFFD ) + 1, MN
            JTMP = J + IOFFD
            DO 50 I = 1, JTMP - 1
               A( I, J ) = ALPHA
   50       CONTINUE
            A( JTMP, J ) = BETA
   60    CONTINUE
         DO 80 J = MAX( 0, MN ) + 1, N
            DO 70 I = 1, M
               A( I, J ) = ALPHA
   70       CONTINUE
   80    CONTINUE
*
      ELSE IF( LSAME( UPLO, 'd' ) ) THEN
*
*        Set the array to BETA on the diagonal.
*
         DO 90 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N )
            A( J + IOFFD, J ) = BETA
   90    CONTINUE
*
      ELSE
*
*        Set the array to BETA on the diagonal and ALPHA on the
*        offdiagonal.
*
         DO 110 J = 1, N
            DO 100 I = 1, M
               A( I, J ) = ALPHA
  100       CONTINUE
  110    CONTINUE
.NE..AND..LT..AND..GT.         IF( ALPHABETA  IOFFDM  IOFFD-N ) THEN
            DO 120 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N )
               A( J + IOFFD, J ) = BETA
  120       CONTINUE
         END IF
*
      END IF
*
      RETURN
*
*     End of PB_ZLASET
*
      END
      SUBROUTINE PB_ZLASCAL( UPLO, M, N, IOFFD, ALPHA, A, LDA )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1        UPLO
      INTEGER            IOFFD, LDA, M, N
      COMPLEX*16         ALPHA
*     ..
*     .. Array Arguments ..
      COMPLEX*16         A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  PB_ZLASCAL scales a two-dimensional array A by the scalar alpha.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          On entry,  UPLO  specifies  which trapezoidal part of the ar-
*          ray A is to be scaled as follows:
*             = 'L' or 'l':          the lower trapezoid of A is scaled,
*             = 'U' or 'u':          the upper trapezoid of A is scaled,
*             = 'D' or 'd':       diagonal specified by IOFFD is scaled,
*             Otherwise:                   all of the array A is scaled.
*
*  M       (input) INTEGER
*          On entry,  M  specifies the number of rows of the array A.  M
*          must be at least zero.
*
*  N       (input) INTEGER
*          On entry,  N  specifies the number of columns of the array A.
*          N must be at least zero.
*
*  IOFFD   (input) INTEGER
*          On entry, IOFFD specifies the position of the offdiagonal de-
*          limiting the upper and lower trapezoidal part of A as follows
*          (see the notes below):
*
*             IOFFD = 0  specifies the main diagonal A( i, i ),
*                        with i = 1 ... MIN( M, N ),
*             IOFFD > 0  specifies the subdiagonal   A( i+IOFFD, i ),
*                        with i = 1 ... MIN( M-IOFFD, N ),
*             IOFFD < 0  specifies the superdiagonal A( i, i-IOFFD ),
*                        with i = 1 ... MIN( M, N+IOFFD ).
*
*  ALPHA   (input) COMPLEX*16
*          On entry, ALPHA specifies the scalar alpha.
*
*  A       (input/output) COMPLEX*16 array
*          On entry, A is an array of dimension  (LDA,N).  Before  entry
*          with  UPLO = 'U' or 'u', the leading m by n part of the array
*          A must contain the upper trapezoidal  part  of the matrix  as
*          specified by  IOFFD to be scaled, and the strictly lower tra-
*          pezoidal part of A is not referenced; When UPLO = 'L' or 'l',
*          the leading m by n part of the array A must contain the lower
*          trapezoidal  part  of  the matrix as specified by IOFFD to be
*          scaled,  and  the strictly upper trapezoidal part of A is not
*          referenced. On exit, the entries of the  trapezoid part of  A
*          determined by UPLO and IOFFD are scaled.
*
*  LDA     (input) INTEGER
*          On entry, LDA specifies the leading dimension of the array A.
*          LDA must be at least max( 1, M ).
*
*  Notes
*  =====
*                           N                                    N
*             ----------------------------                  -----------
*            |       d                    |                |           |
*          M |         d        'U'       |                |      'U'  |
*            |  'L'     'D'               |                |d          |
*            |             d              |              M |  d        |
*             ----------------------------                 |   'D'     |
*                                                          |      d    |
*              IOFFD < 0                                   | 'L'    d  |
*                                                          |          d|
*                  N                                       |           |
*             -----------                                   -----------
*            |    d   'U'|
*            |      d    |                                   IOFFD > 0
*          M |       'D' |
*            |          d|                              N
*            |  'L'      |                 ----------------------------
*            |           |                |          'U'               |
*            |           |                |d                           |
*            |           |                | 'D'                        |
*            |           |                |    d                       |
*            |           |                |'L'   d                     |
*             -----------                  ----------------------------
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, J, JTMP, MN
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
.LE..OR..LE.      IF( M0  N0 )
     $   RETURN
*
*     Start the operations
*
      IF( LSAME( UPLO, 'l' ) ) THEN
*
*        Scales the lower triangular part of the array by ALPHA.
*
         MN = MAX( 0, -IOFFD )
         DO 20 J = 1, MIN( MN, N )
            DO 10 I = 1, M
               A( I, J ) = ALPHA * A( I, J )
   10       CONTINUE
   20    CONTINUE
         DO 40 J = MN + 1, MIN( M - IOFFD, N )
            DO 30 I = J + IOFFD, M
               A( I, J ) = ALPHA * A( I, J )
   30       CONTINUE
   40    CONTINUE
*
      ELSE IF( LSAME( UPLO, 'u' ) ) THEN
*
*        Scales the upper triangular part of the array by ALPHA.
*
         MN = MIN( M - IOFFD, N )
         DO 60 J = MAX( 0, -IOFFD ) + 1, MN
            DO 50 I = 1, J + IOFFD
               A( I, J ) = ALPHA * A( I, J )
   50       CONTINUE
   60    CONTINUE
         DO 80 J = MAX( 0, MN ) + 1, N
            DO 70 I = 1, M
               A( I, J ) = ALPHA * A( I, J )
   70       CONTINUE
   80    CONTINUE
*
      ELSE IF( LSAME( UPLO, 'd' ) ) THEN
*
*        Scales the diagonal entries by ALPHA.
*
         DO 90 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N )
            JTMP = J + IOFFD
            A( JTMP, J ) = ALPHA * A( JTMP, J )
   90    CONTINUE
*
      ELSE
*
*        Scales the entire array by ALPHA.
*
         DO 110 J = 1, N
            DO 100 I = 1, M
               A( I, J ) = ALPHA * A( I, J )
  100       CONTINUE
  110    CONTINUE
*
      END IF
*
      RETURN
*
*     End of PB_ZLASCAL
*
      END
      SUBROUTINE PB_ZLAGEN( UPLO, AFORM, A, LDA, LCMT00, IRAN, MBLKS,
     $                      IMBLOC, MB, LMBLOC, NBLKS, INBLOC, NB,
     $                      LNBLOC, JMP, IMULADD )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1        UPLO, AFORM
      INTEGER            IMBLOC, INBLOC, LCMT00, LDA, LMBLOC, LNBLOC,
     $                   MB, MBLKS, NB, NBLKS
*     ..
*     .. Array Arguments ..
      INTEGER            IMULADD( 4, * ), IRAN( * ), JMP( * )
      COMPLEX*16         A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  PB_ZLAGEN locally initializes an array A.
*
*  Arguments
*  =========
*
*  UPLO    (global input) CHARACTER*1
*          On entry, UPLO  specifies whether the lower (UPLO='L') trape-
*          zoidal part or the upper (UPLO='U') trapezoidal part is to be
*          generated  when  the  matrix  to be generated is symmetric or
*          Hermitian. For  all  the  other values of AFORM, the value of
*          this input argument is ignored.
*
*  AFORM   (global input) CHARACTER*1
*          On entry, AFORM specifies the type of submatrix to be genera-
*          ted as follows:
*             AFORM = 'S', sub( A ) is a symmetric matrix,
*             AFORM = 'H', sub( A ) is a Hermitian matrix,
*             AFORM = 'T', sub( A ) is overrwritten  with  the transpose
*                          of what would normally be generated,
*             AFORM = 'C', sub( A ) is overwritten  with  the  conjugate
*                          transpose  of  what would normally be genera-
*                          ted.
*             AFORM = 'N', a random submatrix is generated.
*
*  A       (local output) COMPLEX*16 array
*          On entry,  A  is  an array of dimension (LLD_A, *).  On exit,
*          this array contains the local entries of the randomly genera-
*          ted submatrix sub( A ).
*
*  LDA     (local input) INTEGER
*          On entry,  LDA  specifies  the local leading dimension of the
*          array A. LDA must be at least one.
*
*  LCMT00  (global input) INTEGER
*          On entry, LCMT00 is the LCM value specifying the off-diagonal
*          of the underlying matrix of interest. LCMT00=0 specifies  the
*          main diagonal, LCMT00 > 0 specifies a subdiagonal, LCMT00 < 0
*          specifies superdiagonals.
*
*  IRAN    (local input) INTEGER array
*          On entry, IRAN  is an array of dimension 2 containing respec-
*          tively the 16-lower and 16-higher bits of the encoding of the
*          entry of  the  random  sequence  corresponding locally to the
*          first local array entry to generate. Usually,  this  array is
*          computed by PB_SETLOCRAN.
*
*  MBLKS   (local input) INTEGER
*          On entry, MBLKS specifies the local number of blocks of rows.
*          MBLKS is at least zero.
*
*  IMBLOC  (local input) INTEGER
*          On entry, IMBLOC specifies  the  number of rows (size) of the
*          local uppest  blocks. IMBLOC is at least zero.
*
*  MB      (global input) INTEGER
*          On entry, MB  specifies the blocking factor used to partition
*          the rows of the matrix.  MB  must be at least one.
*
*  LMBLOC  (local input) INTEGER
*          On entry, LMBLOC specifies the number of  rows  (size) of the
*          local lowest blocks. LMBLOC is at least zero.
*
*  NBLKS   (local input) INTEGER
*          On entry,  NBLKS  specifies the local number of blocks of co-
*          lumns. NBLKS is at least zero.
*
*  INBLOC  (local input) INTEGER
*          On entry,  INBLOC  specifies the number of columns (size)  of
*          the local leftmost blocks. INBLOC is at least zero.
*
*  NB      (global input) INTEGER
*          On entry, NB  specifies the blocking factor used to partition
*          the the columns of the matrix.  NB  must be at least one.
*
*  LNBLOC  (local input) INTEGER
*          On entry,  LNBLOC  specifies  the number of columns (size) of
*          the local rightmost blocks. LNBLOC is at least zero.
*
*  JMP     (local input) INTEGER array
*          On entry, JMP is an array of dimension JMP_LEN containing the
*          different jump values used by the random matrix generator.
*
*  IMULADD (local input) INTEGER array
*          On entry, IMULADD is an array of dimension (4, JMP_LEN).  The
*          jth  column  of this array contains the encoded initial cons-
*          tants a_j and c_j to  jump  from X( n ) to  X( n + JMP( j ) )
*          (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
*          contains respectively the 16-lower and 16-higher bits of  the
*          constant a_j, and IMULADD(3:4,j)  contains  the 16-lower  and
*          16-higher bits of the constant c_j.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
     $                   JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
     $                   JMP_NQINBLOC, JMP_NQNB, JMP_ROW
      PARAMETER          ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3,
     $                   JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6,
     $                   JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9,
     $                   JMP_NQNB = 10, JMP_NQINBLOC = 11,
     $                   JMP_LEN = 11 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IB, IBLK, II, IK, ITMP, JB, JBLK, JJ, JK,
     $                   JTMP, LCMTC, LCMTR, LOW, MNB, UPP
      COMPLEX*16         DUMMY
*     ..
*     .. Local Arrays ..
      INTEGER            IB0( 2 ), IB1( 2 ), IB2( 2 ), IB3( 2 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           PB_JUMPIT
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   PB_DRAND
      EXTERNAL           LSAME, PB_DRAND
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DCMPLX, MAX, MIN
*     ..
*     .. Executable Statements ..
*
      DO 10 I = 1, 2
         IB1( I ) = IRAN( I )
         IB2( I ) = IRAN( I )
         IB3( I ) = IRAN( I )
   10 CONTINUE
*
      IF( LSAME( AFORM, 'n' ) ) THEN
*
*        Generate random matrix
*
         JJ = 1
*
         DO 50 JBLK = 1, NBLKS
*
.EQ.            IF( JBLK1 ) THEN
               JB = INBLOC
.EQ.            ELSE IF( JBLKNBLKS ) THEN
               JB = LNBLOC
            ELSE
               JB = NB
            END IF
*
            DO 40 JK = JJ, JJ + JB - 1
*
               II = 1
*
               DO 30 IBLK = 1, MBLKS
*
.EQ.                  IF( IBLK1 ) THEN
                     IB = IMBLOC
.EQ.                  ELSE IF( IBLKMBLKS ) THEN
                     IB = LMBLOC
                  ELSE
                     IB = MB
                  END IF
*
*                 Blocks are IB by JB
*
                  DO 20 IK = II, II + IB - 1
                     A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
     $                                     PB_DRAND( 0 ) )
   20             CONTINUE
*
                  II = II + IB
*
.EQ.                  IF( IBLK1 ) THEN
*
*                    Jump IMBLOC + ( NPROW - 1 ) * MB rows
*
                     CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1,
     $                               IB0 )
*
                  ELSE
*
*                    Jump NPROW * MB rows
*
                     CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1, IB0 )
*
                  END IF
*
                  IB1( 1 ) = IB0( 1 )
                  IB1( 2 ) = IB0( 2 )
*
   30          CONTINUE
*
*              Jump one column
*
               CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 )
*
               IB1( 1 ) = IB0( 1 )
               IB1( 2 ) = IB0( 2 )
               IB2( 1 ) = IB0( 1 )
               IB2( 2 ) = IB0( 2 )
*
   40       CONTINUE
*
            JJ = JJ + JB
*
.EQ.            IF( JBLK1 ) THEN
*
*              Jump INBLOC + ( NPCOL - 1 ) * NB columns
*
               CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 )
*
            ELSE
*
*              Jump NPCOL * NB columns
*
               CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 )
*
            END IF
*
            IB1( 1 ) = IB0( 1 )
            IB1( 2 ) = IB0( 2 )
            IB2( 1 ) = IB0( 1 )
            IB2( 2 ) = IB0( 2 )
            IB3( 1 ) = IB0( 1 )
            IB3( 2 ) = IB0( 2 )
*
   50    CONTINUE
*
      ELSE IF( LSAME( AFORM, 't' ) ) THEN
*
*        Generate the transpose of the matrix that would be normally
*        generated.
*
         II = 1
*
         DO 90 IBLK = 1, MBLKS
*
.EQ.            IF( IBLK1 ) THEN
               IB = IMBLOC
.EQ.            ELSE IF( IBLKMBLKS ) THEN
               IB = LMBLOC
            ELSE
               IB = MB
            END IF
*
            DO 80 IK = II, II + IB - 1
*
               JJ = 1
*
               DO 70 JBLK = 1, NBLKS
*
.EQ.                  IF( JBLK1 ) THEN
                     JB = INBLOC
.EQ.                  ELSE IF( JBLKNBLKS ) THEN
                     JB = LNBLOC
                  ELSE
                     JB = NB
                  END IF
*
*                 Blocks are IB by JB
*
                  DO 60 JK = JJ, JJ + JB - 1
                     A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
     $                                     PB_DRAND( 0 ) )
   60             CONTINUE
*
                  JJ = JJ + JB
*
.EQ.                  IF( JBLK1 ) THEN
*
*                    Jump INBLOC + ( NPCOL - 1 ) * NB columns
*
                     CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
     $                               IB0 )
*
                  ELSE
*
*                    Jump NPCOL * NB columns
*
                     CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1, IB0 )
*
                  END IF
*
                  IB1( 1 ) = IB0( 1 )
                  IB1( 2 ) = IB0( 2 )
*
   70          CONTINUE
*
*              Jump one row
*
               CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
*
               IB1( 1 ) = IB0( 1 )
               IB1( 2 ) = IB0( 2 )
               IB2( 1 ) = IB0( 1 )
               IB2( 2 ) = IB0( 2 )
*
   80       CONTINUE
*
            II = II + IB
*
.EQ.            IF( IBLK1 ) THEN
*
*              Jump IMBLOC + ( NPROW - 1 ) * MB rows
*
               CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
*
            ELSE
*
*              Jump NPROW * MB rows
*
               CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
*
            END IF
*
            IB1( 1 ) = IB0( 1 )
            IB1( 2 ) = IB0( 2 )
            IB2( 1 ) = IB0( 1 )
            IB2( 2 ) = IB0( 2 )
            IB3( 1 ) = IB0( 1 )
            IB3( 2 ) = IB0( 2 )
*
   90    CONTINUE
*
      ELSE IF( LSAME( AFORM, 's' ) ) THEN
*
*        Generate a symmetric matrix
*
         IF( LSAME( UPLO, 'l' ) ) THEN
*
*           generate lower trapezoidal part
*
            JJ = 1
            LCMTC = LCMT00
*
            DO 170 JBLK = 1, NBLKS
*
.EQ.               IF( JBLK1 ) THEN
                  JB  = INBLOC
                  LOW = 1 - INBLOC
.EQ.               ELSE IF( JBLKNBLKS ) THEN
                  JB = LNBLOC
                  LOW = 1 - NB
               ELSE
                  JB  = NB
                  LOW = 1 - NB
               END IF
*
               DO 160 JK = JJ, JJ + JB - 1
*
                  II = 1
                  LCMTR = LCMTC
*
                  DO 150 IBLK = 1, MBLKS
*
.EQ.                     IF( IBLK1 ) THEN
                        IB  = IMBLOC
                        UPP = IMBLOC - 1
.EQ.                     ELSE IF( IBLKMBLKS ) THEN
                        IB  = LMBLOC
                        UPP = MB - 1
                     ELSE
                        IB  = MB
                        UPP = MB - 1
                     END IF
*
*                    Blocks are IB by JB
*
.GT.                     IF( LCMTRUPP ) THEN
*
                        DO 100 IK = II, II + IB - 1
                           DUMMY = DCMPLX( PB_DRAND( 0 ),
     $                                     PB_DRAND( 0 ) )
  100                   CONTINUE
*
.GE.                     ELSE IF( LCMTRLOW ) THEN
*
                        JTMP = JK - JJ + 1
                        MNB  = MAX( 0, -LCMTR )
*
.LE.                        IF( JTMPMIN( MNB, JB ) ) THEN
*
                           DO 110 IK = II, II + IB - 1
                              A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
     $                                              PB_DRAND( 0 ) )
  110                      CONTINUE
*
.GE..AND.                        ELSE IF( ( JTMP( MNB + 1 )         ) 
.LE.     $                           ( JTMPMIN( IB-LCMTR, JB ) ) ) THEN
*
                           ITMP = II + JTMP + LCMTR - 1
*
                           DO 120 IK = II, ITMP - 1
                              DUMMY = DCMPLX( PB_DRAND( 0 ),
     $                                        PB_DRAND( 0 ) )
  120                      CONTINUE
*
                           DO 130 IK = ITMP, II + IB - 1
                              A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
     $                                              PB_DRAND( 0 ) )
  130                      CONTINUE
*
                        END IF
*
                     ELSE
*
                        DO 140 IK = II, II + IB - 1
                           A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
     $                                           PB_DRAND( 0 ) )
  140                   CONTINUE
*
                     END IF
*
                     II = II + IB
*
.EQ.                     IF( IBLK1 ) THEN
*
*                       Jump IMBLOC + ( NPROW - 1 ) * MB rows
*
                        LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
                        CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1,
     $                                  IB0 )
*
                     ELSE
*
*                       Jump NPROW * MB rows
*
                        LCMTR = LCMTR - JMP( JMP_NPMB )
                        CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1,
     $                                  IB0 )
*
                     END IF
*
                     IB1( 1 ) = IB0( 1 )
                     IB1( 2 ) = IB0( 2 )
*
  150             CONTINUE
*
*                 Jump one column
*
                  CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 )
*
                  IB1( 1 ) = IB0( 1 )
                  IB1( 2 ) = IB0( 2 )
                  IB2( 1 ) = IB0( 1 )
                  IB2( 2 ) = IB0( 2 )
*
  160          CONTINUE
*
               JJ = JJ + JB
*
.EQ.               IF( JBLK1 ) THEN
*
*                 Jump INBLOC + ( NPCOL - 1 ) * NB columns
*
                  LCMTC = LCMTC + JMP( JMP_NQINBLOC )
                  CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 )
*
               ELSE
*
*                 Jump NPCOL * NB columns
*
                  LCMTC = LCMTC + JMP( JMP_NQNB )
                  CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 )
*
               END IF
*
               IB1( 1 ) = IB0( 1 )
               IB1( 2 ) = IB0( 2 )
               IB2( 1 ) = IB0( 1 )
               IB2( 2 ) = IB0( 2 )
               IB3( 1 ) = IB0( 1 )
               IB3( 2 ) = IB0( 2 )
*
  170       CONTINUE
*
         ELSE
*
*           generate upper trapezoidal part
*
            II = 1
            LCMTR = LCMT00
*
            DO 250 IBLK = 1, MBLKS
*
.EQ.               IF( IBLK1 ) THEN
                  IB  = IMBLOC
                  UPP = IMBLOC - 1
.EQ.               ELSE IF( IBLKMBLKS ) THEN
                  IB  = LMBLOC
                  UPP = MB - 1
               ELSE
                  IB  = MB
                  UPP = MB - 1
               END IF
*
               DO 240 IK = II, II + IB - 1
*
                  JJ = 1
                  LCMTC = LCMTR
*
                  DO 230 JBLK = 1, NBLKS
*
.EQ.                     IF( JBLK1 ) THEN
                        JB  = INBLOC
                        LOW = 1 - INBLOC
.EQ.                     ELSE IF( JBLKNBLKS ) THEN
                        JB  = LNBLOC
                        LOW = 1 - NB
                     ELSE
                        JB  = NB
                        LOW = 1 - NB
                     END IF
*
*                    Blocks are IB by JB
*
.LT.                     IF( LCMTCLOW ) THEN
*
                        DO 180 JK = JJ, JJ + JB - 1
                           DUMMY = DCMPLX( PB_DRAND( 0 ),
     $                                     PB_DRAND( 0 ) )
  180                   CONTINUE
*
.LE.                     ELSE IF( LCMTCUPP ) THEN
*
                        ITMP = IK - II + 1
                        MNB  = MAX( 0, LCMTC )
*
.LE.                        IF( ITMPMIN( MNB, IB ) ) THEN
*
                           DO 190 JK = JJ, JJ + JB - 1
                              A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
     $                                              PB_DRAND( 0 ) )
  190                      CONTINUE
*
.GE..AND.                        ELSE IF( ( ITMP( MNB + 1 )         ) 
.LE.     $                           ( ITMPMIN( JB+LCMTC, IB ) ) ) THEN
*
                           JTMP = JJ + ITMP - LCMTC - 1
*
                           DO 200 JK = JJ, JTMP - 1
                              DUMMY = DCMPLX( PB_DRAND( 0 ),
     $                                        PB_DRAND( 0 ) )
  200                      CONTINUE
*
                           DO 210 JK = JTMP, JJ + JB - 1
                              A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
     $                                              PB_DRAND( 0 ) )
  210                      CONTINUE
*
                        END IF
*
                     ELSE
*
                        DO 220 JK = JJ, JJ + JB - 1
                           A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
     $                                           PB_DRAND( 0 ) )
  220                   CONTINUE
*
                     END IF
*
                     JJ = JJ + JB
*
.EQ.                     IF( JBLK1 ) THEN
*
*                       Jump INBLOC + ( NPCOL - 1 ) * NB columns
*
                        LCMTC = LCMTC + JMP( JMP_NQINBLOC )
                        CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
     $                                  IB0 )
*
                     ELSE
*
*                       Jump NPCOL * NB columns
*
                        LCMTC = LCMTC + JMP( JMP_NQNB )
                        CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1,
     $                                  IB0 )
*
                     END IF
*
                     IB1( 1 ) = IB0( 1 )
                     IB1( 2 ) = IB0( 2 )
*
  230             CONTINUE
*
*                 Jump one row
*
                  CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
*
                  IB1( 1 ) = IB0( 1 )
                  IB1( 2 ) = IB0( 2 )
                  IB2( 1 ) = IB0( 1 )
                  IB2( 2 ) = IB0( 2 )
*
  240          CONTINUE
*
               II = II + IB
*
.EQ.               IF( IBLK1 ) THEN
*
*                 Jump IMBLOC + ( NPROW - 1 ) * MB rows
*
                  LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
                  CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
*
               ELSE
*
*                 Jump NPROW * MB rows
*
                  LCMTR = LCMTR - JMP( JMP_NPMB )
                  CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
*
               END IF
*
               IB1( 1 ) = IB0( 1 )
               IB1( 2 ) = IB0( 2 )
               IB2( 1 ) = IB0( 1 )
               IB2( 2 ) = IB0( 2 )
               IB3( 1 ) = IB0( 1 )
               IB3( 2 ) = IB0( 2 )
*
  250       CONTINUE
*
         END IF
*
      ELSE IF( LSAME( AFORM, 'c' ) ) THEN
*
*        Generate the conjugate transpose of the matrix that would be
*        normally generated.
*
         II = 1
*
         DO 290 IBLK = 1, MBLKS
*
.EQ.            IF( IBLK1 ) THEN
               IB = IMBLOC
.EQ.            ELSE IF( IBLKMBLKS ) THEN
               IB = LMBLOC
            ELSE
               IB = MB
            END IF
*
            DO 280 IK = II, II + IB - 1
*
               JJ = 1
*
               DO 270 JBLK = 1, NBLKS
*
.EQ.                  IF( JBLK1 ) THEN
                     JB = INBLOC
.EQ.                  ELSE IF( JBLKNBLKS ) THEN
                     JB = LNBLOC
                  ELSE
                     JB = NB
                  END IF
*
*                 Blocks are IB by JB
*
                  DO 260 JK = JJ, JJ + JB - 1
                     A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
     $                                    -PB_DRAND( 0 ) )
  260             CONTINUE
*
                  JJ = JJ + JB
*
.EQ.                  IF( JBLK1 ) THEN
*
*                    Jump INBLOC + ( NPCOL - 1 ) * NB columns
*
                     CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
     $                               IB0 )
*
                  ELSE
*
*                    Jump NPCOL * NB columns
*
                     CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1,
     $                               IB0 )
*
                  END IF
*
                  IB1( 1 ) = IB0( 1 )
                  IB1( 2 ) = IB0( 2 )
*
  270          CONTINUE
*
*              Jump one row
*
               CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
*
               IB1( 1 ) = IB0( 1 )
               IB1( 2 ) = IB0( 2 )
               IB2( 1 ) = IB0( 1 )
               IB2( 2 ) = IB0( 2 )
*
  280       CONTINUE
*
            II = II + IB
*
.EQ.            IF( IBLK1 ) THEN
*
*              Jump IMBLOC + ( NPROW - 1 ) * MB rows
*
               CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
*
            ELSE
*
*              Jump NPROW * MB rows
*
               CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
*
            END IF
*
            IB1( 1 ) = IB0( 1 )
            IB1( 2 ) = IB0( 2 )
            IB2( 1 ) = IB0( 1 )
            IB2( 2 ) = IB0( 2 )
            IB3( 1 ) = IB0( 1 )
            IB3( 2 ) = IB0( 2 )
*
  290    CONTINUE
*
      ELSE IF( LSAME( AFORM, 'h' ) ) THEN
*
*        Generate a Hermitian matrix
*
         IF( LSAME( UPLO, 'l' ) ) THEN
*
*           generate lower trapezoidal part
*
            JJ = 1
            LCMTC = LCMT00
*
            DO 370 JBLK = 1, NBLKS
*
.EQ.               IF( JBLK1 ) THEN
                  JB  = INBLOC
                  LOW = 1 - INBLOC
.EQ.               ELSE IF( JBLKNBLKS ) THEN
                  JB = LNBLOC
                  LOW = 1 - NB
               ELSE
                  JB  = NB
                  LOW = 1 - NB
               END IF
*
               DO 360 JK = JJ, JJ + JB - 1
*
                  II = 1
                  LCMTR = LCMTC
*
                  DO 350 IBLK = 1, MBLKS
*
.EQ.                     IF( IBLK1 ) THEN
                        IB  = IMBLOC
                        UPP = IMBLOC - 1
.EQ.                     ELSE IF( IBLKMBLKS ) THEN
                        IB  = LMBLOC
                        UPP = MB - 1
                     ELSE
                        IB  = MB
                        UPP = MB - 1
                     END IF
*
*                    Blocks are IB by JB
*
.GT.                     IF( LCMTRUPP ) THEN
*
                        DO 300 IK = II, II + IB - 1
                           DUMMY = DCMPLX( PB_DRAND( 0 ),
     $                                     PB_DRAND( 0 ) )
  300                   CONTINUE
*
.GE.                     ELSE IF( LCMTRLOW ) THEN
*
                        JTMP = JK - JJ + 1
                        MNB  = MAX( 0, -LCMTR )
*
.LE.                        IF( JTMPMIN( MNB, JB ) ) THEN
*
                           DO 310 IK = II, II + IB - 1
                              A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
     $                                              PB_DRAND( 0 ) )
  310                      CONTINUE
*
.GE..AND.                        ELSE IF( ( JTMP( MNB + 1 )         ) 
.LE.     $                           ( JTMPMIN( IB-LCMTR, JB ) ) ) THEN
*
                           ITMP = II + JTMP + LCMTR - 1
*
                           DO 320 IK = II, ITMP - 1
                              DUMMY = DCMPLX( PB_DRAND( 0 ),
     $                                        PB_DRAND( 0 ) )
  320                      CONTINUE
*
.LE.                           IF( ITMP( II + IB - 1 ) ) THEN
                              DUMMY = DCMPLX( PB_DRAND( 0 ),
     $                                       -PB_DRAND( 0 ) )
                              A( ITMP, JK ) = DCMPLX( DBLE( DUMMY ),
     $                                                ZERO )
                           END IF
*
                           DO 330 IK = ITMP + 1, II + IB - 1
                              A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
     $                                              PB_DRAND( 0 ) )
  330                      CONTINUE
*
                        END IF
*
                     ELSE
*
                        DO 340 IK = II, II + IB - 1
                           A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
     $                                           PB_DRAND( 0 ) )
  340                   CONTINUE
*
                     END IF
*
                     II = II + IB
*
.EQ.                     IF( IBLK1 ) THEN
*
*                       Jump IMBLOC + ( NPROW - 1 ) * MB rows
*
                        LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
                        CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1,
     $                                  IB0 )
*
                     ELSE
*
*                       Jump NPROW * MB rows
*
                        LCMTR = LCMTR - JMP( JMP_NPMB )
                        CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1,
     $                                  IB0 )
*
                     END IF
*
                     IB1( 1 ) = IB0( 1 )
                     IB1( 2 ) = IB0( 2 )
*
  350             CONTINUE
*
*                 Jump one column
*
                  CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 )
*
                  IB1( 1 ) = IB0( 1 )
                  IB1( 2 ) = IB0( 2 )
                  IB2( 1 ) = IB0( 1 )
                  IB2( 2 ) = IB0( 2 )
*
  360          CONTINUE
*
               JJ = JJ + JB
*
.EQ.               IF( JBLK1 ) THEN
*
*                 Jump INBLOC + ( NPCOL - 1 ) * NB columns
*
                  LCMTC = LCMTC + JMP( JMP_NQINBLOC )
                  CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 )
*
               ELSE
*
*                 Jump NPCOL * NB columns
*
                  LCMTC = LCMTC + JMP( JMP_NQNB )
                  CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 )
*
               END IF
*
               IB1( 1 ) = IB0( 1 )
               IB1( 2 ) = IB0( 2 )
               IB2( 1 ) = IB0( 1 )
               IB2( 2 ) = IB0( 2 )
               IB3( 1 ) = IB0( 1 )
               IB3( 2 ) = IB0( 2 )
*
  370       CONTINUE
*
         ELSE
*
*           generate upper trapezoidal part
*
            II = 1
            LCMTR = LCMT00
*
            DO 450 IBLK = 1, MBLKS
*
.EQ.               IF( IBLK1 ) THEN
                  IB  = IMBLOC
                  UPP = IMBLOC - 1
.EQ.               ELSE IF( IBLKMBLKS ) THEN
                  IB  = LMBLOC
                  UPP = MB - 1
               ELSE
                  IB  = MB
                  UPP = MB - 1
               END IF
*
               DO 440 IK = II, II + IB - 1
*
                  JJ = 1
                  LCMTC = LCMTR
*
                  DO 430 JBLK = 1, NBLKS
*
.EQ.                     IF( JBLK1 ) THEN
                        JB  = INBLOC
                        LOW = 1 - INBLOC
.EQ.                     ELSE IF( JBLKNBLKS ) THEN
                        JB  = LNBLOC
                        LOW = 1 - NB
                     ELSE
                        JB  = NB
                        LOW = 1 - NB
                     END IF
*
*                    Blocks are IB by JB
*
.LT.                     IF( LCMTCLOW ) THEN
*
                        DO 380 JK = JJ, JJ + JB - 1
                           DUMMY = DCMPLX( PB_DRAND( 0 ),
     $                                    -PB_DRAND( 0 ) )
  380                   CONTINUE
*
.LE.                     ELSE IF( LCMTCUPP ) THEN
*
                        ITMP = IK - II + 1
                        MNB  = MAX( 0, LCMTC )
*
.LE.                        IF( ITMPMIN( MNB, IB ) ) THEN
*
                           DO 390 JK = JJ, JJ + JB - 1
                              A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
     $                                             -PB_DRAND( 0 ) )
  390                      CONTINUE
*
.GE..AND.                        ELSE IF( ( ITMP( MNB + 1 )         ) 
.LE.     $                           ( ITMPMIN( JB+LCMTC, IB ) ) ) THEN
*
                           JTMP = JJ + ITMP - LCMTC - 1
*
                           DO 400 JK = JJ, JTMP - 1
                              DUMMY = DCMPLX( PB_DRAND( 0 ),
     $                                       -PB_DRAND( 0 ) )
  400                      CONTINUE
*
.LE.                           IF( JTMP( JJ + JB - 1 ) ) THEN
                              DUMMY = DCMPLX( PB_DRAND( 0 ),
     $                                       -PB_DRAND( 0 ) )
                              A( IK, JTMP ) = DCMPLX( DBLE( DUMMY ),
     $                                                ZERO )
                           END IF
*
                           DO 410 JK = JTMP + 1, JJ + JB - 1
                              A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
     $                                             -PB_DRAND( 0 ) )
  410                      CONTINUE
*
                        END IF
*
                     ELSE
*
                        DO 420 JK = JJ, JJ + JB - 1
                           A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
     $                                          -PB_DRAND( 0 ) )
  420                   CONTINUE
*
                     END IF
*
                     JJ = JJ + JB
*
.EQ.                     IF( JBLK1 ) THEN
*
*                       Jump INBLOC + ( NPCOL - 1 ) * NB columns
*
                        LCMTC = LCMTC + JMP( JMP_NQINBLOC )
                        CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
     $                                  IB0 )
*
                     ELSE
*
*                       Jump NPCOL * NB columns
*
                        LCMTC = LCMTC + JMP( JMP_NQNB )
                        CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1,
     $                                  IB0 )
*
                     END IF
*
                     IB1( 1 ) = IB0( 1 )
                     IB1( 2 ) = IB0( 2 )
*
  430             CONTINUE
*
*                 Jump one row
*
                  CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
*
                  IB1( 1 ) = IB0( 1 )
                  IB1( 2 ) = IB0( 2 )
                  IB2( 1 ) = IB0( 1 )
                  IB2( 2 ) = IB0( 2 )
*
  440          CONTINUE
*
               II = II + IB
*
.EQ.               IF( IBLK1 ) THEN
*
*                 Jump IMBLOC + ( NPROW - 1 ) * MB rows
*
                  LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
                  CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
*
               ELSE
*
*                 Jump NPROW * MB rows
*
                  LCMTR = LCMTR - JMP( JMP_NPMB )
                  CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
*
               END IF
*
               IB1( 1 ) = IB0( 1 )
               IB1( 2 ) = IB0( 2 )
               IB2( 1 ) = IB0( 1 )
               IB2( 2 ) = IB0( 2 )
               IB3( 1 ) = IB0( 1 )
               IB3( 2 ) = IB0( 2 )
*
  450       CONTINUE
*
         END IF
*
      END IF
*
      RETURN
*
*     End of PB_ZLAGEN
*
      END
      DOUBLE PRECISION   FUNCTION PB_DRAND( IDUMM )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER            IDUMM
*     ..
*
*  Purpose
*  =======
*
*  PB_DRAND generates the next number in the random sequence. This func-
*  tion ensures that this number will be in the interval ( -1.0, 1.0 ).
*
*  Arguments
*  =========
*
*  IDUMM   (local input) INTEGER
*          This argument is ignored, but necessary to a FORTRAN 77 func-
*          tion.
*
*  Further Details
*  ===============
*
*  On entry, the array IRAND stored in the common block  RANCOM contains
*  the information (2 integers)  required to generate the next number in
*  the sequence X( n ). This number is computed as
*
*     X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
*
*  where the constant d is the  largest  32 bit  positive  integer.  The
*  array  IRAND  is  then  updated for the generation of the next number
*  X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
*  The constants  a  and c  should have been preliminarily stored in the
*  array  IACS  as  2 pairs of integers. The initial set up of IRAND and
*  IACS is performed by the routine PB_SETRAN.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, TWO
      PARAMETER          ( ONE = 1.0D+0, TWO = 2.0D+0 )
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   PB_DRAN
      EXTERNAL           PB_DRAN
*     ..
*     .. Executable Statements ..
*
      PB_DRAND = ONE - TWO * PB_DRAN( IDUMM )
*
      RETURN
*
*     End of PB_DRAND
*
      END
      DOUBLE PRECISION   FUNCTION PB_DRAN( IDUMM )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER            IDUMM
*     ..
*
*  Purpose
*  =======
*
*  PB_DRAN generates the next number in the random sequence.
*
*  Arguments
*  =========
*
*  IDUMM   (local input) INTEGER
*          This argument is ignored, but necessary to a FORTRAN 77 func-
*          tion.
*
*  Further Details
*  ===============
*
*  On entry, the array IRAND stored in the common block  RANCOM contains
*  the information (2 integers)  required to generate the next number in
*  the sequence X( n ). This number is computed as
*
*     X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
*
*  where the constant d is the  largest  32 bit  positive  integer.  The
*  array  IRAND  is  then  updated for the generation of the next number
*  X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
*  The constants  a  and c  should have been preliminarily stored in the
*  array  IACS  as  2 pairs of integers. The initial set up of IRAND and
*  IACS is performed by the routine PB_SETRAN.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   DIVFAC, POW16
      PARAMETER          ( DIVFAC = 2.147483648D+9,
     $                   POW16 = 6.5536D+4 )
*     ..
*     .. Local Arrays ..
      INTEGER            J( 2 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           PB_LADD, PB_LMUL
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE
*     ..
*     .. Common Blocks ..
      INTEGER            IACS( 4 ), IRAND( 2 )
      COMMON             /RANCOM/ IRAND, IACS
*     ..
*     .. Save Statements ..
      SAVE               /RANCOM/
*     ..
*     .. Executable Statements ..
*
      PB_DRAN = ( DBLE( IRAND( 1 ) ) + POW16 * DBLE( IRAND( 2 ) ) ) /
     $            DIVFAC
*
      CALL PB_LMUL( IRAND, IACS, J )
      CALL PB_LADD( J, IACS( 3 ), IRAND )
*
      RETURN
*
*     End of PB_DRAN
*
      END