ScaLAPACK  2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
pzblastst.f
Go to the documentation of this file.
00001       SUBROUTINE PZOPTEE( ICTXT, NOUT, SUBPTR, SCODE, SNAME )
00002 *
00003 *  -- PBLAS test routine (version 2.0) --
00004 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
00005 *     and University of California, Berkeley.
00006 *     April 1, 1998
00007 *
00008 *     .. Scalar Arguments ..
00009       INTEGER            ICTXT, NOUT, SCODE
00010 *     ..
00011 *     .. Array Arguments ..
00012       CHARACTER*(*)      SNAME
00013 *     ..
00014 *     .. Subroutine Arguments ..
00015       EXTERNAL           SUBPTR
00016 *     ..
00017 *
00018 *  Purpose
00019 *  =======
00020 *
00021 *  PZOPTEE  tests  whether  the  PBLAS respond correctly to a bad option
00022 *  argument.
00023 *
00024 *  Notes
00025 *  =====
00026 *
00027 *  A description  vector  is associated with each 2D block-cyclicly dis-
00028 *  tributed matrix.  This  vector  stores  the  information  required to
00029 *  establish the  mapping  between a  matrix entry and its corresponding
00030 *  process and memory location.
00031 *
00032 *  In  the  following  comments,   the character _  should  be  read  as
00033 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
00034 *  block cyclicly distributed matrix.  Its description vector is DESCA:
00035 *
00036 *  NOTATION         STORED IN       EXPLANATION
00037 *  ---------------- --------------- ------------------------------------
00038 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
00039 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
00040 *                                   the NPROW x NPCOL BLACS process grid
00041 *                                   A  is distributed over.  The context
00042 *                                   itself  is  global,  but  the handle
00043 *                                   (the integer value) may vary.
00044 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
00045 *                                   ted matrix A, M_A >= 0.
00046 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
00047 *                                   buted matrix A, N_A >= 0.
00048 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
00049 *                                   block of the matrix A, IMB_A > 0.
00050 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
00051 *                                   left   block   of   the   matrix  A,
00052 *                                   INB_A > 0.
00053 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
00054 *                                   bute the last  M_A-IMB_A rows of  A,
00055 *                                   MB_A > 0.
00056 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
00057 *                                   bute the last  N_A-INB_A  columns of
00058 *                                   A, NB_A > 0.
00059 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
00060 *                                   row of the matrix  A is distributed,
00061 *                                   NPROW > RSRC_A >= 0.
00062 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
00063 *                                   first  column of  A  is distributed.
00064 *                                   NPCOL > CSRC_A >= 0.
00065 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
00066 *                                   array  storing  the  local blocks of
00067 *                                   the distributed matrix A,
00068 *                                   IF( Lc( 1, N_A ) > 0 )
00069 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
00070 *                                   ELSE
00071 *                                      LLD_A >= 1.
00072 *
00073 *  Let K be the number of  rows of a matrix A starting at the global in-
00074 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
00075 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
00076 *  receive if these K rows were distributed over NPROW processes.  If  K
00077 *  is the number of columns of a matrix  A  starting at the global index
00078 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
00079 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
00080 *  these K columns were distributed over NPCOL processes.
00081 *
00082 *  The values of Lr() and Lc() may be determined via a call to the func-
00083 *  tion PB_NUMROC:
00084 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
00085 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
00086 *
00087 *  Arguments
00088 *  =========
00089 *
00090 *  ICTXT   (local input) INTEGER
00091 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
00092 *          ting the global  context of the operation. The context itself
00093 *          is global, but the value of ICTXT is local.
00094 *
00095 *  NOUT    (global input) INTEGER
00096 *          On entry, NOUT specifies the unit number for the output file.
00097 *          When NOUT is 6, output to screen,  when  NOUT is 0, output to
00098 *          stderr. NOUT is only defined for process 0.
00099 *
00100 *  SUBPTR  (global input) SUBROUTINE
00101 *          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
00102 *          EXTERNAL in the calling subroutine.
00103 *
00104 *  SCODE   (global input) INTEGER
00105 *          On entry, SCODE specifies the calling sequence code.
00106 *
00107 *  SNAME   (global input) CHARACTER*(*)
00108 *          On entry,  SNAME  specifies  the subroutine name calling this
00109 *          subprogram.
00110 *
00111 *  Calling sequence encodings
00112 *  ==========================
00113 *
00114 *  code Formal argument list                                Examples
00115 *
00116 *  11   (n,      v1,v2)                                     _SWAP, _COPY
00117 *  12   (n,s1,   v1   )                                     _SCAL, _SCAL
00118 *  13   (n,s1,   v1,v2)                                     _AXPY, _DOT_
00119 *  14   (n,s1,i1,v1   )                                     _AMAX
00120 *  15   (n,u1,   v1   )                                     _ASUM, _NRM2
00121 *
00122 *  21   (     trans,     m,n,s1,m1,v1,s2,v2)                _GEMV
00123 *  22   (uplo,             n,s1,m1,v1,s2,v2)                _SYMV, _HEMV
00124 *  23   (uplo,trans,diag,  n,   m1,v1      )                _TRMV, _TRSV
00125 *  24   (                m,n,s1,v1,v2,m1)                   _GER_
00126 *  25   (uplo,             n,s1,v1,   m1)                   _SYR
00127 *  26   (uplo,             n,u1,v1,   m1)                   _HER
00128 *  27   (uplo,             n,s1,v1,v2,m1)                   _SYR2, _HER2
00129 *
00130 *  31   (          transa,transb,     m,n,k,s1,m1,m2,s2,m3) _GEMM
00131 *  32   (side,uplo,                   m,n,  s1,m1,m2,s2,m3) _SYMM, _HEMM
00132 *  33   (     uplo,trans,               n,k,s1,m1,   s2,m3) _SYRK
00133 *  34   (     uplo,trans,               n,k,u1,m1,   u2,m3) _HERK
00134 *  35   (     uplo,trans,               n,k,s1,m1,m2,s2,m3) _SYR2K
00135 *  36   (     uplo,trans,               n,k,s1,m1,m2,u2,m3) _HER2K
00136 *  37   (                             m,n,  s1,m1,   s2,m3) _TRAN_
00137 *  38   (side,uplo,transa,       diag,m,n,  s1,m1,m2      ) _TRMM, _TRSM
00138 *  39   (          trans,             m,n,  s1,m1,   s2,m3) _GEADD
00139 *  40   (     uplo,trans,             m,n,  s1,m1,   s2,m3) _TRADD
00140 *
00141 *  -- Written on April 1, 1998 by
00142 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
00143 *
00144 *  =====================================================================
00145 *
00146 *     .. Local Scalars ..
00147       INTEGER             APOS
00148 *     ..
00149 *     .. External Subroutines ..
00150       EXTERNAL            PZCHKOPT
00151 *     ..
00152 *     .. Executable Statements ..
00153 *
00154 *     Level 2 PBLAS
00155 *
00156       IF( SCODE.EQ.21 ) THEN
00157 *
00158 *        Check 1st (and only) option
00159 *
00160          APOS = 1
00161          CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
00162 *
00163       ELSE IF( SCODE.EQ.22 .OR. SCODE.EQ.25 .OR. SCODE.EQ.26 .OR.
00164      $         SCODE.EQ.27 ) THEN
00165 *
00166 *        Check 1st (and only) option
00167 *
00168          APOS = 1
00169          CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS )
00170 *
00171       ELSE IF( SCODE.EQ.23 ) THEN
00172 *
00173 *        Check 1st option
00174 *
00175          APOS = 1
00176          CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS )
00177 *
00178 *        Check 2nd option
00179 *
00180          APOS = 2
00181          CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
00182 *
00183 *        Check 3rd option
00184 *
00185          APOS = 3
00186          CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'D', APOS )
00187 *
00188 *     Level 3 PBLAS
00189 *
00190       ELSE IF( SCODE.EQ.31 ) THEN
00191 *
00192 *        Check 1st option
00193 *
00194          APOS = 1
00195          CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
00196 *
00197 *        Check 2'nd option
00198 *
00199          APOS = 2
00200          CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'B', APOS )
00201 *
00202       ELSE IF( SCODE.EQ.32 ) THEN
00203 *
00204 *        Check 1st option
00205 *
00206          APOS = 1
00207          CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'S', APOS )
00208 *
00209 *        Check 2nd option
00210 *
00211          APOS = 2
00212          CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS )
00213 *
00214       ELSE IF( SCODE.EQ.33 .OR. SCODE.EQ.34 .OR. SCODE.EQ.35 .OR.
00215      $         SCODE.EQ.36 .OR. SCODE.EQ.40 ) THEN
00216 *
00217 *        Check 1st option
00218 *
00219          APOS = 1
00220          CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS )
00221 *
00222 *        Check 2'nd option
00223 *
00224          APOS = 2
00225          CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
00226 *
00227       ELSE IF( SCODE.EQ.38 ) THEN
00228 *
00229 *        Check 1st option
00230 *
00231          APOS = 1
00232          CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'S', APOS )
00233 *
00234 *        Check 2nd option
00235 *
00236          APOS = 2
00237          CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS )
00238 *
00239 *        Check 3rd option
00240 *
00241          APOS = 3
00242          CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
00243 *
00244 *        Check 4th option
00245 *
00246          APOS = 4
00247          CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'D', APOS )
00248 *
00249 *
00250       ELSE IF( SCODE.EQ.39 ) THEN
00251 *
00252 *        Check 1st option
00253 *
00254          APOS = 1
00255          CALL PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
00256 *
00257       END IF
00258 *
00259       RETURN
00260 *
00261 *     End of PZOPTEE
00262 *
00263       END
00264       SUBROUTINE PZCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, ARGNAM,
00265      $                     ARGPOS )
00266 *
00267 *  -- PBLAS test routine (version 2.0) --
00268 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
00269 *     and University of California, Berkeley.
00270 *     April 1, 1998
00271 *
00272 *     .. Scalar Arguments ..
00273       CHARACTER*1         ARGNAM
00274       INTEGER             ARGPOS, ICTXT, NOUT, SCODE
00275 *     ..
00276 *     .. Array Arguments ..
00277       CHARACTER*(*)       SNAME
00278 *     ..
00279 *     .. Subroutine Arguments ..
00280       EXTERNAL            SUBPTR
00281 *     ..
00282 *
00283 *  Purpose
00284 *  =======
00285 *
00286 *  PZCHKOPT tests the option ARGNAM in any PBLAS routine.
00287 *
00288 *  Notes
00289 *  =====
00290 *
00291 *  A description  vector  is associated with each 2D block-cyclicly dis-
00292 *  tributed matrix.  This  vector  stores  the  information  required to
00293 *  establish the  mapping  between a  matrix entry and its corresponding
00294 *  process and memory location.
00295 *
00296 *  In  the  following  comments,   the character _  should  be  read  as
00297 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
00298 *  block cyclicly distributed matrix.  Its description vector is DESCA:
00299 *
00300 *  NOTATION         STORED IN       EXPLANATION
00301 *  ---------------- --------------- ------------------------------------
00302 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
00303 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
00304 *                                   the NPROW x NPCOL BLACS process grid
00305 *                                   A  is distributed over.  The context
00306 *                                   itself  is  global,  but  the handle
00307 *                                   (the integer value) may vary.
00308 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
00309 *                                   ted matrix A, M_A >= 0.
00310 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
00311 *                                   buted matrix A, N_A >= 0.
00312 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
00313 *                                   block of the matrix A, IMB_A > 0.
00314 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
00315 *                                   left   block   of   the   matrix  A,
00316 *                                   INB_A > 0.
00317 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
00318 *                                   bute the last  M_A-IMB_A rows of  A,
00319 *                                   MB_A > 0.
00320 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
00321 *                                   bute the last  N_A-INB_A  columns of
00322 *                                   A, NB_A > 0.
00323 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
00324 *                                   row of the matrix  A is distributed,
00325 *                                   NPROW > RSRC_A >= 0.
00326 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
00327 *                                   first  column of  A  is distributed.
00328 *                                   NPCOL > CSRC_A >= 0.
00329 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
00330 *                                   array  storing  the  local blocks of
00331 *                                   the distributed matrix A,
00332 *                                   IF( Lc( 1, N_A ) > 0 )
00333 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
00334 *                                   ELSE
00335 *                                      LLD_A >= 1.
00336 *
00337 *  Let K be the number of  rows of a matrix A starting at the global in-
00338 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
00339 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
00340 *  receive if these K rows were distributed over NPROW processes.  If  K
00341 *  is the number of columns of a matrix  A  starting at the global index
00342 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
00343 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
00344 *  these K columns were distributed over NPCOL processes.
00345 *
00346 *  The values of Lr() and Lc() may be determined via a call to the func-
00347 *  tion PB_NUMROC:
00348 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
00349 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
00350 *
00351 *  Arguments
00352 *  =========
00353 *
00354 *  ICTXT   (local input) INTEGER
00355 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
00356 *          ting the global  context of the operation. The context itself
00357 *          is global, but the value of ICTXT is local.
00358 *
00359 *  NOUT    (global input) INTEGER
00360 *          On entry, NOUT specifies the unit number for the output file.
00361 *          When NOUT is 6, output to screen,  when  NOUT is 0, output to
00362 *          stderr. NOUT is only defined for process 0.
00363 *
00364 *  SUBPTR  (global input) SUBROUTINE
00365 *          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
00366 *          EXTERNAL in the calling subroutine.
00367 *
00368 *  SCODE   (global input) INTEGER
00369 *          On entry, SCODE specifies the calling sequence code.
00370 *
00371 *  SNAME   (global input) CHARACTER*(*)
00372 *          On entry,  SNAME  specifies  the subroutine name calling this
00373 *          subprogram.
00374 *
00375 *  ARGNAM  (global input) CHARACTER*(*)
00376 *          On entry,  ARGNAM  specifies  the  name  of  the option to be
00377 *          checked. ARGNAM can either be 'D', 'S', 'A', 'B', or 'U'.
00378 *
00379 *  ARGPOS  (global input) INTEGER
00380 *          On entry, ARGPOS indicates the position of the option ARGNAM
00381 *          to be tested.
00382 *
00383 *  -- Written on April 1, 1998 by
00384 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
00385 *
00386 *  =====================================================================
00387 *
00388 *     .. Local Scalars ..
00389       INTEGER            INFOT
00390 *     ..
00391 *     .. External Subroutines ..
00392       EXTERNAL           PCHKPBE, PZCALLSUB, PZSETPBLAS
00393 *     ..
00394 *     .. External Functions ..
00395       LOGICAL            LSAME
00396       EXTERNAL           LSAME
00397 *     ..
00398 *     .. Common Blocks ..
00399       CHARACTER          DIAG, SIDE, TRANSA, TRANSB, UPLO
00400       COMMON             /PBLASC/DIAG, SIDE, TRANSA, TRANSB, UPLO
00401 *     ..
00402 *     .. Executable Statements ..
00403 *
00404 *     Reiniatilize the dummy arguments to correct values
00405 *
00406       CALL PZSETPBLAS( ICTXT )
00407 *
00408       IF( LSAME( ARGNAM, 'D' ) ) THEN
00409 *
00410 *        Generate bad DIAG option
00411 *
00412          DIAG = '/'
00413 *
00414       ELSE IF( LSAME( ARGNAM, 'S' ) ) THEN
00415 *
00416 *        Generate bad SIDE option
00417 *
00418          SIDE = '/'
00419 *
00420       ELSE IF( LSAME( ARGNAM, 'A' ) ) THEN
00421 *
00422 *        Generate bad TRANSA option
00423 *
00424          TRANSA = '/'
00425 *
00426       ELSE IF( LSAME( ARGNAM, 'B' ) ) THEN
00427 *
00428 *        Generate bad TRANSB option
00429 *
00430          TRANSB = '/'
00431 *
00432       ELSE IF( LSAME( ARGNAM, 'U' ) ) THEN
00433 *
00434 *        Generate bad UPLO option
00435 *
00436          UPLO = '/'
00437 *
00438       END IF
00439 *
00440 *     Set INFOT to the position of the bad dimension argument
00441 *
00442       INFOT = ARGPOS
00443 *
00444 *     Call the PBLAS routine
00445 *
00446       CALL PZCALLSUB( SUBPTR, SCODE )
00447       CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
00448 *
00449       RETURN
00450 *
00451 *     End of PZCHKOPT
00452 *
00453       END
00454       SUBROUTINE PZDIMEE( ICTXT, NOUT, SUBPTR, SCODE, SNAME )
00455 *
00456 *  -- PBLAS test routine (version 2.0) --
00457 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
00458 *     and University of California, Berkeley.
00459 *     April 1, 1998
00460 *
00461 *     .. Scalar Arguments ..
00462       INTEGER            ICTXT, NOUT, SCODE
00463 *     ..
00464 *     .. Array Arguments ..
00465       CHARACTER*(*)      SNAME
00466 *     ..
00467 *     .. Subroutine Arguments ..
00468       EXTERNAL           SUBPTR
00469 *     ..
00470 *
00471 *  Purpose
00472 *  =======
00473 *
00474 *  PZDIMEE  tests whether the PBLAS respond correctly to a bad dimension
00475 *  argument.
00476 *
00477 *  Notes
00478 *  =====
00479 *
00480 *  A description  vector  is associated with each 2D block-cyclicly dis-
00481 *  tributed matrix.  This  vector  stores  the  information  required to
00482 *  establish the  mapping  between a  matrix entry and its corresponding
00483 *  process and memory location.
00484 *
00485 *  In  the  following  comments,   the character _  should  be  read  as
00486 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
00487 *  block cyclicly distributed matrix.  Its description vector is DESCA:
00488 *
00489 *  NOTATION         STORED IN       EXPLANATION
00490 *  ---------------- --------------- ------------------------------------
00491 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
00492 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
00493 *                                   the NPROW x NPCOL BLACS process grid
00494 *                                   A  is distributed over.  The context
00495 *                                   itself  is  global,  but  the handle
00496 *                                   (the integer value) may vary.
00497 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
00498 *                                   ted matrix A, M_A >= 0.
00499 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
00500 *                                   buted matrix A, N_A >= 0.
00501 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
00502 *                                   block of the matrix A, IMB_A > 0.
00503 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
00504 *                                   left   block   of   the   matrix  A,
00505 *                                   INB_A > 0.
00506 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
00507 *                                   bute the last  M_A-IMB_A rows of  A,
00508 *                                   MB_A > 0.
00509 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
00510 *                                   bute the last  N_A-INB_A  columns of
00511 *                                   A, NB_A > 0.
00512 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
00513 *                                   row of the matrix  A is distributed,
00514 *                                   NPROW > RSRC_A >= 0.
00515 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
00516 *                                   first  column of  A  is distributed.
00517 *                                   NPCOL > CSRC_A >= 0.
00518 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
00519 *                                   array  storing  the  local blocks of
00520 *                                   the distributed matrix A,
00521 *                                   IF( Lc( 1, N_A ) > 0 )
00522 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
00523 *                                   ELSE
00524 *                                      LLD_A >= 1.
00525 *
00526 *  Let K be the number of  rows of a matrix A starting at the global in-
00527 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
00528 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
00529 *  receive if these K rows were distributed over NPROW processes.  If  K
00530 *  is the number of columns of a matrix  A  starting at the global index
00531 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
00532 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
00533 *  these K columns were distributed over NPCOL processes.
00534 *
00535 *  The values of Lr() and Lc() may be determined via a call to the func-
00536 *  tion PB_NUMROC:
00537 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
00538 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
00539 *
00540 *  Arguments
00541 *  =========
00542 *
00543 *  ICTXT   (local input) INTEGER
00544 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
00545 *          ting the global  context of the operation. The context itself
00546 *          is global, but the value of ICTXT is local.
00547 *
00548 *  NOUT    (global input) INTEGER
00549 *          On entry, NOUT specifies the unit number for the output file.
00550 *          When NOUT is 6, output to screen,  when  NOUT is 0, output to
00551 *          stderr. NOUT is only defined for process 0.
00552 *
00553 *  SUBPTR  (global input) SUBROUTINE
00554 *          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
00555 *          EXTERNAL in the calling subroutine.
00556 *
00557 *  SCODE   (global input) INTEGER
00558 *          On entry, SCODE specifies the calling sequence code.
00559 *
00560 *  SNAME   (global input) CHARACTER*(*)
00561 *          On entry,  SNAME  specifies  the subroutine name calling this
00562 *          subprogram.
00563 *
00564 *  Calling sequence encodings
00565 *  ==========================
00566 *
00567 *  code Formal argument list                                Examples
00568 *
00569 *  11   (n,      v1,v2)                                     _SWAP, _COPY
00570 *  12   (n,s1,   v1   )                                     _SCAL, _SCAL
00571 *  13   (n,s1,   v1,v2)                                     _AXPY, _DOT_
00572 *  14   (n,s1,i1,v1   )                                     _AMAX
00573 *  15   (n,u1,   v1   )                                     _ASUM, _NRM2
00574 *
00575 *  21   (     trans,     m,n,s1,m1,v1,s2,v2)                _GEMV
00576 *  22   (uplo,             n,s1,m1,v1,s2,v2)                _SYMV, _HEMV
00577 *  23   (uplo,trans,diag,  n,   m1,v1      )                _TRMV, _TRSV
00578 *  24   (                m,n,s1,v1,v2,m1)                   _GER_
00579 *  25   (uplo,             n,s1,v1,   m1)                   _SYR
00580 *  26   (uplo,             n,u1,v1,   m1)                   _HER
00581 *  27   (uplo,             n,s1,v1,v2,m1)                   _SYR2, _HER2
00582 *
00583 *  31   (          transa,transb,     m,n,k,s1,m1,m2,s2,m3) _GEMM
00584 *  32   (side,uplo,                   m,n,  s1,m1,m2,s2,m3) _SYMM, _HEMM
00585 *  33   (     uplo,trans,               n,k,s1,m1,   s2,m3) _SYRK
00586 *  34   (     uplo,trans,               n,k,u1,m1,   u2,m3) _HERK
00587 *  35   (     uplo,trans,               n,k,s1,m1,m2,s2,m3) _SYR2K
00588 *  36   (     uplo,trans,               n,k,s1,m1,m2,u2,m3) _HER2K
00589 *  37   (                             m,n,  s1,m1,   s2,m3) _TRAN_
00590 *  38   (side,uplo,transa,       diag,m,n,  s1,m1,m2      ) _TRMM, _TRSM
00591 *  39   (          trans,             m,n,  s1,m1,   s2,m3) _GEADD
00592 *  40   (     uplo,trans,             m,n,  s1,m1,   s2,m3) _TRADD
00593 *
00594 *  -- Written on April 1, 1998 by
00595 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
00596 *
00597 *  =====================================================================
00598 *
00599 *     .. Local Scalars ..
00600       INTEGER             APOS
00601 *     ..
00602 *     .. External Subroutines ..
00603       EXTERNAL            PZCHKDIM
00604 *     ..
00605 *     .. Executable Statements ..
00606 *
00607 *     Level 1 PBLAS
00608 *
00609       IF( SCODE.EQ.11 .OR. SCODE.EQ.12 .OR. SCODE.EQ.13 .OR.
00610      $    SCODE.EQ.14 .OR. SCODE.EQ.15 ) THEN
00611 *
00612 *        Check 1st (and only) dimension
00613 *
00614          APOS = 1
00615          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00616 *
00617 *     Level 2 PBLAS
00618 *
00619       ELSE IF( SCODE.EQ.21 ) THEN
00620 *
00621 *        Check 1st dimension
00622 *
00623          APOS = 2
00624          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00625 *
00626 *        Check 2nd dimension
00627 *
00628          APOS = 3
00629          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00630 *
00631       ELSE IF( SCODE.EQ.22 .OR. SCODE.EQ.25 .OR. SCODE.EQ.26 .OR.
00632      $         SCODE.EQ.27 ) THEN
00633 *
00634 *        Check 1st (and only) dimension
00635 *
00636          APOS = 2
00637          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00638 *
00639       ELSE IF( SCODE.EQ.23 ) THEN
00640 *
00641 *        Check 1st (and only) dimension
00642 *
00643          APOS = 4
00644          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00645 *
00646       ELSE IF( SCODE.EQ.24 ) THEN
00647 *
00648 *        Check 1st dimension
00649 *
00650          APOS = 1
00651          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00652 *
00653 *        Check 2nd dimension
00654 *
00655          APOS = 2
00656          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00657 *
00658 *     Level 3 PBLAS
00659 *
00660       ELSE IF( SCODE.EQ.31 ) THEN
00661 *
00662 *        Check 1st dimension
00663 *
00664          APOS = 3
00665          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00666 *
00667 *        Check 2nd dimension
00668 *
00669          APOS = 4
00670          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00671 *
00672 *        Check 3rd dimension
00673 *
00674          APOS = 5
00675          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'K', APOS )
00676 *
00677       ELSE IF( SCODE.EQ.32 ) THEN
00678 *
00679 *        Check 1st dimension
00680 *
00681          APOS = 3
00682          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00683 *
00684 *        Check 2nd dimension
00685 *
00686          APOS = 4
00687          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00688 *
00689       ELSE IF( SCODE.EQ.33 .OR. SCODE.EQ.34 .OR. SCODE.EQ.35 .OR.
00690      $         SCODE.EQ.36 ) THEN
00691 *
00692 *        Check 1st dimension
00693 *
00694          APOS = 3
00695          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00696 *
00697 *        Check 2nd dimension
00698 *
00699          APOS = 4
00700          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'K', APOS )
00701 *
00702       ELSE IF( SCODE.EQ.37 ) THEN
00703 *
00704 *        Check 1st dimension
00705 *
00706          APOS = 1
00707          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00708 *
00709 *        Check 2nd dimension
00710 *
00711          APOS = 2
00712          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00713 *
00714       ELSE IF( SCODE.EQ.38 ) THEN
00715 *
00716 *        Check 1st dimension
00717 *
00718          APOS = 5
00719          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00720 *
00721 *        Check 2nd dimension
00722 *
00723          APOS = 6
00724          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00725 *
00726       ELSE IF( SCODE.EQ.39 ) THEN
00727 *
00728 *        Check 1st dimension
00729 *
00730          APOS = 2
00731          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00732 *
00733 *        Check 2nd dimension
00734 *
00735          APOS = 3
00736          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00737 *
00738       ELSE IF( SCODE.EQ.40 ) THEN
00739 *
00740 *        Check 1st dimension
00741 *
00742          APOS = 3
00743          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00744 *
00745 *        Check 2nd dimension
00746 *
00747          APOS = 4
00748          CALL PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00749 *
00750       END IF
00751 *
00752       RETURN
00753 *
00754 *     End of PZDIMEE
00755 *
00756       END
00757       SUBROUTINE PZCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, ARGNAM,
00758      $                     ARGPOS )
00759 *
00760 *  -- PBLAS test routine (version 2.0) --
00761 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
00762 *     and University of California, Berkeley.
00763 *     April 1, 1998
00764 *
00765 *     .. Scalar Arguments ..
00766       CHARACTER*1         ARGNAM
00767       INTEGER             ARGPOS, ICTXT, NOUT, SCODE
00768 *     ..
00769 *     .. Array Arguments ..
00770       CHARACTER*(*)       SNAME
00771 *     ..
00772 *     .. Subroutine Arguments ..
00773       EXTERNAL            SUBPTR
00774 *     ..
00775 *
00776 *  Purpose
00777 *  =======
00778 *
00779 *  PZCHKDIM tests the dimension ARGNAM in any PBLAS routine.
00780 *
00781 *  Notes
00782 *  =====
00783 *
00784 *  A description  vector  is associated with each 2D block-cyclicly dis-
00785 *  tributed matrix.  This  vector  stores  the  information  required to
00786 *  establish the  mapping  between a  matrix entry and its corresponding
00787 *  process and memory location.
00788 *
00789 *  In  the  following  comments,   the character _  should  be  read  as
00790 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
00791 *  block cyclicly distributed matrix.  Its description vector is DESCA:
00792 *
00793 *  NOTATION         STORED IN       EXPLANATION
00794 *  ---------------- --------------- ------------------------------------
00795 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
00796 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
00797 *                                   the NPROW x NPCOL BLACS process grid
00798 *                                   A  is distributed over.  The context
00799 *                                   itself  is  global,  but  the handle
00800 *                                   (the integer value) may vary.
00801 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
00802 *                                   ted matrix A, M_A >= 0.
00803 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
00804 *                                   buted matrix A, N_A >= 0.
00805 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
00806 *                                   block of the matrix A, IMB_A > 0.
00807 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
00808 *                                   left   block   of   the   matrix  A,
00809 *                                   INB_A > 0.
00810 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
00811 *                                   bute the last  M_A-IMB_A rows of  A,
00812 *                                   MB_A > 0.
00813 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
00814 *                                   bute the last  N_A-INB_A  columns of
00815 *                                   A, NB_A > 0.
00816 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
00817 *                                   row of the matrix  A is distributed,
00818 *                                   NPROW > RSRC_A >= 0.
00819 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
00820 *                                   first  column of  A  is distributed.
00821 *                                   NPCOL > CSRC_A >= 0.
00822 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
00823 *                                   array  storing  the  local blocks of
00824 *                                   the distributed matrix A,
00825 *                                   IF( Lc( 1, N_A ) > 0 )
00826 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
00827 *                                   ELSE
00828 *                                      LLD_A >= 1.
00829 *
00830 *  Let K be the number of  rows of a matrix A starting at the global in-
00831 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
00832 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
00833 *  receive if these K rows were distributed over NPROW processes.  If  K
00834 *  is the number of columns of a matrix  A  starting at the global index
00835 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
00836 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
00837 *  these K columns were distributed over NPCOL processes.
00838 *
00839 *  The values of Lr() and Lc() may be determined via a call to the func-
00840 *  tion PB_NUMROC:
00841 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
00842 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
00843 *
00844 *  Arguments
00845 *  =========
00846 *
00847 *  ICTXT   (local input) INTEGER
00848 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
00849 *          ting the global  context of the operation. The context itself
00850 *          is global, but the value of ICTXT is local.
00851 *
00852 *  NOUT    (global input) INTEGER
00853 *          On entry, NOUT specifies the unit number for the output file.
00854 *          When NOUT is 6, output to screen,  when  NOUT is 0, output to
00855 *          stderr. NOUT is only defined for process 0.
00856 *
00857 *  SUBPTR  (global input) SUBROUTINE
00858 *          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
00859 *          EXTERNAL in the calling subroutine.
00860 *
00861 *  SCODE   (global input) INTEGER
00862 *          On entry, SCODE specifies the calling sequence code.
00863 *
00864 *  SNAME   (global input) CHARACTER*(*)
00865 *          On entry,  SNAME  specifies  the subroutine name calling this
00866 *          subprogram.
00867 *
00868 *  ARGNAM  (global input) CHARACTER*(*)
00869 *          On entry,  ARGNAM  specifies  the name of the dimension to be
00870 *          checked. ARGNAM can either be 'M', 'N' or 'K'.
00871 *
00872 *  ARGPOS  (global input) INTEGER
00873 *          On entry, ARGPOS indicates the position of the option ARGNAM
00874 *          to be tested.
00875 *
00876 *  -- Written on April 1, 1998 by
00877 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
00878 *
00879 *  =====================================================================
00880 *
00881 *     .. Local Scalars ..
00882       INTEGER            INFOT
00883 *     ..
00884 *     .. External Subroutines ..
00885       EXTERNAL           PCHKPBE, PZCALLSUB, PZSETPBLAS
00886 *     ..
00887 *     .. External Functions ..
00888       LOGICAL            LSAME
00889       EXTERNAL           LSAME
00890 *     ..
00891 *     .. Common Blocks ..
00892       INTEGER            KDIM, MDIM, NDIM
00893       COMMON             /PBLASN/KDIM, MDIM, NDIM
00894 *     ..
00895 *     .. Executable Statements ..
00896 *
00897 *     Reiniatilize the dummy arguments to correct values
00898 *
00899       CALL PZSETPBLAS( ICTXT )
00900 *
00901       IF( LSAME( ARGNAM, 'M' ) ) THEN
00902 *
00903 *        Generate bad MDIM
00904 *
00905          MDIM = -1
00906 *
00907       ELSE IF( LSAME( ARGNAM, 'N' ) ) THEN
00908 *
00909 *        Generate bad NDIM
00910 *
00911          NDIM = -1
00912 *
00913       ELSE
00914 *
00915 *        Generate bad KDIM
00916 *
00917          KDIM = -1
00918 *
00919       END IF
00920 *
00921 *     Set INFOT to the position of the bad dimension argument
00922 *
00923       INFOT = ARGPOS
00924 *
00925 *     Call the PBLAS routine
00926 *
00927       CALL PZCALLSUB( SUBPTR, SCODE )
00928       CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
00929 *
00930       RETURN
00931 *
00932 *     End of PZCHKDIM
00933 *
00934       END
00935       SUBROUTINE PZVECEE( ICTXT, NOUT, SUBPTR, SCODE, SNAME )
00936 *
00937 *  -- PBLAS test routine (version 2.0) --
00938 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
00939 *     and University of California, Berkeley.
00940 *     April 1, 1998
00941 *
00942 *     .. Scalar Arguments ..
00943       INTEGER             ICTXT, NOUT, SCODE
00944 *     ..
00945 *     .. Array Arguments ..
00946       CHARACTER*7         SNAME
00947 *     ..
00948 *     .. Subroutine Arguments ..
00949       EXTERNAL            SUBPTR
00950 *     ..
00951 *
00952 *  Purpose
00953 *  =======
00954 *
00955 *  PZVECEE  tests  whether  the  PBLAS respond correctly to a bad vector
00956 *  argument.  Each  vector <vec> is described by: <vec>, I<vec>, J<vec>,
00957 *  DESC<vec>,  INC<vec>.   Out   of  all  these,  only  I<vec>,  J<vec>,
00958 *  DESC<vec>, and INC<vec> can be tested.
00959 *
00960 *  Notes
00961 *  =====
00962 *
00963 *  A description  vector  is associated with each 2D block-cyclicly dis-
00964 *  tributed matrix.  This  vector  stores  the  information  required to
00965 *  establish the  mapping  between a  matrix entry and its corresponding
00966 *  process and memory location.
00967 *
00968 *  In  the  following  comments,   the character _  should  be  read  as
00969 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
00970 *  block cyclicly distributed matrix.  Its description vector is DESCA:
00971 *
00972 *  NOTATION         STORED IN       EXPLANATION
00973 *  ---------------- --------------- ------------------------------------
00974 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
00975 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
00976 *                                   the NPROW x NPCOL BLACS process grid
00977 *                                   A  is distributed over.  The context
00978 *                                   itself  is  global,  but  the handle
00979 *                                   (the integer value) may vary.
00980 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
00981 *                                   ted matrix A, M_A >= 0.
00982 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
00983 *                                   buted matrix A, N_A >= 0.
00984 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
00985 *                                   block of the matrix A, IMB_A > 0.
00986 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
00987 *                                   left   block   of   the   matrix  A,
00988 *                                   INB_A > 0.
00989 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
00990 *                                   bute the last  M_A-IMB_A rows of  A,
00991 *                                   MB_A > 0.
00992 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
00993 *                                   bute the last  N_A-INB_A  columns of
00994 *                                   A, NB_A > 0.
00995 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
00996 *                                   row of the matrix  A is distributed,
00997 *                                   NPROW > RSRC_A >= 0.
00998 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
00999 *                                   first  column of  A  is distributed.
01000 *                                   NPCOL > CSRC_A >= 0.
01001 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
01002 *                                   array  storing  the  local blocks of
01003 *                                   the distributed matrix A,
01004 *                                   IF( Lc( 1, N_A ) > 0 )
01005 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
01006 *                                   ELSE
01007 *                                      LLD_A >= 1.
01008 *
01009 *  Let K be the number of  rows of a matrix A starting at the global in-
01010 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
01011 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
01012 *  receive if these K rows were distributed over NPROW processes.  If  K
01013 *  is the number of columns of a matrix  A  starting at the global index
01014 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
01015 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
01016 *  these K columns were distributed over NPCOL processes.
01017 *
01018 *  The values of Lr() and Lc() may be determined via a call to the func-
01019 *  tion PB_NUMROC:
01020 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
01021 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
01022 *
01023 *  Arguments
01024 *  =========
01025 *
01026 *  ICTXT   (local input) INTEGER
01027 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
01028 *          ting the global  context of the operation. The context itself
01029 *          is global, but the value of ICTXT is local.
01030 *
01031 *  NOUT    (global input) INTEGER
01032 *          On entry, NOUT specifies the unit number for the output file.
01033 *          When NOUT is 6, output to screen,  when  NOUT is 0, output to
01034 *          stderr. NOUT is only defined for process 0.
01035 *
01036 *  SUBPTR  (global input) SUBROUTINE
01037 *          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
01038 *          EXTERNAL in the calling subroutine.
01039 *
01040 *  SCODE   (global input) INTEGER
01041 *          On entry, SCODE specifies the calling sequence code.
01042 *
01043 *  SNAME   (global input) CHARACTER*(*)
01044 *          On entry,  SNAME  specifies  the subroutine name calling this
01045 *          subprogram.
01046 *
01047 *  Calling sequence encodings
01048 *  ==========================
01049 *
01050 *  code Formal argument list                                Examples
01051 *
01052 *  11   (n,      v1,v2)                                     _SWAP, _COPY
01053 *  12   (n,s1,   v1   )                                     _SCAL, _SCAL
01054 *  13   (n,s1,   v1,v2)                                     _AXPY, _DOT_
01055 *  14   (n,s1,i1,v1   )                                     _AMAX
01056 *  15   (n,u1,   v1   )                                     _ASUM, _NRM2
01057 *
01058 *  21   (     trans,     m,n,s1,m1,v1,s2,v2)                _GEMV
01059 *  22   (uplo,             n,s1,m1,v1,s2,v2)                _SYMV, _HEMV
01060 *  23   (uplo,trans,diag,  n,   m1,v1      )                _TRMV, _TRSV
01061 *  24   (                m,n,s1,v1,v2,m1)                   _GER_
01062 *  25   (uplo,             n,s1,v1,   m1)                   _SYR
01063 *  26   (uplo,             n,u1,v1,   m1)                   _HER
01064 *  27   (uplo,             n,s1,v1,v2,m1)                   _SYR2, _HER2
01065 *
01066 *  31   (          transa,transb,     m,n,k,s1,m1,m2,s2,m3) _GEMM
01067 *  32   (side,uplo,                   m,n,  s1,m1,m2,s2,m3) _SYMM, _HEMM
01068 *  33   (     uplo,trans,               n,k,s1,m1,   s2,m3) _SYRK
01069 *  34   (     uplo,trans,               n,k,u1,m1,   u2,m3) _HERK
01070 *  35   (     uplo,trans,               n,k,s1,m1,m2,s2,m3) _SYR2K
01071 *  36   (     uplo,trans,               n,k,s1,m1,m2,u2,m3) _HER2K
01072 *  37   (                             m,n,  s1,m1,   s2,m3) _TRAN_
01073 *  38   (side,uplo,transa,       diag,m,n,  s1,m1,m2      ) _TRMM, _TRSM
01074 *  39   (          trans,             m,n,  s1,m1,   s2,m3) _GEADD
01075 *  40   (     uplo,trans,             m,n,  s1,m1,   s2,m3) _TRADD
01076 *
01077 *  -- Written on April 1, 1998 by
01078 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
01079 *
01080 *  =====================================================================
01081 *
01082 *     .. Local Scalars ..
01083       INTEGER             APOS
01084 *     ..
01085 *     .. External Subroutines ..
01086       EXTERNAL            PZCHKMAT
01087 *     ..
01088 *     .. Executable Statements ..
01089 *
01090 *     Level 1 PBLAS
01091 *
01092       IF( SCODE.EQ.11 ) THEN
01093 *
01094 *        Check 1st vector
01095 *
01096          APOS = 2
01097          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01098 *
01099 *        Check 2nd vector
01100 *
01101          APOS = 7
01102          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'Y', APOS )
01103 *
01104       ELSE IF( SCODE.EQ.12 .OR. SCODE.EQ.15 ) THEN
01105 *
01106 *        Check 1st (and only) vector
01107 *
01108          APOS = 3
01109          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01110 *
01111       ELSE IF( SCODE.EQ.13 ) THEN
01112 *
01113 *        Check 1st vector
01114 *
01115          APOS = 3
01116          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01117 *
01118 *        Check 2nd vector
01119 *
01120          APOS = 8
01121          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'Y', APOS )
01122 *
01123       ELSE IF( SCODE.EQ.14 ) THEN
01124 *
01125 *        Check 1st (and only) vector
01126 *
01127          APOS = 4
01128          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01129 *
01130 *     Level 2 PBLAS
01131 *
01132       ELSE IF( SCODE.EQ.21 ) THEN
01133 *
01134 *        Check 1st vector
01135 *
01136          APOS = 9
01137          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01138 *
01139 *        Check 2nd vector
01140 *
01141          APOS = 15
01142          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'Y', APOS )
01143 *
01144       ELSE IF( SCODE.EQ.22 ) THEN
01145 *
01146 *        Check 1st vector
01147 *
01148          APOS = 8
01149          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01150 *
01151 *        Check 2nd vector
01152 *
01153          APOS = 14
01154          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'Y', APOS )
01155 *
01156       ELSE IF( SCODE.EQ.23 ) THEN
01157 *
01158 *        Check 1st (and only) vector
01159 *
01160          APOS = 9
01161          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01162 *
01163       ELSE IF( SCODE.EQ.24 .OR. SCODE.EQ.27 ) THEN
01164 *
01165 *        Check 1st vector
01166 *
01167          APOS = 4
01168          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01169 *
01170 *        Check 2nd vector
01171 *
01172          APOS = 9
01173          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'Y', APOS )
01174 *
01175       ELSE IF( SCODE.EQ.26 .OR. SCODE.EQ.27 ) THEN
01176 *
01177 *        Check 1'st (and only) vector
01178 *
01179          APOS = 4
01180          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01181 *
01182       END IF
01183 *
01184       RETURN
01185 *
01186 *     End of PZVECEE
01187 *
01188       END
01189       SUBROUTINE PZMATEE( ICTXT, NOUT, SUBPTR, SCODE, SNAME )
01190 *
01191 *  -- PBLAS test routine (version 2.0) --
01192 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
01193 *     and University of California, Berkeley.
01194 *     April 1, 1998
01195 *
01196 *     .. Scalar Arguments ..
01197       INTEGER             ICTXT, NOUT, SCODE
01198 *     ..
01199 *     .. Array Arguments ..
01200       CHARACTER*7         SNAME
01201 *     ..
01202 *     .. Subroutine Arguments ..
01203       EXTERNAL            SUBPTR
01204 *     ..
01205 *
01206 *  Purpose
01207 *  =======
01208 *
01209 *  PZMATEE  tests  whether  the  PBLAS respond correctly to a bad matrix
01210 *  argument.  Each  matrix <mat> is described by: <mat>, I<mat>, J<mat>,
01211 *  and DESC<mat>.  Out  of  all these, only I<vec>, J<vec> and DESC<mat>
01212 *  can be tested.
01213 *
01214 *  Notes
01215 *  =====
01216 *
01217 *  A description  vector  is associated with each 2D block-cyclicly dis-
01218 *  tributed matrix.  This  vector  stores  the  information  required to
01219 *  establish the  mapping  between a  matrix entry and its corresponding
01220 *  process and memory location.
01221 *
01222 *  In  the  following  comments,   the character _  should  be  read  as
01223 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
01224 *  block cyclicly distributed matrix.  Its description vector is DESCA:
01225 *
01226 *  NOTATION         STORED IN       EXPLANATION
01227 *  ---------------- --------------- ------------------------------------
01228 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
01229 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
01230 *                                   the NPROW x NPCOL BLACS process grid
01231 *                                   A  is distributed over.  The context
01232 *                                   itself  is  global,  but  the handle
01233 *                                   (the integer value) may vary.
01234 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
01235 *                                   ted matrix A, M_A >= 0.
01236 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
01237 *                                   buted matrix A, N_A >= 0.
01238 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
01239 *                                   block of the matrix A, IMB_A > 0.
01240 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
01241 *                                   left   block   of   the   matrix  A,
01242 *                                   INB_A > 0.
01243 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
01244 *                                   bute the last  M_A-IMB_A rows of  A,
01245 *                                   MB_A > 0.
01246 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
01247 *                                   bute the last  N_A-INB_A  columns of
01248 *                                   A, NB_A > 0.
01249 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
01250 *                                   row of the matrix  A is distributed,
01251 *                                   NPROW > RSRC_A >= 0.
01252 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
01253 *                                   first  column of  A  is distributed.
01254 *                                   NPCOL > CSRC_A >= 0.
01255 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
01256 *                                   array  storing  the  local blocks of
01257 *                                   the distributed matrix A,
01258 *                                   IF( Lc( 1, N_A ) > 0 )
01259 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
01260 *                                   ELSE
01261 *                                      LLD_A >= 1.
01262 *
01263 *  Let K be the number of  rows of a matrix A starting at the global in-
01264 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
01265 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
01266 *  receive if these K rows were distributed over NPROW processes.  If  K
01267 *  is the number of columns of a matrix  A  starting at the global index
01268 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
01269 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
01270 *  these K columns were distributed over NPCOL processes.
01271 *
01272 *  The values of Lr() and Lc() may be determined via a call to the func-
01273 *  tion PB_NUMROC:
01274 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
01275 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
01276 *
01277 *  Arguments
01278 *  =========
01279 *
01280 *  ICTXT   (local input) INTEGER
01281 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
01282 *          ting the global  context of the operation. The context itself
01283 *          is global, but the value of ICTXT is local.
01284 *
01285 *  NOUT    (global input) INTEGER
01286 *          On entry, NOUT specifies the unit number for the output file.
01287 *          When NOUT is 6, output to screen,  when  NOUT is 0, output to
01288 *          stderr. NOUT is only defined for process 0.
01289 *
01290 *  SUBPTR  (global input) SUBROUTINE
01291 *          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
01292 *          EXTERNAL in the calling subroutine.
01293 *
01294 *  SCODE   (global input) INTEGER
01295 *          On entry, SCODE specifies the calling sequence code.
01296 *
01297 *  SNAME   (global input) CHARACTER*(*)
01298 *          On entry,  SNAME  specifies  the subroutine name calling this
01299 *          subprogram.
01300 *
01301 *  Calling sequence encodings
01302 *  ==========================
01303 *
01304 *  code Formal argument list                                Examples
01305 *
01306 *  11   (n,      v1,v2)                                     _SWAP, _COPY
01307 *  12   (n,s1,   v1   )                                     _SCAL, _SCAL
01308 *  13   (n,s1,   v1,v2)                                     _AXPY, _DOT_
01309 *  14   (n,s1,i1,v1   )                                     _AMAX
01310 *  15   (n,u1,   v1   )                                     _ASUM, _NRM2
01311 *
01312 *  21   (     trans,     m,n,s1,m1,v1,s2,v2)                _GEMV
01313 *  22   (uplo,             n,s1,m1,v1,s2,v2)                _SYMV, _HEMV
01314 *  23   (uplo,trans,diag,  n,   m1,v1      )                _TRMV, _TRSV
01315 *  24   (                m,n,s1,v1,v2,m1)                   _GER_
01316 *  25   (uplo,             n,s1,v1,   m1)                   _SYR
01317 *  26   (uplo,             n,u1,v1,   m1)                   _HER
01318 *  27   (uplo,             n,s1,v1,v2,m1)                   _SYR2, _HER2
01319 *
01320 *  31   (          transa,transb,     m,n,k,s1,m1,m2,s2,m3) _GEMM
01321 *  32   (side,uplo,                   m,n,  s1,m1,m2,s2,m3) _SYMM, _HEMM
01322 *  33   (     uplo,trans,               n,k,s1,m1,   s2,m3) _SYRK
01323 *  34   (     uplo,trans,               n,k,u1,m1,   u2,m3) _HERK
01324 *  35   (     uplo,trans,               n,k,s1,m1,m2,s2,m3) _SYR2K
01325 *  36   (     uplo,trans,               n,k,s1,m1,m2,u2,m3) _HER2K
01326 *  37   (                             m,n,  s1,m1,   s2,m3) _TRAN_
01327 *  38   (side,uplo,transa,       diag,m,n,  s1,m1,m2      ) _TRMM, _TRSM
01328 *  39   (          trans,             m,n,  s1,m1,   s2,m3) _GEADD
01329 *  40   (     uplo,trans,             m,n,  s1,m1,   s2,m3) _TRADD
01330 *
01331 *  -- Written on April 1, 1998 by
01332 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
01333 *
01334 *  =====================================================================
01335 *
01336 *     .. Local Scalars ..
01337       INTEGER             APOS
01338 *     ..
01339 *     .. External Subroutines ..
01340       EXTERNAL            PZCHKMAT
01341 *     ..
01342 *     .. Executable Statements ..
01343 *
01344 *     Level 2 PBLAS
01345 *
01346       IF( SCODE.EQ.21 .OR. SCODE.EQ.23 ) THEN
01347 *
01348 *        Check 1st (and only) matrix
01349 *
01350          APOS = 5
01351          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01352 *
01353       ELSE IF( SCODE.EQ.22 ) THEN
01354 *
01355 *        Check 1st (and only) matrix
01356 *
01357          APOS = 4
01358          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01359 *
01360       ELSE IF( SCODE.EQ.24 .OR. SCODE.EQ.27 ) THEN
01361 *
01362 *        Check 1st (and only) matrix
01363 *
01364          APOS = 14
01365          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01366 *
01367       ELSE IF( SCODE.EQ.25 .OR. SCODE.EQ.26 ) THEN
01368 *
01369 *        Check 1st (and only) matrix
01370 *
01371          APOS = 9
01372          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01373 *
01374 *     Level 3 PBLAS
01375 *
01376       ELSE IF( SCODE.EQ.31 ) THEN
01377 *
01378 *        Check 1st matrix
01379 *
01380          APOS = 7
01381          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01382 *
01383 *        Check 2nd matrix
01384 *
01385          APOS = 11
01386          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'B', APOS )
01387 *
01388 *        Check 3nd matrix
01389 *
01390          APOS = 16
01391          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'C', APOS )
01392 *
01393       ELSE IF( SCODE.EQ.32 .OR. SCODE.EQ.35 .OR. SCODE.EQ.36 ) THEN
01394 *
01395 *        Check 1st matrix
01396 *
01397          APOS = 6
01398          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01399 *
01400 *        Check 2nd matrix
01401 *
01402          APOS = 10
01403          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'B', APOS )
01404 *
01405 *        Check 3nd matrix
01406 *
01407          APOS = 15
01408          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'C', APOS )
01409 *
01410       ELSE IF( SCODE.EQ.33 .OR. SCODE.EQ.34 ) THEN
01411 *
01412 *        Check 1st matrix
01413 *
01414          APOS = 6
01415          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01416 *
01417 *        Check 2nd matrix
01418 *
01419          APOS = 11
01420          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'C', APOS )
01421 *
01422       ELSE IF( SCODE.EQ.37 ) THEN
01423 *
01424 *        Check 1st matrix
01425 *
01426          APOS = 4
01427          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01428 *
01429 *        Check 2nd matrix
01430 *
01431          APOS = 9
01432          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'C', APOS )
01433 *
01434       ELSE IF( SCODE.EQ.38 ) THEN
01435 *
01436 *        Check 1st matrix
01437 *
01438          APOS = 8
01439          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01440 *
01441 *        Check 2nd matrix
01442 *
01443          APOS = 12
01444          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'B', APOS )
01445 *
01446       ELSE IF( SCODE.EQ.39 ) THEN
01447 *
01448 *        Check 1st matrix
01449 *
01450          APOS = 5
01451          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01452 *
01453 *        Check 2nd matrix
01454 *
01455          APOS = 10
01456          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'C', APOS )
01457 *
01458       ELSE IF( SCODE.EQ.40 ) THEN
01459 *
01460 *        Check 1st matrix
01461 *
01462          APOS = 6
01463          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01464 *
01465 *        Check 2nd matrix
01466 *
01467          APOS = 11
01468          CALL PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'C', APOS )
01469 *
01470       END IF
01471 *
01472       RETURN
01473 *
01474 *     End of PZMATEE
01475 *
01476       END
01477       SUBROUTINE PZSETPBLAS( ICTXT )
01478 *
01479 *  -- PBLAS test routine (version 2.0) --
01480 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
01481 *     and University of California, Berkeley.
01482 *     April 1, 1998
01483 *
01484 *     .. Scalar Arguments ..
01485       INTEGER            ICTXT
01486 *     ..
01487 *
01488 *  Purpose
01489 *  =======
01490 *
01491 *  PZSETPBLAS initializes *all* the dummy arguments to correct values.
01492 *
01493 *  Notes
01494 *  =====
01495 *
01496 *  A description  vector  is associated with each 2D block-cyclicly dis-
01497 *  tributed matrix.  This  vector  stores  the  information  required to
01498 *  establish the  mapping  between a  matrix entry and its corresponding
01499 *  process and memory location.
01500 *
01501 *  In  the  following  comments,   the character _  should  be  read  as
01502 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
01503 *  block cyclicly distributed matrix.  Its description vector is DESCA:
01504 *
01505 *  NOTATION         STORED IN       EXPLANATION
01506 *  ---------------- --------------- ------------------------------------
01507 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
01508 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
01509 *                                   the NPROW x NPCOL BLACS process grid
01510 *                                   A  is distributed over.  The context
01511 *                                   itself  is  global,  but  the handle
01512 *                                   (the integer value) may vary.
01513 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
01514 *                                   ted matrix A, M_A >= 0.
01515 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
01516 *                                   buted matrix A, N_A >= 0.
01517 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
01518 *                                   block of the matrix A, IMB_A > 0.
01519 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
01520 *                                   left   block   of   the   matrix  A,
01521 *                                   INB_A > 0.
01522 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
01523 *                                   bute the last  M_A-IMB_A rows of  A,
01524 *                                   MB_A > 0.
01525 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
01526 *                                   bute the last  N_A-INB_A  columns of
01527 *                                   A, NB_A > 0.
01528 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
01529 *                                   row of the matrix  A is distributed,
01530 *                                   NPROW > RSRC_A >= 0.
01531 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
01532 *                                   first  column of  A  is distributed.
01533 *                                   NPCOL > CSRC_A >= 0.
01534 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
01535 *                                   array  storing  the  local blocks of
01536 *                                   the distributed matrix A,
01537 *                                   IF( Lc( 1, N_A ) > 0 )
01538 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
01539 *                                   ELSE
01540 *                                      LLD_A >= 1.
01541 *
01542 *  Let K be the number of  rows of a matrix A starting at the global in-
01543 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
01544 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
01545 *  receive if these K rows were distributed over NPROW processes.  If  K
01546 *  is the number of columns of a matrix  A  starting at the global index
01547 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
01548 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
01549 *  these K columns were distributed over NPCOL processes.
01550 *
01551 *  The values of Lr() and Lc() may be determined via a call to the func-
01552 *  tion PB_NUMROC:
01553 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
01554 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
01555 *
01556 *  Arguments
01557 *  =========
01558 *
01559 *  ICTXT   (local input) INTEGER
01560 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
01561 *          ting the global  context of the operation. The context itself
01562 *          is global, but the value of ICTXT is local.
01563 *
01564 *  -- Written on April 1, 1998 by
01565 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
01566 *
01567 *  =====================================================================
01568 *
01569 *     .. Parameters ..
01570       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
01571      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
01572      $                   RSRC_
01573       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
01574      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
01575      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
01576      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
01577       DOUBLE PRECISION   RONE
01578       COMPLEX*16         ONE
01579       PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
01580      $                   RONE = 1.0D+0 )
01581 *     ..
01582 *     .. External Subroutines ..
01583       EXTERNAL           PB_DESCSET2
01584 *     ..
01585 *     .. Common Blocks ..
01586       CHARACTER*1        DIAG, SIDE, TRANSA, TRANSB, UPLO
01587       INTEGER            IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB,
01588      $                   JC, JX, JY, KDIM, MDIM, NDIM
01589       DOUBLE PRECISION   USCLR
01590       COMPLEX*16         SCLR
01591       INTEGER            DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
01592      $                   DESCX( DLEN_ ), DESCY( DLEN_ )
01593       COMPLEX*16         A( 2, 2 ), B( 2, 2 ), C( 2, 2 ), X( 2 ), Y( 2 )
01594       COMMON             /PBLASC/DIAG, SIDE, TRANSA, TRANSB, UPLO
01595       COMMON             /PBLASD/DESCA, DESCB, DESCC, DESCX, DESCY
01596       COMMON             /PBLASI/IA, IB, IC, INCX, INCY, ISCLR, IX, IY,
01597      $                   JA, JB, JC, JX, JY
01598       COMMON             /PBLASM/A, B, C
01599       COMMON             /PBLASN/KDIM, MDIM, NDIM
01600       COMMON             /PBLASS/SCLR, USCLR
01601       COMMON             /PBLASV/X, Y
01602 *     ..
01603 *     .. Executable Statements ..
01604 *
01605 *     Set default values for options
01606 *
01607       DIAG   = 'N'
01608       SIDE   = 'L'
01609       TRANSA = 'N'
01610       TRANSB = 'N'
01611       UPLO   = 'U'
01612 *
01613 *     Set default values for scalars
01614 *
01615       KDIM   = 1
01616       MDIM   = 1
01617       NDIM   = 1
01618       ISCLR  = 1
01619       SCLR   = ONE
01620       USCLR  = RONE
01621 *
01622 *     Set default values for distributed matrix A
01623 *
01624       A( 1, 1 ) = ONE
01625       A( 2, 1 ) = ONE
01626       A( 1, 2 ) = ONE
01627       A( 2, 2 ) = ONE
01628       IA = 1
01629       JA = 1
01630       CALL PB_DESCSET2( DESCA, 2, 2, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
01631 *
01632 *     Set default values for distributed matrix B
01633 *
01634       B( 1, 1 ) = ONE
01635       B( 2, 1 ) = ONE
01636       B( 1, 2 ) = ONE
01637       B( 2, 2 ) = ONE
01638       IB = 1
01639       JB = 1
01640       CALL PB_DESCSET2( DESCB, 2, 2, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
01641 *
01642 *     Set default values for distributed matrix C
01643 *
01644       C( 1, 1 ) = ONE
01645       C( 2, 1 ) = ONE
01646       C( 1, 2 ) = ONE
01647       C( 2, 2 ) = ONE
01648       IC = 1
01649       JC = 1
01650       CALL PB_DESCSET2( DESCC, 2, 2, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
01651 *
01652 *     Set default values for distributed matrix X
01653 *
01654       X( 1 ) = ONE
01655       X( 2 ) = ONE
01656       IX = 1
01657       JX = 1
01658       CALL PB_DESCSET2( DESCX, 2, 1, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
01659       INCX = 1
01660 *
01661 *     Set default values for distributed matrix Y
01662 *
01663       Y( 1 ) = ONE
01664       Y( 2 ) = ONE
01665       IY = 1
01666       JY = 1
01667       CALL PB_DESCSET2( DESCY, 2, 1, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
01668       INCY = 1
01669 *
01670       RETURN
01671 *
01672 *     End of PZSETPBLAS
01673 *
01674       END
01675       SUBROUTINE PZCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, ARGNAM,
01676      $                     ARGPOS )
01677 *
01678 *  -- PBLAS test routine (version 2.0) --
01679 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
01680 *     and University of California, Berkeley.
01681 *     April 1, 1998
01682 *
01683 *     .. Scalar Arguments ..
01684       CHARACTER*1         ARGNAM
01685       INTEGER             ARGPOS, ICTXT, NOUT, SCODE
01686 *     ..
01687 *     .. Array Arguments ..
01688       CHARACTER*(*)       SNAME
01689 *     ..
01690 *     .. Subroutine Arguments ..
01691       EXTERNAL            SUBPTR
01692 *     ..
01693 *
01694 *  Purpose
01695 *  =======
01696 *
01697 *  PZCHKMAT tests the matrix (or vector) ARGNAM in any PBLAS routine.
01698 *
01699 *  Notes
01700 *  =====
01701 *
01702 *  A description  vector  is associated with each 2D block-cyclicly dis-
01703 *  tributed matrix.  This  vector  stores  the  information  required to
01704 *  establish the  mapping  between a  matrix entry and its corresponding
01705 *  process and memory location.
01706 *
01707 *  In  the  following  comments,   the character _  should  be  read  as
01708 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
01709 *  block cyclicly distributed matrix.  Its description vector is DESCA:
01710 *
01711 *  NOTATION         STORED IN       EXPLANATION
01712 *  ---------------- --------------- ------------------------------------
01713 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
01714 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
01715 *                                   the NPROW x NPCOL BLACS process grid
01716 *                                   A  is distributed over.  The context
01717 *                                   itself  is  global,  but  the handle
01718 *                                   (the integer value) may vary.
01719 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
01720 *                                   ted matrix A, M_A >= 0.
01721 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
01722 *                                   buted matrix A, N_A >= 0.
01723 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
01724 *                                   block of the matrix A, IMB_A > 0.
01725 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
01726 *                                   left   block   of   the   matrix  A,
01727 *                                   INB_A > 0.
01728 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
01729 *                                   bute the last  M_A-IMB_A rows of  A,
01730 *                                   MB_A > 0.
01731 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
01732 *                                   bute the last  N_A-INB_A  columns of
01733 *                                   A, NB_A > 0.
01734 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
01735 *                                   row of the matrix  A is distributed,
01736 *                                   NPROW > RSRC_A >= 0.
01737 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
01738 *                                   first  column of  A  is distributed.
01739 *                                   NPCOL > CSRC_A >= 0.
01740 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
01741 *                                   array  storing  the  local blocks of
01742 *                                   the distributed matrix A,
01743 *                                   IF( Lc( 1, N_A ) > 0 )
01744 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
01745 *                                   ELSE
01746 *                                      LLD_A >= 1.
01747 *
01748 *  Let K be the number of  rows of a matrix A starting at the global in-
01749 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
01750 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
01751 *  receive if these K rows were distributed over NPROW processes.  If  K
01752 *  is the number of columns of a matrix  A  starting at the global index
01753 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
01754 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
01755 *  these K columns were distributed over NPCOL processes.
01756 *
01757 *  The values of Lr() and Lc() may be determined via a call to the func-
01758 *  tion PB_NUMROC:
01759 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
01760 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
01761 *
01762 *  Arguments
01763 *  =========
01764 *
01765 *  ICTXT   (local input) INTEGER
01766 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
01767 *          ting the global  context of the operation. The context itself
01768 *          is global, but the value of ICTXT is local.
01769 *
01770 *  NOUT    (global input) INTEGER
01771 *          On entry, NOUT specifies the unit number for the output file.
01772 *          When NOUT is 6, output to screen,  when  NOUT is 0, output to
01773 *          stderr. NOUT is only defined for process 0.
01774 *
01775 *  SUBPTR  (global input) SUBROUTINE
01776 *          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
01777 *          EXTERNAL in the calling subroutine.
01778 *
01779 *  SCODE   (global input) INTEGER
01780 *          On entry, SCODE specifies the calling sequence code.
01781 *
01782 *  SNAME   (global input) CHARACTER*(*)
01783 *          On entry,  SNAME  specifies  the subroutine name calling this
01784 *          subprogram.
01785 *
01786 *  ARGNAM  (global input) CHARACTER*(*)
01787 *          On entry,  ARGNAM  specifies the name of the matrix or vector
01788 *          to be checked.  ARGNAM can either be 'A', 'B' or 'C' when one
01789 *          wants to check a matrix, and 'X' or 'Y' for a vector.
01790 *
01791 *  ARGPOS  (global input) INTEGER
01792 *          On entry, ARGPOS indicates the position of the first argument
01793 *          of the matrix (or vector) ARGNAM.
01794 *
01795 *  -- Written on April 1, 1998 by
01796 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
01797 *
01798 *  =====================================================================
01799 *
01800 *     .. Parameters ..
01801       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
01802      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
01803      $                   RSRC_
01804       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
01805      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
01806      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
01807      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
01808       INTEGER             DESCMULT
01809       PARAMETER           ( DESCMULT = 100 )
01810 *     ..
01811 *     .. Local Scalars ..
01812       INTEGER             I, INFOT, NPROW, NPCOL, MYROW, MYCOL
01813 *     ..
01814 *     .. External Subroutines ..
01815       EXTERNAL           BLACS_GRIDINFO, PCHKPBE, PZCALLSUB, PZSETPBLAS
01816 *     ..
01817 *     .. External Functions ..
01818       LOGICAL             LSAME
01819       EXTERNAL            LSAME
01820 *     ..
01821 *     .. Common Blocks ..
01822       INTEGER            IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB,
01823      $                   JC, JX, JY
01824       INTEGER            DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
01825      $                   DESCX( DLEN_ ), DESCY( DLEN_ )
01826       COMMON             /PBLASD/DESCA, DESCB, DESCC, DESCX, DESCY
01827       COMMON             /PBLASI/IA, IB, IC, INCX, INCY, ISCLR, IX, IY,
01828      $                   JA, JB, JC, JX, JY
01829 *     ..
01830 *     .. Executable Statements ..
01831 *
01832       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
01833 *
01834       IF( LSAME( ARGNAM, 'A' ) ) THEN
01835 *
01836 *        Check IA. Set all other OK, bad IA
01837 *
01838          CALL PZSETPBLAS( ICTXT )
01839          IA    = -1
01840          INFOT = ARGPOS + 1
01841          CALL PZCALLSUB( SUBPTR, SCODE )
01842          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01843 *
01844 *        Check JA. Set all other OK, bad JA
01845 *
01846          CALL PZSETPBLAS( ICTXT )
01847          JA    = -1
01848          INFOT = ARGPOS + 2
01849          CALL PZCALLSUB( SUBPTR, SCODE )
01850          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01851 *
01852 *        Check DESCA. Set all other OK, bad DESCA
01853 *
01854          DO 10 I = 1, DLEN_
01855 *
01856 *           Set I'th entry of DESCA to incorrect value, rest ok.
01857 *
01858             CALL PZSETPBLAS( ICTXT )
01859             DESCA( I ) =  -2
01860             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
01861             CALL PZCALLSUB( SUBPTR, SCODE )
01862             CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01863 *
01864 *           Extra tests for RSRCA, CSRCA, LDA
01865 *
01866             IF( ( I.EQ.RSRC_ ) .OR. ( I.EQ.CSRC_ ) .OR.
01867      $          ( I.EQ.LLD_ ) ) THEN
01868 *
01869                CALL PZSETPBLAS( ICTXT )
01870 *
01871 *              Test RSRCA >= NPROW
01872 *
01873                IF( I.EQ.RSRC_ )
01874      $            DESCA( I ) =  NPROW
01875 *
01876 *              Test CSRCA >= NPCOL
01877 *
01878                IF( I.EQ.CSRC_ )
01879      $            DESCA( I ) =  NPCOL
01880 *
01881 *              Test LDA >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
01882 *
01883                IF( I.EQ.LLD_ ) THEN
01884                   IF( MYROW.EQ.0 .AND.MYCOL.EQ.0 ) THEN
01885                      DESCA( I ) = 1
01886                   ELSE
01887                      DESCA( I ) = 0
01888                   END IF
01889                END IF
01890 *
01891                INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
01892                CALL PZCALLSUB( SUBPTR, SCODE )
01893                CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01894 *
01895             END IF
01896 *
01897    10    CONTINUE
01898 *
01899       ELSE IF( LSAME( ARGNAM, 'B' ) ) THEN
01900 *
01901 *        Check IB. Set all other OK, bad IB
01902 *
01903          CALL PZSETPBLAS( ICTXT )
01904          IB    = -1
01905          INFOT = ARGPOS + 1
01906          CALL PZCALLSUB( SUBPTR, SCODE )
01907          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01908 *
01909 *        Check JB. Set all other OK, bad JB
01910 *
01911          CALL PZSETPBLAS( ICTXT )
01912          JB    = -1
01913          INFOT = ARGPOS + 2
01914          CALL PZCALLSUB( SUBPTR, SCODE )
01915          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01916 *
01917 *        Check DESCB. Set all other OK, bad DESCB
01918 *
01919          DO 20 I = 1, DLEN_
01920 *
01921 *           Set I'th entry of DESCB to incorrect value, rest ok.
01922 *
01923             CALL PZSETPBLAS( ICTXT )
01924             DESCB( I ) =  -2
01925             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
01926             CALL PZCALLSUB( SUBPTR, SCODE )
01927             CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01928 *
01929 *           Extra tests for RSRCB, CSRCB, LDB
01930 *
01931             IF( ( I.EQ.RSRC_ ) .OR. ( I.EQ.CSRC_ ) .OR.
01932      $          ( I.EQ.LLD_ ) ) THEN
01933 *
01934                CALL PZSETPBLAS( ICTXT )
01935 *
01936 *              Test RSRCB >= NPROW
01937 *
01938                IF( I.EQ.RSRC_ )
01939      $            DESCB( I ) =  NPROW
01940 *
01941 *              Test CSRCB >= NPCOL
01942 *
01943                IF( I.EQ.CSRC_ )
01944      $            DESCB( I ) =  NPCOL
01945 *
01946 *              Test LDB >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
01947 *
01948                IF( I.EQ.LLD_ ) THEN
01949                   IF( MYROW.EQ.0 .AND.MYCOL.EQ.0 ) THEN
01950                      DESCB( I ) = 1
01951                   ELSE
01952                      DESCB( I ) = 0
01953                   END IF
01954                END IF
01955 *
01956                INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
01957                CALL PZCALLSUB( SUBPTR, SCODE )
01958                CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01959 *
01960             END IF
01961 *
01962    20    CONTINUE
01963 *
01964       ELSE IF( LSAME( ARGNAM, 'C' ) ) THEN
01965 *
01966 *        Check IC. Set all other OK, bad IC
01967 *
01968          CALL PZSETPBLAS( ICTXT )
01969          IC    = -1
01970          INFOT = ARGPOS + 1
01971          CALL PZCALLSUB( SUBPTR, SCODE )
01972          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01973 *
01974 *        Check JC. Set all other OK, bad JC
01975 *
01976          CALL PZSETPBLAS( ICTXT )
01977          JC    = -1
01978          INFOT = ARGPOS + 2
01979          CALL PZCALLSUB( SUBPTR, SCODE )
01980          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01981 *
01982 *        Check DESCC. Set all other OK, bad DESCC
01983 *
01984          DO 30 I = 1, DLEN_
01985 *
01986 *           Set I'th entry of DESCC to incorrect value, rest ok.
01987 *
01988             CALL PZSETPBLAS( ICTXT )
01989             DESCC( I ) =  -2
01990             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
01991             CALL PZCALLSUB( SUBPTR, SCODE )
01992             CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01993 *
01994 *           Extra tests for RSRCC, CSRCC, LDC
01995 *
01996             IF( ( I.EQ.RSRC_ ) .OR. ( I.EQ.CSRC_ ) .OR.
01997      $          ( I.EQ.LLD_ ) ) THEN
01998 *
01999                CALL PZSETPBLAS( ICTXT )
02000 *
02001 *              Test RSRCC >= NPROW
02002 *
02003                IF( I.EQ.RSRC_ )
02004      $            DESCC( I ) =  NPROW
02005 *
02006 *              Test CSRCC >= NPCOL
02007 *
02008                IF( I.EQ.CSRC_ )
02009      $            DESCC( I ) =  NPCOL
02010 *
02011 *              Test LDC >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
02012 *
02013                IF( I.EQ.LLD_ ) THEN
02014                   IF( MYROW.EQ.0 .AND.MYCOL.EQ.0 ) THEN
02015                      DESCC( I ) = 1
02016                   ELSE
02017                      DESCC( I ) = 0
02018                   END IF
02019                END IF
02020 *
02021                INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
02022                CALL PZCALLSUB( SUBPTR, SCODE )
02023                CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02024 *
02025             END IF
02026 *
02027    30    CONTINUE
02028 *
02029       ELSE IF( LSAME( ARGNAM, 'X' ) ) THEN
02030 *
02031 *        Check IX. Set all other OK, bad IX
02032 *
02033          CALL PZSETPBLAS( ICTXT )
02034          IX    = -1
02035          INFOT = ARGPOS + 1
02036          CALL PZCALLSUB( SUBPTR, SCODE )
02037          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02038 *
02039 *        Check JX. Set all other OK, bad JX
02040 *
02041          CALL PZSETPBLAS( ICTXT )
02042          JX    = -1
02043          INFOT = ARGPOS + 2
02044          CALL PZCALLSUB( SUBPTR, SCODE )
02045          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02046 *
02047 *        Check DESCX. Set all other OK, bad DESCX
02048 *
02049          DO 40 I = 1, DLEN_
02050 *
02051 *           Set I'th entry of DESCX to incorrect value, rest ok.
02052 *
02053             CALL PZSETPBLAS( ICTXT )
02054             DESCX( I ) =  -2
02055             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
02056             CALL PZCALLSUB( SUBPTR, SCODE )
02057             CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02058 *
02059 *           Extra tests for RSRCX, CSRCX, LDX
02060 *
02061             IF( ( I.EQ.RSRC_ ) .OR. ( I.EQ.CSRC_ ) .OR.
02062      $          ( I.EQ.LLD_ ) ) THEN
02063 *
02064                CALL PZSETPBLAS( ICTXT )
02065 *
02066 *              Test RSRCX >= NPROW
02067 *
02068                IF( I.EQ.RSRC_ )
02069      $            DESCX( I ) =  NPROW
02070 *
02071 *              Test CSRCX >= NPCOL
02072 *
02073                IF( I.EQ.CSRC_ )
02074      $            DESCX( I ) =  NPCOL
02075 *
02076 *              Test LDX >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
02077 *
02078                IF( I.EQ.LLD_ ) THEN
02079                   IF( MYROW.EQ.0 .AND.MYCOL.EQ.0 ) THEN
02080                      DESCX( I ) = 1
02081                   ELSE
02082                      DESCX( I ) = 0
02083                   END IF
02084                END IF
02085 *
02086                INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
02087                CALL PZCALLSUB( SUBPTR, SCODE )
02088                CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02089 *
02090             END IF
02091 *
02092    40    CONTINUE
02093 *
02094 *        Check INCX. Set all other OK, bad INCX
02095 *
02096          CALL PZSETPBLAS( ICTXT )
02097          INCX  =  -1
02098          INFOT = ARGPOS + 4
02099          CALL PZCALLSUB( SUBPTR, SCODE )
02100          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02101 *
02102       ELSE
02103 *
02104 *        Check IY. Set all other OK, bad IY
02105 *
02106          CALL PZSETPBLAS( ICTXT )
02107          IY    = -1
02108          INFOT = ARGPOS + 1
02109          CALL PZCALLSUB( SUBPTR, SCODE )
02110          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02111 *
02112 *        Check JY. Set all other OK, bad JY
02113 *
02114          CALL PZSETPBLAS( ICTXT )
02115          JY    = -1
02116          INFOT = ARGPOS + 2
02117          CALL PZCALLSUB( SUBPTR, SCODE )
02118          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02119 *
02120 *        Check DESCY. Set all other OK, bad DESCY
02121 *
02122          DO 50 I = 1, DLEN_
02123 *
02124 *           Set I'th entry of DESCY to incorrect value, rest ok.
02125 *
02126             CALL PZSETPBLAS( ICTXT )
02127             DESCY( I ) =  -2
02128             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
02129             CALL PZCALLSUB( SUBPTR, SCODE )
02130             CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02131 *
02132 *           Extra tests for RSRCY, CSRCY, LDY
02133 *
02134             IF( ( I.EQ.RSRC_ ) .OR. ( I.EQ.CSRC_ ) .OR.
02135      $          ( I.EQ.LLD_ ) ) THEN
02136 *
02137                CALL PZSETPBLAS( ICTXT )
02138 *
02139 *              Test RSRCY >= NPROW
02140 *
02141                IF( I.EQ.RSRC_ )
02142      $            DESCY( I ) = NPROW
02143 *
02144 *              Test CSRCY >= NPCOL
02145 *
02146                IF( I.EQ.CSRC_ )
02147      $            DESCY( I ) = NPCOL
02148 *
02149 *              Test LDY >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
02150 *
02151                IF( I.EQ.LLD_ ) THEN
02152                   IF( MYROW.EQ.0 .AND.MYCOL.EQ.0 ) THEN
02153                      DESCY( I ) = 1
02154                   ELSE
02155                      DESCY( I ) = 0
02156                   END IF
02157                END IF
02158 *
02159                INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
02160                CALL PZCALLSUB( SUBPTR, SCODE )
02161                CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02162 *
02163             END IF
02164 *
02165    50    CONTINUE
02166 *
02167 *        Check INCY. Set all other OK, bad INCY
02168 *
02169          CALL PZSETPBLAS( ICTXT )
02170          INCY =  -1
02171          INFOT = ARGPOS + 4
02172          CALL PZCALLSUB( SUBPTR, SCODE )
02173          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02174 *
02175       END IF
02176 *
02177       RETURN
02178 *
02179 *     End of PZCHKMAT
02180 *
02181       END
02182       SUBROUTINE PZCALLSUB( SUBPTR, SCODE )
02183 *
02184 *  -- PBLAS test routine (version 2.0) --
02185 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
02186 *     and University of California, Berkeley.
02187 *     April 1, 1998
02188 *
02189 *     .. Scalar Arguments ..
02190       INTEGER             SCODE
02191 *     ..
02192 *     .. Subroutine Arguments ..
02193       EXTERNAL            SUBPTR
02194 *     ..
02195 *
02196 *  Purpose
02197 *  =======
02198 *
02199 *  PZCALLSUB calls the subroutine SUBPTR with the calling sequence iden-
02200 *  tified by SCODE.
02201 *
02202 *  Notes
02203 *  =====
02204 *
02205 *  A description  vector  is associated with each 2D block-cyclicly dis-
02206 *  tributed matrix.  This  vector  stores  the  information  required to
02207 *  establish the  mapping  between a  matrix entry and its corresponding
02208 *  process and memory location.
02209 *
02210 *  In  the  following  comments,   the character _  should  be  read  as
02211 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
02212 *  block cyclicly distributed matrix.  Its description vector is DESCA:
02213 *
02214 *  NOTATION         STORED IN       EXPLANATION
02215 *  ---------------- --------------- ------------------------------------
02216 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
02217 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
02218 *                                   the NPROW x NPCOL BLACS process grid
02219 *                                   A  is distributed over.  The context
02220 *                                   itself  is  global,  but  the handle
02221 *                                   (the integer value) may vary.
02222 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
02223 *                                   ted matrix A, M_A >= 0.
02224 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
02225 *                                   buted matrix A, N_A >= 0.
02226 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
02227 *                                   block of the matrix A, IMB_A > 0.
02228 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
02229 *                                   left   block   of   the   matrix  A,
02230 *                                   INB_A > 0.
02231 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
02232 *                                   bute the last  M_A-IMB_A rows of  A,
02233 *                                   MB_A > 0.
02234 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
02235 *                                   bute the last  N_A-INB_A  columns of
02236 *                                   A, NB_A > 0.
02237 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
02238 *                                   row of the matrix  A is distributed,
02239 *                                   NPROW > RSRC_A >= 0.
02240 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
02241 *                                   first  column of  A  is distributed.
02242 *                                   NPCOL > CSRC_A >= 0.
02243 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
02244 *                                   array  storing  the  local blocks of
02245 *                                   the distributed matrix A,
02246 *                                   IF( Lc( 1, N_A ) > 0 )
02247 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
02248 *                                   ELSE
02249 *                                      LLD_A >= 1.
02250 *
02251 *  Let K be the number of  rows of a matrix A starting at the global in-
02252 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
02253 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
02254 *  receive if these K rows were distributed over NPROW processes.  If  K
02255 *  is the number of columns of a matrix  A  starting at the global index
02256 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
02257 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
02258 *  these K columns were distributed over NPCOL processes.
02259 *
02260 *  The values of Lr() and Lc() may be determined via a call to the func-
02261 *  tion PB_NUMROC:
02262 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
02263 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
02264 *
02265 *  Arguments
02266 *  =========
02267 *
02268 *  SUBPTR  (global input) SUBROUTINE
02269 *          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
02270 *          EXTERNAL in the calling subroutine.
02271 *
02272 *  SCODE   (global input) INTEGER
02273 *          On entry, SCODE specifies the calling sequence code.
02274 *
02275 *  Calling sequence encodings
02276 *  ==========================
02277 *
02278 *  code Formal argument list                                Examples
02279 *
02280 *  11   (n,      v1,v2)                                     _SWAP, _COPY
02281 *  12   (n,s1,   v1   )                                     _SCAL, _SCAL
02282 *  13   (n,s1,   v1,v2)                                     _AXPY, _DOT_
02283 *  14   (n,s1,i1,v1   )                                     _AMAX
02284 *  15   (n,u1,   v1   )                                     _ASUM, _NRM2
02285 *
02286 *  21   (     trans,     m,n,s1,m1,v1,s2,v2)                _GEMV
02287 *  22   (uplo,             n,s1,m1,v1,s2,v2)                _SYMV, _HEMV
02288 *  23   (uplo,trans,diag,  n,   m1,v1      )                _TRMV, _TRSV
02289 *  24   (                m,n,s1,v1,v2,m1)                   _GER_
02290 *  25   (uplo,             n,s1,v1,   m1)                   _SYR
02291 *  26   (uplo,             n,u1,v1,   m1)                   _HER
02292 *  27   (uplo,             n,s1,v1,v2,m1)                   _SYR2, _HER2
02293 *
02294 *  31   (          transa,transb,     m,n,k,s1,m1,m2,s2,m3) _GEMM
02295 *  32   (side,uplo,                   m,n,  s1,m1,m2,s2,m3) _SYMM, _HEMM
02296 *  33   (     uplo,trans,               n,k,s1,m1,   s2,m3) _SYRK
02297 *  34   (     uplo,trans,               n,k,u1,m1,   u2,m3) _HERK
02298 *  35   (     uplo,trans,               n,k,s1,m1,m2,s2,m3) _SYR2K
02299 *  36   (     uplo,trans,               n,k,s1,m1,m2,u2,m3) _HER2K
02300 *  37   (                             m,n,  s1,m1,   s2,m3) _TRAN_
02301 *  38   (side,uplo,transa,       diag,m,n,  s1,m1,m2      ) _TRMM, _TRSM
02302 *  39   (          trans,             m,n,  s1,m1,   s2,m3) _GEADD
02303 *  40   (     uplo,trans,             m,n,  s1,m1,   s2,m3) _TRADD
02304 *
02305 *  -- Written on April 1, 1998 by
02306 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
02307 *
02308 *  =====================================================================
02309 *
02310 *     .. Parameters ..
02311       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
02312      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
02313      $                   RSRC_
02314       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
02315      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
02316      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
02317      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
02318 *     ..
02319 *     .. Common Blocks ..
02320       CHARACTER*1        DIAG, SIDE, TRANSA, TRANSB, UPLO
02321       INTEGER            IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB,
02322      $                   JC, JX, JY, KDIM, MDIM, NDIM
02323       DOUBLE PRECISION   USCLR
02324       COMPLEX*16         SCLR
02325       INTEGER            DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
02326      $                   DESCX( DLEN_ ), DESCY( DLEN_ )
02327       COMPLEX*16         A( 2, 2 ), B( 2, 2 ), C( 2, 2 ), X( 2 ), Y( 2 )
02328       COMMON             /PBLASC/DIAG, SIDE, TRANSA, TRANSB, UPLO
02329       COMMON             /PBLASD/DESCA, DESCB, DESCC, DESCX, DESCY
02330       COMMON             /PBLASI/IA, IB, IC, INCX, INCY, ISCLR, IX, IY,
02331      $                   JA, JB, JC, JX, JY
02332       COMMON             /PBLASM/A, B, C
02333       COMMON             /PBLASN/KDIM, MDIM, NDIM
02334       COMMON             /PBLASS/SCLR, USCLR
02335       COMMON             /PBLASV/X, Y
02336 *     ..
02337 *     .. Executable Statements ..
02338 *
02339 *     Level 1 PBLAS
02340 *
02341       IF( SCODE.EQ.11 ) THEN
02342 *
02343          CALL SUBPTR( NDIM, X, IX, JX, DESCX, INCX, Y, IY, JY, DESCY,
02344      $                INCY )
02345 *
02346       ELSE IF( SCODE.EQ.12 ) THEN
02347 *
02348          CALL SUBPTR( NDIM, SCLR, X, IX, JX, DESCX, INCX )
02349 *
02350       ELSE IF( SCODE.EQ.13 ) THEN
02351 *
02352          CALL SUBPTR( NDIM, SCLR, X, IX, JX, DESCX, INCX, Y, IY, JY,
02353      $                DESCY, INCY )
02354 *
02355       ELSE IF( SCODE.EQ.14 ) THEN
02356 *
02357          CALL SUBPTR( NDIM, SCLR, ISCLR, X, IX, JX, DESCX, INCX )
02358 *
02359       ELSE IF( SCODE.EQ.15 ) THEN
02360 *
02361          CALL SUBPTR( NDIM, USCLR, X, IX, JX, DESCX, INCX )
02362 *
02363 *     Level 2 PBLAS
02364 *
02365       ELSE IF( SCODE.EQ.21 ) THEN
02366 *
02367          CALL SUBPTR( TRANSA, MDIM, NDIM, SCLR, A, IA, JA, DESCA, X, IX,
02368      $                JX, DESCX, INCX, SCLR, Y, IY, JY, DESCY, INCY )
02369 *
02370       ELSE IF( SCODE.EQ.22 ) THEN
02371 *
02372          CALL SUBPTR( UPLO, NDIM, SCLR, A, IA, JA, DESCA, X, IX, JX,
02373      $                DESCX, INCX, SCLR, Y, IY, JY, DESCY, INCY )
02374 *
02375       ELSE IF( SCODE.EQ.23 ) THEN
02376 *
02377          CALL SUBPTR( UPLO, TRANSA, DIAG, NDIM, A, IA, JA, DESCA, X, IX,
02378      $                JX, DESCX, INCX )
02379 *
02380       ELSE IF( SCODE.EQ.24 ) THEN
02381 *
02382          CALL SUBPTR( MDIM, NDIM, SCLR, X, IX, JX, DESCX, INCX, Y, IY,
02383      $                JY, DESCY, INCY, A, IA, JA, DESCA )
02384 *
02385       ELSE IF( SCODE.EQ.25 ) THEN
02386 *
02387          CALL SUBPTR( UPLO, NDIM, SCLR, X, IX, JX, DESCX, INCX, A, IA,
02388      $                JA, DESCA )
02389 *
02390       ELSE IF( SCODE.EQ.26 ) THEN
02391 *
02392          CALL SUBPTR( UPLO, NDIM, USCLR, X, IX, JX, DESCX, INCX, A, IA,
02393      $                JA, DESCA )
02394 *
02395       ELSE IF( SCODE.EQ.27 ) THEN
02396 *
02397          CALL SUBPTR( UPLO, NDIM, SCLR, X, IX, JX, DESCX, INCX, Y, IY,
02398      $                JY, DESCY, INCY, A, IA, JA, DESCA )
02399 *
02400 *     Level 3 PBLAS
02401 *
02402       ELSE IF( SCODE.EQ.31 ) THEN
02403 *
02404          CALL SUBPTR( TRANSA, TRANSB, MDIM, NDIM, KDIM, SCLR, A, IA, JA,
02405      $                DESCA, B, IB, JB, DESCB, SCLR, C, IC, JC, DESCC )
02406 *
02407       ELSE IF( SCODE.EQ.32 ) THEN
02408 *
02409          CALL SUBPTR( SIDE, UPLO, MDIM, NDIM, SCLR, A, IA, JA, DESCA, B,
02410      $                IB, JB, DESCB, SCLR, C, IC, JC, DESCC )
02411 *
02412       ELSE IF( SCODE.EQ.33 ) THEN
02413 *
02414          CALL SUBPTR( UPLO, TRANSA, NDIM, KDIM, SCLR, A, IA, JA, DESCA,
02415      $                SCLR, C, IC, JC, DESCC )
02416 *
02417       ELSE IF( SCODE.EQ.34 ) THEN
02418 *
02419          CALL SUBPTR( UPLO, TRANSA, NDIM, KDIM, USCLR, A, IA, JA, DESCA,
02420      $                USCLR, C, IC, JC, DESCC )
02421 *
02422       ELSE IF( SCODE.EQ.35 ) THEN
02423 *
02424          CALL SUBPTR( UPLO, TRANSA, NDIM, KDIM, SCLR, A, IA, JA, DESCA,
02425      $                B, IB, JB, DESCB, SCLR, C, IC, JC, DESCC )
02426 *
02427       ELSE IF( SCODE.EQ.36 ) THEN
02428 *
02429          CALL SUBPTR( UPLO, TRANSA, NDIM, KDIM, SCLR, A, IA, JA, DESCA,
02430      $                B, IB, JB, DESCB, USCLR, C, IC, JC, DESCC )
02431 *
02432       ELSE IF( SCODE.EQ.37 ) THEN
02433 *
02434          CALL SUBPTR( MDIM, NDIM, SCLR, A, IA, JA, DESCA, SCLR, C, IC,
02435      $                JC, DESCC )
02436 *
02437       ELSE IF( SCODE.EQ.38 ) THEN
02438 *
02439          CALL SUBPTR( SIDE, UPLO, TRANSA, DIAG, MDIM, NDIM, SCLR, A, IA,
02440      $                JA, DESCA, B, IB, JB, DESCB )
02441 *
02442       ELSE IF( SCODE.EQ.39 ) THEN
02443 *
02444          CALL SUBPTR( TRANSA, MDIM, NDIM, SCLR, A, IA, JA, DESCA, SCLR,
02445      $                C, IC, JC, DESCC )
02446 *
02447       ELSE IF( SCODE.EQ.40 ) THEN
02448 *
02449          CALL SUBPTR( UPLO, TRANSA, MDIM, NDIM, SCLR, A, IA, JA, DESCA,
02450      $                SCLR, C, IC, JC, DESCC )
02451 *
02452       END IF
02453 *
02454       RETURN
02455 *
02456 *     End of PZCALLSUB
02457 *
02458       END
02459       SUBROUTINE PZERRSET( ERR, ERRMAX, XTRUE, X )
02460 *
02461 *  -- PBLAS test routine (version 2.0) --
02462 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
02463 *     and University of California, Berkeley.
02464 *     April 1, 1998
02465 *
02466 *     .. Scalar Arguments ..
02467       DOUBLE PRECISION   ERR, ERRMAX
02468       COMPLEX*16         X, XTRUE
02469 *     ..
02470 *
02471 *  Purpose
02472 *  =======
02473 *
02474 *  PZERRSET  computes the absolute difference ERR = |XTRUE - X| and com-
02475 *  pares it with zero. ERRMAX accumulates the absolute error difference.
02476 *
02477 *  Notes
02478 *  =====
02479 *
02480 *  A description  vector  is associated with each 2D block-cyclicly dis-
02481 *  tributed matrix.  This  vector  stores  the  information  required to
02482 *  establish the  mapping  between a  matrix entry and its corresponding
02483 *  process and memory location.
02484 *
02485 *  In  the  following  comments,   the character _  should  be  read  as
02486 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
02487 *  block cyclicly distributed matrix.  Its description vector is DESCA:
02488 *
02489 *  NOTATION         STORED IN       EXPLANATION
02490 *  ---------------- --------------- ------------------------------------
02491 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
02492 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
02493 *                                   the NPROW x NPCOL BLACS process grid
02494 *                                   A  is distributed over.  The context
02495 *                                   itself  is  global,  but  the handle
02496 *                                   (the integer value) may vary.
02497 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
02498 *                                   ted matrix A, M_A >= 0.
02499 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
02500 *                                   buted matrix A, N_A >= 0.
02501 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
02502 *                                   block of the matrix A, IMB_A > 0.
02503 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
02504 *                                   left   block   of   the   matrix  A,
02505 *                                   INB_A > 0.
02506 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
02507 *                                   bute the last  M_A-IMB_A rows of  A,
02508 *                                   MB_A > 0.
02509 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
02510 *                                   bute the last  N_A-INB_A  columns of
02511 *                                   A, NB_A > 0.
02512 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
02513 *                                   row of the matrix  A is distributed,
02514 *                                   NPROW > RSRC_A >= 0.
02515 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
02516 *                                   first  column of  A  is distributed.
02517 *                                   NPCOL > CSRC_A >= 0.
02518 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
02519 *                                   array  storing  the  local blocks of
02520 *                                   the distributed matrix A,
02521 *                                   IF( Lc( 1, N_A ) > 0 )
02522 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
02523 *                                   ELSE
02524 *                                      LLD_A >= 1.
02525 *
02526 *  Let K be the number of  rows of a matrix A starting at the global in-
02527 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
02528 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
02529 *  receive if these K rows were distributed over NPROW processes.  If  K
02530 *  is the number of columns of a matrix  A  starting at the global index
02531 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
02532 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
02533 *  these K columns were distributed over NPCOL processes.
02534 *
02535 *  The values of Lr() and Lc() may be determined via a call to the func-
02536 *  tion PB_NUMROC:
02537 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
02538 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
02539 *
02540 *  Arguments
02541 *  =========
02542 *
02543 *  ERR     (local output) DOUBLE PRECISION
02544 *          On exit, ERR specifies the absolute difference |XTRUE - X|.
02545 *
02546 *  ERRMAX  (local input/local output) DOUBLE PRECISION
02547 *          On entry,  ERRMAX  specifies  a previously computed error. On
02548 *          exit ERRMAX is the accumulated error MAX( ERRMAX, ERR ).
02549 *
02550 *  XTRUE   (local input) COMPLEX*16
02551 *          On entry, XTRUE specifies the true value.
02552 *
02553 *  X       (local input) COMPLEX*16
02554 *          On entry, X specifies the value to be compared to XTRUE.
02555 *
02556 *  -- Written on April 1, 1998 by
02557 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
02558 *
02559 *  =====================================================================
02560 *
02561 *     .. External Functions ..
02562       DOUBLE PRECISION   PDDIFF
02563       EXTERNAL           PDDIFF
02564 *     ..
02565 *     .. Intrinsic Functions ..
02566       INTRINSIC          ABS, DBLE, DIMAG, MAX
02567 *     ..
02568 *     .. Executable Statements ..
02569 *
02570       ERR = ABS( PDDIFF( DBLE( XTRUE ), DBLE( X ) ) )
02571       ERR = MAX( ERR, ABS( PDDIFF( DIMAG( XTRUE ), DIMAG( X ) ) ) )
02572 *
02573       ERRMAX = MAX( ERRMAX, ERR )
02574 *
02575       RETURN
02576 *
02577 *     End of PZERRSET
02578 *
02579       END
02580       SUBROUTINE PZCHKVIN( ERRMAX, N, X, PX, IX, JX, DESCX, INCX,
02581      $                     INFO )
02582 *
02583 *  -- PBLAS test routine (version 2.0) --
02584 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
02585 *     and University of California, Berkeley.
02586 *     April 1, 1998
02587 *
02588 *     .. Scalar Arguments ..
02589       INTEGER            INCX, INFO, IX, JX, N
02590       DOUBLE PRECISION   ERRMAX
02591 *     ..
02592 *     .. Array Arguments ..
02593       INTEGER            DESCX( * )
02594       COMPLEX*16         PX( * ), X( * )
02595 *     ..
02596 *
02597 *  Purpose
02598 *  =======
02599 *
02600 *  PZCHKVIN  checks that the submatrix sub( PX ) remained unchanged. The
02601 *  local  array  entries are compared element by element, and their dif-
02602 *  ference  is tested against 0.0 as well as the epsilon machine. Notice
02603 *  that  this difference should be numerically exactly the zero machine,
02604 *  but  because of the possible fluctuation of some of the data we flag-
02605 *  ged differently a difference less than twice the epsilon machine. The
02606 *  largest error is also returned.
02607 *
02608 *  Notes
02609 *  =====
02610 *
02611 *  A description  vector  is associated with each 2D block-cyclicly dis-
02612 *  tributed matrix.  This  vector  stores  the  information  required to
02613 *  establish the  mapping  between a  matrix entry and its corresponding
02614 *  process and memory location.
02615 *
02616 *  In  the  following  comments,   the character _  should  be  read  as
02617 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
02618 *  block cyclicly distributed matrix.  Its description vector is DESCA:
02619 *
02620 *  NOTATION         STORED IN       EXPLANATION
02621 *  ---------------- --------------- ------------------------------------
02622 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
02623 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
02624 *                                   the NPROW x NPCOL BLACS process grid
02625 *                                   A  is distributed over.  The context
02626 *                                   itself  is  global,  but  the handle
02627 *                                   (the integer value) may vary.
02628 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
02629 *                                   ted matrix A, M_A >= 0.
02630 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
02631 *                                   buted matrix A, N_A >= 0.
02632 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
02633 *                                   block of the matrix A, IMB_A > 0.
02634 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
02635 *                                   left   block   of   the   matrix  A,
02636 *                                   INB_A > 0.
02637 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
02638 *                                   bute the last  M_A-IMB_A rows of  A,
02639 *                                   MB_A > 0.
02640 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
02641 *                                   bute the last  N_A-INB_A  columns of
02642 *                                   A, NB_A > 0.
02643 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
02644 *                                   row of the matrix  A is distributed,
02645 *                                   NPROW > RSRC_A >= 0.
02646 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
02647 *                                   first  column of  A  is distributed.
02648 *                                   NPCOL > CSRC_A >= 0.
02649 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
02650 *                                   array  storing  the  local blocks of
02651 *                                   the distributed matrix A,
02652 *                                   IF( Lc( 1, N_A ) > 0 )
02653 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
02654 *                                   ELSE
02655 *                                      LLD_A >= 1.
02656 *
02657 *  Let K be the number of  rows of a matrix A starting at the global in-
02658 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
02659 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
02660 *  receive if these K rows were distributed over NPROW processes.  If  K
02661 *  is the number of columns of a matrix  A  starting at the global index
02662 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
02663 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
02664 *  these K columns were distributed over NPCOL processes.
02665 *
02666 *  The values of Lr() and Lc() may be determined via a call to the func-
02667 *  tion PB_NUMROC:
02668 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
02669 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
02670 *
02671 *  Arguments
02672 *  =========
02673 *
02674 *  ERRMAX  (global output) DOUBLE PRECISION
02675 *          On exit,  ERRMAX  specifies the largest absolute element-wise
02676 *          difference between sub( X ) and sub( PX ).
02677 *
02678 *  N       (global input) INTEGER
02679 *          On entry,  N  specifies  the  length of the subvector operand
02680 *          sub( X ). N must be at least zero.
02681 *
02682 *  X       (local input) COMPLEX*16 array
02683 *          On entry, X is an array of  dimension  (DESCX( M_ ),*).  This
02684 *          array contains a local copy of the initial entire matrix PX.
02685 *
02686 *  PX      (local input) COMPLEX*16 array
02687 *          On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
02688 *          array contains the local entries of the matrix PX.
02689 *
02690 *  IX      (global input) INTEGER
02691 *          On entry, IX  specifies X's global row index, which points to
02692 *          the beginning of the submatrix sub( X ).
02693 *
02694 *  JX      (global input) INTEGER
02695 *          On entry, JX  specifies X's global column index, which points
02696 *          to the beginning of the submatrix sub( X ).
02697 *
02698 *  DESCX   (global and local input) INTEGER array
02699 *          On entry, DESCX  is an integer array of dimension DLEN_. This
02700 *          is the array descriptor for the matrix X.
02701 *
02702 *  INCX    (global input) INTEGER
02703 *          On entry,  INCX   specifies  the  global  increment  for  the
02704 *          elements of  X.  Only two values of  INCX   are  supported in
02705 *          this version, namely 1 and M_X. INCX  must not be zero.
02706 *
02707 *  INFO    (global output) INTEGER
02708 *          On exit, if INFO = 0, no error has been found,
02709 *          If INFO > 0, the maximum abolute error found is in (0,eps],
02710 *          If INFO < 0, the maximum abolute error found is in (eps,+oo).
02711 *
02712 *  -- Written on April 1, 1998 by
02713 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
02714 *
02715 *  =====================================================================
02716 *
02717 *     .. Parameters ..
02718       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
02719      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
02720      $                   RSRC_
02721       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
02722      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
02723      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
02724      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
02725       DOUBLE PRECISION   ZERO
02726       PARAMETER          ( ZERO = 0.0D+0 )
02727 *     ..
02728 *     .. Local Scalars ..
02729       LOGICAL            COLREP, ROWREP
02730       INTEGER            I, IB, ICTXT, ICURCOL, ICURROW, IIX, IN, IXCOL,
02731      $                   IXROW, J, JB, JJX, JN, KK, LDPX, LDX, LL,
02732      $                   MYCOL, MYROW, NPCOL, NPROW
02733       DOUBLE PRECISION   ERR, EPS
02734 *     ..
02735 *     .. External Subroutines ..
02736       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, PB_INFOG2L, PZERRSET
02737 *     ..
02738 *     .. External Functions ..
02739       DOUBLE PRECISION   PDLAMCH
02740       EXTERNAL           PDLAMCH
02741 *     ..
02742 *     .. Intrinsic Functions ..
02743       INTRINSIC          ABS, DBLE, DIMAG, MAX, MIN, MOD
02744 *     ..
02745 *     .. Executable Statements ..
02746 *
02747       INFO = 0
02748       ERRMAX = ZERO
02749 *
02750 *     Quick return if possible
02751 *
02752       IF( N.LE.0 )
02753      $   RETURN
02754 *
02755       ICTXT = DESCX( CTXT_ )
02756       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
02757 *
02758       EPS = PDLAMCH( ICTXT, 'eps' )
02759 *
02760       CALL PB_INFOG2L( IX, JX, DESCX, NPROW, NPCOL, MYROW, MYCOL, IIX,
02761      $                 JJX, IXROW, IXCOL )
02762 *
02763       LDX    = DESCX( M_ )
02764       LDPX   = DESCX( LLD_ )
02765       ROWREP = ( IXROW.EQ.-1 )
02766       COLREP = ( IXCOL.EQ.-1 )
02767 *
02768       IF( N.EQ.1 ) THEN
02769 *
02770          IF( ( MYROW.EQ.IXROW .OR. ROWREP ) .AND.
02771      $       ( MYCOL.EQ.IXCOL .OR. COLREP ) )
02772      $      CALL PZERRSET( ERR, ERRMAX, X( IX+(JX-1)*LDX ),
02773      $                     PX( IIX+(JJX-1)*LDPX ) )
02774 *
02775       ELSE IF( INCX.EQ.DESCX( M_ ) ) THEN
02776 *
02777 *        sub( X ) is a row vector
02778 *
02779          JB = DESCX( INB_ ) - JX + 1
02780          IF( JB.LE.0 )
02781      $      JB = ( ( -JB ) / DESCX( NB_ ) + 1 ) * DESCX( NB_ ) + JB
02782          JB = MIN( JB, N )
02783          JN = JX + JB - 1
02784 *
02785          IF( MYROW.EQ.IXROW .OR. ROWREP ) THEN
02786 *
02787             ICURCOL = IXCOL
02788             IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN
02789                DO 10 J = JX, JN
02790                   CALL PZERRSET( ERR, ERRMAX, X( IX+(J-1)*LDX ),
02791      $                           PX( IIX+(JJX-1)*LDPX ) )
02792                   JJX = JJX + 1
02793    10          CONTINUE
02794             END IF
02795             ICURCOL = MOD( ICURCOL+1, NPCOL )
02796 *
02797             DO 30 J = JN+1, JX+N-1, DESCX( NB_ )
02798                JB = MIN( JX+N-J, DESCX( NB_ ) )
02799 *
02800                IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN
02801 *
02802                   DO 20 KK = 0, JB-1
02803                      CALL PZERRSET( ERR, ERRMAX, X( IX+(J+KK-1)*LDX ),
02804      $                              PX( IIX+(JJX+KK-1)*LDPX ) )
02805    20             CONTINUE
02806 *
02807                   JJX = JJX + JB
02808 *
02809                END IF
02810 *
02811                ICURCOL = MOD( ICURCOL+1, NPCOL )
02812 *
02813    30       CONTINUE
02814 *
02815          END IF
02816 *
02817       ELSE
02818 *
02819 *        sub( X ) is a column vector
02820 *
02821          IB = DESCX( IMB_ ) - IX + 1
02822          IF( IB.LE.0 )
02823      $      IB = ( ( -IB ) / DESCX( MB_ ) + 1 ) * DESCX( MB_ ) + IB
02824          IB = MIN( IB, N )
02825          IN = IX + IB - 1
02826 *
02827          IF( MYCOL.EQ.IXCOL .OR. COLREP ) THEN
02828 *
02829             ICURROW = IXROW
02830             IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
02831                DO 40 I = IX, IN
02832                   CALL PZERRSET( ERR, ERRMAX, X( I+(JX-1)*LDX ),
02833      $                           PX( IIX+(JJX-1)*LDPX ) )
02834                   IIX = IIX + 1
02835    40          CONTINUE
02836             END IF
02837             ICURROW = MOD( ICURROW+1, NPROW )
02838 *
02839             DO 60 I = IN+1, IX+N-1, DESCX( MB_ )
02840                IB = MIN( IX+N-I, DESCX( MB_ ) )
02841 *
02842                IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
02843 *
02844                   DO 50 KK = 0, IB-1
02845                      CALL PZERRSET( ERR, ERRMAX, X( I+KK+(JX-1)*LDX ),
02846      $                              PX( IIX+KK+(JJX-1)*LDPX ) )
02847    50             CONTINUE
02848 *
02849                   IIX = IIX + IB
02850 *
02851                END IF
02852 *
02853                ICURROW = MOD( ICURROW+1, NPROW )
02854 *
02855    60       CONTINUE
02856 *
02857          END IF
02858 *
02859       END IF
02860 *
02861       CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERRMAX, 1, KK, LL, -1,
02862      $              -1, -1 )
02863 *
02864       IF( ERRMAX.GT.ZERO .AND. ERRMAX.LE.EPS ) THEN
02865          INFO = 1
02866       ELSE IF( ERRMAX.GT.EPS ) THEN
02867          INFO = -1
02868       END IF
02869 *
02870       RETURN
02871 *
02872 *     End of PZCHKVIN
02873 *
02874       END
02875       SUBROUTINE PZCHKVOUT( N, X, PX, IX, JX, DESCX, INCX, INFO )
02876 *
02877 *  -- PBLAS test routine (version 2.0) --
02878 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
02879 *     and University of California, Berkeley.
02880 *     April 1, 1998
02881 *
02882 *     .. Scalar Arguments ..
02883       INTEGER            INCX, INFO, IX, JX, N
02884 *     ..
02885 *     .. Array Arguments ..
02886       INTEGER            DESCX( * )
02887       COMPLEX*16         PX( * ), X( * )
02888 *     ..
02889 *
02890 *  Purpose
02891 *  =======
02892 *
02893 *  PZCHKVOUT  checks  that the matrix PX \ sub( PX ) remained unchanged.
02894 *  The  local array  entries  are compared element by element, and their
02895 *  difference  is tested against 0.0 as well as the epsilon machine. No-
02896 *  tice that this  difference should be numerically exactly the zero ma-
02897 *  chine, but because  of  the  possible movement of some of the data we
02898 *  flagged differently a difference less than twice the epsilon machine.
02899 *  The largest error is reported.
02900 *
02901 *  Notes
02902 *  =====
02903 *
02904 *  A description  vector  is associated with each 2D block-cyclicly dis-
02905 *  tributed matrix.  This  vector  stores  the  information  required to
02906 *  establish the  mapping  between a  matrix entry and its corresponding
02907 *  process and memory location.
02908 *
02909 *  In  the  following  comments,   the character _  should  be  read  as
02910 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
02911 *  block cyclicly distributed matrix.  Its description vector is DESCA:
02912 *
02913 *  NOTATION         STORED IN       EXPLANATION
02914 *  ---------------- --------------- ------------------------------------
02915 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
02916 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
02917 *                                   the NPROW x NPCOL BLACS process grid
02918 *                                   A  is distributed over.  The context
02919 *                                   itself  is  global,  but  the handle
02920 *                                   (the integer value) may vary.
02921 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
02922 *                                   ted matrix A, M_A >= 0.
02923 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
02924 *                                   buted matrix A, N_A >= 0.
02925 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
02926 *                                   block of the matrix A, IMB_A > 0.
02927 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
02928 *                                   left   block   of   the   matrix  A,
02929 *                                   INB_A > 0.
02930 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
02931 *                                   bute the last  M_A-IMB_A rows of  A,
02932 *                                   MB_A > 0.
02933 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
02934 *                                   bute the last  N_A-INB_A  columns of
02935 *                                   A, NB_A > 0.
02936 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
02937 *                                   row of the matrix  A is distributed,
02938 *                                   NPROW > RSRC_A >= 0.
02939 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
02940 *                                   first  column of  A  is distributed.
02941 *                                   NPCOL > CSRC_A >= 0.
02942 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
02943 *                                   array  storing  the  local blocks of
02944 *                                   the distributed matrix A,
02945 *                                   IF( Lc( 1, N_A ) > 0 )
02946 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
02947 *                                   ELSE
02948 *                                      LLD_A >= 1.
02949 *
02950 *  Let K be the number of  rows of a matrix A starting at the global in-
02951 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
02952 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
02953 *  receive if these K rows were distributed over NPROW processes.  If  K
02954 *  is the number of columns of a matrix  A  starting at the global index
02955 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
02956 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
02957 *  these K columns were distributed over NPCOL processes.
02958 *
02959 *  The values of Lr() and Lc() may be determined via a call to the func-
02960 *  tion PB_NUMROC:
02961 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
02962 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
02963 *
02964 *  Arguments
02965 *  =========
02966 *
02967 *  N       (global input) INTEGER
02968 *          On entry,  N  specifies  the  length of the subvector operand
02969 *          sub( X ). N must be at least zero.
02970 *
02971 *  X       (local input) COMPLEX*16 array
02972 *          On entry, X is an array of  dimension  (DESCX( M_ ),*).  This
02973 *          array contains a local copy of the initial entire matrix PX.
02974 *
02975 *  PX      (local input) COMPLEX*16 array
02976 *          On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
02977 *          array contains the local entries of the matrix PX.
02978 *
02979 *  IX      (global input) INTEGER
02980 *          On entry, IX  specifies X's global row index, which points to
02981 *          the beginning of the submatrix sub( X ).
02982 *
02983 *  JX      (global input) INTEGER
02984 *          On entry, JX  specifies X's global column index, which points
02985 *          to the beginning of the submatrix sub( X ).
02986 *
02987 *  DESCX   (global and local input) INTEGER array
02988 *          On entry, DESCX  is an integer array of dimension DLEN_. This
02989 *          is the array descriptor for the matrix X.
02990 *
02991 *  INCX    (global input) INTEGER
02992 *          On entry,  INCX   specifies  the  global  increment  for  the
02993 *          elements of  X.  Only two values of  INCX   are  supported in
02994 *          this version, namely 1 and M_X. INCX  must not be zero.
02995 *
02996 *  INFO    (global output) INTEGER
02997 *          On exit, if INFO = 0, no error has been found,
02998 *          If INFO > 0, the maximum abolute error found is in (0,eps],
02999 *          If INFO < 0, the maximum abolute error found is in (eps,+oo).
03000 *
03001 *  -- Written on April 1, 1998 by
03002 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
03003 *
03004 *  =====================================================================
03005 *
03006 *     .. Parameters ..
03007       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
03008      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
03009      $                   RSRC_
03010       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
03011      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
03012      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
03013      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
03014       DOUBLE PRECISION   ZERO
03015       PARAMETER          ( ZERO = 0.0D+0 )
03016 *     ..
03017 *     .. Local Scalars ..
03018       LOGICAL            COLREP, ROWREP
03019       INTEGER            I, IB, ICTXT, ICURCOL, ICURROW, II, IMBX, INBX,
03020      $                   J, JB, JJ, KK, LDPX, LDX, LL, MBX, MPALL,
03021      $                   MYCOL, MYCOLDIST, MYROW, MYROWDIST, NBX, NPCOL,
03022      $                   NPROW, NQALL
03023       DOUBLE PRECISION   EPS, ERR, ERRMAX
03024 *     ..
03025 *     .. External Subroutines ..
03026       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, PZERRSET
03027 *     ..
03028 *     .. External Functions ..
03029       INTEGER            PB_NUMROC
03030       DOUBLE PRECISION   PDLAMCH
03031       EXTERNAL           PDLAMCH, PB_NUMROC
03032 *     ..
03033 *     .. Intrinsic Functions ..
03034       INTRINSIC          ABS, DBLE, DIMAG, MAX, MIN, MOD
03035 *     ..
03036 *     .. Executable Statements ..
03037 *
03038       INFO = 0
03039       ERRMAX = ZERO
03040 *
03041 *     Quick return if possible
03042 *
03043       IF( ( DESCX( M_ ).LE.0 ).OR.( DESCX( N_ ).LE.0 ) )
03044      $   RETURN
03045 *
03046 *     Start the operations
03047 *
03048       ICTXT = DESCX( CTXT_ )
03049       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
03050 *
03051       EPS = PDLAMCH( ICTXT, 'eps' )
03052 *
03053       MPALL   = PB_NUMROC( DESCX( M_ ), 1, DESCX( IMB_ ), DESCX( MB_ ),
03054      $                     MYROW, DESCX( RSRC_ ), NPROW )
03055       NQALL   = PB_NUMROC( DESCX( N_ ), 1, DESCX( INB_ ), DESCX( NB_ ),
03056      $                     MYCOL, DESCX( CSRC_ ), NPCOL )
03057 *
03058       MBX     = DESCX( MB_ )
03059       NBX     = DESCX( NB_ )
03060       LDX     = DESCX( M_ )
03061       LDPX    = DESCX( LLD_ )
03062       ICURROW = DESCX( RSRC_ )
03063       ICURCOL = DESCX( CSRC_ )
03064       ROWREP  = ( ICURROW.EQ.-1 )
03065       COLREP  = ( ICURCOL.EQ.-1 )
03066       IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
03067          IMBX = DESCX( IMB_ )
03068       ELSE
03069          IMBX = MBX
03070       END IF
03071       IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN
03072          INBX = DESCX( INB_ )
03073       ELSE
03074          INBX = NBX
03075       END IF
03076       IF( ROWREP ) THEN
03077          MYROWDIST = 0
03078       ELSE
03079          MYROWDIST = MOD( MYROW - ICURROW + NPROW, NPROW )
03080       END IF
03081       IF( COLREP ) THEN
03082          MYCOLDIST = 0
03083       ELSE
03084          MYCOLDIST = MOD( MYCOL - ICURCOL + NPCOL, NPCOL )
03085       END IF
03086       II = 1
03087       JJ = 1
03088 *
03089       IF( INCX.EQ.DESCX( M_ ) ) THEN
03090 *
03091 *        sub( X ) is a row vector
03092 *
03093          IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
03094 *
03095             I = 1
03096             IF( MYCOLDIST.EQ.0 ) THEN
03097                J = 1
03098             ELSE
03099                J = DESCX( INB_ ) + ( MYCOLDIST - 1 ) * NBX + 1
03100             END IF
03101             JB = MIN( MAX( 0, DESCX( N_ ) - J + 1 ), INBX )
03102             IB = MIN( DESCX( M_ ), DESCX( IMB_ ) )
03103 *
03104             DO 20 KK = 0, JB-1
03105                DO 10 LL = 0, IB-1
03106                   IF( I+LL.NE.IX .OR. J+KK.LT.JX .OR. J+KK.GT.JX+N-1 )
03107      $               CALL PZERRSET( ERR, ERRMAX,
03108      $                              X( I+LL+(J+KK-1)*LDX ),
03109      $                              PX( II+LL+(JJ+KK-1)*LDPX ) )
03110    10          CONTINUE
03111    20       CONTINUE
03112             IF( COLREP ) THEN
03113                J = J + INBX
03114             ELSE
03115                J = J + INBX + ( NPCOL - 1 ) * NBX
03116             END IF
03117 *
03118             DO 50 JJ = INBX+1, NQALL, NBX
03119                JB = MIN( NQALL-JJ+1, NBX )
03120 *
03121                DO 40 KK = 0, JB-1
03122                   DO 30 LL = 0, IB-1
03123                      IF( I+LL.NE.IX .OR. J+KK.LT.JX .OR.
03124      $                   J+KK.GT.JX+N-1 )
03125      $                  CALL PZERRSET( ERR, ERRMAX,
03126      $                                 X( I+LL+(J+KK-1)*LDX ),
03127      $                                 PX( II+LL+(JJ+KK-1)*LDPX ) )
03128    30             CONTINUE
03129    40          CONTINUE
03130 *
03131                IF( COLREP ) THEN
03132                   J = J + NBX
03133                ELSE
03134                   J = J + NPCOL * NBX
03135                END IF
03136 *
03137    50       CONTINUE
03138 *
03139             II = II + IB
03140 *
03141          END IF
03142 *
03143          ICURROW = MOD( ICURROW + 1, NPROW )
03144 *
03145          DO 110 I = DESCX( IMB_ ) + 1, DESCX( M_ ), MBX
03146             IB = MIN( DESCX( M_ ) - I + 1, MBX )
03147 *
03148             IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
03149 *
03150                IF( MYCOLDIST.EQ.0 ) THEN
03151                   J = 1
03152                ELSE
03153                   J = DESCX( INB_ ) + ( MYCOLDIST - 1 ) * NBX + 1
03154                END IF
03155 *
03156                JJ = 1
03157                JB = MIN( MAX( 0, DESCX( N_ ) - J + 1 ), INBX )
03158                DO 70 KK = 0, JB-1
03159                   DO 60 LL = 0, IB-1
03160                      IF( I+LL.NE.IX .OR. J+KK.LT.JX .OR.
03161      $                   J+KK.GT.JX+N-1 )
03162      $                  CALL PZERRSET( ERR, ERRMAX,
03163      $                                 X( I+LL+(J+KK-1)*LDX ),
03164      $                                 PX( II+LL+(JJ+KK-1)*LDPX ) )
03165    60             CONTINUE
03166    70          CONTINUE
03167                IF( COLREP ) THEN
03168                   J = J + INBX
03169                ELSE
03170                   J = J + INBX + ( NPCOL - 1 ) * NBX
03171                END IF
03172 *
03173                DO 100 JJ = INBX+1, NQALL, NBX
03174                   JB = MIN( NQALL-JJ+1, NBX )
03175 *
03176                   DO 90 KK = 0, JB-1
03177                      DO 80 LL = 0, IB-1
03178                         IF( I+LL.NE.IX .OR. J+KK.LT.JX .OR.
03179      $                      J+KK.GT.JX+N-1 )
03180      $                     CALL PZERRSET( ERR, ERRMAX,
03181      $                                    X( I+LL+(J+KK-1)*LDX ),
03182      $                                    PX( II+LL+(JJ+KK-1)*LDPX ) )
03183    80                CONTINUE
03184    90             CONTINUE
03185 *
03186                   IF( COLREP ) THEN
03187                      J = J + NBX
03188                   ELSE
03189                      J = J + NPCOL * NBX
03190                   END IF
03191 *
03192   100          CONTINUE
03193 *
03194                II = II + IB
03195 *
03196             END IF
03197 *
03198             ICURROW = MOD( ICURROW + 1, NPROW )
03199 *
03200   110    CONTINUE
03201 *
03202       ELSE
03203 *
03204 *        sub( X ) is a column vector
03205 *
03206          IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN
03207 *
03208             J = 1
03209             IF( MYROWDIST.EQ.0 ) THEN
03210                I = 1
03211             ELSE
03212                I = DESCX( IMB_ ) + ( MYROWDIST - 1 ) * MBX + 1
03213             END IF
03214             IB = MIN( MAX( 0, DESCX( M_ ) - I + 1 ), IMBX )
03215             JB = MIN( DESCX( N_ ), DESCX( INB_ ) )
03216 *
03217             DO 130 KK = 0, JB-1
03218                DO 120 LL = 0, IB-1
03219                   IF( J+KK.NE.JX .OR. I+LL.LT.IX .OR. I+LL.GT.IX+N-1 )
03220      $               CALL PZERRSET( ERR, ERRMAX,
03221      $                              X( I+LL+(J+KK-1)*LDX ),
03222      $                              PX( II+LL+(JJ+KK-1)*LDPX ) )
03223   120          CONTINUE
03224   130       CONTINUE
03225             IF( ROWREP ) THEN
03226                I = I + IMBX
03227             ELSE
03228                I = I + IMBX + ( NPROW - 1 ) * MBX
03229             END IF
03230 *
03231             DO 160 II = IMBX+1, MPALL, MBX
03232                IB = MIN( MPALL-II+1, MBX )
03233 *
03234                DO 150 KK = 0, JB-1
03235                   DO 140 LL = 0, IB-1
03236                      IF( J+KK.NE.JX .OR. I+LL.LT.IX .OR.
03237      $                   I+LL.GT.IX+N-1 )
03238      $                  CALL PZERRSET( ERR, ERRMAX,
03239      $                                 X( I+LL+(J+KK-1)*LDX ),
03240      $                                 PX( II+LL+(JJ+KK-1)*LDPX ) )
03241   140             CONTINUE
03242   150          CONTINUE
03243 *
03244                IF( ROWREP ) THEN
03245                   I = I + MBX
03246                ELSE
03247                   I = I + NPROW * MBX
03248                END IF
03249 *
03250   160       CONTINUE
03251 *
03252             JJ = JJ + JB
03253 *
03254          END IF
03255 *
03256          ICURCOL = MOD( ICURCOL + 1, NPCOL )
03257 *
03258          DO 220 J = DESCX( INB_ ) + 1, DESCX( N_ ), NBX
03259             JB = MIN( DESCX( N_ ) - J + 1, NBX )
03260 *
03261             IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN
03262 *
03263                IF( MYROWDIST.EQ.0 ) THEN
03264                   I = 1
03265                ELSE
03266                   I = DESCX( IMB_ ) + ( MYROWDIST - 1 ) * MBX + 1
03267                END IF
03268 *
03269                II = 1
03270                IB = MIN( MAX( 0, DESCX( M_ ) - I + 1 ), IMBX )
03271                DO 180 KK = 0, JB-1
03272                   DO 170 LL = 0, IB-1
03273                      IF( J+KK.NE.JX .OR. I+LL.LT.IX .OR.
03274      $                   I+LL.GT.IX+N-1 )
03275      $                  CALL PZERRSET( ERR, ERRMAX,
03276      $                                 X( I+LL+(J+KK-1)*LDX ),
03277      $                                 PX( II+LL+(JJ+KK-1)*LDPX ) )
03278   170             CONTINUE
03279   180          CONTINUE
03280                IF( ROWREP ) THEN
03281                   I = I + IMBX
03282                ELSE
03283                   I = I + IMBX + ( NPROW - 1 ) * MBX
03284                END IF
03285 *
03286                DO 210 II = IMBX+1, MPALL, MBX
03287                   IB = MIN( MPALL-II+1, MBX )
03288 *
03289                   DO 200 KK = 0, JB-1
03290                      DO 190 LL = 0, IB-1
03291                         IF( J+KK.NE.JX .OR. I+LL.LT.IX .OR.
03292      $                      I+LL.GT.IX+N-1 )
03293      $                     CALL PZERRSET( ERR, ERRMAX,
03294      $                                    X( I+LL+(J+KK-1)*LDX ),
03295      $                                    PX( II+LL+(JJ+KK-1)*LDPX ) )
03296   190                CONTINUE
03297   200             CONTINUE
03298 *
03299                   IF( ROWREP ) THEN
03300                      I = I + MBX
03301                   ELSE
03302                      I = I + NPROW * MBX
03303                   END IF
03304 *
03305   210          CONTINUE
03306 *
03307                JJ = JJ + JB
03308 *
03309             END IF
03310 *
03311             ICURCOL = MOD( ICURCOL + 1, NPCOL )
03312 *
03313   220    CONTINUE
03314 *
03315       END IF
03316 *
03317       CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERRMAX, 1, KK, LL, -1,
03318      $              -1, -1 )
03319 *
03320       IF( ERRMAX.GT.ZERO .AND. ERRMAX.LE.EPS ) THEN
03321          INFO = 1
03322       ELSE IF( ERRMAX.GT.EPS ) THEN
03323          INFO = -1
03324       END IF
03325 *
03326       RETURN
03327 *
03328 *     End of PZCHKVOUT
03329 *
03330       END
03331       SUBROUTINE PZCHKMIN( ERRMAX, M, N, A, PA, IA, JA, DESCA, INFO )
03332 *
03333 *  -- PBLAS test routine (version 2.0) --
03334 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
03335 *     and University of California, Berkeley.
03336 *     April 1, 1998
03337 *
03338 *     .. Scalar Arguments ..
03339       INTEGER            IA, INFO, JA, M, N
03340       DOUBLE PRECISION   ERRMAX
03341 *     ..
03342 *     .. Array Arguments ..
03343       INTEGER            DESCA( * )
03344       COMPLEX*16         PA( * ), A( * )
03345 *     ..
03346 *
03347 *  Purpose
03348 *  =======
03349 *
03350 *  PZCHKMIN  checks that the submatrix sub( PA ) remained unchanged. The
03351 *  local  array  entries are compared element by element, and their dif-
03352 *  ference  is tested against 0.0 as well as the epsilon machine. Notice
03353 *  that  this difference should be numerically exactly the zero machine,
03354 *  but  because of the possible fluctuation of some of the data we flag-
03355 *  ged differently a difference less than twice the epsilon machine. The
03356 *  largest error is also returned.
03357 *
03358 *  Notes
03359 *  =====
03360 *
03361 *  A description  vector  is associated with each 2D block-cyclicly dis-
03362 *  tributed matrix.  This  vector  stores  the  information  required to
03363 *  establish the  mapping  between a  matrix entry and its corresponding
03364 *  process and memory location.
03365 *
03366 *  In  the  following  comments,   the character _  should  be  read  as
03367 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
03368 *  block cyclicly distributed matrix.  Its description vector is DESCA:
03369 *
03370 *  NOTATION         STORED IN       EXPLANATION
03371 *  ---------------- --------------- ------------------------------------
03372 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
03373 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
03374 *                                   the NPROW x NPCOL BLACS process grid
03375 *                                   A  is distributed over.  The context
03376 *                                   itself  is  global,  but  the handle
03377 *                                   (the integer value) may vary.
03378 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
03379 *                                   ted matrix A, M_A >= 0.
03380 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
03381 *                                   buted matrix A, N_A >= 0.
03382 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
03383 *                                   block of the matrix A, IMB_A > 0.
03384 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
03385 *                                   left   block   of   the   matrix  A,
03386 *                                   INB_A > 0.
03387 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
03388 *                                   bute the last  M_A-IMB_A rows of  A,
03389 *                                   MB_A > 0.
03390 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
03391 *                                   bute the last  N_A-INB_A  columns of
03392 *                                   A, NB_A > 0.
03393 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
03394 *                                   row of the matrix  A is distributed,
03395 *                                   NPROW > RSRC_A >= 0.
03396 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
03397 *                                   first  column of  A  is distributed.
03398 *                                   NPCOL > CSRC_A >= 0.
03399 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
03400 *                                   array  storing  the  local blocks of
03401 *                                   the distributed matrix A,
03402 *                                   IF( Lc( 1, N_A ) > 0 )
03403 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
03404 *                                   ELSE
03405 *                                      LLD_A >= 1.
03406 *
03407 *  Let K be the number of  rows of a matrix A starting at the global in-
03408 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
03409 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
03410 *  receive if these K rows were distributed over NPROW processes.  If  K
03411 *  is the number of columns of a matrix  A  starting at the global index
03412 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
03413 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
03414 *  these K columns were distributed over NPCOL processes.
03415 *
03416 *  The values of Lr() and Lc() may be determined via a call to the func-
03417 *  tion PB_NUMROC:
03418 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
03419 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
03420 *
03421 *  Arguments
03422 *  =========
03423 *
03424 *  ERRMAX  (global output) DOUBLE PRECISION
03425 *          On exit,  ERRMAX  specifies the largest absolute element-wise
03426 *          difference between sub( A ) and sub( PA ).
03427 *
03428 *  M       (global input) INTEGER
03429 *          On entry,  M  specifies  the  number of rows of the submatrix
03430 *          operand sub( A ). M must be at least zero.
03431 *
03432 *  N       (global input) INTEGER
03433 *          On entry, N  specifies the number of columns of the submatrix
03434 *          operand sub( A ). N must be at least zero.
03435 *
03436 *  A       (local input) COMPLEX*16 array
03437 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
03438 *          array contains a local copy of the initial entire matrix PA.
03439 *
03440 *  PA      (local input) COMPLEX*16 array
03441 *          On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
03442 *          array contains the local entries of the matrix PA.
03443 *
03444 *  IA      (global input) INTEGER
03445 *          On entry, IA  specifies A's global row index, which points to
03446 *          the beginning of the submatrix sub( A ).
03447 *
03448 *  JA      (global input) INTEGER
03449 *          On entry, JA  specifies A's global column index, which points
03450 *          to the beginning of the submatrix sub( A ).
03451 *
03452 *  DESCA   (global and local input) INTEGER array
03453 *          On entry, DESCA  is an integer array of dimension DLEN_. This
03454 *          is the array descriptor for the matrix A.
03455 *
03456 *  INFO    (global output) INTEGER
03457 *          On exit, if INFO = 0, no error has been found,
03458 *          If INFO > 0, the maximum abolute error found is in (0,eps],
03459 *          If INFO < 0, the maximum abolute error found is in (eps,+oo).
03460 *
03461 *  -- Written on April 1, 1998 by
03462 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
03463 *
03464 *  =====================================================================
03465 *
03466 *     .. Parameters ..
03467       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
03468      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
03469      $                   RSRC_
03470       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
03471      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
03472      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
03473      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
03474       DOUBLE PRECISION   ZERO
03475       PARAMETER          ( ZERO = 0.0D+0 )
03476 *     ..
03477 *     .. Local Scalars ..
03478       LOGICAL            COLREP, ROWREP
03479       INTEGER            H, I, IACOL, IAROW, IB, ICTXT, ICURCOL,
03480      $                   ICURROW, II, IIA, IN, J, JB, JJ, JJA, JN, K,
03481      $                   KK, LDA, LDPA, LL, MYCOL, MYROW, NPCOL, NPROW
03482       DOUBLE PRECISION   ERR, EPS
03483 *     ..
03484 *     .. External Subroutines ..
03485       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, PB_INFOG2L, PZERRSET
03486 *     ..
03487 *     .. External Functions ..
03488       DOUBLE PRECISION   PDLAMCH
03489       EXTERNAL           PDLAMCH
03490 *     ..
03491 *     .. Intrinsic Functions ..
03492       INTRINSIC          ABS, DBLE, DIMAG, MAX, MIN, MOD
03493 *     ..
03494 *     .. Executable Statements ..
03495 *
03496       INFO   = 0
03497       ERRMAX = ZERO
03498 *
03499 *     Quick return if posssible
03500 *
03501       IF( ( M.EQ.0 ).OR.( N.EQ.0 ) )
03502      $   RETURN
03503 *
03504 *     Start the operations
03505 *
03506       ICTXT = DESCA( CTXT_ )
03507       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
03508 *
03509       EPS = PDLAMCH( ICTXT, 'eps' )
03510 *
03511       CALL PB_INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL, IIA,
03512      $                 JJA, IAROW, IACOL )
03513 *
03514       II      = IIA
03515       JJ      = JJA
03516       LDA     = DESCA( M_ )
03517       LDPA    = DESCA( LLD_ )
03518       ICURROW = IAROW
03519       ICURCOL = IACOL
03520       ROWREP  = ( IAROW.EQ.-1 )
03521       COLREP  = ( IACOL.EQ.-1 )
03522 *
03523 *     Handle the first block of column separately
03524 *
03525       JB = DESCA( INB_ ) - JA  + 1
03526       IF( JB.LE.0 )
03527      $   JB = ( ( -JB ) / DESCA( NB_ ) + 1 ) * DESCA( NB_ ) + JB
03528       JB = MIN( JB, N )
03529       JN = JA + JB - 1
03530 *
03531       IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN
03532 *
03533          DO 40 H = 0, JB-1
03534             IB = DESCA( IMB_ ) - IA  + 1
03535             IF( IB.LE.0 )
03536      $         IB = ( ( -IB ) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
03537             IB = MIN( IB, M )
03538             IN = IA + IB - 1
03539             IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
03540                DO 10 K = 0, IB-1
03541                   CALL PZERRSET( ERR, ERRMAX, A( IA+K+(JA+H-1)*LDA ),
03542      $                           PA( II+K+(JJ+H-1)*LDPA ) )
03543    10          CONTINUE
03544                II = II + IB
03545             END IF
03546             ICURROW = MOD( ICURROW+1, NPROW )
03547 *
03548 *           Loop over remaining block of rows
03549 *
03550             DO 30 I = IN+1, IA+M-1, DESCA( MB_ )
03551                IB = MIN( DESCA( MB_ ), IA+M-I )
03552                IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
03553                   DO 20 K = 0, IB-1
03554                      CALL PZERRSET( ERR, ERRMAX, A( I+K+(JA+H-1)*LDA ),
03555      $                              PA( II+K+(JJ+H-1)*LDPA ) )
03556    20             CONTINUE
03557                   II = II + IB
03558                END IF
03559                ICURROW = MOD( ICURROW+1, NPROW )
03560    30       CONTINUE
03561 *
03562             II = IIA
03563             ICURROW = IAROW
03564    40    CONTINUE
03565 *
03566          JJ = JJ + JB
03567 *
03568       END IF
03569 *
03570       ICURCOL = MOD( ICURCOL+1, NPCOL )
03571 *
03572 *     Loop over remaining column blocks
03573 *
03574       DO 90 J = JN+1, JA+N-1, DESCA( NB_ )
03575          JB = MIN(  DESCA( NB_ ), JA+N-J )
03576          IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN
03577             DO 80 H = 0, JB-1
03578                IB = DESCA( IMB_ ) - IA  + 1
03579                IF( IB.LE.0 )
03580      $            IB = ( ( -IB ) / DESCA( MB_ ) + 1 )*DESCA( MB_ ) + IB
03581                IB = MIN( IB, M )
03582                IN = IA + IB - 1
03583                IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
03584                   DO 50 K = 0, IB-1
03585                      CALL PZERRSET( ERR, ERRMAX, A( IA+K+(J+H-1)*LDA ),
03586      $                              PA( II+K+(JJ+H-1)*LDPA ) )
03587    50             CONTINUE
03588                   II = II + IB
03589                END IF
03590                ICURROW = MOD( ICURROW+1, NPROW )
03591 *
03592 *              Loop over remaining block of rows
03593 *
03594                DO 70 I = IN+1, IA+M-1, DESCA( MB_ )
03595                   IB = MIN( DESCA( MB_ ), IA+M-I )
03596                   IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
03597                      DO 60 K = 0, IB-1
03598                         CALL PZERRSET( ERR, ERRMAX,
03599      $                                 A( I+K+(J+H-1)*LDA ),
03600      $                                 PA( II+K+(JJ+H-1)*LDPA ) )
03601    60                CONTINUE
03602                      II = II + IB
03603                   END IF
03604                   ICURROW = MOD( ICURROW+1, NPROW )
03605    70          CONTINUE
03606 *
03607                II = IIA
03608                ICURROW = IAROW
03609    80       CONTINUE
03610 *
03611             JJ = JJ + JB
03612          END IF
03613 *
03614          ICURCOL = MOD( ICURCOL+1, NPCOL )
03615 *
03616    90 CONTINUE
03617 *
03618       CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERRMAX, 1, KK, LL, -1,
03619      $              -1, -1 )
03620 *
03621       IF( ERRMAX.GT.ZERO .AND. ERRMAX.LE.EPS ) THEN
03622          INFO = 1
03623       ELSE IF( ERRMAX.GT.EPS ) THEN
03624          INFO = -1
03625       END IF
03626 *
03627       RETURN
03628 *
03629 *     End of PZCHKMIN
03630 *
03631       END
03632       SUBROUTINE PZCHKMOUT( M, N, A, PA, IA, JA, DESCA, INFO )
03633 *
03634 *  -- PBLAS test routine (version 2.0) --
03635 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
03636 *     and University of California, Berkeley.
03637 *     April 1, 1998
03638 *
03639 *     .. Scalar Arguments ..
03640       INTEGER            IA, INFO, JA, M, N
03641 *     ..
03642 *     .. Array Arguments ..
03643       INTEGER            DESCA( * )
03644       COMPLEX*16         A( * ), PA( * )
03645 *     ..
03646 *
03647 *  Purpose
03648 *  =======
03649 *
03650 *  PZCHKMOUT  checks  that the matrix PA \ sub( PA ) remained unchanged.
03651 *  The  local array  entries  are compared element by element, and their
03652 *  difference  is tested against 0.0 as well as the epsilon machine. No-
03653 *  tice that this  difference should be numerically exactly the zero ma-
03654 *  chine, but because  of  the  possible movement of some of the data we
03655 *  flagged differently a difference less than twice the epsilon machine.
03656 *  The largest error is reported.
03657 *
03658 *  Notes
03659 *  =====
03660 *
03661 *  A description  vector  is associated with each 2D block-cyclicly dis-
03662 *  tributed matrix.  This  vector  stores  the  information  required to
03663 *  establish the  mapping  between a  matrix entry and its corresponding
03664 *  process and memory location.
03665 *
03666 *  In  the  following  comments,   the character _  should  be  read  as
03667 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
03668 *  block cyclicly distributed matrix.  Its description vector is DESCA:
03669 *
03670 *  NOTATION         STORED IN       EXPLANATION
03671 *  ---------------- --------------- ------------------------------------
03672 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
03673 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
03674 *                                   the NPROW x NPCOL BLACS process grid
03675 *                                   A  is distributed over.  The context
03676 *                                   itself  is  global,  but  the handle
03677 *                                   (the integer value) may vary.
03678 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
03679 *                                   ted matrix A, M_A >= 0.
03680 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
03681 *                                   buted matrix A, N_A >= 0.
03682 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
03683 *                                   block of the matrix A, IMB_A > 0.
03684 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
03685 *                                   left   block   of   the   matrix  A,
03686 *                                   INB_A > 0.
03687 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
03688 *                                   bute the last  M_A-IMB_A rows of  A,
03689 *                                   MB_A > 0.
03690 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
03691 *                                   bute the last  N_A-INB_A  columns of
03692 *                                   A, NB_A > 0.
03693 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
03694 *                                   row of the matrix  A is distributed,
03695 *                                   NPROW > RSRC_A >= 0.
03696 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
03697 *                                   first  column of  A  is distributed.
03698 *                                   NPCOL > CSRC_A >= 0.
03699 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
03700 *                                   array  storing  the  local blocks of
03701 *                                   the distributed matrix A,
03702 *                                   IF( Lc( 1, N_A ) > 0 )
03703 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
03704 *                                   ELSE
03705 *                                      LLD_A >= 1.
03706 *
03707 *  Let K be the number of  rows of a matrix A starting at the global in-
03708 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
03709 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
03710 *  receive if these K rows were distributed over NPROW processes.  If  K
03711 *  is the number of columns of a matrix  A  starting at the global index
03712 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
03713 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
03714 *  these K columns were distributed over NPCOL processes.
03715 *
03716 *  The values of Lr() and Lc() may be determined via a call to the func-
03717 *  tion PB_NUMROC:
03718 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
03719 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
03720 *
03721 *  Arguments
03722 *  =========
03723 *
03724 *  M       (global input) INTEGER
03725 *          On entry,  M  specifies  the  number of rows of the submatrix
03726 *          sub( PA ). M must be at least zero.
03727 *
03728 *  N       (global input) INTEGER
03729 *          On entry, N specifies the  number of columns of the submatrix
03730 *          sub( PA ). N must be at least zero.
03731 *
03732 *  A       (local input) COMPLEX*16 array
03733 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
03734 *          array contains a local copy of the initial entire matrix PA.
03735 *
03736 *  PA      (local input) COMPLEX*16 array
03737 *          On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
03738 *          array contains the local entries of the matrix PA.
03739 *
03740 *  IA      (global input) INTEGER
03741 *          On entry, IA  specifies A's global row index, which points to
03742 *          the beginning of the submatrix sub( A ).
03743 *
03744 *  JA      (global input) INTEGER
03745 *          On entry, JA  specifies A's global column index, which points
03746 *          to the beginning of the submatrix sub( A ).
03747 *
03748 *  DESCA   (global and local input) INTEGER array
03749 *          On entry, DESCA  is an integer array of dimension DLEN_. This
03750 *          is the array descriptor for the matrix A.
03751 *
03752 *  INFO    (global output) INTEGER
03753 *          On exit, if INFO = 0, no error has been found,
03754 *          If INFO > 0, the maximum abolute error found is in (0,eps],
03755 *          If INFO < 0, the maximum abolute error found is in (eps,+oo).
03756 *
03757 *  -- Written on April 1, 1998 by
03758 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
03759 *
03760 *  =====================================================================
03761 *
03762 *     .. Parameters ..
03763       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
03764      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
03765      $                   RSRC_
03766       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
03767      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
03768      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
03769      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
03770       DOUBLE PRECISION   ZERO
03771       PARAMETER          ( ZERO = 0.0D+0 )
03772 *     ..
03773 *     .. Local Scalars ..
03774       LOGICAL            COLREP, ROWREP
03775       INTEGER            I, IB, ICTXT, ICURCOL, II, IMBA, J, JB, JJ, KK,
03776      $                   LDA, LDPA, LL, MPALL, MYCOL, MYROW, MYROWDIST,
03777      $                   NPCOL, NPROW
03778       DOUBLE PRECISION   EPS, ERR, ERRMAX
03779 *     ..
03780 *     .. External Subroutines ..
03781       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, PZERRSET
03782 *     ..
03783 *     .. External Functions ..
03784       INTEGER            PB_NUMROC
03785       DOUBLE PRECISION   PDLAMCH
03786       EXTERNAL           PDLAMCH, PB_NUMROC
03787 *     ..
03788 *     .. Intrinsic Functions ..
03789       INTRINSIC          MAX, MIN, MOD
03790 *     ..
03791 *     .. Executable Statements ..
03792 *
03793       INFO = 0
03794       ERRMAX = ZERO
03795 *
03796 *     Quick return if possible
03797 *
03798       IF( ( DESCA( M_ ).LE.0 ).OR.( DESCA( N_ ).LE.0 ) )
03799      $   RETURN
03800 *
03801 *     Start the operations
03802 *
03803       ICTXT = DESCA( CTXT_ )
03804       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
03805 *
03806       EPS = PDLAMCH( ICTXT, 'eps' )
03807 *
03808       MPALL = PB_NUMROC( DESCA( M_ ), 1, DESCA( IMB_ ), DESCA( MB_ ),
03809      $                   MYROW, DESCA( RSRC_ ), NPROW )
03810 *
03811       LDA    = DESCA( M_ )
03812       LDPA   = DESCA( LLD_ )
03813 *
03814       II = 1
03815       JJ = 1
03816       ROWREP  = ( DESCA( RSRC_ ).EQ.-1 )
03817       COLREP  = ( DESCA( CSRC_ ).EQ.-1 )
03818       ICURCOL = DESCA( CSRC_ )
03819       IF( MYROW.EQ.DESCA( RSRC_ ) .OR. ROWREP ) THEN
03820          IMBA = DESCA( IMB_ )
03821       ELSE
03822          IMBA = DESCA( MB_ )
03823       END IF
03824       IF( ROWREP ) THEN
03825          MYROWDIST = 0
03826       ELSE
03827          MYROWDIST = MOD( MYROW - DESCA( RSRC_ ) + NPROW, NPROW )
03828       END IF
03829 *
03830       IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN
03831 *
03832          J = 1
03833          IF( MYROWDIST.EQ.0 ) THEN
03834             I = 1
03835          ELSE
03836             I = DESCA( IMB_ ) + ( MYROWDIST - 1 ) * DESCA( MB_ ) + 1
03837          END IF
03838          IB = MIN( MAX( 0, DESCA( M_ ) - I + 1 ), IMBA )
03839          JB = MIN( DESCA( N_ ), DESCA( INB_ ) )
03840 *
03841          DO 20 KK = 0, JB-1
03842             DO 10 LL = 0, IB-1
03843                IF( I+LL.LT.IA .OR. I+LL.GT.IA+M-1 .OR.
03844      $             J+KK.LT.JA .OR. J+KK.GT.JA+N-1 )
03845      $            CALL PZERRSET( ERR, ERRMAX, A( I+LL+(J+KK-1)*LDA ),
03846      $                           PA( II+LL+(JJ+KK-1)*LDPA ) )
03847    10       CONTINUE
03848    20    CONTINUE
03849          IF( ROWREP ) THEN
03850             I = I + IMBA
03851          ELSE
03852             I = I + IMBA + ( NPROW - 1 ) * DESCA( MB_ )
03853          END IF
03854 *
03855          DO 50 II = IMBA + 1, MPALL, DESCA( MB_ )
03856             IB = MIN( MPALL-II+1, DESCA( MB_ ) )
03857 *
03858             DO 40 KK = 0, JB-1
03859                DO 30 LL = 0, IB-1
03860                   IF( I+LL.LT.IA .OR. I+LL.GT.IA+M-1 .OR.
03861      $                J+KK.LT.JA .OR. J+KK.GT.JA+N-1 )
03862      $               CALL PZERRSET( ERR, ERRMAX,
03863      $                              A( I+LL+(J+KK-1)*LDA ),
03864      $                              PA( II+LL+(JJ+KK-1)*LDPA ) )
03865    30          CONTINUE
03866    40       CONTINUE
03867 *
03868             IF( ROWREP ) THEN
03869                I = I + DESCA( MB_ )
03870             ELSE
03871                I = I + NPROW * DESCA( MB_ )
03872             END IF
03873 *
03874    50    CONTINUE
03875 *
03876          JJ = JJ + JB
03877 *
03878       END IF
03879 *
03880       ICURCOL = MOD( ICURCOL + 1, NPCOL )
03881 *
03882       DO 110 J = DESCA( INB_ ) + 1, DESCA( N_ ), DESCA( NB_ )
03883          JB = MIN( DESCA( N_ ) - J + 1, DESCA( NB_ ) )
03884 *
03885          IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN
03886 *
03887             IF( MYROWDIST.EQ.0 ) THEN
03888                I = 1
03889             ELSE
03890                I = DESCA( IMB_ ) + ( MYROWDIST - 1 ) * DESCA( MB_ ) + 1
03891             END IF
03892 *
03893             II = 1
03894             IB = MIN( MAX( 0, DESCA( M_ ) - I + 1 ), IMBA )
03895             DO 70 KK = 0, JB-1
03896                DO 60 LL = 0, IB-1
03897                   IF( I+LL.LT.IA .OR. I+LL.GT.IA+M-1 .OR.
03898      $                J+KK.LT.JA .OR. J+KK.GT.JA+N-1 )
03899      $               CALL PZERRSET( ERR, ERRMAX,
03900      $                              A( I+LL+(J+KK-1)*LDA ),
03901      $                              PA( II+LL+(JJ+KK-1)*LDPA ) )
03902    60          CONTINUE
03903    70       CONTINUE
03904             IF( ROWREP ) THEN
03905                I = I + IMBA
03906             ELSE
03907                I = I + IMBA + ( NPROW - 1 ) * DESCA( MB_ )
03908             END IF
03909 *
03910             DO 100 II = IMBA+1, MPALL, DESCA( MB_ )
03911                IB = MIN( MPALL-II+1, DESCA( MB_ ) )
03912 *
03913                DO 90 KK = 0, JB-1
03914                   DO 80 LL = 0, IB-1
03915                      IF( I+LL.LT.IA .OR. I+LL.GT.IA+M-1 .OR.
03916      $                   J+KK.LT.JA .OR. J+KK.GT.JA+N-1 )
03917      $                  CALL PZERRSET( ERR, ERRMAX,
03918      $                                 A( I+LL+(J+KK-1)*LDA ),
03919      $                                 PA( II+LL+(JJ+KK-1)*LDPA ) )
03920    80             CONTINUE
03921    90          CONTINUE
03922 *
03923                IF( ROWREP ) THEN
03924                   I = I + DESCA( MB_ )
03925                ELSE
03926                   I = I + NPROW * DESCA( MB_ )
03927                END IF
03928 *
03929   100       CONTINUE
03930 *
03931             JJ = JJ + JB
03932 *
03933          END IF
03934 *
03935          ICURCOL = MOD( ICURCOL + 1, NPCOL )
03936 *                                                           INSERT MODE
03937   110 CONTINUE
03938 *
03939       CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERRMAX, 1, KK, LL, -1,
03940      $              -1, -1 )
03941 *
03942       IF( ERRMAX.GT.ZERO .AND. ERRMAX.LE.EPS ) THEN
03943          INFO = 1
03944       ELSE IF( ERRMAX.GT.EPS ) THEN
03945          INFO = -1
03946       END IF
03947 *
03948       RETURN
03949 *
03950 *     End of PZCHKMOUT
03951 *
03952       END
03953       SUBROUTINE PZMPRNT( ICTXT, NOUT, M, N, A, LDA, IRPRNT, ICPRNT,
03954      $                    CMATNM )
03955 *
03956 *  -- PBLAS test routine (version 2.0) --
03957 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
03958 *     and University of California, Berkeley.
03959 *     April 1, 1998
03960 *
03961 *     .. Scalar Arguments ..
03962       INTEGER            ICPRNT, ICTXT, IRPRNT, LDA, M, N, NOUT
03963 *     ..
03964 *     .. Array Arguments ..
03965       CHARACTER*(*)      CMATNM
03966       COMPLEX*16         A( LDA, * )
03967 *     ..
03968 *
03969 *  Purpose
03970 *  =======
03971 *
03972 *  PZMPRNT prints to the standard output an array A of size m by n. Only
03973 *  the process of coordinates ( IRPRNT, ICPRNT ) is printing.
03974 *
03975 *  Arguments
03976 *  =========
03977 *
03978 *  ICTXT   (local input) INTEGER
03979 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
03980 *          ting the global  context of the operation. The context itself
03981 *          is global, but the value of ICTXT is local.
03982 *
03983 *  NOUT    (global input) INTEGER
03984 *          On entry, NOUT specifies the unit number for the output file.
03985 *          When NOUT is 6, output to screen,  when  NOUT is 0, output to
03986 *          stderr. NOUT is only defined for process 0.
03987 *
03988 *  M       (global input) INTEGER
03989 *          On entry, M  specifies the number of rows of the matrix A.  M
03990 *          must be at least zero.
03991 *
03992 *  N       (global input) INTEGER
03993 *          On entry, N  specifies the number of columns of the matrix A.
03994 *          N must be at least zero.
03995 *
03996 *  A       (local input) COMPLEX*16 array
03997 *          On entry,  A  is an array of dimension (LDA,N). The leading m
03998 *          by n part of this array is printed.
03999 *
04000 *  LDA     (local input) INTEGER
04001 *          On entry, LDA  specifies the leading dimension of  the  local
04002 *          array A to be printed. LDA must be at least MAX( 1, M ).
04003 *
04004 *  IRPRNT  (global input) INTEGER
04005 *          On entry, IRPRNT  specifies the process row coordinate of the
04006 *          printing process.
04007 *
04008 *  ICPRNT  (global input) INTEGER
04009 *          On entry,  ICPRNT  specifies the process column coordinate of
04010 *          the printing process.
04011 *
04012 *  CMATNM  (global input) CHARACTER*(*)
04013 *          On entry, CMATNM specifies the identifier of the matrix to be
04014 *          printed.
04015 *
04016 *  -- Written on April 1, 1998 by
04017 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
04018 *
04019 *  =====================================================================
04020 *
04021 *     .. Local Scalars ..
04022       INTEGER            I, J, MYCOL, MYROW, NPCOL, NPROW
04023 *     ..
04024 *     .. External Subroutines ..
04025       EXTERNAL           BLACS_GRIDINFO
04026 *     ..
04027 *     .. Intrinsic Functions ..
04028       INTRINSIC          DBLE, DIMAG
04029 *     ..
04030 *     .. Executable Statements ..
04031 *
04032 *     Quick return if possible
04033 *
04034       IF( ( M.LE.0 ).OR.( N.LE.0 ) )
04035      $   RETURN
04036 *
04037 *     Get grid parameters
04038 *
04039       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
04040 *
04041       IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
04042 *
04043          WRITE( NOUT, FMT = * )
04044          DO 20 J = 1, N
04045 *
04046             DO 10 I = 1, M
04047 *
04048                WRITE( NOUT, FMT = 9999 ) CMATNM, I, J,
04049      $                         DBLE( A( I, J ) ), DIMAG( A( I, J ) )
04050 *
04051    10       CONTINUE
04052 *
04053    20    CONTINUE
04054 *
04055       END IF
04056 *
04057  9999 FORMAT( 1X, A, '(', I6, ',', I6, ')=', D30.18, '+i*(',
04058      $        D30.18, ')' )
04059 *
04060       RETURN
04061 *
04062 *     End of PZMPRNT
04063 *
04064       END
04065       SUBROUTINE PZVPRNT( ICTXT, NOUT, N, X, INCX, IRPRNT, ICPRNT,
04066      $                    CVECNM )
04067 *
04068 *  -- PBLAS test routine (version 2.0) --
04069 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
04070 *     and University of California, Berkeley.
04071 *     April 1, 1998
04072 *
04073 *     .. Scalar Arguments ..
04074       INTEGER            ICPRNT, ICTXT, INCX, IRPRNT, N, NOUT
04075 *     ..
04076 *     .. Array Arguments ..
04077       CHARACTER*(*)      CVECNM
04078       COMPLEX*16         X( * )
04079 *     ..
04080 *
04081 *  Purpose
04082 *  =======
04083 *
04084 *  PZVPRNT  prints  to the standard output an vector x of length n. Only
04085 *  the process of coordinates ( IRPRNT, ICPRNT ) is printing.
04086 *
04087 *  Arguments
04088 *  =========
04089 *
04090 *  ICTXT   (local input) INTEGER
04091 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
04092 *          ting the global  context of the operation. The context itself
04093 *          is global, but the value of ICTXT is local.
04094 *
04095 *  NOUT    (global input) INTEGER
04096 *          On entry, NOUT specifies the unit number for the output file.
04097 *          When NOUT is 6, output to screen,  when  NOUT is 0, output to
04098 *          stderr. NOUT is only defined for process 0.
04099 *
04100 *  N       (global input) INTEGER
04101 *          On entry, N  specifies the length of the vector X.  N must be
04102 *          at least zero.
04103 *
04104 *  X       (global input) COMPLEX*16 array
04105 *          On   entry,   X   is   an   array   of   dimension  at  least
04106 *          ( 1 + ( n - 1 )*abs( INCX ) ).  Before  entry,  the incremen-
04107 *          ted array X must contain the vector x.
04108 *
04109 *  INCX    (global input) INTEGER.
04110 *          On entry, INCX specifies the increment for the elements of X.
04111 *          INCX must not be zero.
04112 *
04113 *  IRPRNT  (global input) INTEGER
04114 *          On entry, IRPRNT  specifies the process row coordinate of the
04115 *          printing process.
04116 *
04117 *  ICPRNT  (global input) INTEGER
04118 *          On entry,  ICPRNT  specifies the process column coordinate of
04119 *          the printing process.
04120 *
04121 *  CVECNM  (global input) CHARACTER*(*)
04122 *          On entry, CVECNM specifies the identifier of the vector to be
04123 *          printed.
04124 *
04125 *  -- Written on April 1, 1998 by
04126 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
04127 *
04128 *  =====================================================================
04129 *
04130 *     .. Local Scalars ..
04131       INTEGER            I, MYCOL, MYROW, NPCOL, NPROW
04132 *     ..
04133 *     .. External Subroutines ..
04134       EXTERNAL           BLACS_GRIDINFO
04135 *     ..
04136 *     .. Intrinsic Functions ..
04137       INTRINSIC          DBLE, DIMAG
04138 *     ..
04139 *     .. Executable Statements ..
04140 *
04141 *     Quick return if possible
04142 *
04143       IF( N.LE.0 )
04144      $   RETURN
04145 *
04146 *     Get grid parameters
04147 *
04148       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
04149 *
04150       IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
04151 *
04152          WRITE( NOUT, FMT = * )
04153          DO 10 I = 1, 1 + ( N-1 )*INCX, INCX
04154 *
04155             WRITE( NOUT, FMT = 9999 ) CVECNM, I, DBLE( X( I ) ),
04156      $                                DIMAG( X( I ) )
04157 *
04158    10    CONTINUE
04159 *
04160       END IF
04161 *
04162  9999 FORMAT( 1X, A, '(', I6, ')=', D30.18, '+i*(', D30.18, ')' )
04163 *
04164       RETURN
04165 *
04166 *     End of PZVPRNT
04167 *
04168       END
04169       SUBROUTINE PZMVCH( ICTXT, TRANS, M, N, ALPHA, A, IA, JA, DESCA,
04170      $                   X, IX, JX, DESCX, INCX, BETA, Y, PY, IY, JY,
04171      $                   DESCY, INCY, G, ERR, INFO )
04172 *
04173 *  -- PBLAS test routine (version 2.0) --
04174 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
04175 *     and University of California, Berkeley.
04176 *     April 1, 1998
04177 *
04178 *     .. Scalar Arguments ..
04179       CHARACTER*1        TRANS
04180       INTEGER            IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
04181      $                   JY, M, N
04182       DOUBLE PRECISION   ERR
04183       COMPLEX*16         ALPHA, BETA
04184 *     ..
04185 *     .. Array Arguments ..
04186       INTEGER            DESCA( * ), DESCX( * ), DESCY( * )
04187       DOUBLE PRECISION   G( * )
04188       COMPLEX*16         A( * ), PY( * ), X( * ), Y( * )
04189 *     ..
04190 *
04191 *  Purpose
04192 *  =======
04193 *
04194 *  PZMVCH checks the results of the computational tests.
04195 *
04196 *  Notes
04197 *  =====
04198 *
04199 *  A description  vector  is associated with each 2D block-cyclicly dis-
04200 *  tributed matrix.  This  vector  stores  the  information  required to
04201 *  establish the  mapping  between a  matrix entry and its corresponding
04202 *  process and memory location.
04203 *
04204 *  In  the  following  comments,   the character _  should  be  read  as
04205 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
04206 *  block cyclicly distributed matrix.  Its description vector is DESCA:
04207 *
04208 *  NOTATION         STORED IN       EXPLANATION
04209 *  ---------------- --------------- ------------------------------------
04210 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
04211 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
04212 *                                   the NPROW x NPCOL BLACS process grid
04213 *                                   A  is distributed over.  The context
04214 *                                   itself  is  global,  but  the handle
04215 *                                   (the integer value) may vary.
04216 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
04217 *                                   ted matrix A, M_A >= 0.
04218 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
04219 *                                   buted matrix A, N_A >= 0.
04220 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
04221 *                                   block of the matrix A, IMB_A > 0.
04222 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
04223 *                                   left   block   of   the   matrix  A,
04224 *                                   INB_A > 0.
04225 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
04226 *                                   bute the last  M_A-IMB_A rows of  A,
04227 *                                   MB_A > 0.
04228 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
04229 *                                   bute the last  N_A-INB_A  columns of
04230 *                                   A, NB_A > 0.
04231 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
04232 *                                   row of the matrix  A is distributed,
04233 *                                   NPROW > RSRC_A >= 0.
04234 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
04235 *                                   first  column of  A  is distributed.
04236 *                                   NPCOL > CSRC_A >= 0.
04237 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
04238 *                                   array  storing  the  local blocks of
04239 *                                   the distributed matrix A,
04240 *                                   IF( Lc( 1, N_A ) > 0 )
04241 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
04242 *                                   ELSE
04243 *                                      LLD_A >= 1.
04244 *
04245 *  Let K be the number of  rows of a matrix A starting at the global in-
04246 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
04247 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
04248 *  receive if these K rows were distributed over NPROW processes.  If  K
04249 *  is the number of columns of a matrix  A  starting at the global index
04250 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
04251 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
04252 *  these K columns were distributed over NPCOL processes.
04253 *
04254 *  The values of Lr() and Lc() may be determined via a call to the func-
04255 *  tion PB_NUMROC:
04256 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
04257 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
04258 *
04259 *  Arguments
04260 *  =========
04261 *
04262 *  ICTXT   (local input) INTEGER
04263 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
04264 *          ting the global  context of the operation. The context itself
04265 *          is global, but the value of ICTXT is local.
04266 *
04267 *  TRANS   (global input) CHARACTER*1
04268 *          On entry,  TRANS  specifies which matrix-vector product is to
04269 *          be computed as follows:
04270 *             If TRANS = 'T',
04271 *                sub( Y ) = BETA * sub( Y ) + sub( A )**T  * sub( X ),
04272 *             else if TRANS = 'C',
04273 *                sub( Y ) = BETA * sub( Y ) + sub( A )**H  * sub( X ),
04274 *             otherwise
04275 *                sub( Y ) = BETA * sub( Y ) + sub( A )     * sub( X ).
04276 *
04277 *  M       (global input) INTEGER
04278 *          On entry,  M  specifies  the  number of rows of the submatrix
04279 *          operand matrix A. M must be at least zero.
04280 *
04281 *  N       (global input) INTEGER
04282 *          On entry,  N  specifies  the  number of columns of the subma-
04283 *          trix operand matrix A. N must be at least zero.
04284 *
04285 *  ALPHA   (global input) COMPLEX*16
04286 *          On entry, ALPHA specifies the scalar alpha.
04287 *
04288 *  A       (local input) COMPLEX*16 array
04289 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
04290 *          array contains a local copy of the initial entire matrix PA.
04291 *
04292 *  IA      (global input) INTEGER
04293 *          On entry, IA  specifies A's global row index, which points to
04294 *          the beginning of the submatrix sub( A ).
04295 *
04296 *  JA      (global input) INTEGER
04297 *          On entry, JA  specifies A's global column index, which points
04298 *          to the beginning of the submatrix sub( A ).
04299 *
04300 *  DESCA   (global and local input) INTEGER array
04301 *          On entry, DESCA  is an integer array of dimension DLEN_. This
04302 *          is the array descriptor for the matrix A.
04303 *
04304 *  X       (local input) COMPLEX*16 array
04305 *          On entry, X is an array of  dimension  (DESCX( M_ ),*).  This
04306 *          array contains a local copy of the initial entire matrix PX.
04307 *
04308 *  IX      (global input) INTEGER
04309 *          On entry, IX  specifies X's global row index, which points to
04310 *          the beginning of the submatrix sub( X ).
04311 *
04312 *  JX      (global input) INTEGER
04313 *          On entry, JX  specifies X's global column index, which points
04314 *          to the beginning of the submatrix sub( X ).
04315 *
04316 *  DESCX   (global and local input) INTEGER array
04317 *          On entry, DESCX  is an integer array of dimension DLEN_. This
04318 *          is the array descriptor for the matrix X.
04319 *
04320 *  INCX    (global input) INTEGER
04321 *          On entry,  INCX   specifies  the  global  increment  for  the
04322 *          elements of  X.  Only two values of  INCX   are  supported in
04323 *          this version, namely 1 and M_X. INCX  must not be zero.
04324 *
04325 *  BETA    (global input) COMPLEX*16
04326 *          On entry, BETA specifies the scalar beta.
04327 *
04328 *  Y       (local input/local output) COMPLEX*16 array
04329 *          On entry, Y is an array of  dimension  (DESCY( M_ ),*).  This
04330 *          array contains a local copy of the initial entire matrix PY.
04331 *
04332 *  PY      (local input) COMPLEX*16 array
04333 *          On entry, PY is an array of dimension (DESCY( LLD_ ),*). This
04334 *          array contains the local entries of the matrix PY.
04335 *
04336 *  IY      (global input) INTEGER
04337 *          On entry, IY  specifies Y's global row index, which points to
04338 *          the beginning of the submatrix sub( Y ).
04339 *
04340 *  JY      (global input) INTEGER
04341 *          On entry, JY  specifies Y's global column index, which points
04342 *          to the beginning of the submatrix sub( Y ).
04343 *
04344 *  DESCY   (global and local input) INTEGER array
04345 *          On entry, DESCY  is an integer array of dimension DLEN_. This
04346 *          is the array descriptor for the matrix Y.
04347 *
04348 *  INCY    (global input) INTEGER
04349 *          On entry,  INCY   specifies  the  global  increment  for  the
04350 *          elements of  Y.  Only two values of  INCY   are  supported in
04351 *          this version, namely 1 and M_Y. INCY  must not be zero.
04352 *
04353 *  G       (workspace) DOUBLE PRECISION array
04354 *          On entry, G is an array of dimension at least MAX( M, N ).  G
04355 *          is used to compute the gauges.
04356 *
04357 *  ERR     (global output) DOUBLE PRECISION
04358 *          On exit, ERR specifies the largest error in absolute value.
04359 *
04360 *  INFO    (global output) INTEGER
04361 *          On exit, if INFO <> 0, the result is less than half accurate.
04362 *
04363 *  -- Written on April 1, 1998 by
04364 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
04365 *
04366 *  =====================================================================
04367 *
04368 *     .. Parameters ..
04369       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
04370      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
04371      $                   RSRC_
04372       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
04373      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
04374      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
04375      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
04376       DOUBLE PRECISION   RZERO, RONE
04377       PARAMETER          ( RZERO = 0.0D+0, RONE = 1.0D+0 )
04378       COMPLEX*16         ZERO, ONE
04379       PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
04380      $                   ONE = ( 1.0D+0, 0.0D+0 ) )
04381 *     ..
04382 *     .. Local Scalars ..
04383       LOGICAL            COLREP, CTRAN, ROWREP, TRAN
04384       INTEGER            I, IB, ICURCOL, ICURROW, IIY, IN, IOFFA, IOFFX,
04385      $                   IOFFY, IYCOL, IYROW, J, JB, JJY, JN, KK, LDA,
04386      $                   LDPY, LDX, LDY, ML, MYCOL, MYROW, NL, NPCOL,
04387      $                   NPROW
04388       DOUBLE PRECISION   EPS, ERRI, GTMP
04389       COMPLEX*16         C, TBETA, YTMP
04390 *     ..
04391 *     .. External Subroutines ..
04392       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L
04393 *     ..
04394 *     .. External Functions ..
04395       LOGICAL            LSAME
04396       DOUBLE PRECISION   PDLAMCH
04397       EXTERNAL           LSAME, PDLAMCH
04398 *     ..
04399 *     .. Intrinsic Functions ..
04400       INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD, SQRT
04401 *     ..
04402 *     .. Statement Functions ..
04403       DOUBLE PRECISION   ABS1
04404       ABS1( C ) = ABS( DBLE( C ) ) + ABS( DIMAG( C ) )
04405 *     ..
04406 *     .. Executable Statements ..
04407 *
04408       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
04409 *
04410       EPS = PDLAMCH( ICTXT, 'eps' )
04411 *
04412       IF( M.EQ.0 .OR. N.EQ.0 ) THEN
04413          TBETA = ONE
04414       ELSE
04415          TBETA = BETA
04416       END IF
04417 *
04418       TRAN = LSAME( TRANS, 'T' )
04419       CTRAN = LSAME( TRANS, 'C' )
04420       IF( TRAN.OR.CTRAN ) THEN
04421          ML = N
04422          NL = M
04423       ELSE
04424          ML = M
04425          NL = N
04426       END IF
04427 *
04428       LDA = MAX( 1, DESCA( M_ ) )
04429       LDX = MAX( 1, DESCX( M_ ) )
04430       LDY = MAX( 1, DESCY( M_ ) )
04431 *
04432 *     Compute expected result in Y using data in A, X and Y.
04433 *     Compute gauges in G. This part of the computation is performed
04434 *     by every process in the grid.
04435 *
04436       IOFFY = IY + ( JY - 1 ) * LDY
04437       DO 40 I = 1, ML
04438          YTMP = ZERO
04439          GTMP = RZERO
04440          IOFFX = IX + ( JX - 1 ) * LDX
04441          IF( TRAN )THEN
04442             IOFFA = IA + ( JA + I - 2 ) * LDA
04443             DO 10 J = 1, NL
04444                YTMP = YTMP + A( IOFFA ) * X( IOFFX )
04445                GTMP = GTMP + ABS1( A( IOFFA ) ) * ABS1( X( IOFFX ) )
04446                IOFFA = IOFFA + 1
04447                IOFFX = IOFFX + INCX
04448    10       CONTINUE
04449          ELSE IF( CTRAN )THEN
04450             IOFFA = IA + ( JA + I - 2 ) * LDA
04451             DO 20 J = 1, NL
04452                YTMP = YTMP + DCONJG( A( IOFFA ) ) * X( IOFFX )
04453                GTMP = GTMP + ABS1( A( IOFFA ) ) * ABS1( X( IOFFX ) )
04454                IOFFA = IOFFA + 1
04455                IOFFX = IOFFX + INCX
04456    20       CONTINUE
04457          ELSE
04458             IOFFA = IA + I - 1 + ( JA - 1 ) * LDA
04459             DO 30 J = 1, NL
04460                YTMP = YTMP + A( IOFFA ) * X( IOFFX )
04461                GTMP = GTMP + ABS1( A( IOFFA ) ) * ABS1( X( IOFFX ) )
04462                IOFFA = IOFFA + LDA
04463                IOFFX = IOFFX + INCX
04464    30       CONTINUE
04465          END IF
04466          G( I ) = ABS1( ALPHA )*GTMP + ABS1( TBETA )*ABS1( Y( IOFFY ) )
04467          Y( IOFFY ) = ALPHA * YTMP + TBETA * Y( IOFFY )
04468          IOFFY = IOFFY + INCY
04469    40 CONTINUE
04470 *
04471 *     Compute the error ratio for this result.
04472 *
04473       ERR  = RZERO
04474       INFO = 0
04475       LDPY = DESCY( LLD_ )
04476       IOFFY = IY + ( JY - 1 ) * LDY
04477       CALL PB_INFOG2L( IY, JY, DESCY, NPROW, NPCOL, MYROW, MYCOL, IIY,
04478      $                 JJY, IYROW, IYCOL )
04479       ICURROW = IYROW
04480       ICURCOL = IYCOL
04481       ROWREP  = ( IYROW.EQ.-1 )
04482       COLREP  = ( IYCOL.EQ.-1 )
04483 *
04484       IF( INCY.EQ.DESCY( M_ ) ) THEN
04485 *
04486 *        sub( Y ) is a row vector
04487 *
04488          JB = DESCY( INB_ ) - JY + 1
04489          IF( JB.LE.0 )
04490      $      JB = ( ( -JB ) / DESCY( NB_ ) + 1 ) * DESCY( NB_ ) + JB
04491          JB = MIN( JB, ML )
04492          JN = JY + JB - 1
04493 *
04494          DO 50 J = JY, JN
04495 *
04496             IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND.
04497      $          ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN
04498                ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) ) / EPS
04499                IF( G( J-JY+1 ).NE.RZERO )
04500      $            ERRI = ERRI / G( J-JY+1 )
04501                ERR = MAX( ERR, ERRI )
04502                IF( ERR*SQRT( EPS ).GE.RONE )
04503      $            INFO = 1
04504                JJY = JJY + 1
04505             END IF
04506 *
04507             IOFFY = IOFFY + INCY
04508 *
04509    50    CONTINUE
04510 *
04511          ICURCOL = MOD( ICURCOL+1, NPCOL )
04512 *
04513          DO 70 J = JN+1, JY+ML-1, DESCY( NB_ )
04514             JB = MIN( JY+ML-J, DESCY( NB_ ) )
04515 *
04516             DO 60 KK = 0, JB-1
04517 *
04518                IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND.
04519      $             ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN
04520                   ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) )/EPS
04521                   IF( G( J+KK-JY+1 ).NE.RZERO )
04522      $               ERRI = ERRI / G( J+KK-JY+1 )
04523                   ERR = MAX( ERR, ERRI )
04524                   IF( ERR*SQRT( EPS ).GE.RONE )
04525      $               INFO = 1
04526                   JJY = JJY + 1
04527                END IF
04528 *
04529                IOFFY = IOFFY + INCY
04530 *
04531    60       CONTINUE
04532 *
04533             ICURCOL = MOD( ICURCOL+1, NPCOL )
04534 *
04535    70    CONTINUE
04536 *
04537       ELSE
04538 *
04539 *        sub( Y ) is a column vector
04540 *
04541          IB = DESCY( IMB_ ) - IY + 1
04542          IF( IB.LE.0 )
04543      $      IB = ( ( -IB ) / DESCY( MB_ ) + 1 ) * DESCY( MB_ ) + IB
04544          IB = MIN( IB, ML )
04545          IN = IY + IB - 1
04546 *
04547          DO 80 I = IY, IN
04548 *
04549             IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND.
04550      $          ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN
04551                ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) ) / EPS
04552                IF( G( I-IY+1 ).NE.RZERO )
04553      $            ERRI = ERRI / G( I-IY+1 )
04554                ERR = MAX( ERR, ERRI )
04555                IF( ERR*SQRT( EPS ).GE.RONE )
04556      $            INFO = 1
04557                IIY = IIY + 1
04558             END IF
04559 *
04560             IOFFY = IOFFY + INCY
04561 *
04562    80    CONTINUE
04563 *
04564          ICURROW = MOD( ICURROW+1, NPROW )
04565 *
04566          DO 100 I = IN+1, IY+ML-1, DESCY( MB_ )
04567             IB = MIN( IY+ML-I, DESCY( MB_ ) )
04568 *
04569             DO 90 KK = 0, IB-1
04570 *
04571                IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND.
04572      $             ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN
04573                   ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) )/EPS
04574                   IF( G( I+KK-IY+1 ).NE.RZERO )
04575      $               ERRI = ERRI / G( I+KK-IY+1 )
04576                   ERR = MAX( ERR, ERRI )
04577                   IF( ERR*SQRT( EPS ).GE.RONE )
04578      $               INFO = 1
04579                   IIY = IIY + 1
04580                END IF
04581 *
04582                IOFFY = IOFFY + INCY
04583 *
04584    90       CONTINUE
04585 *
04586             ICURROW = MOD( ICURROW+1, NPROW )
04587 *
04588   100    CONTINUE
04589 *
04590       END IF
04591 *
04592 *     If INFO = 0, all results are at least half accurate.
04593 *
04594       CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL )
04595       CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
04596      $              MYCOL )
04597 *
04598       RETURN
04599 *
04600 *     End of PZMVCH
04601 *
04602       END
04603       SUBROUTINE PZVMCH( ICTXT, TRANS, UPLO, M, N, ALPHA, X, IX, JX,
04604      $                     DESCX, INCX, Y, IY, JY, DESCY, INCY, A, PA,
04605      $                     IA, JA, DESCA, G, ERR, INFO )
04606 *
04607 *  -- PBLAS test routine (version 2.0) --
04608 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
04609 *     and University of California, Berkeley.
04610 *     April 1, 1998
04611 *
04612 *     .. Scalar Arguments ..
04613       CHARACTER*1        TRANS, UPLO
04614       INTEGER            IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
04615      $                   JY, M, N
04616       DOUBLE PRECISION   ERR
04617       COMPLEX*16         ALPHA
04618 *     ..
04619 *     .. Array Arguments ..
04620       INTEGER            DESCA( * ), DESCX( * ), DESCY( * )
04621       DOUBLE PRECISION   G( * )
04622       COMPLEX*16         A( * ), PA( * ), X( * ), Y( * )
04623 *     ..
04624 *
04625 *  Purpose
04626 *  =======
04627 *
04628 *  PZVMCH checks the results of the computational tests.
04629 *
04630 *  Notes
04631 *  =====
04632 *
04633 *  A description  vector  is associated with each 2D block-cyclicly dis-
04634 *  tributed matrix.  This  vector  stores  the  information  required to
04635 *  establish the  mapping  between a  matrix entry and its corresponding
04636 *  process and memory location.
04637 *
04638 *  In  the  following  comments,   the character _  should  be  read  as
04639 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
04640 *  block cyclicly distributed matrix.  Its description vector is DESCA:
04641 *
04642 *  NOTATION         STORED IN       EXPLANATION
04643 *  ---------------- --------------- ------------------------------------
04644 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
04645 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
04646 *                                   the NPROW x NPCOL BLACS process grid
04647 *                                   A  is distributed over.  The context
04648 *                                   itself  is  global,  but  the handle
04649 *                                   (the integer value) may vary.
04650 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
04651 *                                   ted matrix A, M_A >= 0.
04652 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
04653 *                                   buted matrix A, N_A >= 0.
04654 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
04655 *                                   block of the matrix A, IMB_A > 0.
04656 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
04657 *                                   left   block   of   the   matrix  A,
04658 *                                   INB_A > 0.
04659 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
04660 *                                   bute the last  M_A-IMB_A rows of  A,
04661 *                                   MB_A > 0.
04662 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
04663 *                                   bute the last  N_A-INB_A  columns of
04664 *                                   A, NB_A > 0.
04665 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
04666 *                                   row of the matrix  A is distributed,
04667 *                                   NPROW > RSRC_A >= 0.
04668 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
04669 *                                   first  column of  A  is distributed.
04670 *                                   NPCOL > CSRC_A >= 0.
04671 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
04672 *                                   array  storing  the  local blocks of
04673 *                                   the distributed matrix A,
04674 *                                   IF( Lc( 1, N_A ) > 0 )
04675 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
04676 *                                   ELSE
04677 *                                      LLD_A >= 1.
04678 *
04679 *  Let K be the number of  rows of a matrix A starting at the global in-
04680 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
04681 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
04682 *  receive if these K rows were distributed over NPROW processes.  If  K
04683 *  is the number of columns of a matrix  A  starting at the global index
04684 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
04685 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
04686 *  these K columns were distributed over NPCOL processes.
04687 *
04688 *  The values of Lr() and Lc() may be determined via a call to the func-
04689 *  tion PB_NUMROC:
04690 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
04691 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
04692 *
04693 *  Arguments
04694 *  =========
04695 *
04696 *  ICTXT   (local input) INTEGER
04697 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
04698 *          ting the global  context of the operation. The context itself
04699 *          is global, but the value of ICTXT is local.
04700 *
04701 *  TRANS   (global input) CHARACTER*1
04702 *          On entry,  TRANS  specifies  the operation to be performed in
04703 *          the complex cases:
04704 *             if TRANS = 'C',
04705 *                sub( A ) := sub( A ) + alpha * sub( X ) * sub( Y )**H,
04706 *             otherwise
04707 *                sub( A ) := sub( A ) + alpha * sub( X ) * sub( Y )**T.
04708 *
04709 *  UPLO    (global input) CHARACTER*1
04710 *          On entry, UPLO specifies which part of the submatrix sub( A )
04711 *          is to be referenced as follows:
04712 *             If UPLO = 'L', only the lower triangular part,
04713 *             If UPLO = 'U', only the upper triangular part,
04714 *             else the entire matrix is to be referenced.
04715 *
04716 *  M       (global input) INTEGER
04717 *          On entry,  M  specifies  the  number of rows of the submatrix
04718 *          operand matrix A. M must be at least zero.
04719 *
04720 *  N       (global input) INTEGER
04721 *          On entry,  N  specifies  the  number of columns of the subma-
04722 *          trix operand matrix A. N must be at least zero.
04723 *
04724 *  ALPHA   (global input) COMPLEX*16
04725 *          On entry, ALPHA specifies the scalar alpha.
04726 *
04727 *  X       (local input) COMPLEX*16 array
04728 *          On entry, X is an array of  dimension  (DESCX( M_ ),*).  This
04729 *          array contains a local copy of the initial entire matrix PX.
04730 *
04731 *  IX      (global input) INTEGER
04732 *          On entry, IX  specifies X's global row index, which points to
04733 *          the beginning of the submatrix sub( X ).
04734 *
04735 *  JX      (global input) INTEGER
04736 *          On entry, JX  specifies X's global column index, which points
04737 *          to the beginning of the submatrix sub( X ).
04738 *
04739 *  DESCX   (global and local input) INTEGER array
04740 *          On entry, DESCX  is an integer array of dimension DLEN_. This
04741 *          is the array descriptor for the matrix X.
04742 *
04743 *  INCX    (global input) INTEGER
04744 *          On entry,  INCX   specifies  the  global  increment  for  the
04745 *          elements of  X.  Only two values of  INCX   are  supported in
04746 *          this version, namely 1 and M_X. INCX  must not be zero.
04747 *
04748 *  Y       (local input) COMPLEX*16 array
04749 *          On entry, Y is an array of  dimension  (DESCY( M_ ),*).  This
04750 *          array contains a local copy of the initial entire matrix PY.
04751 *
04752 *  IY      (global input) INTEGER
04753 *          On entry, IY  specifies Y's global row index, which points to
04754 *          the beginning of the submatrix sub( Y ).
04755 *
04756 *  JY      (global input) INTEGER
04757 *          On entry, JY  specifies Y's global column index, which points
04758 *          to the beginning of the submatrix sub( Y ).
04759 *
04760 *  DESCY   (global and local input) INTEGER array
04761 *          On entry, DESCY  is an integer array of dimension DLEN_. This
04762 *          is the array descriptor for the matrix Y.
04763 *
04764 *  INCY    (global input) INTEGER
04765 *          On entry,  INCY   specifies  the  global  increment  for  the
04766 *          elements of  Y.  Only two values of  INCY   are  supported in
04767 *          this version, namely 1 and M_Y. INCY  must not be zero.
04768 *
04769 *  A       (local input/local output) COMPLEX*16 array
04770 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
04771 *          array contains a local copy of the initial entire matrix PA.
04772 *
04773 *  PA      (local input) COMPLEX*16 array
04774 *          On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
04775 *          array contains the local entries of the matrix PA.
04776 *
04777 *  IA      (global input) INTEGER
04778 *          On entry, IA  specifies A's global row index, which points to
04779 *          the beginning of the submatrix sub( A ).
04780 *
04781 *  JA      (global input) INTEGER
04782 *          On entry, JA  specifies A's global column index, which points
04783 *          to the beginning of the submatrix sub( A ).
04784 *
04785 *  DESCA   (global and local input) INTEGER array
04786 *          On entry, DESCA  is an integer array of dimension DLEN_. This
04787 *          is the array descriptor for the matrix A.
04788 *
04789 *  G       (workspace) DOUBLE PRECISION array
04790 *          On entry, G is an array of dimension at least MAX( M, N ).  G
04791 *          is used to compute the gauges.
04792 *
04793 *  ERR     (global output) DOUBLE PRECISION
04794 *          On exit, ERR specifies the largest error in absolute value.
04795 *
04796 *  INFO    (global output) INTEGER
04797 *          On exit, if INFO <> 0, the result is less than half accurate.
04798 *
04799 *  -- Written on April 1, 1998 by
04800 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
04801 *
04802 *  =====================================================================
04803 *
04804 *     .. Parameters ..
04805       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
04806      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
04807      $                   RSRC_
04808       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
04809      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
04810      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
04811      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
04812       DOUBLE PRECISION   ZERO, ONE
04813       PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
04814 *     ..
04815 *     .. Local Scalars ..
04816       LOGICAL            COLREP, CTRAN, LOWER, ROWREP, UPPER
04817       INTEGER            I, IACOL, IAROW, IB, IBEG, ICURROW, IEND, IIA,
04818      $                   IN, IOFFA, IOFFX, IOFFY, J, JJA, KK, LDA, LDPA,
04819      $                   LDX, LDY, MYCOL, MYROW, NPCOL, NPROW
04820       DOUBLE PRECISION   EPS, ERRI, GTMP
04821       COMPLEX*16         ATMP, C
04822 *     ..
04823 *     .. External Subroutines ..
04824       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L
04825 *     ..
04826 *     .. External Functions ..
04827       LOGICAL            LSAME
04828       DOUBLE PRECISION   PDLAMCH
04829       EXTERNAL           LSAME, PDLAMCH
04830 *     ..
04831 *     .. Intrinsic Functions ..
04832       INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD, SQRT
04833 *     ..
04834 *     .. Statement Functions ..
04835       DOUBLE PRECISION   ABS1
04836       ABS1( C ) = ABS( DBLE( C ) ) + ABS( DIMAG( C ) )
04837 *     ..
04838 *     .. Executable Statements ..
04839 *
04840       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
04841 *
04842       EPS = PDLAMCH( ICTXT, 'eps' )
04843 *
04844       CTRAN = LSAME( TRANS, 'C' )
04845       UPPER = LSAME( UPLO, 'U' )
04846       LOWER = LSAME( UPLO, 'L' )
04847 *
04848       LDA = MAX( 1, DESCA( M_ ) )
04849       LDX = MAX( 1, DESCX( M_ ) )
04850       LDY = MAX( 1, DESCY( M_ ) )
04851 *
04852 *     Compute expected result in A using data in A, X and Y.
04853 *     Compute gauges in G. This part of the computation is performed
04854 *     by every process in the grid.
04855 *
04856       DO 70 J = 1, N
04857 *
04858          IOFFY = IY + ( JY - 1 ) * LDY + ( J - 1 ) * INCY
04859 *
04860          IF( LOWER ) THEN
04861             IBEG = J
04862             IEND = M
04863             DO 10 I = 1, J-1
04864                G( I ) = ZERO
04865    10       CONTINUE
04866          ELSE IF( UPPER ) THEN
04867             IBEG = 1
04868             IEND = J
04869             DO 20 I = J+1, M
04870                G( I ) = ZERO
04871    20       CONTINUE
04872          ELSE
04873             IBEG = 1
04874             IEND = M
04875          END IF
04876 *
04877          DO 30 I = IBEG, IEND
04878 *
04879             IOFFX = IX + ( JX - 1 ) * LDX + ( I - 1 ) * INCX
04880             IOFFA = IA + I - 1 + ( JA + J - 2 ) * LDA
04881             IF( CTRAN ) THEN
04882                ATMP = X( IOFFX ) * DCONJG( Y( IOFFY ) )
04883             ELSE
04884                ATMP = X( IOFFX ) * Y( IOFFY )
04885             END IF
04886             GTMP = ABS1( X( IOFFX ) ) * ABS1( Y( IOFFY ) )
04887             G( I ) = ABS1( ALPHA ) * GTMP + ABS1( A( IOFFA ) )
04888             A( IOFFA ) = ALPHA * ATMP + A( IOFFA )
04889 *
04890    30    CONTINUE
04891 *
04892 *        Compute the error ratio for this result.
04893 *
04894          INFO = 0
04895          ERR  = ZERO
04896          LDPA = DESCA( LLD_ )
04897          IOFFA = IA + ( JA + J - 2 ) * LDA
04898          CALL PB_INFOG2L( IA, JA+J-1, DESCA, NPROW, NPCOL, MYROW, MYCOL,
04899      $                    IIA, JJA, IAROW, IACOL )
04900          ROWREP = ( IAROW.EQ.-1 )
04901          COLREP = ( IACOL.EQ.-1 )
04902 *
04903          IF( MYCOL.EQ.IACOL .OR. COLREP ) THEN
04904 *
04905             ICURROW = IAROW
04906             IB = DESCA( IMB_ ) - IA + 1
04907             IF( IB.LE.0 )
04908      $         IB = ( ( -IB ) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
04909             IB = MIN( IB, M )
04910             IN = IA + IB - 1
04911 *
04912             DO 40 I = IA, IN
04913 *
04914                IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
04915                   ERRI = ABS( PA( IIA+(JJA-1)*LDPA ) - A( IOFFA ) )/EPS
04916                   IF( G( I-IA+1 ).NE.ZERO )
04917      $               ERRI = ERRI / G( I-IA+1 )
04918                   ERR = MAX( ERR, ERRI )
04919                   IF( ERR*SQRT( EPS ).GE.ONE )
04920      $               INFO = 1
04921                   IIA = IIA + 1
04922                END IF
04923 *
04924                IOFFA = IOFFA + 1
04925 *
04926    40       CONTINUE
04927 *
04928             ICURROW = MOD( ICURROW+1, NPROW )
04929 *
04930             DO 60 I = IN+1, IA+M-1, DESCA( MB_ )
04931                IB = MIN( IA+M-I, DESCA( MB_ ) )
04932 *
04933                DO 50 KK = 0, IB-1
04934 *
04935                   IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
04936                      ERRI = ABS( PA( IIA+(JJA-1)*LDPA )-A( IOFFA ) )/EPS
04937                      IF( G( I+KK-IA+1 ).NE.ZERO )
04938      $                  ERRI = ERRI / G( I+KK-IA+1 )
04939                      ERR = MAX( ERR, ERRI )
04940                      IF( ERR*SQRT( EPS ).GE.ONE )
04941      $                  INFO = 1
04942                      IIA = IIA + 1
04943                   END IF
04944 *
04945                   IOFFA = IOFFA + 1
04946 *
04947    50          CONTINUE
04948 *
04949                ICURROW = MOD( ICURROW+1, NPROW )
04950 *
04951    60       CONTINUE
04952 *
04953          END IF
04954 *
04955 *        If INFO = 0, all results are at least half accurate.
04956 *
04957          CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL )
04958          CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
04959      $                 MYCOL )
04960          IF( INFO.NE.0 )
04961      $      GO TO 80
04962 *
04963    70 CONTINUE
04964 *
04965    80 CONTINUE
04966 *
04967       RETURN
04968 *
04969 *     End of PZVMCH
04970 *
04971       END
04972       SUBROUTINE PZVMCH2( ICTXT, UPLO, M, N, ALPHA, X, IX, JX, DESCX,
04973      $                    INCX, Y, IY, JY, DESCY, INCY, A, PA, IA,
04974      $                    JA, DESCA, G, ERR, INFO )
04975 *
04976 *  -- PBLAS test routine (version 2.0) --
04977 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
04978 *     and University of California, Berkeley.
04979 *     April 1, 1998
04980 *
04981 *     .. Scalar Arguments ..
04982       CHARACTER*1        UPLO
04983       INTEGER            IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
04984      $                   JY, M, N
04985       DOUBLE PRECISION   ERR
04986       COMPLEX*16         ALPHA
04987 *     ..
04988 *     .. Array Arguments ..
04989       INTEGER            DESCA( * ), DESCX( * ), DESCY( * )
04990       DOUBLE PRECISION   G( * )
04991       COMPLEX*16         A( * ), PA( * ), X( * ), Y( * )
04992 *     ..
04993 *
04994 *  Purpose
04995 *  =======
04996 *
04997 *  PZVMCH2 checks the results of the computational tests.
04998 *
04999 *  Notes
05000 *  =====
05001 *
05002 *  A description  vector  is associated with each 2D block-cyclicly dis-
05003 *  tributed matrix.  This  vector  stores  the  information  required to
05004 *  establish the  mapping  between a  matrix entry and its corresponding
05005 *  process and memory location.
05006 *
05007 *  In  the  following  comments,   the character _  should  be  read  as
05008 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
05009 *  block cyclicly distributed matrix.  Its description vector is DESCA:
05010 *
05011 *  NOTATION         STORED IN       EXPLANATION
05012 *  ---------------- --------------- ------------------------------------
05013 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
05014 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
05015 *                                   the NPROW x NPCOL BLACS process grid
05016 *                                   A  is distributed over.  The context
05017 *                                   itself  is  global,  but  the handle
05018 *                                   (the integer value) may vary.
05019 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
05020 *                                   ted matrix A, M_A >= 0.
05021 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
05022 *                                   buted matrix A, N_A >= 0.
05023 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
05024 *                                   block of the matrix A, IMB_A > 0.
05025 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
05026 *                                   left   block   of   the   matrix  A,
05027 *                                   INB_A > 0.
05028 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
05029 *                                   bute the last  M_A-IMB_A rows of  A,
05030 *                                   MB_A > 0.
05031 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
05032 *                                   bute the last  N_A-INB_A  columns of
05033 *                                   A, NB_A > 0.
05034 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
05035 *                                   row of the matrix  A is distributed,
05036 *                                   NPROW > RSRC_A >= 0.
05037 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
05038 *                                   first  column of  A  is distributed.
05039 *                                   NPCOL > CSRC_A >= 0.
05040 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
05041 *                                   array  storing  the  local blocks of
05042 *                                   the distributed matrix A,
05043 *                                   IF( Lc( 1, N_A ) > 0 )
05044 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
05045 *                                   ELSE
05046 *                                      LLD_A >= 1.
05047 *
05048 *  Let K be the number of  rows of a matrix A starting at the global in-
05049 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
05050 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
05051 *  receive if these K rows were distributed over NPROW processes.  If  K
05052 *  is the number of columns of a matrix  A  starting at the global index
05053 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
05054 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
05055 *  these K columns were distributed over NPCOL processes.
05056 *
05057 *  The values of Lr() and Lc() may be determined via a call to the func-
05058 *  tion PB_NUMROC:
05059 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
05060 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
05061 *
05062 *  Arguments
05063 *  =========
05064 *
05065 *  ICTXT   (local input) INTEGER
05066 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
05067 *          ting the global  context of the operation. The context itself
05068 *          is global, but the value of ICTXT is local.
05069 *
05070 *  UPLO    (global input) CHARACTER*1
05071 *          On entry, UPLO specifies which part of the submatrix sub( A )
05072 *          is to be referenced as follows:
05073 *             If UPLO = 'L', only the lower triangular part,
05074 *             If UPLO = 'U', only the upper triangular part,
05075 *             else the entire matrix is to be referenced.
05076 *
05077 *  M       (global input) INTEGER
05078 *          On entry,  M  specifies  the  number of rows of the submatrix
05079 *          operand matrix A. M must be at least zero.
05080 *
05081 *  N       (global input) INTEGER
05082 *          On entry,  N  specifies  the  number of columns of the subma-
05083 *          trix operand matrix A. N must be at least zero.
05084 *
05085 *  ALPHA   (global input) COMPLEX*16
05086 *          On entry, ALPHA specifies the scalar alpha.
05087 *
05088 *  X       (local input) COMPLEX*16 array
05089 *          On entry, X is an array of  dimension  (DESCX( M_ ),*).  This
05090 *          array contains a local copy of the initial entire matrix PX.
05091 *
05092 *  IX      (global input) INTEGER
05093 *          On entry, IX  specifies X's global row index, which points to
05094 *          the beginning of the submatrix sub( X ).
05095 *
05096 *  JX      (global input) INTEGER
05097 *          On entry, JX  specifies X's global column index, which points
05098 *          to the beginning of the submatrix sub( X ).
05099 *
05100 *  DESCX   (global and local input) INTEGER array
05101 *          On entry, DESCX  is an integer array of dimension DLEN_. This
05102 *          is the array descriptor for the matrix X.
05103 *
05104 *  INCX    (global input) INTEGER
05105 *          On entry,  INCX   specifies  the  global  increment  for  the
05106 *          elements of  X.  Only two values of  INCX   are  supported in
05107 *          this version, namely 1 and M_X. INCX  must not be zero.
05108 *
05109 *  Y       (local input) COMPLEX*16 array
05110 *          On entry, Y is an array of  dimension  (DESCY( M_ ),*).  This
05111 *          array contains a local copy of the initial entire matrix PY.
05112 *
05113 *  IY      (global input) INTEGER
05114 *          On entry, IY  specifies Y's global row index, which points to
05115 *          the beginning of the submatrix sub( Y ).
05116 *
05117 *  JY      (global input) INTEGER
05118 *          On entry, JY  specifies Y's global column index, which points
05119 *          to the beginning of the submatrix sub( Y ).
05120 *
05121 *  DESCY   (global and local input) INTEGER array
05122 *          On entry, DESCY  is an integer array of dimension DLEN_. This
05123 *          is the array descriptor for the matrix Y.
05124 *
05125 *  INCY    (global input) INTEGER
05126 *          On entry,  INCY   specifies  the  global  increment  for  the
05127 *          elements of  Y.  Only two values of  INCY   are  supported in
05128 *          this version, namely 1 and M_Y. INCY  must not be zero.
05129 *
05130 *  A       (local input/local output) COMPLEX*16 array
05131 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
05132 *          array contains a local copy of the initial entire matrix PA.
05133 *
05134 *  PA      (local input) COMPLEX*16 array
05135 *          On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
05136 *          array contains the local entries of the matrix PA.
05137 *
05138 *  IA      (global input) INTEGER
05139 *          On entry, IA  specifies A's global row index, which points to
05140 *          the beginning of the submatrix sub( A ).
05141 *
05142 *  JA      (global input) INTEGER
05143 *          On entry, JA  specifies A's global column index, which points
05144 *          to the beginning of the submatrix sub( A ).
05145 *
05146 *  DESCA   (global and local input) INTEGER array
05147 *          On entry, DESCA  is an integer array of dimension DLEN_. This
05148 *          is the array descriptor for the matrix A.
05149 *
05150 *  G       (workspace) DOUBLE PRECISION array
05151 *          On entry, G is an array of dimension at least MAX( M, N ).  G
05152 *          is used to compute the gauges.
05153 *
05154 *  ERR     (global output) DOUBLE PRECISION
05155 *          On exit, ERR specifies the largest error in absolute value.
05156 *
05157 *  INFO    (global output) INTEGER
05158 *          On exit, if INFO <> 0, the result is less than half accurate.
05159 *
05160 *  -- Written on April 1, 1998 by
05161 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
05162 *
05163 *  =====================================================================
05164 *
05165 *     .. Parameters ..
05166       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
05167      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
05168      $                   RSRC_
05169       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
05170      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
05171      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
05172      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
05173       DOUBLE PRECISION   ZERO, ONE
05174       PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
05175 *     ..
05176 *     .. Local Scalars ..
05177       LOGICAL            COLREP, LOWER, ROWREP, UPPER
05178       INTEGER            I, IACOL, IAROW, IB, IBEG, ICURROW, IEND, IIA,
05179      $                   IN, IOFFA, IOFFXI, IOFFXJ, IOFFYI, IOFFYJ, J,
05180      $                   JJA, KK, LDA, LDPA, LDX, LDY, MYCOL, MYROW,
05181      $                   NPCOL, NPROW
05182       DOUBLE PRECISION   EPS, ERRI, GTMP
05183       COMPLEX*16         C, ATMP
05184 *     ..
05185 *     .. External Subroutines ..
05186       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L
05187 *     ..
05188 *     .. External Functions ..
05189       LOGICAL            LSAME
05190       DOUBLE PRECISION   PDLAMCH
05191       EXTERNAL           LSAME, PDLAMCH
05192 *     ..
05193 *     .. Intrinsic Functions ..
05194       INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD, SQRT
05195 *     ..
05196 *     .. Statement Functions ..
05197       DOUBLE PRECISION   ABS1
05198       ABS1( C ) = ABS( DBLE( C ) ) + ABS( DIMAG( C ) )
05199 *     ..
05200 *     .. Executable Statements ..
05201 *
05202       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
05203 *
05204       EPS = PDLAMCH( ICTXT, 'eps' )
05205 *
05206       UPPER = LSAME( UPLO, 'U' )
05207       LOWER = LSAME( UPLO, 'L' )
05208 *
05209       LDA = MAX( 1, DESCA( M_ ) )
05210       LDX = MAX( 1, DESCX( M_ ) )
05211       LDY = MAX( 1, DESCY( M_ ) )
05212 *
05213 *     Compute expected result in A using data in A, X and Y.
05214 *     Compute gauges in G. This part of the computation is performed
05215 *     by every process in the grid.
05216 *
05217       DO 70 J = 1, N
05218 *
05219          IOFFXJ = IX + ( JX - 1 ) * LDX + ( J - 1 ) * INCX
05220          IOFFYJ = IY + ( JY - 1 ) * LDY + ( J - 1 ) * INCY
05221 *
05222          IF( LOWER ) THEN
05223             IBEG = J
05224             IEND = M
05225             DO 10 I = 1, J-1
05226                G( I ) = ZERO
05227    10       CONTINUE
05228          ELSE IF( UPPER ) THEN
05229             IBEG = 1
05230             IEND = J
05231             DO 20 I = J+1, M
05232                G( I ) = ZERO
05233    20       CONTINUE
05234          ELSE
05235             IBEG = 1
05236             IEND = M
05237          END IF
05238 *
05239          DO 30 I = IBEG, IEND
05240             IOFFA = IA + I - 1 + ( JA + J - 2 ) * LDA
05241             IOFFXI = IX + ( JX - 1 ) * LDX + ( I - 1 ) * INCX
05242             IOFFYI = IY + ( JY - 1 ) * LDY + ( I - 1 ) * INCY
05243             ATMP = ALPHA * X( IOFFXI ) * DCONJG( Y( IOFFYJ ) )
05244             ATMP = ATMP + Y( IOFFYI ) * DCONJG( ALPHA * X( IOFFXJ ) )
05245             GTMP = ABS1( ALPHA * X( IOFFXI ) ) * ABS1( Y( IOFFYJ ) )
05246             GTMP = GTMP + ABS1( Y( IOFFYI ) ) *
05247      $                    ABS1( DCONJG( ALPHA * X( IOFFXJ ) ) )
05248             G( I ) = GTMP + ABS1( A( IOFFA ) )
05249             A( IOFFA ) = A( IOFFA ) + ATMP
05250 *
05251    30    CONTINUE
05252 *
05253 *        Compute the error ratio for this result.
05254 *
05255          INFO = 0
05256          ERR  = ZERO
05257          LDPA = DESCA( LLD_ )
05258          IOFFA = IA + ( JA + J - 2 ) * LDA
05259          CALL PB_INFOG2L( IA, JA+J-1, DESCA, NPROW, NPCOL, MYROW, MYCOL,
05260      $                    IIA, JJA, IAROW, IACOL )
05261          ROWREP = ( IAROW.EQ.-1 )
05262          COLREP = ( IACOL.EQ.-1 )
05263 *
05264          IF( MYCOL.EQ.IACOL .OR. COLREP ) THEN
05265 *
05266             ICURROW = IAROW
05267             IB = DESCA( IMB_ ) - IA + 1
05268             IF( IB.LE.0 )
05269      $         IB = ( ( -IB ) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
05270             IB = MIN( IB, M )
05271             IN = IA + IB - 1
05272 *
05273             DO 40 I = IA, IN
05274 *
05275                IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
05276                   ERRI = ABS( PA( IIA+(JJA-1)*LDPA ) - A( IOFFA ) )/EPS
05277                   IF( G( I-IA+1 ).NE.ZERO )
05278      $               ERRI = ERRI / G( I-IA+1 )
05279                   ERR = MAX( ERR, ERRI )
05280                   IF( ERR*SQRT( EPS ).GE.ONE )
05281      $               INFO = 1
05282                   IIA = IIA + 1
05283                END IF
05284 *
05285                IOFFA = IOFFA + 1
05286 *
05287    40       CONTINUE
05288 *
05289             ICURROW = MOD( ICURROW+1, NPROW )
05290 *
05291             DO 60 I = IN+1, IA+M-1, DESCA( MB_ )
05292                IB = MIN( IA+M-I, DESCA( MB_ ) )
05293 *
05294                DO 50 KK = 0, IB-1
05295 *
05296                   IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
05297                      ERRI = ABS( PA( IIA+(JJA-1)*LDPA )-A( IOFFA ) )/EPS
05298                      IF( G( I+KK-IA+1 ).NE.ZERO )
05299      $                  ERRI = ERRI / G( I+KK-IA+1 )
05300                      ERR = MAX( ERR, ERRI )
05301                      IF( ERR*SQRT( EPS ).GE.ONE )
05302      $                  INFO = 1
05303                      IIA = IIA + 1
05304                   END IF
05305 *
05306                   IOFFA = IOFFA + 1
05307 *
05308    50          CONTINUE
05309 *
05310                ICURROW = MOD( ICURROW+1, NPROW )
05311 *
05312    60       CONTINUE
05313 *
05314          END IF
05315 *
05316 *        If INFO = 0, all results are at least half accurate.
05317 *
05318          CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL )
05319          CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
05320      $                 MYCOL )
05321          IF( INFO.NE.0 )
05322      $      GO TO 80
05323 *
05324    70 CONTINUE
05325 *
05326    80 CONTINUE
05327 *
05328       RETURN
05329 *
05330 *     End of PZVMCH2
05331 *
05332       END
05333       SUBROUTINE PZMMCH( ICTXT, TRANSA, TRANSB, M, N, K, ALPHA, A, IA,
05334      $                   JA, DESCA, B, IB, JB, DESCB, BETA, C, PC, IC,
05335      $                   JC, DESCC, CT, G, ERR, INFO )
05336 *
05337 *  -- PBLAS test routine (version 2.0) --
05338 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
05339 *     and University of California, Berkeley.
05340 *     April 1, 1998
05341 *
05342 *     .. Scalar Arguments ..
05343       CHARACTER*1        TRANSA, TRANSB
05344       INTEGER            IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, M, N
05345       DOUBLE PRECISION   ERR
05346       COMPLEX*16         ALPHA, BETA
05347 *     ..
05348 *     .. Array Arguments ..
05349       INTEGER            DESCA( * ), DESCB( * ), DESCC( * )
05350       DOUBLE PRECISION   G( * )
05351       COMPLEX*16         A( * ), B( * ), C( * ), CT( * ), PC( * )
05352 *     ..
05353 *
05354 *  Purpose
05355 *  =======
05356 *
05357 *  PZMMCH checks the results of the computational tests.
05358 *
05359 *  Notes
05360 *  =====
05361 *
05362 *  A description  vector  is associated with each 2D block-cyclicly dis-
05363 *  tributed matrix.  This  vector  stores  the  information  required to
05364 *  establish the  mapping  between a  matrix entry and its corresponding
05365 *  process and memory location.
05366 *
05367 *  In  the  following  comments,   the character _  should  be  read  as
05368 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
05369 *  block cyclicly distributed matrix.  Its description vector is DESCA:
05370 *
05371 *  NOTATION         STORED IN       EXPLANATION
05372 *  ---------------- --------------- ------------------------------------
05373 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
05374 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
05375 *                                   the NPROW x NPCOL BLACS process grid
05376 *                                   A  is distributed over.  The context
05377 *                                   itself  is  global,  but  the handle
05378 *                                   (the integer value) may vary.
05379 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
05380 *                                   ted matrix A, M_A >= 0.
05381 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
05382 *                                   buted matrix A, N_A >= 0.
05383 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
05384 *                                   block of the matrix A, IMB_A > 0.
05385 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
05386 *                                   left   block   of   the   matrix  A,
05387 *                                   INB_A > 0.
05388 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
05389 *                                   bute the last  M_A-IMB_A rows of  A,
05390 *                                   MB_A > 0.
05391 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
05392 *                                   bute the last  N_A-INB_A  columns of
05393 *                                   A, NB_A > 0.
05394 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
05395 *                                   row of the matrix  A is distributed,
05396 *                                   NPROW > RSRC_A >= 0.
05397 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
05398 *                                   first  column of  A  is distributed.
05399 *                                   NPCOL > CSRC_A >= 0.
05400 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
05401 *                                   array  storing  the  local blocks of
05402 *                                   the distributed matrix A,
05403 *                                   IF( Lc( 1, N_A ) > 0 )
05404 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
05405 *                                   ELSE
05406 *                                      LLD_A >= 1.
05407 *
05408 *  Let K be the number of  rows of a matrix A starting at the global in-
05409 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
05410 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
05411 *  receive if these K rows were distributed over NPROW processes.  If  K
05412 *  is the number of columns of a matrix  A  starting at the global index
05413 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
05414 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
05415 *  these K columns were distributed over NPCOL processes.
05416 *
05417 *  The values of Lr() and Lc() may be determined via a call to the func-
05418 *  tion PB_NUMROC:
05419 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
05420 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
05421 *
05422 *  Arguments
05423 *  =========
05424 *
05425 *  ICTXT   (local input) INTEGER
05426 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
05427 *          ting the global  context of the operation. The context itself
05428 *          is global, but the value of ICTXT is local.
05429 *
05430 *  TRANSA  (global input) CHARACTER*1
05431 *          On entry, TRANSA specifies if the matrix  operand  A is to be
05432 *          transposed.
05433 *
05434 *  TRANSB  (global input) CHARACTER*1
05435 *          On entry, TRANSB specifies if the matrix  operand  B is to be
05436 *          transposed.
05437 *
05438 *  M       (global input) INTEGER
05439 *          On entry, M specifies the number of rows of C.
05440 *
05441 *  N       (global input) INTEGER
05442 *          On entry, N specifies the number of columns of C.
05443 *
05444 *  K       (global input) INTEGER
05445 *          On entry, K specifies the number of columns (resp. rows) of A
05446 *          when  TRANSA = 'N'  (resp. TRANSA <> 'N')  in PxGEMM, PxSYRK,
05447 *          PxSYR2K, PxHERK and PxHER2K.
05448 *
05449 *  ALPHA   (global input) COMPLEX*16
05450 *          On entry, ALPHA specifies the scalar alpha.
05451 *
05452 *  A       (local input) COMPLEX*16 array
05453 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
05454 *          array contains a local copy of the initial entire matrix PA.
05455 *
05456 *  IA      (global input) INTEGER
05457 *          On entry, IA  specifies A's global row index, which points to
05458 *          the beginning of the submatrix sub( A ).
05459 *
05460 *  JA      (global input) INTEGER
05461 *          On entry, JA  specifies A's global column index, which points
05462 *          to the beginning of the submatrix sub( A ).
05463 *
05464 *  DESCA   (global and local input) INTEGER array
05465 *          On entry, DESCA  is an integer array of dimension DLEN_. This
05466 *          is the array descriptor for the matrix A.
05467 *
05468 *  B       (local input) COMPLEX*16 array
05469 *          On entry, B is an array of  dimension  (DESCB( M_ ),*).  This
05470 *          array contains a local copy of the initial entire matrix PB.
05471 *
05472 *  IB      (global input) INTEGER
05473 *          On entry, IB  specifies B's global row index, which points to
05474 *          the beginning of the submatrix sub( B ).
05475 *
05476 *  JB      (global input) INTEGER
05477 *          On entry, JB  specifies B's global column index, which points
05478 *          to the beginning of the submatrix sub( B ).
05479 *
05480 *  DESCB   (global and local input) INTEGER array
05481 *          On entry, DESCB  is an integer array of dimension DLEN_. This
05482 *          is the array descriptor for the matrix B.
05483 *
05484 *  BETA    (global input) COMPLEX*16
05485 *          On entry, BETA specifies the scalar beta.
05486 *
05487 *  C       (local input/local output) COMPLEX*16 array
05488 *          On entry, C is an array of  dimension  (DESCC( M_ ),*).  This
05489 *          array contains a local copy of the initial entire matrix PC.
05490 *
05491 *  PC      (local input) COMPLEX*16 array
05492 *          On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
05493 *          array contains the local pieces of the matrix PC.
05494 *
05495 *  IC      (global input) INTEGER
05496 *          On entry, IC  specifies C's global row index, which points to
05497 *          the beginning of the submatrix sub( C ).
05498 *
05499 *  JC      (global input) INTEGER
05500 *          On entry, JC  specifies C's global column index, which points
05501 *          to the beginning of the submatrix sub( C ).
05502 *
05503 *  DESCC   (global and local input) INTEGER array
05504 *          On entry, DESCC  is an integer array of dimension DLEN_. This
05505 *          is the array descriptor for the matrix C.
05506 *
05507 *  CT      (workspace) COMPLEX*16 array
05508 *          On entry, CT is an array of dimension at least MAX(M,N,K). CT
05509 *          holds a copy of the current column of C.
05510 *
05511 *  G       (workspace) DOUBLE PRECISION array
05512 *          On entry, G  is  an array of dimension at least MAX(M,N,K). G
05513 *          is used to compute the gauges.
05514 *
05515 *  ERR     (global output) DOUBLE PRECISION
05516 *          On exit, ERR specifies the largest error in absolute value.
05517 *
05518 *  INFO    (global output) INTEGER
05519 *          On exit, if INFO <> 0, the result is less than half accurate.
05520 *
05521 *  -- Written on April 1, 1998 by
05522 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
05523 *
05524 *  =====================================================================
05525 *
05526 *     .. Parameters ..
05527       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
05528      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
05529      $                   RSRC_
05530       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
05531      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
05532      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
05533      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
05534       DOUBLE PRECISION   RZERO, RONE
05535       PARAMETER          ( RZERO = 0.0D+0, RONE = 1.0D+0 )
05536       COMPLEX*16         ZERO
05537       PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
05538 *     ..
05539 *     .. Local Scalars ..
05540       LOGICAL            COLREP, CTRANA, CTRANB, ROWREP, TRANA, TRANB
05541       INTEGER            I, IBB, ICCOL, ICROW, ICURROW, IIC, IN, IOFFA,
05542      $                   IOFFB, IOFFC, J, JJC, KK, LDA, LDB, LDC, LDPC,
05543      $                   MYCOL, MYROW, NPCOL, NPROW
05544       DOUBLE PRECISION   EPS, ERRI
05545       COMPLEX*16         Z
05546 *     ..
05547 *     .. External Subroutines ..
05548       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L
05549 *     ..
05550 *     .. External Functions ..
05551       LOGICAL            LSAME
05552       DOUBLE PRECISION   PDLAMCH
05553       EXTERNAL           LSAME, PDLAMCH
05554 *     ..
05555 *     .. Intrinsic Functions ..
05556       INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD, SQRT
05557 *     ..
05558 *     .. Statement Functions ..
05559       DOUBLE PRECISION   ABS1
05560       ABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
05561 *     ..
05562 *     .. Executable Statements ..
05563 *
05564       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
05565 *
05566       EPS = PDLAMCH( ICTXT, 'eps' )
05567 *
05568       TRANA = LSAME( TRANSA, 'T' ).OR.LSAME( TRANSA, 'C' )
05569       TRANB = LSAME( TRANSB, 'T' ).OR.LSAME( TRANSB, 'C' )
05570       CTRANA = LSAME( TRANSA, 'C' )
05571       CTRANB = LSAME( TRANSB, 'C' )
05572 *
05573       LDA = MAX( 1, DESCA( M_ ) )
05574       LDB = MAX( 1, DESCB( M_ ) )
05575       LDC = MAX( 1, DESCC( M_ ) )
05576 *
05577 *     Compute expected result in C using data in A, B and C.
05578 *     Compute gauges in G. This part of the computation is performed
05579 *     by every process in the grid.
05580 *
05581       DO 240 J = 1, N
05582 *
05583          IOFFC = IC + ( JC + J - 2 ) * LDC
05584          DO 10 I = 1, M
05585             CT( I ) = ZERO
05586             G( I )  = RZERO
05587    10    CONTINUE
05588 *
05589          IF( .NOT.TRANA .AND. .NOT.TRANB ) THEN
05590             DO 30 KK = 1, K
05591                IOFFB = IB + KK - 1 + ( JB + J - 2 ) * LDB
05592                DO 20 I = 1, M
05593                   IOFFA = IA + I - 1 + ( JA + KK - 2 ) * LDA
05594                   CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB )
05595                   G( I ) = G( I ) + ABS( A( IOFFA ) ) *
05596      $                     ABS( B( IOFFB ) )
05597    20          CONTINUE
05598    30       CONTINUE
05599          ELSE IF( TRANA .AND. .NOT.TRANB ) THEN
05600             IF( CTRANA ) THEN
05601                DO 50 KK = 1, K
05602                   IOFFB = IB + KK - 1 + ( JB + J - 2 ) * LDB
05603                   DO 40 I = 1, M
05604                      IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA
05605                      CT( I ) = CT( I ) + DCONJG( A( IOFFA ) ) *
05606      $                                   B( IOFFB )
05607                      G( I ) = G( I ) + ABS1( A( IOFFA ) ) *
05608      $                        ABS1( B( IOFFB ) )
05609    40             CONTINUE
05610    50          CONTINUE
05611             ELSE
05612                DO 70 KK = 1, K
05613                   IOFFB = IB + KK - 1 + ( JB + J - 2 ) * LDB
05614                   DO 60 I = 1, M
05615                      IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA
05616                      CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB )
05617                      G( I ) = G( I ) + ABS1( A( IOFFA ) ) *
05618      $                        ABS1( B( IOFFB ) )
05619    60             CONTINUE
05620    70          CONTINUE
05621             END IF
05622          ELSE IF( .NOT.TRANA .AND. TRANB ) THEN
05623             IF( CTRANB ) THEN
05624                DO 90 KK = 1, K
05625                   IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB
05626                   DO 80 I = 1, M
05627                      IOFFA = IA + I - 1 + ( JA + KK - 2 ) * LDA
05628                      CT( I ) = CT( I ) + A( IOFFA ) *
05629      $                                   DCONJG( B( IOFFB ) )
05630                      G( I ) = G( I ) + ABS1( A( IOFFA ) ) *
05631      $                        ABS1( B( IOFFB ) )
05632    80             CONTINUE
05633    90          CONTINUE
05634             ELSE
05635                DO 110 KK = 1, K
05636                   IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB
05637                   DO 100 I = 1, M
05638                      IOFFA = IA + I - 1 + ( JA + KK - 2 ) * LDA
05639                      CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB )
05640                      G( I ) = G( I ) + ABS1( A( IOFFA ) ) *
05641      $                        ABS1( B( IOFFB ) )
05642   100             CONTINUE
05643   110          CONTINUE
05644             END IF
05645          ELSE IF( TRANA .AND. TRANB ) THEN
05646             IF( CTRANA ) THEN
05647                IF( CTRANB ) THEN
05648                   DO 130 KK = 1, K
05649                      IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB
05650                      DO 120 I = 1, M
05651                         IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA
05652                         CT( I ) = CT( I ) + DCONJG( A( IOFFA ) ) *
05653      $                                      DCONJG( B( IOFFB ) )
05654                         G( I ) = G( I ) + ABS1( A( IOFFA ) ) *
05655      $                           ABS1( B( IOFFB ) )
05656   120                CONTINUE
05657   130             CONTINUE
05658                ELSE
05659                   DO 150 KK = 1, K
05660                      IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB
05661                      DO 140 I = 1, M
05662                         IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA
05663                         CT( I ) = CT( I ) + DCONJG( A( IOFFA ) ) *
05664      $                                      B( IOFFB )
05665                         G( I ) = G( I ) + ABS1( A( IOFFA ) ) *
05666      $                           ABS1( B( IOFFB ) )
05667   140                CONTINUE
05668   150             CONTINUE
05669                END IF
05670             ELSE
05671                IF( CTRANB ) THEN
05672                   DO 170 KK = 1, K
05673                      IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB
05674                      DO 160 I = 1, M
05675                         IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA
05676                         CT( I ) = CT( I ) + A( IOFFA ) *
05677      $                                      DCONJG( B( IOFFB ) )
05678                         G( I ) = G( I ) + ABS1( A( IOFFA ) ) *
05679      $                           ABS1( B( IOFFB ) )
05680   160                CONTINUE
05681   170             CONTINUE
05682                ELSE
05683                   DO 190 KK = 1, K
05684                      IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB
05685                      DO 180 I = 1, M
05686                         IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA
05687                         CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB )
05688                         G( I ) = G( I ) + ABS1( A( IOFFA ) ) *
05689      $                           ABS1( B( IOFFB ) )
05690   180                CONTINUE
05691   190             CONTINUE
05692                END IF
05693             END IF
05694          END IF
05695 *
05696          DO 200 I = 1, M
05697             CT( I ) = ALPHA*CT( I ) + BETA * C( IOFFC )
05698             G( I ) = ABS1( ALPHA )*G( I ) +
05699      $               ABS1( BETA )*ABS1( C( IOFFC ) )
05700             C( IOFFC ) = CT( I )
05701             IOFFC      = IOFFC + 1
05702   200    CONTINUE
05703 *
05704 *        Compute the error ratio for this result.
05705 *
05706          ERR  = RZERO
05707          INFO = 0
05708          LDPC = DESCC( LLD_ )
05709          IOFFC = IC + ( JC + J - 2 ) * LDC
05710          CALL PB_INFOG2L( IC, JC+J-1, DESCC, NPROW, NPCOL, MYROW, MYCOL,
05711      $                    IIC, JJC, ICROW, ICCOL )
05712          ICURROW = ICROW
05713          ROWREP  = ( ICROW.EQ.-1 )
05714          COLREP  = ( ICCOL.EQ.-1 )
05715 *
05716          IF( MYCOL.EQ.ICCOL .OR. COLREP ) THEN
05717 *
05718             IBB = DESCC( IMB_ ) - IC + 1
05719             IF( IBB.LE.0 )
05720      $         IBB = ( ( -IBB ) / DESCC( MB_ ) + 1 )*DESCC( MB_ ) + IBB
05721             IBB = MIN( IBB, M )
05722             IN = IC + IBB - 1
05723 *
05724             DO 210 I = IC, IN
05725 *
05726                IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
05727                   ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
05728      $                        C( IOFFC ) ) / EPS
05729                   IF( G( I-IC+1 ).NE.RZERO )
05730      $               ERRI = ERRI / G( I-IC+1 )
05731                   ERR = MAX( ERR, ERRI )
05732                   IF( ERR*SQRT( EPS ).GE.RONE )
05733      $               INFO = 1
05734                   IIC = IIC + 1
05735                END IF
05736 *
05737                IOFFC = IOFFC + 1
05738 *
05739   210       CONTINUE
05740 *
05741             ICURROW = MOD( ICURROW+1, NPROW )
05742 *
05743             DO 230 I = IN+1, IC+M-1, DESCC( MB_ )
05744                IBB = MIN( IC+M-I, DESCC( MB_ ) )
05745 *
05746                DO 220 KK = 0, IBB-1
05747 *
05748                   IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
05749                      ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
05750      $                           C( IOFFC ) )/EPS
05751                      IF( G( I+KK-IC+1 ).NE.RZERO )
05752      $                  ERRI = ERRI / G( I+KK-IC+1 )
05753                      ERR = MAX( ERR, ERRI )
05754                      IF( ERR*SQRT( EPS ).GE.RONE )
05755      $                  INFO = 1
05756                      IIC = IIC + 1
05757                   END IF
05758 *
05759                   IOFFC = IOFFC + 1
05760 *
05761   220          CONTINUE
05762 *
05763                ICURROW = MOD( ICURROW+1, NPROW )
05764 *
05765   230       CONTINUE
05766 *
05767          END IF
05768 *
05769 *        If INFO = 0, all results are at least half accurate.
05770 *
05771          CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL )
05772          CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
05773      $                 MYCOL )
05774          IF( INFO.NE.0 )
05775      $      GO TO 250
05776 *
05777   240 CONTINUE
05778 *
05779   250 CONTINUE
05780 *
05781       RETURN
05782 *
05783 *     End of PZMMCH
05784 *
05785       END
05786       SUBROUTINE PZMMCH1( ICTXT, UPLO, TRANS, N, K, ALPHA, A, IA, JA,
05787      $                    DESCA, BETA, C, PC, IC, JC, DESCC, CT, G,
05788      $                    ERR, INFO )
05789 *
05790 *  -- PBLAS test routine (version 2.0) --
05791 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
05792 *     and University of California, Berkeley.
05793 *     April 1, 1998
05794 *
05795 *     .. Scalar Arguments ..
05796       CHARACTER*1        TRANS, UPLO
05797       INTEGER            IA, IC, ICTXT, INFO, JA, JC, K, N
05798       DOUBLE PRECISION   ERR
05799       COMPLEX*16         ALPHA, BETA
05800 *     ..
05801 *     .. Array Arguments ..
05802       INTEGER            DESCA( * ), DESCC( * )
05803       DOUBLE PRECISION   G( * )
05804       COMPLEX*16         A( * ), C( * ), CT( * ), PC( * )
05805 *     ..
05806 *
05807 *  Purpose
05808 *  =======
05809 *
05810 *  PZMMCH1 checks the results of the computational tests.
05811 *
05812 *  Notes
05813 *  =====
05814 *
05815 *  A description  vector  is associated with each 2D block-cyclicly dis-
05816 *  tributed matrix.  This  vector  stores  the  information  required to
05817 *  establish the  mapping  between a  matrix entry and its corresponding
05818 *  process and memory location.
05819 *
05820 *  In  the  following  comments,   the character _  should  be  read  as
05821 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
05822 *  block cyclicly distributed matrix.  Its description vector is DESCA:
05823 *
05824 *  NOTATION         STORED IN       EXPLANATION
05825 *  ---------------- --------------- ------------------------------------
05826 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
05827 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
05828 *                                   the NPROW x NPCOL BLACS process grid
05829 *                                   A  is distributed over.  The context
05830 *                                   itself  is  global,  but  the handle
05831 *                                   (the integer value) may vary.
05832 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
05833 *                                   ted matrix A, M_A >= 0.
05834 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
05835 *                                   buted matrix A, N_A >= 0.
05836 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
05837 *                                   block of the matrix A, IMB_A > 0.
05838 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
05839 *                                   left   block   of   the   matrix  A,
05840 *                                   INB_A > 0.
05841 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
05842 *                                   bute the last  M_A-IMB_A rows of  A,
05843 *                                   MB_A > 0.
05844 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
05845 *                                   bute the last  N_A-INB_A  columns of
05846 *                                   A, NB_A > 0.
05847 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
05848 *                                   row of the matrix  A is distributed,
05849 *                                   NPROW > RSRC_A >= 0.
05850 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
05851 *                                   first  column of  A  is distributed.
05852 *                                   NPCOL > CSRC_A >= 0.
05853 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
05854 *                                   array  storing  the  local blocks of
05855 *                                   the distributed matrix A,
05856 *                                   IF( Lc( 1, N_A ) > 0 )
05857 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
05858 *                                   ELSE
05859 *                                      LLD_A >= 1.
05860 *
05861 *  Let K be the number of  rows of a matrix A starting at the global in-
05862 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
05863 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
05864 *  receive if these K rows were distributed over NPROW processes.  If  K
05865 *  is the number of columns of a matrix  A  starting at the global index
05866 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
05867 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
05868 *  these K columns were distributed over NPCOL processes.
05869 *
05870 *  The values of Lr() and Lc() may be determined via a call to the func-
05871 *  tion PB_NUMROC:
05872 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
05873 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
05874 *
05875 *  Arguments
05876 *  =========
05877 *
05878 *  ICTXT   (local input) INTEGER
05879 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
05880 *          ting the global  context of the operation. The context itself
05881 *          is global, but the value of ICTXT is local.
05882 *
05883 *  UPLO    (global input) CHARACTER*1
05884 *          On entry,  UPLO  specifies which part of C should contain the
05885 *          result.
05886 *
05887 *  TRANS   (global input) CHARACTER*1
05888 *          On entry,  TRANS  specifies  whether  the  matrix A has to be
05889 *          transposed or not before computing the matrix-matrix product.
05890 *
05891 *  N       (global input) INTEGER
05892 *          On entry, N  specifies  the order  the submatrix operand C. N
05893 *          must be at least zero.
05894 *
05895 *  K       (global input) INTEGER
05896 *          On entry, K specifies the number of columns (resp. rows) of A
05897 *          when  TRANS = 'N'  (resp. TRANS <> 'N').  K  must be at least
05898 *          zero.
05899 *
05900 *  ALPHA   (global input) COMPLEX*16
05901 *          On entry, ALPHA specifies the scalar alpha.
05902 *
05903 *  A       (local input) COMPLEX*16 array
05904 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
05905 *          array contains a local copy of the initial entire matrix PA.
05906 *
05907 *  IA      (global input) INTEGER
05908 *          On entry, IA  specifies A's global row index, which points to
05909 *          the beginning of the submatrix sub( A ).
05910 *
05911 *  JA      (global input) INTEGER
05912 *          On entry, JA  specifies A's global column index, which points
05913 *          to the beginning of the submatrix sub( A ).
05914 *
05915 *  DESCA   (global and local input) INTEGER array
05916 *          On entry, DESCA  is an integer array of dimension DLEN_. This
05917 *          is the array descriptor for the matrix A.
05918 *
05919 *  BETA    (global input) COMPLEX*16
05920 *          On entry, BETA specifies the scalar beta.
05921 *
05922 *  C       (local input/local output) COMPLEX*16 array
05923 *          On entry, C is an array of  dimension  (DESCC( M_ ),*).  This
05924 *          array contains a local copy of the initial entire matrix PC.
05925 *
05926 *  PC      (local input) COMPLEX*16 array
05927 *          On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
05928 *          array contains the local pieces of the matrix PC.
05929 *
05930 *  IC      (global input) INTEGER
05931 *          On entry, IC  specifies C's global row index, which points to
05932 *          the beginning of the submatrix sub( C ).
05933 *
05934 *  JC      (global input) INTEGER
05935 *          On entry, JC  specifies C's global column index, which points
05936 *          to the beginning of the submatrix sub( C ).
05937 *
05938 *  DESCC   (global and local input) INTEGER array
05939 *          On entry, DESCC  is an integer array of dimension DLEN_. This
05940 *          is the array descriptor for the matrix C.
05941 *
05942 *  CT      (workspace) COMPLEX*16 array
05943 *          On entry, CT is an array of dimension at least MAX(M,N,K). CT
05944 *          holds a copy of the current column of C.
05945 *
05946 *  G       (workspace) DOUBLE PRECISION array
05947 *          On entry, G  is  an array of dimension at least MAX(M,N,K). G
05948 *          is used to compute the gauges.
05949 *
05950 *  ERR     (global output) DOUBLE PRECISION
05951 *          On exit, ERR specifies the largest error in absolute value.
05952 *
05953 *  INFO    (global output) INTEGER
05954 *          On exit, if INFO <> 0, the result is less than half accurate.
05955 *
05956 *  -- Written on April 1, 1998 by
05957 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
05958 *
05959 *  =====================================================================
05960 *
05961 *     .. Parameters ..
05962       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
05963      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
05964      $                   RSRC_
05965       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
05966      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
05967      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
05968      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
05969       DOUBLE PRECISION   RZERO, RONE
05970       PARAMETER          ( RZERO = 0.0D+0, RONE = 1.0D+0 )
05971       COMPLEX*16         ZERO
05972       PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
05973 *     ..
05974 *     .. Local Scalars ..
05975       LOGICAL            COLREP, HTRAN, NOTRAN, ROWREP, TRAN, UPPER
05976       INTEGER            I, IBB, IBEG, ICCOL, ICROW, ICURROW, IEND, IIC,
05977      $                   IN, IOFFAK, IOFFAN, IOFFC, J, JJC, KK, LDA,
05978      $                   LDC, LDPC, MYCOL, MYROW, NPCOL, NPROW
05979       DOUBLE PRECISION   EPS, ERRI
05980       COMPLEX*16         Z
05981 *     ..
05982 *     .. External Subroutines ..
05983       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L
05984 *     ..
05985 *     .. External Functions ..
05986       LOGICAL            LSAME
05987       DOUBLE PRECISION   PDLAMCH
05988       EXTERNAL           LSAME, PDLAMCH
05989 *     ..
05990 *     .. Intrinsic Functions ..
05991       INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD, SQRT
05992 *     ..
05993 *     .. Statement Functions ..
05994       DOUBLE PRECISION   ABS1
05995       ABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
05996 *     ..
05997 *     .. Executable Statements ..
05998 *
05999       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
06000 *
06001       EPS = PDLAMCH( ICTXT, 'eps' )
06002 *
06003       UPPER  = LSAME( UPLO,  'U' )
06004       NOTRAN = LSAME( TRANS, 'N' )
06005       TRAN   = LSAME( TRANS, 'T' )
06006       HTRAN  = LSAME( TRANS, 'H' )
06007 *
06008       LDA = MAX( 1, DESCA( M_ ) )
06009       LDC = MAX( 1, DESCC( M_ ) )
06010 *
06011 *     Compute expected result in C using data in A, B and C.
06012 *     Compute gauges in G. This part of the computation is performed
06013 *     by every process in the grid.
06014 *
06015       DO 140 J = 1, N
06016 *
06017          IF( UPPER ) THEN
06018             IBEG = 1
06019             IEND = J
06020          ELSE
06021             IBEG = J
06022             IEND = N
06023          END IF
06024 *
06025          DO 10 I = 1, N
06026             CT( I ) = ZERO
06027             G( I )  = RZERO
06028    10    CONTINUE
06029 *
06030          IF( NOTRAN ) THEN
06031             DO 30 KK = 1, K
06032                IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA
06033                DO 20 I = IBEG, IEND
06034                   IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA
06035                   CT( I ) = CT( I ) + A( IOFFAK ) * A( IOFFAN )
06036                   G( I ) = G( I ) + ABS1( A( IOFFAK ) ) *
06037      $                     ABS1( A( IOFFAN ) )
06038    20          CONTINUE
06039    30       CONTINUE
06040          ELSE IF( TRAN ) THEN
06041             DO 50 KK = 1, K
06042                IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA
06043                DO 40 I = IBEG, IEND
06044                   IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA
06045                   CT( I ) = CT( I ) + A( IOFFAK ) * A( IOFFAN )
06046                   G( I ) = G( I ) + ABS1( A( IOFFAK ) ) *
06047      $                     ABS1( A( IOFFAN ) )
06048    40          CONTINUE
06049    50       CONTINUE
06050          ELSE IF( HTRAN ) THEN
06051             DO 70 KK = 1, K
06052                IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA
06053                DO 60 I = IBEG, IEND
06054                   IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA
06055                   CT( I ) = CT( I ) + A( IOFFAN ) *
06056      $                      DCONJG( A( IOFFAK ) )
06057                   G( I ) = G( I ) + ABS1( A( IOFFAK ) ) *
06058      $                     ABS1( A( IOFFAN ) )
06059    60          CONTINUE
06060    70       CONTINUE
06061          ELSE
06062             DO 90 KK = 1, K
06063                IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA
06064                DO 80 I = IBEG, IEND
06065                   IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA
06066                   CT( I ) = CT( I ) + DCONJG( A( IOFFAN ) ) *
06067      $                      A( IOFFAK )
06068                   G( I ) = G( I ) + ABS1( DCONJG( A( IOFFAN ) ) ) *
06069      $                     ABS1( A( IOFFAK ) )
06070    80          CONTINUE
06071    90       CONTINUE
06072          END IF
06073 *
06074          IOFFC = IC + IBEG - 1 + ( JC + J - 2 ) * LDC
06075 *
06076          DO 100 I = IBEG, IEND
06077             CT( I ) = ALPHA*CT( I ) + BETA * C( IOFFC )
06078             G( I ) = ABS1( ALPHA )*G( I ) +
06079      $               ABS1( BETA )*ABS1( C( IOFFC ) )
06080             C( IOFFC ) = CT( I )
06081             IOFFC = IOFFC + 1
06082   100    CONTINUE
06083 *
06084 *        Compute the error ratio for this result.
06085 *
06086          ERR  = RZERO
06087          INFO = 0
06088          LDPC = DESCC( LLD_ )
06089          IOFFC = IC + ( JC + J - 2 ) * LDC
06090          CALL PB_INFOG2L( IC, JC+J-1, DESCC, NPROW, NPCOL, MYROW, MYCOL,
06091      $                    IIC, JJC, ICROW, ICCOL )
06092          ICURROW = ICROW
06093          ROWREP  = ( ICROW.EQ.-1 )
06094          COLREP  = ( ICCOL.EQ.-1 )
06095 *
06096          IF( MYCOL.EQ.ICCOL .OR. COLREP ) THEN
06097 *
06098             IBB = DESCC( IMB_ ) - IC + 1
06099             IF( IBB.LE.0 )
06100      $         IBB = ( ( -IBB ) / DESCC( MB_ ) + 1 )*DESCC( MB_ ) + IBB
06101             IBB = MIN( IBB, N )
06102             IN = IC + IBB - 1
06103 *
06104             DO 110 I = IC, IN
06105 *
06106                IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
06107                   ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
06108      $                        C( IOFFC ) ) / EPS
06109                   IF( G( I-IC+1 ).NE.RZERO )
06110      $               ERRI = ERRI / G( I-IC+1 )
06111                   ERR = MAX( ERR, ERRI )
06112                   IF( ERR*SQRT( EPS ).GE.RONE )
06113      $               INFO = 1
06114                   IIC = IIC + 1
06115                END IF
06116 *
06117                IOFFC = IOFFC + 1
06118 *
06119   110       CONTINUE
06120 *
06121             ICURROW = MOD( ICURROW+1, NPROW )
06122 *
06123             DO 130 I = IN+1, IC+N-1, DESCC( MB_ )
06124                IBB = MIN( IC+N-I, DESCC( MB_ ) )
06125 *
06126                DO 120 KK = 0, IBB-1
06127 *
06128                   IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
06129                      ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
06130      $                           C( IOFFC ) )/EPS
06131                      IF( G( I+KK-IC+1 ).NE.RZERO )
06132      $                  ERRI = ERRI / G( I+KK-IC+1 )
06133                      ERR = MAX( ERR, ERRI )
06134                      IF( ERR*SQRT( EPS ).GE.RONE )
06135      $                  INFO = 1
06136                      IIC = IIC + 1
06137                   END IF
06138 *
06139                   IOFFC = IOFFC + 1
06140 *
06141   120          CONTINUE
06142 *
06143                ICURROW = MOD( ICURROW+1, NPROW )
06144 *
06145   130       CONTINUE
06146 *
06147          END IF
06148 *
06149 *        If INFO = 0, all results are at least half accurate.
06150 *
06151          CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL )
06152          CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
06153      $                 MYCOL )
06154          IF( INFO.NE.0 )
06155      $      GO TO 150
06156 *
06157   140 CONTINUE
06158 *
06159   150 CONTINUE
06160 *
06161       RETURN
06162 *
06163 *     End of PZMMCH1
06164 *
06165       END
06166       SUBROUTINE PZMMCH2( ICTXT, UPLO, TRANS, N, K, ALPHA, A, IA, JA,
06167      $                    DESCA, B, IB, JB, DESCB, BETA, C, PC, IC,
06168      $                    JC, DESCC, CT, G, ERR, INFO )
06169 *
06170 *  -- PBLAS test routine (version 2.0) --
06171 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
06172 *     and University of California, Berkeley.
06173 *     April 1, 1998
06174 *
06175 *     .. Scalar Arguments ..
06176       CHARACTER*1        TRANS, UPLO
06177       INTEGER            IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, N
06178       DOUBLE PRECISION   ERR
06179       COMPLEX*16         ALPHA, BETA
06180 *     ..
06181 *     .. Array Arguments ..
06182       INTEGER            DESCA( * ), DESCB( * ), DESCC( * )
06183       DOUBLE PRECISION   G( * )
06184       COMPLEX*16         A( * ), B( * ), C( * ), CT( * ),
06185      $                   PC( * )
06186 *     ..
06187 *
06188 *  Purpose
06189 *  =======
06190 *
06191 *  PZMMCH2 checks the results of the computational tests.
06192 *
06193 *  Notes
06194 *  =====
06195 *
06196 *  A description  vector  is associated with each 2D block-cyclicly dis-
06197 *  tributed matrix.  This  vector  stores  the  information  required to
06198 *  establish the  mapping  between a  matrix entry and its corresponding
06199 *  process and memory location.
06200 *
06201 *  In  the  following  comments,   the character _  should  be  read  as
06202 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
06203 *  block cyclicly distributed matrix.  Its description vector is DESCA:
06204 *
06205 *  NOTATION         STORED IN       EXPLANATION
06206 *  ---------------- --------------- ------------------------------------
06207 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
06208 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
06209 *                                   the NPROW x NPCOL BLACS process grid
06210 *                                   A  is distributed over.  The context
06211 *                                   itself  is  global,  but  the handle
06212 *                                   (the integer value) may vary.
06213 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
06214 *                                   ted matrix A, M_A >= 0.
06215 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
06216 *                                   buted matrix A, N_A >= 0.
06217 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
06218 *                                   block of the matrix A, IMB_A > 0.
06219 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
06220 *                                   left   block   of   the   matrix  A,
06221 *                                   INB_A > 0.
06222 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
06223 *                                   bute the last  M_A-IMB_A rows of  A,
06224 *                                   MB_A > 0.
06225 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
06226 *                                   bute the last  N_A-INB_A  columns of
06227 *                                   A, NB_A > 0.
06228 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
06229 *                                   row of the matrix  A is distributed,
06230 *                                   NPROW > RSRC_A >= 0.
06231 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
06232 *                                   first  column of  A  is distributed.
06233 *                                   NPCOL > CSRC_A >= 0.
06234 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
06235 *                                   array  storing  the  local blocks of
06236 *                                   the distributed matrix A,
06237 *                                   IF( Lc( 1, N_A ) > 0 )
06238 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
06239 *                                   ELSE
06240 *                                      LLD_A >= 1.
06241 *
06242 *  Let K be the number of  rows of a matrix A starting at the global in-
06243 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
06244 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
06245 *  receive if these K rows were distributed over NPROW processes.  If  K
06246 *  is the number of columns of a matrix  A  starting at the global index
06247 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
06248 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
06249 *  these K columns were distributed over NPCOL processes.
06250 *
06251 *  The values of Lr() and Lc() may be determined via a call to the func-
06252 *  tion PB_NUMROC:
06253 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
06254 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
06255 *
06256 *  Arguments
06257 *  =========
06258 *
06259 *  ICTXT   (local input) INTEGER
06260 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
06261 *          ting the global  context of the operation. The context itself
06262 *          is global, but the value of ICTXT is local.
06263 *
06264 *  UPLO    (global input) CHARACTER*1
06265 *          On entry,  UPLO  specifies which part of C should contain the
06266 *          result.
06267 *
06268 *  TRANS   (global input) CHARACTER*1
06269 *          On entry,  TRANS  specifies whether the matrices A and B have
06270 *          to  be  transposed  or not before computing the matrix-matrix
06271 *          product.
06272 *
06273 *  N       (global input) INTEGER
06274 *          On entry, N  specifies  the order  the submatrix operand C. N
06275 *          must be at least zero.
06276 *
06277 *  K       (global input) INTEGER
06278 *          On entry, K specifies the number of columns (resp. rows) of A
06279 *          and B when  TRANS = 'N' (resp. TRANS <> 'N').  K  must  be at
06280 *          least zero.
06281 *
06282 *  ALPHA   (global input) COMPLEX*16
06283 *          On entry, ALPHA specifies the scalar alpha.
06284 *
06285 *  A       (local input) COMPLEX*16 array
06286 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
06287 *          array contains a local copy of the initial entire matrix PA.
06288 *
06289 *  IA      (global input) INTEGER
06290 *          On entry, IA  specifies A's global row index, which points to
06291 *          the beginning of the submatrix sub( A ).
06292 *
06293 *  JA      (global input) INTEGER
06294 *          On entry, JA  specifies A's global column index, which points
06295 *          to the beginning of the submatrix sub( A ).
06296 *
06297 *  DESCA   (global and local input) INTEGER array
06298 *          On entry, DESCA  is an integer array of dimension DLEN_. This
06299 *          is the array descriptor for the matrix A.
06300 *
06301 *  B       (local input) COMPLEX*16 array
06302 *          On entry, B is an array of  dimension  (DESCB( M_ ),*).  This
06303 *          array contains a local copy of the initial entire matrix PB.
06304 *
06305 *  IB      (global input) INTEGER
06306 *          On entry, IB  specifies B's global row index, which points to
06307 *          the beginning of the submatrix sub( B ).
06308 *
06309 *  JB      (global input) INTEGER
06310 *          On entry, JB  specifies B's global column index, which points
06311 *          to the beginning of the submatrix sub( B ).
06312 *
06313 *  DESCB   (global and local input) INTEGER array
06314 *          On entry, DESCB  is an integer array of dimension DLEN_. This
06315 *          is the array descriptor for the matrix B.
06316 *
06317 *  BETA    (global input) COMPLEX*16
06318 *          On entry, BETA specifies the scalar beta.
06319 *
06320 *  C       (local input/local output) COMPLEX*16 array
06321 *          On entry, C is an array of  dimension  (DESCC( M_ ),*).  This
06322 *          array contains a local copy of the initial entire matrix PC.
06323 *
06324 *  PC      (local input) COMPLEX*16 array
06325 *          On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
06326 *          array contains the local pieces of the matrix PC.
06327 *
06328 *  IC      (global input) INTEGER
06329 *          On entry, IC  specifies C's global row index, which points to
06330 *          the beginning of the submatrix sub( C ).
06331 *
06332 *  JC      (global input) INTEGER
06333 *          On entry, JC  specifies C's global column index, which points
06334 *          to the beginning of the submatrix sub( C ).
06335 *
06336 *  DESCC   (global and local input) INTEGER array
06337 *          On entry, DESCC  is an integer array of dimension DLEN_. This
06338 *          is the array descriptor for the matrix C.
06339 *
06340 *  CT      (workspace) COMPLEX*16 array
06341 *          On entry, CT is an array of dimension at least MAX(M,N,K). CT
06342 *          holds a copy of the current column of C.
06343 *
06344 *  G       (workspace) DOUBLE PRECISION array
06345 *          On entry, G  is  an array of dimension at least MAX(M,N,K). G
06346 *          is used to compute the gauges.
06347 *
06348 *  ERR     (global output) DOUBLE PRECISION
06349 *          On exit, ERR specifies the largest error in absolute value.
06350 *
06351 *  INFO    (global output) INTEGER
06352 *          On exit, if INFO <> 0, the result is less than half accurate.
06353 *
06354 *  -- Written on April 1, 1998 by
06355 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
06356 *
06357 *  =====================================================================
06358 *
06359 *     .. Parameters ..
06360       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
06361      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
06362      $                   RSRC_
06363       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
06364      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
06365      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
06366      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
06367       DOUBLE PRECISION   RZERO, RONE
06368       PARAMETER          ( RZERO = 0.0D+0, RONE = 1.0D+0 )
06369       COMPLEX*16         ZERO
06370       PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
06371 *     ..
06372 *     .. Local Scalars ..
06373       LOGICAL            COLREP, HTRAN, NOTRAN, ROWREP, TRAN, UPPER
06374       INTEGER            I, IBB, IBEG, ICCOL, ICROW, ICURROW, IEND, IIC,
06375      $                   IN, IOFFAK, IOFFAN, IOFFBK, IOFFBN, IOFFC, J,
06376      $                   JJC, KK, LDA, LDB, LDC, LDPC, MYCOL, MYROW,
06377      $                   NPCOL, NPROW
06378       DOUBLE PRECISION   EPS, ERRI
06379       COMPLEX*16         Z
06380 *     ..
06381 *     .. External Subroutines ..
06382       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L
06383 *     ..
06384 *     .. External Functions ..
06385       LOGICAL            LSAME
06386       DOUBLE PRECISION   PDLAMCH
06387       EXTERNAL           LSAME, PDLAMCH
06388 *     ..
06389 *     .. Intrinsic Functions ..
06390       INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD, SQRT
06391 *     ..
06392 *     .. Statement Functions ..
06393       DOUBLE PRECISION   ABS1
06394       ABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
06395 *     ..
06396 *     .. Executable Statements ..
06397 *
06398       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
06399 *
06400       EPS = PDLAMCH( ICTXT, 'eps' )
06401 *
06402       UPPER = LSAME( UPLO, 'U' )
06403       HTRAN = LSAME( TRANS, 'H' )
06404       NOTRAN = LSAME( TRANS, 'N' )
06405       TRAN = LSAME( TRANS, 'T' )
06406 *
06407       LDA = MAX( 1, DESCA( M_ ) )
06408       LDB = MAX( 1, DESCB( M_ ) )
06409       LDC = MAX( 1, DESCC( M_ ) )
06410 *
06411 *     Compute expected result in C using data in A, B and C.
06412 *     Compute gauges in G. This part of the computation is performed
06413 *     by every process in the grid.
06414 *
06415       DO 140 J = 1, N
06416 *
06417          IF( UPPER ) THEN
06418             IBEG = 1
06419             IEND = J
06420          ELSE
06421             IBEG = J
06422             IEND = N
06423          END IF
06424 *
06425          DO 10 I = 1, N
06426             CT( I ) = ZERO
06427             G( I )  = RZERO
06428    10    CONTINUE
06429 *
06430          IF( NOTRAN ) THEN
06431             DO 30 KK = 1, K
06432                IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA
06433                IOFFBK = IB + J - 1 + ( JB + KK - 2 ) * LDB
06434                DO 20 I = IBEG, IEND
06435                   IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA
06436                   IOFFBN = IB + I - 1 + ( JB + KK - 2 ) * LDB
06437                   CT( I ) = CT( I ) + ALPHA * (
06438      $                      A( IOFFAN ) * B( IOFFBK ) +
06439      $                      B( IOFFBN ) * A( IOFFAK ) )
06440                   G( I ) = G( I ) + ABS( ALPHA ) * (
06441      $                     ABS1( A( IOFFAN ) ) * ABS1( B( IOFFBK ) ) +
06442      $                     ABS1( B( IOFFBN ) ) * ABS1( A( IOFFAK ) ) )
06443    20          CONTINUE
06444    30       CONTINUE
06445          ELSE IF( TRAN ) THEN
06446             DO 50 KK = 1, K
06447                IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA
06448                IOFFBK = IB + KK - 1 + ( JB + J - 2 ) * LDB
06449                DO 40 I = IBEG, IEND
06450                   IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA
06451                   IOFFBN = IB + KK - 1 + ( JB + I - 2 ) * LDB
06452                   CT( I ) = CT( I ) + ALPHA * (
06453      $                      A( IOFFAN ) * B( IOFFBK ) +
06454      $                      B( IOFFBN ) * A( IOFFAK ) )
06455                   G( I ) = G( I ) + ABS( ALPHA ) * (
06456      $                     ABS1( A( IOFFAN ) ) * ABS1( B( IOFFBK ) ) +
06457      $                     ABS1( B( IOFFBN ) ) * ABS1( A( IOFFAK ) ) )
06458    40          CONTINUE
06459    50       CONTINUE
06460          ELSE IF( HTRAN ) THEN
06461             DO 70 KK = 1, K
06462                IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA
06463                IOFFBK = IB + J - 1 + ( JB + KK - 2 ) * LDB
06464                DO 60 I = IBEG, IEND
06465                   IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA
06466                   IOFFBN = IB + I - 1 + ( JB + KK - 2 ) * LDB
06467                   CT( I ) = CT( I ) +
06468      $                ALPHA * A( IOFFAN ) * DCONJG( B( IOFFBK ) ) +
06469      $                B( IOFFBN ) * DCONJG( ALPHA * A( IOFFAK ) )
06470                   G( I ) = G( I ) + ABS1( ALPHA ) * (
06471      $                     ABS1( A( IOFFAN ) ) * ABS1( B( IOFFBK ) ) +
06472      $                     ABS1( B( IOFFBN ) ) * ABS1( A( IOFFAK ) ) )
06473    60          CONTINUE
06474    70       CONTINUE
06475          ELSE
06476             DO 90 KK = 1, K
06477                IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA
06478                IOFFBK = IB + KK - 1 + ( JB + J - 2 ) * LDB
06479                DO 80 I = IBEG, IEND
06480                   IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA
06481                   IOFFBN = IB + KK - 1 + ( JB + I - 2 ) * LDB
06482                   CT( I ) = CT( I ) +
06483      $                   ALPHA * DCONJG( A( IOFFAN ) ) * B( IOFFBK ) +
06484      $                   DCONJG( ALPHA * B( IOFFBN ) ) * A( IOFFAK )
06485                   G( I ) = G( I ) + ABS1( ALPHA ) * (
06486      $                   ABS1( DCONJG( A( IOFFAN ) ) * B( IOFFBK ) ) +
06487      $                   ABS1( DCONJG( B( IOFFBN ) ) * A( IOFFAK ) ) )
06488    80          CONTINUE
06489    90       CONTINUE
06490          END IF
06491 *
06492          IOFFC = IC + IBEG - 1 + ( JC + J - 2 ) * LDC
06493 *
06494          DO 100 I = IBEG, IEND
06495             CT( I ) = CT( I ) + BETA * C( IOFFC )
06496             G( I ) = G( I ) + ABS1( BETA )*ABS1( C( IOFFC ) )
06497             C( IOFFC ) = CT( I )
06498             IOFFC = IOFFC + 1
06499   100    CONTINUE
06500 *
06501 *        Compute the error ratio for this result.
06502 *
06503          ERR  = RZERO
06504          INFO = 0
06505          LDPC = DESCC( LLD_ )
06506          IOFFC = IC + ( JC + J - 2 ) * LDC
06507          CALL PB_INFOG2L( IC, JC+J-1, DESCC, NPROW, NPCOL, MYROW, MYCOL,
06508      $                    IIC, JJC, ICROW, ICCOL )
06509          ICURROW = ICROW
06510          ROWREP  = ( ICROW.EQ.-1 )
06511          COLREP  = ( ICCOL.EQ.-1 )
06512 *
06513          IF( MYCOL.EQ.ICCOL .OR. COLREP ) THEN
06514 *
06515             IBB = DESCC( IMB_ ) - IC + 1
06516             IF( IBB.LE.0 )
06517      $         IBB = ( ( -IBB ) / DESCC( MB_ ) + 1 )*DESCC( MB_ ) + IBB
06518             IBB = MIN( IBB, N )
06519             IN = IC + IBB - 1
06520 *
06521             DO 110 I = IC, IN
06522 *
06523                IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
06524                   ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
06525      $                        C( IOFFC ) ) / EPS
06526                   IF( G( I-IC+1 ).NE.RZERO )
06527      $               ERRI = ERRI / G( I-IC+1 )
06528                   ERR = MAX( ERR, ERRI )
06529                   IF( ERR*SQRT( EPS ).GE.RONE )
06530      $               INFO = 1
06531                   IIC = IIC + 1
06532                END IF
06533 *
06534                IOFFC = IOFFC + 1
06535 *
06536   110       CONTINUE
06537 *
06538             ICURROW = MOD( ICURROW+1, NPROW )
06539 *
06540             DO 130 I = IN+1, IC+N-1, DESCC( MB_ )
06541                IBB = MIN( IC+N-I, DESCC( MB_ ) )
06542 *
06543                DO 120 KK = 0, IBB-1
06544 *
06545                   IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
06546                      ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
06547      $                           C( IOFFC ) )/EPS
06548                      IF( G( I+KK-IC+1 ).NE.RZERO )
06549      $                  ERRI = ERRI / G( I+KK-IC+1 )
06550                      ERR = MAX( ERR, ERRI )
06551                      IF( ERR*SQRT( EPS ).GE.RONE )
06552      $                  INFO = 1
06553                      IIC = IIC + 1
06554                   END IF
06555 *
06556                   IOFFC = IOFFC + 1
06557 *
06558   120          CONTINUE
06559 *
06560                ICURROW = MOD( ICURROW+1, NPROW )
06561 *
06562   130       CONTINUE
06563 *
06564          END IF
06565 *
06566 *        If INFO = 0, all results are at least half accurate.
06567 *
06568          CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL )
06569          CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
06570      $                 MYCOL )
06571          IF( INFO.NE.0 )
06572      $      GO TO 150
06573 *
06574   140 CONTINUE
06575 *
06576   150 CONTINUE
06577 *
06578       RETURN
06579 *
06580 *     End of PZMMCH2
06581 *
06582       END
06583       SUBROUTINE PZMMCH3( UPLO, TRANS, M, N, ALPHA, A, IA, JA, DESCA,
06584      $                    BETA, C, PC, IC, JC, DESCC, ERR, INFO )
06585 *
06586 *  -- PBLAS test routine (version 2.0) --
06587 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
06588 *     and University of California, Berkeley.
06589 *     April 1, 1998
06590 *
06591 *     .. Scalar Arguments ..
06592       CHARACTER*1        TRANS, UPLO
06593       INTEGER            IA, IC, INFO, JA, JC, M, N
06594       DOUBLE PRECISION   ERR
06595       COMPLEX*16         ALPHA, BETA
06596 *     ..
06597 *     .. Array Arguments ..
06598       INTEGER            DESCA( * ), DESCC( * )
06599       COMPLEX*16         A( * ), C( * ), PC( * )
06600 *     ..
06601 *
06602 *  Purpose
06603 *  =======
06604 *
06605 *  PZMMCH3 checks the results of the computational tests.
06606 *
06607 *  Notes
06608 *  =====
06609 *
06610 *  A description  vector  is associated with each 2D block-cyclicly dis-
06611 *  tributed matrix.  This  vector  stores  the  information  required to
06612 *  establish the  mapping  between a  matrix entry and its corresponding
06613 *  process and memory location.
06614 *
06615 *  In  the  following  comments,   the character _  should  be  read  as
06616 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
06617 *  block cyclicly distributed matrix.  Its description vector is DESCA:
06618 *
06619 *  NOTATION         STORED IN       EXPLANATION
06620 *  ---------------- --------------- ------------------------------------
06621 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
06622 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
06623 *                                   the NPROW x NPCOL BLACS process grid
06624 *                                   A  is distributed over.  The context
06625 *                                   itself  is  global,  but  the handle
06626 *                                   (the integer value) may vary.
06627 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
06628 *                                   ted matrix A, M_A >= 0.
06629 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
06630 *                                   buted matrix A, N_A >= 0.
06631 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
06632 *                                   block of the matrix A, IMB_A > 0.
06633 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
06634 *                                   left   block   of   the   matrix  A,
06635 *                                   INB_A > 0.
06636 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
06637 *                                   bute the last  M_A-IMB_A rows of  A,
06638 *                                   MB_A > 0.
06639 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
06640 *                                   bute the last  N_A-INB_A  columns of
06641 *                                   A, NB_A > 0.
06642 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
06643 *                                   row of the matrix  A is distributed,
06644 *                                   NPROW > RSRC_A >= 0.
06645 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
06646 *                                   first  column of  A  is distributed.
06647 *                                   NPCOL > CSRC_A >= 0.
06648 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
06649 *                                   array  storing  the  local blocks of
06650 *                                   the distributed matrix A,
06651 *                                   IF( Lc( 1, N_A ) > 0 )
06652 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
06653 *                                   ELSE
06654 *                                      LLD_A >= 1.
06655 *
06656 *  Let K be the number of  rows of a matrix A starting at the global in-
06657 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
06658 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
06659 *  receive if these K rows were distributed over NPROW processes.  If  K
06660 *  is the number of columns of a matrix  A  starting at the global index
06661 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
06662 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
06663 *  these K columns were distributed over NPCOL processes.
06664 *
06665 *  The values of Lr() and Lc() may be determined via a call to the func-
06666 *  tion PB_NUMROC:
06667 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
06668 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
06669 *
06670 *  Arguments
06671 *  =========
06672 *
06673 *  UPLO    (global input) CHARACTER*1
06674 *          On entry,  UPLO  specifies which part of C should contain the
06675 *          result.
06676 *
06677 *  TRANS   (global input) CHARACTER*1
06678 *          On entry,  TRANS  specifies  whether  the  matrix A has to be
06679 *          transposed  or not  before computing the  matrix-matrix addi-
06680 *          tion.
06681 *
06682 *  M       (global input) INTEGER
06683 *          On entry, M specifies the number of rows of C.
06684 *
06685 *  N       (global input) INTEGER
06686 *          On entry, N specifies the number of columns of C.
06687 *
06688 *  ALPHA   (global input) COMPLEX*16
06689 *          On entry, ALPHA specifies the scalar alpha.
06690 *
06691 *  A       (local input) COMPLEX*16 array
06692 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
06693 *          array contains a local copy of the initial entire matrix PA.
06694 *
06695 *  IA      (global input) INTEGER
06696 *          On entry, IA  specifies A's global row index, which points to
06697 *          the beginning of the submatrix sub( A ).
06698 *
06699 *  JA      (global input) INTEGER
06700 *          On entry, JA  specifies A's global column index, which points
06701 *          to the beginning of the submatrix sub( A ).
06702 *
06703 *  DESCA   (global and local input) INTEGER array
06704 *          On entry, DESCA  is an integer array of dimension DLEN_. This
06705 *          is the array descriptor for the matrix A.
06706 *
06707 *  BETA    (global input) COMPLEX*16
06708 *          On entry, BETA specifies the scalar beta.
06709 *
06710 *  C       (local input/local output) COMPLEX*16 array
06711 *          On entry, C is an array of  dimension  (DESCC( M_ ),*).  This
06712 *          array contains a local copy of the initial entire matrix PC.
06713 *
06714 *  PC      (local input) COMPLEX*16 array
06715 *          On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
06716 *          array contains the local pieces of the matrix PC.
06717 *
06718 *  IC      (global input) INTEGER
06719 *          On entry, IC  specifies C's global row index, which points to
06720 *          the beginning of the submatrix sub( C ).
06721 *
06722 *  JC      (global input) INTEGER
06723 *          On entry, JC  specifies C's global column index, which points
06724 *          to the beginning of the submatrix sub( C ).
06725 *
06726 *  DESCC   (global and local input) INTEGER array
06727 *          On entry, DESCC  is an integer array of dimension DLEN_. This
06728 *          is the array descriptor for the matrix C.
06729 *
06730 *  ERR     (global output) DOUBLE PRECISION
06731 *          On exit, ERR specifies the largest error in absolute value.
06732 *
06733 *  INFO    (global output) INTEGER
06734 *          On exit, if INFO <> 0, the result is less than half accurate.
06735 *
06736 *  -- Written on April 1, 1998 by
06737 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
06738 *
06739 *  =====================================================================
06740 *
06741 *     .. Parameters ..
06742       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
06743      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
06744      $                   RSRC_
06745       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
06746      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
06747      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
06748      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
06749       DOUBLE PRECISION   ZERO
06750       PARAMETER          ( ZERO = 0.0D+0 )
06751 *     ..
06752 *     .. Local Scalars ..
06753       LOGICAL            COLREP, CTRAN, LOWER, NOTRAN, ROWREP, UPPER
06754       INTEGER            I, ICCOL, ICROW, ICTXT, IIC, IOFFA, IOFFC, J,
06755      $                   JJC, LDA, LDC, LDPC, MYCOL, MYROW, NPCOL,
06756      $                   NPROW
06757       DOUBLE PRECISION   ERR0, ERRI, PREC
06758 *     ..
06759 *     .. External Subroutines ..
06760       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L,
06761      $                   PZERRAXPBY
06762 *     ..
06763 *     .. External Functions ..
06764       LOGICAL            LSAME
06765       DOUBLE PRECISION   PDLAMCH
06766       EXTERNAL           LSAME, PDLAMCH
06767 *     ..
06768 *     .. Intrinsic Functions ..
06769       INTRINSIC          ABS, DCONJG, MAX
06770 *     ..
06771 *     .. Executable Statements ..
06772 *
06773       ICTXT = DESCC( CTXT_ )
06774       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
06775 *
06776       PREC   = PDLAMCH( ICTXT, 'eps' )
06777 *
06778       UPPER  = LSAME( UPLO,  'U' )
06779       LOWER  = LSAME( UPLO,  'L' )
06780       NOTRAN = LSAME( TRANS, 'N' )
06781       CTRAN  = LSAME( TRANS, 'C' )
06782 *
06783 *     Compute expected result in C using data in A and C. This part of
06784 *     the computation is performed by every process in the grid.
06785 *
06786       INFO   = 0
06787       ERR    = ZERO
06788 *
06789       LDA    = MAX( 1, DESCA( M_   ) )
06790       LDC    = MAX( 1, DESCC( M_   ) )
06791       LDPC   = MAX( 1, DESCC( LLD_ ) )
06792       ROWREP = ( DESCC( RSRC_ ).EQ.-1 )
06793       COLREP = ( DESCC( CSRC_ ).EQ.-1 )
06794 *
06795       IF( NOTRAN ) THEN
06796 *
06797          DO 20 J = JC, JC + N - 1
06798 *
06799             IOFFC = IC + ( J  - 1          ) * LDC
06800             IOFFA = IA + ( JA - 1 + J - JC ) * LDA
06801 *
06802             DO 10 I = IC, IC + M - 1
06803 *
06804                IF( UPPER ) THEN
06805                   IF( ( J - JC ).GE.( I - IC ) ) THEN
06806                      CALL PZERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06807      $                                C( IOFFC ), PREC )
06808                   ELSE
06809                      ERRI = ZERO
06810                   END IF
06811                ELSE IF( LOWER ) THEN
06812                   IF( ( J - JC ).LE.( I - IC ) ) THEN
06813                      CALL PZERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06814      $                                C( IOFFC ), PREC )
06815                   ELSE
06816                      ERRI = ZERO
06817                   END IF
06818                ELSE
06819                   CALL PZERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06820      $                             C( IOFFC ), PREC )
06821                END IF
06822 *
06823                CALL PB_INFOG2L( I, J, DESCC, NPROW, NPCOL, MYROW, MYCOL,
06824      $                          IIC, JJC, ICROW, ICCOL )
06825                IF( ( MYROW.EQ.ICROW .OR. ROWREP ) .AND.
06826      $             ( MYCOL.EQ.ICCOL .OR. COLREP ) ) THEN
06827                   ERR0 = ABS( PC( IIC+(JJC-1)*LDPC )-C( IOFFC ) )
06828                   IF( ERR0.GT.ERRI )
06829      $               INFO = 1
06830                   ERR = MAX( ERR, ERR0 )
06831                END IF
06832 *
06833                IOFFA = IOFFA + 1
06834                IOFFC = IOFFC + 1
06835 *
06836    10       CONTINUE
06837 *
06838    20    CONTINUE
06839 *
06840       ELSE IF( CTRAN ) THEN
06841 *
06842          DO 40 J = JC, JC + N - 1
06843 *
06844             IOFFC = IC +              ( J  - 1 ) * LDC
06845             IOFFA = IA + ( J - JC ) + ( JA - 1 ) * LDA
06846 *
06847             DO 30 I = IC, IC + M - 1
06848 *
06849                IF( UPPER ) THEN
06850                   IF( ( J - JC ).GE.( I - IC ) ) THEN
06851                      CALL PZERRAXPBY( ERRI, ALPHA, DCONJG( A( IOFFA ) ),
06852      $                                BETA, C( IOFFC ), PREC )
06853                   ELSE
06854                      ERRI = ZERO
06855                   END IF
06856                ELSE IF( LOWER ) THEN
06857                   IF( ( J - JC ).LE.( I - IC ) ) THEN
06858                      CALL PZERRAXPBY( ERRI, ALPHA, DCONJG( A( IOFFA ) ),
06859      $                                BETA, C( IOFFC ), PREC )
06860                   ELSE
06861                      ERRI = ZERO
06862                   END IF
06863                ELSE
06864                   CALL PZERRAXPBY( ERRI, ALPHA, DCONJG( A( IOFFA ) ),
06865      $                             BETA, C( IOFFC ), PREC )
06866                END IF
06867 *
06868                CALL PB_INFOG2L( I, J, DESCC, NPROW, NPCOL, MYROW, MYCOL,
06869      $                          IIC, JJC, ICROW, ICCOL )
06870                IF( ( MYROW.EQ.ICROW .OR. ROWREP ) .AND.
06871      $             ( MYCOL.EQ.ICCOL .OR. COLREP ) ) THEN
06872                   ERR0 = ABS( PC( IIC+(JJC-1)*LDPC )-C( IOFFC ) )
06873                   IF( ERR0.GT.ERRI )
06874      $               INFO = 1
06875                   ERR = MAX( ERR, ERR0 )
06876                END IF
06877 *
06878                IOFFC = IOFFC + 1
06879                IOFFA = IOFFA + LDA
06880 *
06881    30       CONTINUE
06882 *
06883    40    CONTINUE
06884 *
06885       ELSE
06886 *
06887          DO 60 J = JC, JC + N - 1
06888 *
06889             IOFFC = IC +              ( J  - 1 ) * LDC
06890             IOFFA = IA + ( J - JC ) + ( JA - 1 ) * LDA
06891 *
06892             DO 50 I = IC, IC + M - 1
06893 *
06894                IF( UPPER ) THEN
06895                   IF( ( J - JC ).GE.( I - IC ) ) THEN
06896                      CALL PZERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06897      $                                C( IOFFC ), PREC )
06898                   ELSE
06899                      ERRI = ZERO
06900                   END IF
06901                ELSE IF( LOWER ) THEN
06902                   IF( ( J - JC ).LE.( I - IC ) ) THEN
06903                      CALL PZERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06904      $                                C( IOFFC ), PREC )
06905                   ELSE
06906                      ERRI = ZERO
06907                   END IF
06908                ELSE
06909                   CALL PZERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06910      $                             C( IOFFC ), PREC )
06911                END IF
06912 *
06913                CALL PB_INFOG2L( I, J, DESCC, NPROW, NPCOL, MYROW, MYCOL,
06914      $                          IIC, JJC, ICROW, ICCOL )
06915                IF( ( MYROW.EQ.ICROW .OR. ROWREP ) .AND.
06916      $             ( MYCOL.EQ.ICCOL .OR. COLREP ) ) THEN
06917                   ERR0 = ABS( PC( IIC+(JJC-1)*LDPC )-C( IOFFC ) )
06918                   IF( ERR0.GT.ERRI )
06919      $               INFO = 1
06920                   ERR = MAX( ERR, ERR0 )
06921                END IF
06922 *
06923                IOFFC = IOFFC + 1
06924                IOFFA = IOFFA + LDA
06925 *
06926    50       CONTINUE
06927 *
06928    60    CONTINUE
06929 *
06930       END IF
06931 *
06932 *     If INFO = 0, all results are at least half accurate.
06933 *
06934       CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL )
06935       CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
06936      $              MYCOL )
06937 *
06938       RETURN
06939 *
06940 *     End of PZMMCH3
06941 *
06942       END
06943       SUBROUTINE PZERRAXPBY( ERRBND, ALPHA, X, BETA, Y, PREC )
06944 *
06945 *  -- PBLAS test routine (version 2.0) --
06946 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
06947 *     and University of California, Berkeley.
06948 *     April 1, 1998
06949 *
06950 *     .. Scalar Arguments ..
06951       DOUBLE PRECISION   ERRBND, PREC
06952       COMPLEX*16         ALPHA, BETA, X, Y
06953 *     ..
06954 *
06955 *  Purpose
06956 *  =======
06957 *
06958 *  PZERRAXPBY  serially  computes  y := beta*y + alpha * x and returns a
06959 *  scaled relative acceptable error bound on the result.
06960 *
06961 *  Arguments
06962 *  =========
06963 *
06964 *  ERRBND  (global output) DOUBLE PRECISION
06965 *          On exit, ERRBND  specifies the scaled relative acceptable er-
06966 *          ror bound.
06967 *
06968 *  ALPHA   (global input) COMPLEX*16
06969 *          On entry, ALPHA specifies the scalar alpha.
06970 *
06971 *  X       (global input) COMPLEX*16
06972 *          On entry, X  specifies the scalar x to be scaled.
06973 *
06974 *  BETA    (global input) COMPLEX*16
06975 *          On entry, BETA specifies the scalar beta.
06976 *
06977 *  Y       (global input/global output) COMPLEX*16
06978 *          On entry,  Y  specifies  the scalar y to be added. On exit, Y
06979 *          contains the resulting scalar y.
06980 *
06981 *  PREC    (global input) DOUBLE PRECISION
06982 *          On entry, PREC specifies the machine precision.
06983 *
06984 *  -- Written on April 1, 1998 by
06985 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
06986 *
06987 *  =====================================================================
06988 *
06989 *     .. Parameters ..
06990       DOUBLE PRECISION   ONE, TWO, ZERO
06991       PARAMETER          ( ONE = 1.0D+0, TWO = 2.0D+0,
06992      $                   ZERO = 0.0D+0 )
06993 *     ..
06994 *     .. Local Scalars ..
06995       DOUBLE PRECISION   ADDBND, FACT, SUMINEG, SUMIPOS, SUMRNEG,
06996      $                   SUMRPOS
06997       COMPLEX*16         TMP
06998 *     ..
06999 *     .. Intrinsic Functions ..
07000 *     ..
07001 *     .. Executable Statements ..
07002 *
07003       SUMIPOS = ZERO
07004       SUMINEG = ZERO
07005       SUMRPOS = ZERO
07006       SUMRNEG = ZERO
07007       FACT = ONE + TWO * PREC
07008       ADDBND = TWO * TWO * TWO * PREC
07009 *
07010       TMP = ALPHA * X
07011       IF( DBLE( TMP ).GE.ZERO ) THEN
07012          SUMRPOS = SUMRPOS + DBLE( TMP ) * FACT
07013       ELSE
07014          SUMRNEG = SUMRNEG - DBLE( TMP ) * FACT
07015       END IF
07016       IF( DIMAG( TMP ).GE.ZERO ) THEN
07017          SUMIPOS = SUMIPOS + DIMAG( TMP ) * FACT
07018       ELSE
07019          SUMINEG = SUMINEG - DIMAG( TMP ) * FACT
07020       END IF
07021 *
07022       TMP = BETA * Y
07023       IF( DBLE( TMP ).GE.ZERO ) THEN
07024          SUMRPOS = SUMRPOS + DBLE( TMP ) * FACT
07025       ELSE
07026          SUMRNEG = SUMRNEG - DBLE( TMP ) * FACT
07027       END IF
07028       IF( DIMAG( TMP ).GE.ZERO ) THEN
07029          SUMIPOS = SUMIPOS + DIMAG( TMP ) * FACT
07030       ELSE
07031          SUMINEG = SUMINEG - DIMAG( TMP ) * FACT
07032       END IF
07033 *
07034       Y = ( BETA * Y ) + ( ALPHA * X )
07035 *
07036       ERRBND = ADDBND * MAX( MAX( SUMRPOS, SUMRNEG ),
07037      $                       MAX( SUMIPOS, SUMINEG ) )
07038 *
07039       RETURN
07040 *
07041 *     End of PZERRAXPBY
07042 *
07043       END
07044       SUBROUTINE PZIPSET( TOGGLE, N, A, IA, JA, DESCA )
07045 *
07046 *  -- PBLAS test routine (version 2.0) --
07047 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
07048 *     and University of California, Berkeley.
07049 *     April 1, 1998
07050 *
07051 *     .. Scalar Arguments ..
07052       CHARACTER*1        TOGGLE
07053       INTEGER            IA, JA, N
07054 *     ..
07055 *     .. Array Arguments ..
07056       INTEGER            DESCA( * )
07057       COMPLEX*16         A( * )
07058 *     ..
07059 *
07060 *  Purpose
07061 *  =======
07062 *
07063 *  PZIPSET  sets the imaginary part of the diagonal entries of an n by n
07064 *  matrix sub( A )  denoting  A( IA:IA+N-1, JA:JA+N-1 ). This is used to
07065 *  test the  PBLAS routines  for  complex Hermitian  matrices, which are
07066 *  either  not supposed to access or use the imaginary parts of the dia-
07067 *  gonals, or supposed to set  them to zero. The  value  used to set the
07068 *  imaginary part of the diagonals depends on the value of TOGGLE.
07069 *
07070 *  Notes
07071 *  =====
07072 *
07073 *  A description  vector  is associated with each 2D block-cyclicly dis-
07074 *  tributed matrix.  This  vector  stores  the  information  required to
07075 *  establish the  mapping  between a  matrix entry and its corresponding
07076 *  process and memory location.
07077 *
07078 *  In  the  following  comments,   the character _  should  be  read  as
07079 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
07080 *  block cyclicly distributed matrix.  Its description vector is DESCA:
07081 *
07082 *  NOTATION         STORED IN       EXPLANATION
07083 *  ---------------- --------------- ------------------------------------
07084 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
07085 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
07086 *                                   the NPROW x NPCOL BLACS process grid
07087 *                                   A  is distributed over.  The context
07088 *                                   itself  is  global,  but  the handle
07089 *                                   (the integer value) may vary.
07090 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
07091 *                                   ted matrix A, M_A >= 0.
07092 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
07093 *                                   buted matrix A, N_A >= 0.
07094 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
07095 *                                   block of the matrix A, IMB_A > 0.
07096 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
07097 *                                   left   block   of   the   matrix  A,
07098 *                                   INB_A > 0.
07099 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
07100 *                                   bute the last  M_A-IMB_A rows of  A,
07101 *                                   MB_A > 0.
07102 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
07103 *                                   bute the last  N_A-INB_A  columns of
07104 *                                   A, NB_A > 0.
07105 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
07106 *                                   row of the matrix  A is distributed,
07107 *                                   NPROW > RSRC_A >= 0.
07108 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
07109 *                                   first  column of  A  is distributed.
07110 *                                   NPCOL > CSRC_A >= 0.
07111 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
07112 *                                   array  storing  the  local blocks of
07113 *                                   the distributed matrix A,
07114 *                                   IF( Lc( 1, N_A ) > 0 )
07115 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
07116 *                                   ELSE
07117 *                                      LLD_A >= 1.
07118 *
07119 *  Let K be the number of  rows of a matrix A starting at the global in-
07120 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
07121 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
07122 *  receive if these K rows were distributed over NPROW processes.  If  K
07123 *  is the number of columns of a matrix  A  starting at the global index
07124 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
07125 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
07126 *  these K columns were distributed over NPCOL processes.
07127 *
07128 *  The values of Lr() and Lc() may be determined via a call to the func-
07129 *  tion PB_NUMROC:
07130 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
07131 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
07132 *
07133 *  Arguments
07134 *  =========
07135 *
07136 *  TOGGLE  (global input) CHARACTER*1
07137 *          On entry,  TOGGLE  specifies the set-value to be used as fol-
07138 *          lows:
07139 *             If TOGGLE = 'Z' or 'z', the  imaginary  part of the diago-
07140 *                                     nals are set to zero,
07141 *             If TOGGLE = 'B' or 'b', the  imaginary  part of the diago-
07142 *                                     nals are set to a large value.
07143 *
07144 *  N       (global input) INTEGER
07145 *          On entry,  N  specifies  the  order of sub( A ). N must be at
07146 *          least zero.
07147 *
07148 *  A       (local input/local output) pointer to COMPLEX*16
07149 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
07150 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
07151 *          the local entries of the matrix  A. On exit, the diagonals of
07152 *          sub( A ) have been updated as specified by TOGGLE.
07153 *
07154 *  IA      (global input) INTEGER
07155 *          On entry, IA  specifies A's global row index, which points to
07156 *          the beginning of the submatrix sub( A ).
07157 *
07158 *  JA      (global input) INTEGER
07159 *          On entry, JA  specifies A's global column index, which points
07160 *          to the beginning of the submatrix sub( A ).
07161 *
07162 *  DESCA   (global and local input) INTEGER array
07163 *          On entry, DESCA  is an integer array of dimension DLEN_. This
07164 *          is the array descriptor for the matrix A.
07165 *
07166 *  -- Written on April 1, 1998 by
07167 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
07168 *
07169 *  =====================================================================
07170 *
07171 *     .. Parameters ..
07172       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
07173      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
07174      $                   RSRC_
07175       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
07176      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
07177      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
07178      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
07179       DOUBLE PRECISION   ZERO
07180       PARAMETER          ( ZERO = 0.0D+0 )
07181 *     ..
07182 *     .. Local Scalars ..
07183       LOGICAL            COLREP, GODOWN, GOLEFT, ROWREP
07184       INTEGER            I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW,
07185      $                   IMB1, IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP,
07186      $                   JJA, JOFFA, JOFFD, LCMT, LCMT00, LDA, LDAP1,
07187      $                   LMBLOC, LNBLOC, LOW, MB, MBLKD, MBLKS, MBLOC,
07188      $                   MRCOL, MRROW, MYCOL, MYROW, NB, NBLKD, NBLKS,
07189      $                   NBLOC, NP, NPCOL, NPROW, NQ, PMB, QNB, UPP
07190       DOUBLE PRECISION   ALPHA, ATMP
07191 *     ..
07192 *     .. Local Arrays ..
07193       INTEGER            DESCA2( DLEN_ )
07194 *     ..
07195 *     .. External Subroutines ..
07196       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
07197      $                   PB_DESCTRANS
07198 *     ..
07199 *     .. External Functions ..
07200       LOGICAL            LSAME
07201       DOUBLE PRECISION   PDLAMCH
07202       EXTERNAL           LSAME, PDLAMCH
07203 *     ..
07204 *     .. Intrinsic Functions ..
07205       INTRINSIC          DBLE, DCMPLX, MAX, MIN
07206 *     ..
07207 *     .. Executable Statements ..
07208 *
07209 *     Convert descriptor
07210 *
07211       CALL PB_DESCTRANS( DESCA, DESCA2 )
07212 *
07213 *     Get grid parameters
07214 *
07215       ICTXT = DESCA2( CTXT_ )
07216       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
07217 *
07218       IF( N.LE.0 )
07219      $   RETURN
07220 *
07221       IF( LSAME( TOGGLE, 'Z' ) ) THEN
07222          ALPHA = ZERO
07223       ELSE IF( LSAME( TOGGLE, 'B' ) ) THEN
07224          ALPHA = PDLAMCH( ICTXT, 'Epsilon' )
07225          ALPHA = ALPHA / PDLAMCH( ICTXT, 'Safe minimum' )
07226       END IF
07227 *
07228       CALL PB_AINFOG2L( N, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
07229      $                  MYCOL, IMB1, INB1, NP, NQ, IIA, JJA, IAROW,
07230      $                  IACOL, MRROW, MRCOL )
07231 *
07232       IF( NP.LE.0 .OR. NQ.LE.0 )
07233      $   RETURN
07234 *
07235 *     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
07236 *     ILOW, LOW, IUPP, and UPP.
07237 *
07238       MB = DESCA2( MB_ )
07239       NB = DESCA2( NB_ )
07240       CALL PB_BINFO( 0, NP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL,
07241      $               LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
07242      $               LNBLOC, ILOW, LOW, IUPP, UPP )
07243 *
07244       IOFFA  = IIA - 1
07245       JOFFA  = JJA - 1
07246       ROWREP = ( DESCA2( RSRC_ ).EQ.-1 )
07247       COLREP = ( DESCA2( CSRC_ ).EQ.-1 )
07248       LDA    = DESCA2( LLD_ )
07249       LDAP1  = LDA + 1
07250 *
07251       IF( ROWREP ) THEN
07252          PMB = MB
07253       ELSE
07254          PMB = NPROW * MB
07255       END IF
07256       IF( COLREP ) THEN
07257          QNB = NB
07258       ELSE
07259          QNB = NPCOL * NB
07260       END IF
07261 *
07262 *     Handle the first block of rows or columns separately, and update
07263 *     LCMT00, MBLKS and NBLKS.
07264 *
07265       GODOWN = ( LCMT00.GT.IUPP )
07266       GOLEFT = ( LCMT00.LT.ILOW )
07267 *
07268       IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN
07269 *
07270 *        LCMT00 >= ILOW && LCMT00 <= IUPP
07271 *
07272          IF( LCMT00.GE.0 ) THEN
07273             IJOFFA = IOFFA + LCMT00 + ( JOFFA - 1 ) * LDA
07274             DO 10 I = 1, MIN( INBLOC, MAX( 0, IMBLOC - LCMT00 ) )
07275                ATMP = DBLE( A( IJOFFA + I*LDAP1 ) )
07276                A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA )
07277    10       CONTINUE
07278          ELSE
07279             IJOFFA = IOFFA + ( JOFFA - LCMT00 - 1 ) * LDA
07280             DO 20 I = 1, MIN( IMBLOC, MAX( 0, INBLOC + LCMT00 ) )
07281                ATMP = DBLE( A( IJOFFA + I*LDAP1 ) )
07282                A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA )
07283    20       CONTINUE
07284          END IF
07285          GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW )
07286          GODOWN = .NOT.GOLEFT
07287 *
07288       END IF
07289 *
07290       IF( GODOWN ) THEN
07291 *
07292          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
07293          MBLKS  = MBLKS - 1
07294          IOFFA  = IOFFA + IMBLOC
07295 *
07296    30    CONTINUE
07297          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
07298             LCMT00 = LCMT00 - PMB
07299             MBLKS  = MBLKS - 1
07300             IOFFA  = IOFFA + MB
07301             GO TO 30
07302          END IF
07303 *
07304          IF( MBLKS.LE.0 )
07305      $      RETURN
07306 *
07307          LCMT  = LCMT00
07308          MBLKD = MBLKS
07309          IOFFD = IOFFA
07310 *
07311          MBLOC = MB
07312    40    CONTINUE
07313          IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN
07314             IF( MBLKD.EQ.1 )
07315      $         MBLOC = LMBLOC
07316             IF( LCMT.GE.0 ) THEN
07317                IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
07318                DO 50 I = 1, MIN( INBLOC, MAX( 0, MBLOC - LCMT ) )
07319                   ATMP = DBLE( A( IJOFFA + I*LDAP1 ) )
07320                   A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA )
07321    50          CONTINUE
07322             ELSE
07323                IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
07324                DO 60 I = 1, MIN( MBLOC, MAX( 0, INBLOC + LCMT ) )
07325                   ATMP = DBLE( A( IJOFFA + I*LDAP1 ) )
07326                   A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA )
07327    60          CONTINUE
07328             END IF
07329             LCMT00 = LCMT
07330             LCMT   = LCMT - PMB
07331             MBLKS  = MBLKD
07332             MBLKD  = MBLKD - 1
07333             IOFFA  = IOFFD
07334             IOFFD  = IOFFD + MBLOC
07335             GO TO 40
07336          END IF
07337 *
07338          LCMT00 = LCMT00 + LOW - ILOW + QNB
07339          NBLKS  = NBLKS - 1
07340          JOFFA  = JOFFA + INBLOC
07341 *
07342       ELSE IF( GOLEFT ) THEN
07343 *
07344          LCMT00 = LCMT00 + LOW - ILOW + QNB
07345          NBLKS  = NBLKS - 1
07346          JOFFA  = JOFFA + INBLOC
07347 *
07348    70    CONTINUE
07349          IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN
07350             LCMT00 = LCMT00 + QNB
07351             NBLKS  = NBLKS - 1
07352             JOFFA  = JOFFA + NB
07353             GO TO 70
07354          END IF
07355 *
07356          IF( NBLKS.LE.0 )
07357      $      RETURN
07358 *
07359          LCMT  = LCMT00
07360          NBLKD = NBLKS
07361          JOFFD = JOFFA
07362 *
07363          NBLOC = NB
07364    80    CONTINUE
07365          IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN
07366             IF( NBLKD.EQ.1 )
07367      $         NBLOC = LNBLOC
07368             IF( LCMT.GE.0 ) THEN
07369                IJOFFA = IOFFA + LCMT + ( JOFFD - 1 ) * LDA
07370                DO 90 I = 1, MIN( NBLOC, MAX( 0, IMBLOC - LCMT ) )
07371                   ATMP = DBLE( A( IJOFFA + I*LDAP1 ) )
07372                   A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA )
07373    90          CONTINUE
07374             ELSE
07375                IJOFFA = IOFFA + ( JOFFD - LCMT - 1 ) * LDA
07376                DO 100 I = 1, MIN( IMBLOC, MAX( 0, NBLOC + LCMT ) )
07377                   ATMP = DBLE( A( IJOFFA + I*LDAP1 ) )
07378                   A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA )
07379   100          CONTINUE
07380             END IF
07381             LCMT00 = LCMT
07382             LCMT   = LCMT + QNB
07383             NBLKS  = NBLKD
07384             NBLKD  = NBLKD - 1
07385             JOFFA  = JOFFD
07386             JOFFD  = JOFFD + NBLOC
07387             GO TO 80
07388          END IF
07389 *
07390          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
07391          MBLKS  = MBLKS - 1
07392          IOFFA  = IOFFA + IMBLOC
07393 *
07394       END IF
07395 *
07396       NBLOC = NB
07397   110 CONTINUE
07398       IF( NBLKS.GT.0 ) THEN
07399          IF( NBLKS.EQ.1 )
07400      $      NBLOC = LNBLOC
07401   120    CONTINUE
07402          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
07403             LCMT00 = LCMT00 - PMB
07404             MBLKS  = MBLKS - 1
07405             IOFFA  = IOFFA + MB
07406             GO TO 120
07407          END IF
07408 *
07409          IF( MBLKS.LE.0 )
07410      $      RETURN
07411 *
07412          LCMT  = LCMT00
07413          MBLKD = MBLKS
07414          IOFFD = IOFFA
07415 *
07416          MBLOC = MB
07417   130    CONTINUE
07418          IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN
07419             IF( MBLKD.EQ.1 )
07420      $         MBLOC = LMBLOC
07421             IF( LCMT.GE.0 ) THEN
07422                IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
07423                DO 140 I = 1, MIN( NBLOC, MAX( 0, MBLOC - LCMT ) )
07424                   ATMP = DBLE( A( IJOFFA + I*LDAP1 ) )
07425                   A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA )
07426   140          CONTINUE
07427             ELSE
07428                IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
07429                DO 150 I = 1, MIN( MBLOC, MAX( 0, NBLOC + LCMT ) )
07430                   ATMP = DBLE( A( IJOFFA + I*LDAP1 ) )
07431                   A( IJOFFA + I*LDAP1 ) = DCMPLX( ATMP, ALPHA )
07432   150          CONTINUE
07433             END IF
07434             LCMT00 = LCMT
07435             LCMT   = LCMT - PMB
07436             MBLKS  = MBLKD
07437             MBLKD  = MBLKD - 1
07438             IOFFA  = IOFFD
07439             IOFFD  = IOFFD + MBLOC
07440             GO TO 130
07441          END IF
07442 *
07443          LCMT00 = LCMT00 + QNB
07444          NBLKS  = NBLKS - 1
07445          JOFFA  = JOFFA + NBLOC
07446          GO TO 110
07447 *
07448       END IF
07449 *
07450       RETURN
07451 *
07452 *     End of PZIPSET
07453 *
07454       END
07455       DOUBLE PRECISION   FUNCTION PDLAMCH( ICTXT, CMACH )
07456 *
07457 *  -- PBLAS test routine (version 2.0) --
07458 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
07459 *     and University of California, Berkeley.
07460 *     April 1, 1998
07461 *
07462 *     .. Scalar Arguments ..
07463       CHARACTER*1        CMACH
07464       INTEGER            ICTXT
07465 *     ..
07466 *
07467 *  Purpose
07468 *  =======
07469 *
07470 *
07471 *     .. Local Scalars ..
07472       CHARACTER*1        TOP
07473       INTEGER            IDUMM
07474       DOUBLE PRECISION   TEMP
07475 *     ..
07476 *     .. External Subroutines ..
07477       EXTERNAL           DGAMN2D, DGAMX2D, PB_TOPGET
07478 *     ..
07479 *     .. External Functions ..
07480       LOGICAL            LSAME
07481       DOUBLE PRECISION   DLAMCH
07482       EXTERNAL           DLAMCH, LSAME
07483 *     ..
07484 *     .. Executable Statements ..
07485 *
07486       TEMP = DLAMCH( CMACH )
07487 *
07488       IF( LSAME( CMACH, 'E' ).OR.LSAME( CMACH, 'S' ).OR.
07489      $    LSAME( CMACH, 'M' ).OR.LSAME( CMACH, 'U' ) ) THEN
07490          CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP )
07491          IDUMM = 0
07492          CALL DGAMX2D( ICTXT, 'All', TOP, 1, 1, TEMP, 1, IDUMM,
07493      $                 IDUMM, -1, -1, IDUMM )
07494       ELSE IF( LSAME( CMACH, 'L' ).OR.LSAME( CMACH, 'O' ) ) THEN
07495          CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP )
07496          IDUMM = 0
07497          CALL DGAMN2D( ICTXT, 'All', TOP, 1, 1, TEMP, 1, IDUMM,
07498      $                 IDUMM, -1, -1, IDUMM )
07499       END IF
07500 *
07501       PDLAMCH = TEMP
07502 *
07503       RETURN
07504 *
07505 *     End of PDLAMCH
07506 *
07507       END
07508       SUBROUTINE PZLASET( UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA )
07509 *
07510 *  -- PBLAS test routine (version 2.0) --
07511 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
07512 *     and University of California, Berkeley.
07513 *     April 1, 1998
07514 *
07515 *     .. Scalar Arguments ..
07516       CHARACTER*1        UPLO
07517       INTEGER            IA, JA, M, N
07518       COMPLEX*16         ALPHA, BETA
07519 *     ..
07520 *     .. Array Arguments ..
07521       INTEGER            DESCA( * )
07522       COMPLEX*16         A( * )
07523 *     ..
07524 *
07525 *  Purpose
07526 *  =======
07527 *
07528 *  PZLASET  initializes an m by n submatrix A(IA:IA+M-1,JA:JA+N-1) deno-
07529 *  ted  by  sub( A )  to beta on the diagonal and alpha on the offdiago-
07530 *  nals.
07531 *
07532 *  Notes
07533 *  =====
07534 *
07535 *  A description  vector  is associated with each 2D block-cyclicly dis-
07536 *  tributed matrix.  This  vector  stores  the  information  required to
07537 *  establish the  mapping  between a  matrix entry and its corresponding
07538 *  process and memory location.
07539 *
07540 *  In  the  following  comments,   the character _  should  be  read  as
07541 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
07542 *  block cyclicly distributed matrix.  Its description vector is DESCA:
07543 *
07544 *  NOTATION         STORED IN       EXPLANATION
07545 *  ---------------- --------------- ------------------------------------
07546 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
07547 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
07548 *                                   the NPROW x NPCOL BLACS process grid
07549 *                                   A  is distributed over.  The context
07550 *                                   itself  is  global,  but  the handle
07551 *                                   (the integer value) may vary.
07552 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
07553 *                                   ted matrix A, M_A >= 0.
07554 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
07555 *                                   buted matrix A, N_A >= 0.
07556 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
07557 *                                   block of the matrix A, IMB_A > 0.
07558 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
07559 *                                   left   block   of   the   matrix  A,
07560 *                                   INB_A > 0.
07561 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
07562 *                                   bute the last  M_A-IMB_A rows of  A,
07563 *                                   MB_A > 0.
07564 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
07565 *                                   bute the last  N_A-INB_A  columns of
07566 *                                   A, NB_A > 0.
07567 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
07568 *                                   row of the matrix  A is distributed,
07569 *                                   NPROW > RSRC_A >= 0.
07570 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
07571 *                                   first  column of  A  is distributed.
07572 *                                   NPCOL > CSRC_A >= 0.
07573 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
07574 *                                   array  storing  the  local blocks of
07575 *                                   the distributed matrix A,
07576 *                                   IF( Lc( 1, N_A ) > 0 )
07577 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
07578 *                                   ELSE
07579 *                                      LLD_A >= 1.
07580 *
07581 *  Let K be the number of  rows of a matrix A starting at the global in-
07582 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
07583 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
07584 *  receive if these K rows were distributed over NPROW processes.  If  K
07585 *  is the number of columns of a matrix  A  starting at the global index
07586 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
07587 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
07588 *  these K columns were distributed over NPCOL processes.
07589 *
07590 *  The values of Lr() and Lc() may be determined via a call to the func-
07591 *  tion PB_NUMROC:
07592 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
07593 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
07594 *
07595 *  Arguments
07596 *  =========
07597 *
07598 *  UPLO    (global input) CHARACTER*1
07599 *          On entry, UPLO specifies the part  of  the submatrix sub( A )
07600 *          to be set:
07601 *             = 'L' or 'l':   Lower triangular part is set; the strictly
07602 *                      upper triangular part of sub( A ) is not changed;
07603 *             = 'U' or 'u':   Upper triangular part is set; the strictly
07604 *                      lower triangular part of sub( A ) is not changed;
07605 *             Otherwise:  All of the matrix sub( A ) is set.
07606 *
07607 *  M       (global input) INTEGER
07608 *          On entry,  M  specifies the number of rows of  the  submatrix
07609 *          sub( A ). M  must be at least zero.
07610 *
07611 *  N       (global input) INTEGER
07612 *          On entry, N  specifies the number of columns of the submatrix
07613 *          sub( A ). N must be at least zero.
07614 *
07615 *  ALPHA   (global input) COMPLEX*16
07616 *          On entry,  ALPHA  specifies the scalar alpha, i.e., the cons-
07617 *          tant to which the offdiagonal elements are to be set.
07618 *
07619 *  BETA    (global input) COMPLEX*16
07620 *          On entry, BETA  specifies the scalar beta, i.e., the constant
07621 *          to which the diagonal elements are to be set.
07622 *
07623 *  A       (local input/local output) COMPLEX*16 array
07624 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
07625 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
07626 *          the local entries of the matrix  A  to be  set.  On exit, the
07627 *          leading m by n submatrix sub( A ) is set as follows:
07628 *
07629 *          if UPLO = 'U',  A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=j-1, 1<=j<=N,
07630 *          if UPLO = 'L',  A(IA+i-1,JA+j-1) = ALPHA, j+1<=i<=M, 1<=j<=N,
07631 *          otherwise,      A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=M,   1<=j<=N,
07632 *                                                      and IA+i.NE.JA+j,
07633 *          and, for all UPLO,  A(IA+i-1,JA+i-1) = BETA,  1<=i<=min(M,N).
07634 *
07635 *  IA      (global input) INTEGER
07636 *          On entry, IA  specifies A's global row index, which points to
07637 *          the beginning of the submatrix sub( A ).
07638 *
07639 *  JA      (global input) INTEGER
07640 *          On entry, JA  specifies A's global column index, which points
07641 *          to the beginning of the submatrix sub( A ).
07642 *
07643 *  DESCA   (global and local input) INTEGER array
07644 *          On entry, DESCA  is an integer array of dimension DLEN_. This
07645 *          is the array descriptor for the matrix A.
07646 *
07647 *  -- Written on April 1, 1998 by
07648 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
07649 *
07650 *  =====================================================================
07651 *
07652 *     .. Parameters ..
07653       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
07654      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
07655      $                   RSRC_
07656       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
07657      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
07658      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
07659      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
07660 *     ..
07661 *     .. Local Scalars ..
07662       LOGICAL            GODOWN, GOLEFT, ISCOLREP, ISROWREP, LOWER,
07663      $                   UPPER
07664       INTEGER            IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1,
07665      $                   IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP, JJA,
07666      $                   JJMAX, JOFFA, JOFFD, LCMT, LCMT00, LDA, LMBLOC,
07667      $                   LNBLOC, LOW, M1, MB, MBLKD, MBLKS, MBLOC, MP,
07668      $                   MRCOL, MRROW, MYCOL, MYROW, N1, NB, NBLKD,
07669      $                   NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB, QNB, TMP1,
07670      $                   UPP
07671 *     ..
07672 *     .. Local Arrays ..
07673       INTEGER            DESCA2( DLEN_ )
07674 *     ..
07675 *     .. External Subroutines ..
07676       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
07677      $                   PB_DESCTRANS, PB_ZLASET
07678 *     ..
07679 *     .. External Functions ..
07680       LOGICAL            LSAME
07681       EXTERNAL           LSAME
07682 *     ..
07683 *     .. Intrinsic Functions ..
07684       INTRINSIC          MIN
07685 *     ..
07686 *     .. Executable Statements ..
07687 *
07688       IF( M.EQ.0 .OR. N.EQ.0 )
07689      $   RETURN
07690 *
07691 *     Convert descriptor
07692 *
07693       CALL PB_DESCTRANS( DESCA, DESCA2 )
07694 *
07695 *     Get grid parameters
07696 *
07697       ICTXT = DESCA2( CTXT_ )
07698       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
07699 *
07700       CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
07701      $                  MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
07702      $                  IACOL, MRROW, MRCOL )
07703 *
07704       IF( MP.LE.0 .OR. NQ.LE.0 )
07705      $   RETURN
07706 *
07707       ISROWREP = ( DESCA2( RSRC_ ).LT.0 )
07708       ISCOLREP = ( DESCA2( CSRC_ ).LT.0 )
07709       LDA      = DESCA2( LLD_ )
07710 *
07711       UPPER = .NOT.( LSAME( UPLO, 'L' ) )
07712       LOWER = .NOT.( LSAME( UPLO, 'U' ) )
07713 *
07714       IF( ( ( LOWER.AND.UPPER ).AND.( ALPHA.EQ.BETA ) ).OR.
07715      $    (   ISROWREP        .AND.  ISCOLREP        ) ) THEN
07716          IF( ( MP.GT.0 ).AND.( NQ.GT.0 ) )
07717      $      CALL PB_ZLASET( UPLO, MP, NQ, 0, ALPHA, BETA,
07718      $                      A( IIA + ( JJA - 1 ) * LDA ), LDA )
07719          RETURN
07720       END IF
07721 *
07722 *     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
07723 *     ILOW, LOW, IUPP, and UPP.
07724 *
07725       MB = DESCA2( MB_ )
07726       NB = DESCA2( NB_ )
07727       CALL PB_BINFO( 0, MP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL,
07728      $               LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
07729      $               LNBLOC, ILOW, LOW, IUPP, UPP )
07730 *
07731       IOFFA = IIA - 1
07732       JOFFA = JJA - 1
07733       IIMAX = IOFFA + MP
07734       JJMAX = JOFFA + NQ
07735 *
07736       IF( ISROWREP ) THEN
07737          PMB = MB
07738       ELSE
07739          PMB = NPROW * MB
07740       END IF
07741       IF( ISCOLREP ) THEN
07742          QNB = NB
07743       ELSE
07744          QNB = NPCOL * NB
07745       END IF
07746 *
07747       M1 = MP
07748       N1 = NQ
07749 *
07750 *     Handle the first block of rows or columns separately, and update
07751 *     LCMT00, MBLKS and NBLKS.
07752 *
07753       GODOWN = ( LCMT00.GT.IUPP )
07754       GOLEFT = ( LCMT00.LT.ILOW )
07755 *
07756       IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN
07757 *
07758 *        LCMT00 >= ILOW && LCMT00 <= IUPP
07759 *
07760          GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW )
07761          GODOWN = .NOT.GOLEFT
07762 *
07763          CALL PB_ZLASET( UPLO, IMBLOC, INBLOC, LCMT00, ALPHA, BETA,
07764      $                   A( IIA+JOFFA*LDA ), LDA )
07765          IF( GODOWN ) THEN
07766             IF( UPPER .AND. NQ.GT.INBLOC )
07767      $         CALL PB_ZLASET( 'All', IMBLOC, NQ-INBLOC, 0, ALPHA,
07768      $                         ALPHA, A( IIA+(JOFFA+INBLOC)*LDA ), LDA )
07769             IIA = IIA + IMBLOC
07770             M1  = M1 - IMBLOC
07771          ELSE
07772             IF( LOWER .AND. MP.GT.IMBLOC )
07773      $         CALL PB_ZLASET( 'All', MP-IMBLOC, INBLOC, 0, ALPHA,
07774      $                         ALPHA, A( IIA+IMBLOC+JOFFA*LDA ), LDA )
07775             JJA = JJA + INBLOC
07776             N1  = N1 - INBLOC
07777          END IF
07778 *
07779       END IF
07780 *
07781       IF( GODOWN ) THEN
07782 *
07783          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
07784          MBLKS  = MBLKS - 1
07785          IOFFA  = IOFFA + IMBLOC
07786 *
07787    10    CONTINUE
07788          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
07789             LCMT00 = LCMT00 - PMB
07790             MBLKS  = MBLKS - 1
07791             IOFFA  = IOFFA + MB
07792             GO TO 10
07793          END IF
07794 *
07795          TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
07796          IF( UPPER .AND. TMP1.GT.0 ) THEN
07797             CALL PB_ZLASET( 'All', TMP1, N1, 0, ALPHA, ALPHA,
07798      $                      A( IIA+JOFFA*LDA ), LDA )
07799             IIA = IIA + TMP1
07800             M1  = M1 - TMP1
07801          END IF
07802 *
07803          IF( MBLKS.LE.0 )
07804      $      RETURN
07805 *
07806          LCMT  = LCMT00
07807          MBLKD = MBLKS
07808          IOFFD = IOFFA
07809 *
07810          MBLOC = MB
07811    20    CONTINUE
07812          IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN
07813             IF( MBLKD.EQ.1 )
07814      $         MBLOC = LMBLOC
07815             CALL PB_ZLASET( UPLO, MBLOC, INBLOC, LCMT, ALPHA, BETA,
07816      $                      A( IOFFD+1+JOFFA*LDA ), LDA )
07817             LCMT00 = LCMT
07818             LCMT   = LCMT - PMB
07819             MBLKS  = MBLKD
07820             MBLKD  = MBLKD - 1
07821             IOFFA  = IOFFD
07822             IOFFD  = IOFFD + MBLOC
07823             GO TO 20
07824          END IF
07825 *
07826          TMP1 = M1 - IOFFD + IIA - 1
07827          IF( LOWER .AND. TMP1.GT.0 )
07828      $      CALL PB_ZLASET( 'ALL', TMP1, INBLOC, 0, ALPHA, ALPHA,
07829      $                      A( IOFFD+1+JOFFA*LDA ), LDA )
07830 *
07831          TMP1   = IOFFA - IIA + 1
07832          M1     = M1 - TMP1
07833          N1     = N1 - INBLOC
07834          LCMT00 = LCMT00 + LOW - ILOW + QNB
07835          NBLKS  = NBLKS - 1
07836          JOFFA  = JOFFA + INBLOC
07837 *
07838          IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 )
07839      $      CALL PB_ZLASET( 'ALL', TMP1, N1, 0, ALPHA, ALPHA,
07840      $                      A( IIA+JOFFA*LDA ), LDA )
07841 *
07842          IIA = IOFFA + 1
07843          JJA = JOFFA + 1
07844 *
07845       ELSE IF( GOLEFT ) THEN
07846 *
07847          LCMT00 = LCMT00 + LOW - ILOW + QNB
07848          NBLKS  = NBLKS - 1
07849          JOFFA  = JOFFA + INBLOC
07850 *
07851    30    CONTINUE
07852          IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN
07853             LCMT00 = LCMT00 + QNB
07854             NBLKS  = NBLKS - 1
07855             JOFFA  = JOFFA + NB
07856             GO TO 30
07857          END IF
07858 *
07859          TMP1 = MIN( JOFFA, JJMAX ) - JJA + 1
07860          IF( LOWER .AND. TMP1.GT.0 ) THEN
07861             CALL PB_ZLASET( 'All', M1, TMP1, 0, ALPHA, ALPHA,
07862      $                      A( IIA+(JJA-1)*LDA ), LDA )
07863             JJA = JJA + TMP1
07864             N1  = N1 - TMP1
07865          END IF
07866 *
07867          IF( NBLKS.LE.0 )
07868      $      RETURN
07869 *
07870          LCMT  = LCMT00
07871          NBLKD = NBLKS
07872          JOFFD = JOFFA
07873 *
07874          NBLOC = NB
07875    40    CONTINUE
07876          IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN
07877             IF( NBLKD.EQ.1 )
07878      $         NBLOC = LNBLOC
07879             CALL PB_ZLASET( UPLO, IMBLOC, NBLOC, LCMT, ALPHA, BETA,
07880      $                      A( IIA+JOFFD*LDA ), LDA )
07881             LCMT00 = LCMT
07882             LCMT   = LCMT + QNB
07883             NBLKS  = NBLKD
07884             NBLKD  = NBLKD - 1
07885             JOFFA  = JOFFD
07886             JOFFD  = JOFFD + NBLOC
07887             GO TO 40
07888          END IF
07889 *
07890          TMP1 = N1 - JOFFD + JJA - 1
07891          IF( UPPER .AND. TMP1.GT.0 )
07892      $      CALL PB_ZLASET( 'All', IMBLOC, TMP1, 0, ALPHA, ALPHA,
07893      $                      A( IIA+JOFFD*LDA ), LDA )
07894 *
07895          TMP1   = JOFFA - JJA + 1
07896          M1     = M1 - IMBLOC
07897          N1     = N1 - TMP1
07898          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
07899          MBLKS  = MBLKS - 1
07900          IOFFA  = IOFFA + IMBLOC
07901 *
07902          IF( LOWER .AND. M1.GT.0 .AND. TMP1.GT.0 )
07903      $      CALL PB_ZLASET( 'All', M1, TMP1, 0, ALPHA, ALPHA,
07904      $                      A( IOFFA+1+(JJA-1)*LDA ), LDA )
07905 *
07906          IIA = IOFFA + 1
07907          JJA = JOFFA + 1
07908 *
07909       END IF
07910 *
07911       NBLOC = NB
07912    50 CONTINUE
07913       IF( NBLKS.GT.0 ) THEN
07914          IF( NBLKS.EQ.1 )
07915      $      NBLOC = LNBLOC
07916    60    CONTINUE
07917          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
07918             LCMT00 = LCMT00 - PMB
07919             MBLKS  = MBLKS - 1
07920             IOFFA  = IOFFA + MB
07921             GO TO 60
07922          END IF
07923 *
07924          TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
07925          IF( UPPER .AND. TMP1.GT.0 ) THEN
07926             CALL PB_ZLASET( 'All', TMP1, N1, 0, ALPHA, ALPHA,
07927      $                      A( IIA+JOFFA*LDA ), LDA )
07928             IIA = IIA + TMP1
07929             M1  = M1 - TMP1
07930          END IF
07931 *
07932          IF( MBLKS.LE.0 )
07933      $      RETURN
07934 *
07935          LCMT  = LCMT00
07936          MBLKD = MBLKS
07937          IOFFD = IOFFA
07938 *
07939          MBLOC = MB
07940    70    CONTINUE
07941          IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN
07942             IF( MBLKD.EQ.1 )
07943      $         MBLOC = LMBLOC
07944             CALL PB_ZLASET( UPLO, MBLOC, NBLOC, LCMT, ALPHA, BETA,
07945      $                      A( IOFFD+1+JOFFA*LDA ), LDA )
07946             LCMT00 = LCMT
07947             LCMT   = LCMT - PMB
07948             MBLKS  = MBLKD
07949             MBLKD  = MBLKD - 1
07950             IOFFA  = IOFFD
07951             IOFFD  = IOFFD + MBLOC
07952             GO TO 70
07953          END IF
07954 *
07955          TMP1 = M1 - IOFFD + IIA - 1
07956          IF( LOWER .AND. TMP1.GT.0 )
07957      $      CALL PB_ZLASET( 'All', TMP1, NBLOC, 0, ALPHA, ALPHA,
07958      $                      A( IOFFD+1+JOFFA*LDA ), LDA )
07959 *
07960          TMP1   = MIN( IOFFA, IIMAX )  - IIA + 1
07961          M1     = M1 - TMP1
07962          N1     = N1 - NBLOC
07963          LCMT00 = LCMT00 + QNB
07964          NBLKS  = NBLKS - 1
07965          JOFFA  = JOFFA + NBLOC
07966 *
07967          IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 )
07968      $      CALL PB_ZLASET( 'All', TMP1, N1, 0, ALPHA, ALPHA,
07969      $                      A( IIA+JOFFA*LDA ), LDA )
07970 *
07971          IIA = IOFFA + 1
07972          JJA = JOFFA + 1
07973 *
07974          GO TO 50
07975 *
07976       END IF
07977 *
07978       RETURN
07979 *
07980 *     End of PZLASET
07981 *
07982       END
07983       SUBROUTINE PZLASCAL( TYPE, M, N, ALPHA, A, IA, JA, DESCA )
07984 *
07985 *  -- PBLAS test routine (version 2.0) --
07986 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
07987 *     and University of California, Berkeley.
07988 *     April 1, 1998
07989 *
07990 *     .. Scalar Arguments ..
07991       CHARACTER*1        TYPE
07992       INTEGER            IA, JA, M, N
07993       COMPLEX*16         ALPHA
07994 *     ..
07995 *     .. Array Arguments ..
07996       INTEGER            DESCA( * )
07997       COMPLEX*16         A( * )
07998 *     ..
07999 *
08000 *  Purpose
08001 *  =======
08002 *
08003 *  PZLASCAL  scales the  m by n submatrix A(IA:IA+M-1,JA:JA+N-1) denoted
08004 *  by sub( A ) by the scalar alpha. TYPE  specifies if sub( A ) is full,
08005 *  upper triangular, lower triangular or upper Hessenberg.
08006 *
08007 *  Notes
08008 *  =====
08009 *
08010 *  A description  vector  is associated with each 2D block-cyclicly dis-
08011 *  tributed matrix.  This  vector  stores  the  information  required to
08012 *  establish the  mapping  between a  matrix entry and its corresponding
08013 *  process and memory location.
08014 *
08015 *  In  the  following  comments,   the character _  should  be  read  as
08016 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
08017 *  block cyclicly distributed matrix.  Its description vector is DESCA:
08018 *
08019 *  NOTATION         STORED IN       EXPLANATION
08020 *  ---------------- --------------- ------------------------------------
08021 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
08022 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
08023 *                                   the NPROW x NPCOL BLACS process grid
08024 *                                   A  is distributed over.  The context
08025 *                                   itself  is  global,  but  the handle
08026 *                                   (the integer value) may vary.
08027 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
08028 *                                   ted matrix A, M_A >= 0.
08029 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
08030 *                                   buted matrix A, N_A >= 0.
08031 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
08032 *                                   block of the matrix A, IMB_A > 0.
08033 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
08034 *                                   left   block   of   the   matrix  A,
08035 *                                   INB_A > 0.
08036 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
08037 *                                   bute the last  M_A-IMB_A rows of  A,
08038 *                                   MB_A > 0.
08039 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
08040 *                                   bute the last  N_A-INB_A  columns of
08041 *                                   A, NB_A > 0.
08042 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
08043 *                                   row of the matrix  A is distributed,
08044 *                                   NPROW > RSRC_A >= 0.
08045 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
08046 *                                   first  column of  A  is distributed.
08047 *                                   NPCOL > CSRC_A >= 0.
08048 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
08049 *                                   array  storing  the  local blocks of
08050 *                                   the distributed matrix A,
08051 *                                   IF( Lc( 1, N_A ) > 0 )
08052 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
08053 *                                   ELSE
08054 *                                      LLD_A >= 1.
08055 *
08056 *  Let K be the number of  rows of a matrix A starting at the global in-
08057 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
08058 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
08059 *  receive if these K rows were distributed over NPROW processes.  If  K
08060 *  is the number of columns of a matrix  A  starting at the global index
08061 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
08062 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
08063 *  these K columns were distributed over NPCOL processes.
08064 *
08065 *  The values of Lr() and Lc() may be determined via a call to the func-
08066 *  tion PB_NUMROC:
08067 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
08068 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
08069 *
08070 *  Arguments
08071 *  =========
08072 *
08073 *  TYPE    (global input) CHARACTER*1
08074 *          On entry,  TYPE  specifies the type of the input submatrix as
08075 *          follows:
08076 *             = 'L' or 'l':  sub( A ) is a lower triangular matrix,
08077 *             = 'U' or 'u':  sub( A ) is an upper triangular matrix,
08078 *             = 'H' or 'h':  sub( A ) is an upper Hessenberg matrix,
08079 *             otherwise sub( A ) is a  full matrix.
08080 *
08081 *  M       (global input) INTEGER
08082 *          On entry,  M  specifies the number of rows of  the  submatrix
08083 *          sub( A ). M  must be at least zero.
08084 *
08085 *  N       (global input) INTEGER
08086 *          On entry, N  specifies the number of columns of the submatrix
08087 *          sub( A ). N  must be at least zero.
08088 *
08089 *  ALPHA   (global input) COMPLEX*16
08090 *          On entry, ALPHA specifies the scalar alpha.
08091 *
08092 *  A       (local input/local output) COMPLEX*16 array
08093 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
08094 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
08095 *          the local entries of the matrix  A.
08096 *          On exit, the local entries of this array corresponding to the
08097 *          to  the entries of the submatrix sub( A ) are  overwritten by
08098 *          the local entries of the m by n scaled submatrix.
08099 *
08100 *  IA      (global input) INTEGER
08101 *          On entry, IA  specifies A's global row index, which points to
08102 *          the beginning of the submatrix sub( A ).
08103 *
08104 *  JA      (global input) INTEGER
08105 *          On entry, JA  specifies A's global column index, which points
08106 *          to the beginning of the submatrix sub( A ).
08107 *
08108 *  DESCA   (global and local input) INTEGER array
08109 *          On entry, DESCA  is an integer array of dimension DLEN_. This
08110 *          is the array descriptor for the matrix A.
08111 *
08112 *  -- Written on April 1, 1998 by
08113 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
08114 *
08115 *  =====================================================================
08116 *
08117 *     .. Parameters ..
08118       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
08119      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
08120      $                   RSRC_
08121       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
08122      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
08123      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
08124      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
08125 *     ..
08126 *     .. Local Scalars ..
08127       CHARACTER*1        UPLO
08128       LOGICAL            GODOWN, GOLEFT, LOWER, UPPER
08129       INTEGER            IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1,
08130      $                   IMBLOC, INB1, INBLOC, IOFFA, IOFFD, ITYPE,
08131      $                   IUPP, JJA, JJMAX, JOFFA, JOFFD, LCMT, LCMT00,
08132      $                   LDA, LMBLOC, LNBLOC, LOW, M1, MB, MBLKD, MBLKS,
08133      $                   MBLOC, MP, MRCOL, MRROW, MYCOL, MYROW, N1, NB,
08134      $                   NBLKD, NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB,
08135      $                   QNB, TMP1, UPP
08136 *     ..
08137 *     .. Local Arrays ..
08138       INTEGER            DESCA2( DLEN_ )
08139 *     ..
08140 *     .. External Subroutines ..
08141       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
08142      $                   PB_DESCTRANS, PB_INFOG2L, PB_ZLASCAL
08143 *     ..
08144 *     .. External Functions ..
08145       LOGICAL            LSAME
08146       INTEGER            PB_NUMROC
08147       EXTERNAL           LSAME, PB_NUMROC
08148 *     ..
08149 *     .. Intrinsic Functions ..
08150       INTRINSIC          MIN
08151 *     ..
08152 *     .. Executable Statements ..
08153 *
08154 *     Convert descriptor
08155 *
08156       CALL PB_DESCTRANS( DESCA, DESCA2 )
08157 *
08158 *     Get grid parameters
08159 *
08160       ICTXT = DESCA2( CTXT_ )
08161       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
08162 *
08163 *     Quick return if possible
08164 *
08165       IF( M.EQ.0 .OR. N.EQ.0 )
08166      $   RETURN
08167 *
08168       IF( LSAME( TYPE, 'L' ) ) THEN
08169          ITYPE = 1
08170          UPLO  = TYPE
08171          UPPER = .FALSE.
08172          LOWER = .TRUE.
08173          IOFFD = 0
08174       ELSE IF( LSAME( TYPE, 'U' ) ) THEN
08175          ITYPE = 2
08176          UPLO  = TYPE
08177          UPPER = .TRUE.
08178          LOWER = .FALSE.
08179          IOFFD = 0
08180       ELSE IF( LSAME( TYPE, 'H' ) ) THEN
08181          ITYPE = 3
08182          UPLO  = 'U'
08183          UPPER = .TRUE.
08184          LOWER = .FALSE.
08185          IOFFD = 1
08186       ELSE
08187          ITYPE = 0
08188          UPLO  = 'A'
08189          UPPER = .TRUE.
08190          LOWER = .TRUE.
08191          IOFFD = 0
08192       END IF
08193 *
08194 *     Compute local indexes
08195 *
08196       IF( ITYPE.EQ.0 ) THEN
08197 *
08198 *        Full matrix
08199 *
08200          CALL PB_INFOG2L( IA, JA, DESCA2, NPROW, NPCOL, MYROW, MYCOL,
08201      $                    IIA, JJA, IAROW, IACOL )
08202          MP = PB_NUMROC( M, IA, DESCA2( IMB_ ), DESCA2( MB_ ), MYROW,
08203      $                   DESCA2( RSRC_ ), NPROW )
08204          NQ = PB_NUMROC( N, JA, DESCA2( INB_ ), DESCA2( NB_ ), MYCOL,
08205      $                   DESCA2( CSRC_ ), NPCOL )
08206 *
08207          IF( MP.LE.0 .OR. NQ.LE.0 )
08208      $      RETURN
08209 *
08210          LDA   = DESCA2( LLD_ )
08211          IOFFA = IIA + ( JJA - 1 ) * LDA
08212 *
08213          CALL PB_ZLASCAL( 'All', MP, NQ, 0, ALPHA, A( IOFFA ), LDA )
08214 *
08215       ELSE
08216 *
08217 *        Trapezoidal matrix
08218 *
08219          CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
08220      $                     MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
08221      $                     IACOL, MRROW, MRCOL )
08222 *
08223          IF( MP.LE.0 .OR. NQ.LE.0 )
08224      $      RETURN
08225 *
08226 *        Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
08227 *        LNBLOC, ILOW, LOW, IUPP, and UPP.
08228 *
08229          MB  = DESCA2( MB_ )
08230          NB  = DESCA2( NB_ )
08231          LDA = DESCA2( LLD_ )
08232 *
08233          CALL PB_BINFO( IOFFD, MP, NQ, IMB1, INB1, MB, NB, MRROW,
08234      $                  MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC,
08235      $                  LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP )
08236 *
08237          M1    = MP
08238          N1    = NQ
08239          IOFFA = IIA - 1
08240          JOFFA = JJA - 1
08241          IIMAX = IOFFA + MP
08242          JJMAX = JOFFA + NQ
08243 *
08244          IF( DESCA2( RSRC_ ).LT.0 ) THEN
08245             PMB = MB
08246          ELSE
08247             PMB = NPROW * MB
08248          END IF
08249          IF( DESCA2( CSRC_ ).LT.0 ) THEN
08250             QNB = NB
08251          ELSE
08252             QNB = NPCOL * NB
08253          END IF
08254 *
08255 *        Handle the first block of rows or columns separately, and
08256 *        update LCMT00, MBLKS and NBLKS.
08257 *
08258          GODOWN = ( LCMT00.GT.IUPP )
08259          GOLEFT = ( LCMT00.LT.ILOW )
08260 *
08261          IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN
08262 *
08263 *           LCMT00 >= ILOW && LCMT00 <= IUPP
08264 *
08265             GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW )
08266             GODOWN = .NOT.GOLEFT
08267 *
08268             CALL PB_ZLASCAL( UPLO, IMBLOC, INBLOC, LCMT00, ALPHA,
08269      $                       A( IIA+JOFFA*LDA ), LDA )
08270             IF( GODOWN ) THEN
08271                IF( UPPER .AND. NQ.GT.INBLOC )
08272      $            CALL PB_ZLASCAL( 'All', IMBLOC, NQ-INBLOC, 0, ALPHA,
08273      $                             A( IIA+(JOFFA+INBLOC)*LDA ), LDA )
08274                IIA = IIA + IMBLOC
08275                M1  = M1 - IMBLOC
08276             ELSE
08277                IF( LOWER .AND. MP.GT.IMBLOC )
08278      $            CALL PB_ZLASCAL( 'All', MP-IMBLOC, INBLOC, 0, ALPHA,
08279      $                             A( IIA+IMBLOC+JOFFA*LDA ), LDA )
08280                JJA = JJA + INBLOC
08281                N1  = N1 - INBLOC
08282             END IF
08283 *
08284          END IF
08285 *
08286          IF( GODOWN ) THEN
08287 *
08288             LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
08289             MBLKS  = MBLKS - 1
08290             IOFFA  = IOFFA + IMBLOC
08291 *
08292    10       CONTINUE
08293             IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
08294                LCMT00 = LCMT00 - PMB
08295                MBLKS  = MBLKS - 1
08296                IOFFA  = IOFFA + MB
08297                GO TO 10
08298             END IF
08299 *
08300             TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
08301             IF( UPPER .AND. TMP1.GT.0 ) THEN
08302                CALL PB_ZLASCAL( 'All', TMP1, N1, 0, ALPHA,
08303      $                          A( IIA+JOFFA*LDA ), LDA )
08304                IIA = IIA + TMP1
08305                M1  = M1 - TMP1
08306             END IF
08307 *
08308             IF( MBLKS.LE.0 )
08309      $         RETURN
08310 *
08311             LCMT  = LCMT00
08312             MBLKD = MBLKS
08313             IOFFD = IOFFA
08314 *
08315             MBLOC = MB
08316    20       CONTINUE
08317             IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN
08318                IF( MBLKD.EQ.1 )
08319      $            MBLOC = LMBLOC
08320                CALL PB_ZLASCAL( UPLO, MBLOC, INBLOC, LCMT, ALPHA,
08321      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
08322                LCMT00 = LCMT
08323                LCMT   = LCMT - PMB
08324                MBLKS  = MBLKD
08325                MBLKD  = MBLKD - 1
08326                IOFFA  = IOFFD
08327                IOFFD  = IOFFD + MBLOC
08328                GO TO 20
08329             END IF
08330 *
08331             TMP1 = M1 - IOFFD + IIA - 1
08332             IF( LOWER .AND. TMP1.GT.0 )
08333      $         CALL PB_ZLASCAL( 'All', TMP1, INBLOC, 0, ALPHA,
08334      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
08335 *
08336             TMP1   = IOFFA - IIA + 1
08337             M1     = M1 - TMP1
08338             N1     = N1 - INBLOC
08339             LCMT00 = LCMT00 + LOW - ILOW + QNB
08340             NBLKS  = NBLKS - 1
08341             JOFFA  = JOFFA + INBLOC
08342 *
08343             IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 )
08344      $         CALL PB_ZLASCAL( 'All', TMP1, N1, 0, ALPHA,
08345      $                          A( IIA+JOFFA*LDA ), LDA )
08346 *
08347             IIA = IOFFA + 1
08348             JJA = JOFFA + 1
08349 *
08350          ELSE IF( GOLEFT ) THEN
08351 *
08352             LCMT00 = LCMT00 + LOW - ILOW + QNB
08353             NBLKS  = NBLKS - 1
08354             JOFFA  = JOFFA + INBLOC
08355 *
08356    30       CONTINUE
08357             IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN
08358                LCMT00 = LCMT00 + QNB
08359                NBLKS  = NBLKS - 1
08360                JOFFA  = JOFFA + NB
08361                GO TO 30
08362             END IF
08363 *
08364             TMP1 = MIN( JOFFA, JJMAX ) - JJA + 1
08365             IF( LOWER .AND. TMP1.GT.0 ) THEN
08366                CALL PB_ZLASCAL( 'All', M1, TMP1, 0, ALPHA,
08367      $                          A( IIA+(JJA-1)*LDA ), LDA )
08368                JJA = JJA + TMP1
08369                N1  = N1 - TMP1
08370             END IF
08371 *
08372             IF( NBLKS.LE.0 )
08373      $         RETURN
08374 *
08375             LCMT  = LCMT00
08376             NBLKD = NBLKS
08377             JOFFD = JOFFA
08378 *
08379             NBLOC = NB
08380    40       CONTINUE
08381             IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN
08382                IF( NBLKD.EQ.1 )
08383      $            NBLOC = LNBLOC
08384                CALL PB_ZLASCAL( UPLO, IMBLOC, NBLOC, LCMT, ALPHA,
08385      $                          A( IIA+JOFFD*LDA ), LDA )
08386                LCMT00 = LCMT
08387                LCMT   = LCMT + QNB
08388                NBLKS  = NBLKD
08389                NBLKD  = NBLKD - 1
08390                JOFFA  = JOFFD
08391                JOFFD  = JOFFD + NBLOC
08392                GO TO 40
08393             END IF
08394 *
08395             TMP1 = N1 - JOFFD + JJA - 1
08396             IF( UPPER .AND. TMP1.GT.0 )
08397      $         CALL PB_ZLASCAL( 'All', IMBLOC, TMP1, 0, ALPHA,
08398      $                          A( IIA+JOFFD*LDA ), LDA )
08399 *
08400             TMP1   = JOFFA - JJA + 1
08401             M1     = M1 - IMBLOC
08402             N1     = N1 - TMP1
08403             LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
08404             MBLKS  = MBLKS - 1
08405             IOFFA  = IOFFA + IMBLOC
08406 *
08407             IF( LOWER .AND. M1.GT.0 .AND. TMP1.GT.0 )
08408      $         CALL PB_ZLASCAL( 'All', M1, TMP1, 0, ALPHA,
08409      $                          A( IOFFA+1+(JJA-1)*LDA ), LDA )
08410 *
08411             IIA = IOFFA + 1
08412             JJA = JOFFA + 1
08413 *
08414          END IF
08415 *
08416          NBLOC = NB
08417    50    CONTINUE
08418          IF( NBLKS.GT.0 ) THEN
08419             IF( NBLKS.EQ.1 )
08420      $         NBLOC = LNBLOC
08421    60       CONTINUE
08422             IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
08423                LCMT00 = LCMT00 - PMB
08424                MBLKS  = MBLKS - 1
08425                IOFFA  = IOFFA + MB
08426                GO TO 60
08427             END IF
08428 *
08429             TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
08430             IF( UPPER .AND. TMP1.GT.0 ) THEN
08431                CALL PB_ZLASCAL( 'All', TMP1, N1, 0, ALPHA,
08432      $                          A( IIA+JOFFA*LDA ), LDA )
08433                IIA = IIA + TMP1
08434                M1  = M1 - TMP1
08435             END IF
08436 *
08437             IF( MBLKS.LE.0 )
08438      $         RETURN
08439 *
08440             LCMT  = LCMT00
08441             MBLKD = MBLKS
08442             IOFFD = IOFFA
08443 *
08444             MBLOC = MB
08445    70       CONTINUE
08446             IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN
08447                IF( MBLKD.EQ.1 )
08448      $            MBLOC = LMBLOC
08449                CALL PB_ZLASCAL( UPLO, MBLOC, NBLOC, LCMT, ALPHA,
08450      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
08451                LCMT00 = LCMT
08452                LCMT   = LCMT - PMB
08453                MBLKS  = MBLKD
08454                MBLKD  = MBLKD - 1
08455                IOFFA  = IOFFD
08456                IOFFD  = IOFFD + MBLOC
08457                GO TO 70
08458             END IF
08459 *
08460             TMP1 = M1 - IOFFD + IIA - 1
08461             IF( LOWER .AND. TMP1.GT.0 )
08462      $         CALL PB_ZLASCAL( 'All', TMP1, NBLOC, 0, ALPHA,
08463      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
08464 *
08465             TMP1   = MIN( IOFFA, IIMAX )  - IIA + 1
08466             M1     = M1 - TMP1
08467             N1     = N1 - NBLOC
08468             LCMT00 = LCMT00 + QNB
08469             NBLKS  = NBLKS - 1
08470             JOFFA  = JOFFA + NBLOC
08471 *
08472             IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 )
08473      $         CALL PB_ZLASCAL( 'All', TMP1, N1, 0, ALPHA,
08474      $                          A( IIA+JOFFA*LDA ), LDA )
08475 *
08476             IIA = IOFFA + 1
08477             JJA = JOFFA + 1
08478 *
08479             GO TO 50
08480 *
08481          END IF
08482 *
08483       END IF
08484 *
08485       RETURN
08486 *
08487 *     End of PZLASCAL
08488 *
08489       END
08490       SUBROUTINE PZLAGEN( INPLACE, AFORM, DIAG, OFFA, M, N, IA, JA,
08491      $                    DESCA, IASEED, A, LDA )
08492 *
08493 *  -- PBLAS test routine (version 2.0) --
08494 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
08495 *     and University of California, Berkeley.
08496 *     April 1, 1998
08497 *
08498 *     .. Scalar Arguments ..
08499       LOGICAL            INPLACE
08500       CHARACTER*1        AFORM, DIAG
08501       INTEGER            IA, IASEED, JA, LDA, M, N, OFFA
08502 *     ..
08503 *     .. Array Arguments ..
08504       INTEGER            DESCA( * )
08505       COMPLEX*16         A( LDA, * )
08506 *     ..
08507 *
08508 *  Purpose
08509 *  =======
08510 *
08511 *  PZLAGEN  generates  (or regenerates)  a  submatrix  sub( A ) denoting
08512 *  A(IA:IA+M-1,JA:JA+N-1).
08513 *
08514 *  Notes
08515 *  =====
08516 *
08517 *  A description  vector  is associated with each 2D block-cyclicly dis-
08518 *  tributed matrix.  This  vector  stores  the  information  required to
08519 *  establish the  mapping  between a  matrix entry and its corresponding
08520 *  process and memory location.
08521 *
08522 *  In  the  following  comments,   the character _  should  be  read  as
08523 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
08524 *  block cyclicly distributed matrix.  Its description vector is DESCA:
08525 *
08526 *  NOTATION         STORED IN       EXPLANATION
08527 *  ---------------- --------------- ------------------------------------
08528 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
08529 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
08530 *                                   the NPROW x NPCOL BLACS process grid
08531 *                                   A  is distributed over.  The context
08532 *                                   itself  is  global,  but  the handle
08533 *                                   (the integer value) may vary.
08534 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
08535 *                                   ted matrix A, M_A >= 0.
08536 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
08537 *                                   buted matrix A, N_A >= 0.
08538 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
08539 *                                   block of the matrix A, IMB_A > 0.
08540 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
08541 *                                   left   block   of   the   matrix  A,
08542 *                                   INB_A > 0.
08543 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
08544 *                                   bute the last  M_A-IMB_A rows of  A,
08545 *                                   MB_A > 0.
08546 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
08547 *                                   bute the last  N_A-INB_A  columns of
08548 *                                   A, NB_A > 0.
08549 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
08550 *                                   row of the matrix  A is distributed,
08551 *                                   NPROW > RSRC_A >= 0.
08552 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
08553 *                                   first  column of  A  is distributed.
08554 *                                   NPCOL > CSRC_A >= 0.
08555 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
08556 *                                   array  storing  the  local blocks of
08557 *                                   the distributed matrix A,
08558 *                                   IF( Lc( 1, N_A ) > 0 )
08559 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
08560 *                                   ELSE
08561 *                                      LLD_A >= 1.
08562 *
08563 *  Let K be the number of  rows of a matrix A starting at the global in-
08564 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
08565 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
08566 *  receive if these K rows were distributed over NPROW processes.  If  K
08567 *  is the number of columns of a matrix  A  starting at the global index
08568 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
08569 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
08570 *  these K columns were distributed over NPCOL processes.
08571 *
08572 *  The values of Lr() and Lc() may be determined via a call to the func-
08573 *  tion PB_NUMROC:
08574 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
08575 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
08576 *
08577 *  Arguments
08578 *  =========
08579 *
08580 *  INPLACE (global input) LOGICAL
08581 *          On entry, INPLACE specifies if the matrix should be generated
08582 *          in place or not. If INPLACE is .TRUE., the local random array
08583 *          to be generated  will start in memory at the local memory lo-
08584 *          cation A( 1, 1 ),  otherwise it will start at the local posi-
08585 *          tion induced by IA and JA.
08586 *
08587 *  AFORM   (global input) CHARACTER*1
08588 *          On entry, AFORM specifies the type of submatrix to be genera-
08589 *          ted as follows:
08590 *             AFORM = 'S', sub( A ) is a symmetric matrix,
08591 *             AFORM = 'H', sub( A ) is a Hermitian matrix,
08592 *             AFORM = 'T', sub( A ) is overrwritten  with  the transpose
08593 *                          of what would normally be generated,
08594 *             AFORM = 'C', sub( A ) is overwritten  with  the  conjugate
08595 *                          transpose  of  what would normally be genera-
08596 *                          ted.
08597 *             AFORM = 'N', a random submatrix is generated.
08598 *
08599 *  DIAG    (global input) CHARACTER*1
08600 *          On entry, DIAG specifies if the generated submatrix is diago-
08601 *          nally dominant or not as follows:
08602 *             DIAG = 'D' : sub( A ) is diagonally dominant,
08603 *             DIAG = 'N' : sub( A ) is not diagonally dominant.
08604 *
08605 *  OFFA    (global input) INTEGER
08606 *          On entry, OFFA  specifies  the  offdiagonal of the underlying
08607 *          matrix A(1:DESCA(M_),1:DESCA(N_)) of interest when the subma-
08608 *          trix is symmetric, Hermitian or diagonally dominant. OFFA = 0
08609 *          specifies the main diagonal,  OFFA > 0  specifies a subdiago-
08610 *          nal,  and OFFA < 0 specifies a superdiagonal (see further de-
08611 *          tails).
08612 *
08613 *  M       (global input) INTEGER
08614 *          On entry, M specifies the global number of matrix rows of the
08615 *          submatrix sub( A ) to be generated. M must be at least zero.
08616 *
08617 *  N       (global input) INTEGER
08618 *          On entry,  N specifies the global number of matrix columns of
08619 *          the  submatrix  sub( A )  to be generated. N must be at least
08620 *          zero.
08621 *
08622 *  IA      (global input) INTEGER
08623 *          On entry, IA  specifies A's global row index, which points to
08624 *          the beginning of the submatrix sub( A ).
08625 *
08626 *  JA      (global input) INTEGER
08627 *          On entry, JA  specifies A's global column index, which points
08628 *          to the beginning of the submatrix sub( A ).
08629 *
08630 *  DESCA   (global and local input) INTEGER array
08631 *          On entry, DESCA  is an integer array of dimension DLEN_. This
08632 *          is the array descriptor for the matrix A.
08633 *
08634 *  IASEED  (global input) INTEGER
08635 *          On entry, IASEED  specifies  the  seed number to generate the
08636 *          matrix A. IASEED must be at least zero.
08637 *
08638 *  A       (local output) COMPLEX*16 array
08639 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
08640 *          at least Lc( 1, JA+N-1 ).  On  exit, this array  contains the
08641 *          local entries of the randomly generated submatrix sub( A ).
08642 *
08643 *  LDA     (local input) INTEGER
08644 *          On entry,  LDA  specifies  the local leading dimension of the
08645 *          array A. When INPLACE is .FALSE., LDA is usually DESCA(LLD_).
08646 *          This restriction is however not enforced, and this subroutine
08647 *          requires only that LDA >= MAX( 1, Mp ) where
08648 *
08649 *          Mp = PB_NUMROC( M, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ).
08650 *
08651 *          PB_NUMROC  is  a ScaLAPACK tool function; MYROW, MYCOL, NPROW
08652 *          and NPCOL  can  be determined by calling the BLACS subroutine
08653 *          BLACS_GRIDINFO.
08654 *
08655 *  Further Details
08656 *  ===============
08657 *
08658 *  OFFD  is  tied  to  the matrix described by  DESCA, as opposed to the
08659 *  piece that is currently  (re)generated.  This is a global information
08660 *  independent from the distribution  parameters.  Below are examples of
08661 *  the meaning of OFFD for a global 7 by 5 matrix:
08662 *
08663 *  ---------------------------------------------------------------------
08664 *  OFFD   |  0 -1 -2 -3 -4         0 -1 -2 -3 -4          0 -1 -2 -3 -4
08665 *  -------|-------------------------------------------------------------
08666 *         |     | OFFD=-1          |   OFFD=0                 OFFD=2
08667 *         |     V                  V
08668 *  0      |  .  d  .  .  .      -> d  .  .  .  .          .  .  .  .  .
08669 *  1      |  .  .  d  .  .         .  d  .  .  .          .  .  .  .  .
08670 *  2      |  .  .  .  d  .         .  .  d  .  .       -> d  .  .  .  .
08671 *  3      |  .  .  .  .  d         .  .  .  d  .          .  d  .  .  .
08672 *  4      |  .  .  .  .  .         .  .  .  .  d          .  .  d  .  .
08673 *  5      |  .  .  .  .  .         .  .  .  .  .          .  .  .  d  .
08674 *  6      |  .  .  .  .  .         .  .  .  .  .          .  .  .  .  d
08675 *  ---------------------------------------------------------------------
08676 *
08677 *  -- Written on April 1, 1998 by
08678 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
08679 *
08680 *  =====================================================================
08681 *
08682 *     .. Parameters ..
08683       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
08684      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
08685      $                   RSRC_
08686       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
08687      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
08688      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
08689      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
08690       INTEGER            JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
08691      $                   JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
08692      $                   JMP_NQINBLOC, JMP_NQNB, JMP_ROW
08693       PARAMETER          ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3,
08694      $                   JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6,
08695      $                   JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9,
08696      $                   JMP_NQNB = 10, JMP_NQINBLOC = 11,
08697      $                   JMP_LEN = 11 )
08698       DOUBLE PRECISION   ZERO
08699       PARAMETER          ( ZERO = 0.0D+0 )
08700 *     ..
08701 *     .. Local Scalars ..
08702       LOGICAL            DIAGDO, SYMM, HERM, NOTRAN
08703       INTEGER            CSRC, I, IACOL, IAROW, ICTXT, IIA, ILOCBLK,
08704      $                   ILOCOFF, ILOW, IMB, IMB1, IMBLOC, IMBVIR, INB,
08705      $                   INB1, INBLOC, INBVIR, INFO, IOFFDA, ITMP, IUPP,
08706      $                   IVIR, JJA, JLOCBLK, JLOCOFF, JVIR, LCMT00,
08707      $                   LMBLOC, LNBLOC, LOW, MAXMN, MB, MBLKS, MP,
08708      $                   MRCOL, MRROW, MYCDIST, MYCOL, MYRDIST, MYROW,
08709      $                   NB, NBLKS, NPCOL, NPROW, NQ, NVIR, RSRC, UPP
08710       COMPLEX*16         ALPHA
08711 *     ..
08712 *     .. Local Arrays ..
08713       INTEGER            DESCA2( DLEN_ ), IMULADD( 4, JMP_LEN ),
08714      $                   IRAN( 2 ), JMP( JMP_LEN ), MULADD0( 4 )
08715 *     ..
08716 *     .. External Subroutines ..
08717       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
08718      $                   PB_CHKMAT, PB_DESCTRANS, PB_INITJMP,
08719      $                   PB_INITMULADD, PB_JUMP, PB_JUMPIT, PB_LOCINFO,
08720      $                   PB_SETLOCRAN, PB_SETRAN, PB_ZLAGEN, PXERBLA,
08721      $                   PZLADOM
08722 *     ..
08723 *     .. External Functions ..
08724       LOGICAL            LSAME
08725       EXTERNAL           LSAME
08726 *     ..
08727 *     .. Intrinsic Functions ..
08728       INTRINSIC          DBLE, DCMPLX, MAX, MIN
08729 *     ..
08730 *     .. Data Statements ..
08731       DATA               ( MULADD0( I ), I = 1, 4 ) / 20077, 16838,
08732      $                   12345, 0 /
08733 *     ..
08734 *     .. Executable Statements ..
08735 *
08736 *     Convert descriptor
08737 *
08738       CALL PB_DESCTRANS( DESCA, DESCA2 )
08739 *
08740 *     Test the input arguments
08741 *
08742       ICTXT = DESCA2( CTXT_ )
08743       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
08744 *
08745 *     Test the input parameters
08746 *
08747       INFO = 0
08748       IF( NPROW.EQ.-1 ) THEN
08749          INFO = -( 1000 + CTXT_ )
08750       ELSE
08751          SYMM   = LSAME( AFORM, 'S' )
08752          HERM   = LSAME( AFORM, 'H' )
08753          NOTRAN = LSAME( AFORM, 'N' )
08754          DIAGDO = LSAME( DIAG, 'D' )
08755          IF( .NOT.( SYMM.OR.HERM.OR.NOTRAN ) .AND.
08756      $       .NOT.( LSAME( AFORM, 'T' )    ) .AND.
08757      $       .NOT.( LSAME( AFORM, 'C' )    ) ) THEN
08758             INFO = -2
08759          ELSE IF( ( .NOT.DIAGDO ) .AND.
08760      $            ( .NOT.LSAME( DIAG, 'N' ) ) ) THEN
08761             INFO = -3
08762          END IF
08763          CALL PB_CHKMAT( ICTXT, M, 5, N, 6, IA, JA, DESCA2, 10, INFO )
08764       END IF
08765 *
08766       IF( INFO.NE.0 ) THEN
08767          CALL PXERBLA( ICTXT, 'PZLAGEN', -INFO )
08768          RETURN
08769       END IF
08770 *
08771 *     Quick return if possible
08772 *
08773       IF( ( M.LE.0 ).OR.( N.LE.0 ) )
08774      $   RETURN
08775 *
08776 *     Start the operations
08777 *
08778       MB   = DESCA2( MB_   )
08779       NB   = DESCA2( NB_   )
08780       IMB  = DESCA2( IMB_  )
08781       INB  = DESCA2( INB_  )
08782       RSRC = DESCA2( RSRC_ )
08783       CSRC = DESCA2( CSRC_ )
08784 *
08785 *     Figure out local information about the distributed matrix operand
08786 *
08787       CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
08788      $                  MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
08789      $                  IACOL, MRROW, MRCOL )
08790 *
08791 *     Decide where the entries shall be stored in memory
08792 *
08793       IF( INPLACE ) THEN
08794          IIA = 1
08795          JJA = 1
08796       END IF
08797 *
08798 *     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
08799 *     ILOW, LOW, IUPP, and UPP.
08800 *
08801       IOFFDA = JA + OFFA - IA
08802       CALL PB_BINFO( IOFFDA, MP, NQ, IMB1, INB1, MB, NB, MRROW,
08803      $               MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC,
08804      $               LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP )
08805 *
08806 *     Initialize ILOCBLK, ILOCOFF, MYRDIST, JLOCBLK, JLOCOFF, MYCDIST
08807 *     This values correspond to the square virtual underlying matrix
08808 *     of size MAX( M_ + MAX( 0, -OFFA ), N_ + MAX( 0, OFFA ) ) used
08809 *     to set up the random sequence. For practical purposes, the size
08810 *     of this virtual matrix is upper bounded by M_ + N_ - 1.
08811 *
08812       ITMP   = MAX( 0, -OFFA )
08813       IVIR   = IA  + ITMP
08814       IMBVIR = IMB + ITMP
08815       NVIR   = DESCA2( M_ ) + ITMP
08816 *
08817       CALL PB_LOCINFO( IVIR, IMBVIR, MB, MYROW, RSRC, NPROW, ILOCBLK,
08818      $                 ILOCOFF, MYRDIST )
08819 *
08820       ITMP   = MAX( 0, OFFA )
08821       JVIR   = JA  + ITMP
08822       INBVIR = INB + ITMP
08823       NVIR   = MAX( MAX( NVIR, DESCA2( N_ ) + ITMP ),
08824      $              DESCA2( M_ ) + DESCA2( N_ ) - 1 )
08825 *
08826       CALL PB_LOCINFO( JVIR, INBVIR, NB, MYCOL, CSRC, NPCOL, JLOCBLK,
08827      $                 JLOCOFF, MYCDIST )
08828 *
08829       IF( SYMM .OR. HERM .OR. NOTRAN ) THEN
08830 *
08831          CALL PB_INITJMP( .TRUE., NVIR, IMBVIR, INBVIR, IMBLOC, INBLOC,
08832      $                    MB, NB, RSRC, CSRC, NPROW, NPCOL, 2, JMP )
08833 *
08834 *        Compute constants to jump JMP( * ) numbers in the sequence
08835 *
08836          CALL PB_INITMULADD( MULADD0, JMP, IMULADD )
08837 *
08838 *        Compute and set the random value corresponding to A( IA, JA )
08839 *
08840          CALL PB_SETLOCRAN( IASEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF,
08841      $                      MYRDIST, MYCDIST, NPROW, NPCOL, JMP,
08842      $                      IMULADD, IRAN )
08843 *
08844          CALL PB_ZLAGEN( 'Lower', AFORM, A( IIA, JJA ), LDA, LCMT00,
08845      $                   IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC,
08846      $                   NB, LNBLOC, JMP, IMULADD )
08847 *
08848       END IF
08849 *
08850       IF( SYMM .OR. HERM .OR. ( .NOT. NOTRAN ) ) THEN
08851 *
08852          CALL PB_INITJMP( .FALSE., NVIR, IMBVIR, INBVIR, IMBLOC, INBLOC,
08853      $                    MB, NB, RSRC, CSRC, NPROW, NPCOL, 2, JMP )
08854 *
08855 *        Compute constants to jump JMP( * ) numbers in the sequence
08856 *
08857          CALL PB_INITMULADD( MULADD0, JMP, IMULADD )
08858 *
08859 *        Compute and set the random value corresponding to A( IA, JA )
08860 *
08861          CALL PB_SETLOCRAN( IASEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF,
08862      $                      MYRDIST, MYCDIST, NPROW, NPCOL, JMP,
08863      $                      IMULADD, IRAN )
08864 *
08865          CALL PB_ZLAGEN( 'Upper', AFORM, A( IIA, JJA ), LDA, LCMT00,
08866      $                   IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC,
08867      $                   NB, LNBLOC, JMP, IMULADD )
08868 *
08869       END IF
08870 *
08871       IF( DIAGDO ) THEN
08872 *
08873          MAXMN = MAX( DESCA2( M_ ), DESCA2( N_ ) )
08874          IF( HERM ) THEN
08875             ALPHA = DCMPLX( DBLE( 2 * MAXMN ), ZERO )
08876          ELSE
08877             ALPHA = DCMPLX( DBLE( NVIR ), DBLE( MAXMN ) )
08878          END IF
08879 *
08880          IF( IOFFDA.GE.0 ) THEN
08881             CALL PZLADOM( INPLACE, MIN( MAX( 0, M-IOFFDA ), N ), ALPHA,
08882      $                    A, MIN( IA+IOFFDA, IA+M-1 ), JA, DESCA )
08883          ELSE
08884             CALL PZLADOM( INPLACE, MIN( M, MAX( 0, N+IOFFDA ) ), ALPHA,
08885      $                    A, IA, MIN( JA-IOFFDA, JA+N-1 ), DESCA )
08886          END IF
08887 *
08888       END IF
08889 *
08890       RETURN
08891 *
08892 *     End of PZLAGEN
08893 *
08894       END
08895       SUBROUTINE PZLADOM( INPLACE, N, ALPHA, A, IA, JA, DESCA )
08896 *
08897 *  -- PBLAS test routine (version 2.0) --
08898 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
08899 *     and University of California, Berkeley.
08900 *     April 1, 1998
08901 *
08902 *     .. Scalar Arguments ..
08903       LOGICAL            INPLACE
08904       INTEGER            IA, JA, N
08905       COMPLEX*16         ALPHA
08906 *     ..
08907 *     .. Array Arguments ..
08908       INTEGER            DESCA( * )
08909       COMPLEX*16         A( * )
08910 *     ..
08911 *
08912 *  Purpose
08913 *  =======
08914 *
08915 *  PZLADOM  adds alpha to the diagonal entries  of  an  n by n submatrix
08916 *  sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ).
08917 *
08918 *  Notes
08919 *  =====
08920 *
08921 *  A description  vector  is associated with each 2D block-cyclicly dis-
08922 *  tributed matrix.  This  vector  stores  the  information  required to
08923 *  establish the  mapping  between a  matrix entry and its corresponding
08924 *  process and memory location.
08925 *
08926 *  In  the  following  comments,   the character _  should  be  read  as
08927 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
08928 *  block cyclicly distributed matrix.  Its description vector is DESCA:
08929 *
08930 *  NOTATION         STORED IN       EXPLANATION
08931 *  ---------------- --------------- ------------------------------------
08932 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
08933 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
08934 *                                   the NPROW x NPCOL BLACS process grid
08935 *                                   A  is distributed over.  The context
08936 *                                   itself  is  global,  but  the handle
08937 *                                   (the integer value) may vary.
08938 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
08939 *                                   ted matrix A, M_A >= 0.
08940 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
08941 *                                   buted matrix A, N_A >= 0.
08942 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
08943 *                                   block of the matrix A, IMB_A > 0.
08944 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
08945 *                                   left   block   of   the   matrix  A,
08946 *                                   INB_A > 0.
08947 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
08948 *                                   bute the last  M_A-IMB_A rows of  A,
08949 *                                   MB_A > 0.
08950 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
08951 *                                   bute the last  N_A-INB_A  columns of
08952 *                                   A, NB_A > 0.
08953 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
08954 *                                   row of the matrix  A is distributed,
08955 *                                   NPROW > RSRC_A >= 0.
08956 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
08957 *                                   first  column of  A  is distributed.
08958 *                                   NPCOL > CSRC_A >= 0.
08959 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
08960 *                                   array  storing  the  local blocks of
08961 *                                   the distributed matrix A,
08962 *                                   IF( Lc( 1, N_A ) > 0 )
08963 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
08964 *                                   ELSE
08965 *                                      LLD_A >= 1.
08966 *
08967 *  Let K be the number of  rows of a matrix A starting at the global in-
08968 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
08969 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
08970 *  receive if these K rows were distributed over NPROW processes.  If  K
08971 *  is the number of columns of a matrix  A  starting at the global index
08972 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
08973 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
08974 *  these K columns were distributed over NPCOL processes.
08975 *
08976 *  The values of Lr() and Lc() may be determined via a call to the func-
08977 *  tion PB_NUMROC:
08978 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
08979 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
08980 *
08981 *  Arguments
08982 *  =========
08983 *
08984 *  INPLACE (global input) LOGICAL
08985 *          On entry, INPLACE specifies if the matrix should be generated
08986 *          in place or not. If INPLACE is .TRUE., the local random array
08987 *          to be generated  will start in memory at the local memory lo-
08988 *          cation A( 1, 1 ),  otherwise it will start at the local posi-
08989 *          tion induced by IA and JA.
08990 *
08991 *  N       (global input) INTEGER
08992 *          On entry,  N  specifies  the  global  order  of the submatrix
08993 *          sub( A ) to be modified. N must be at least zero.
08994 *
08995 *  ALPHA   (global input) COMPLEX*16
08996 *          On entry, ALPHA specifies the scalar alpha.
08997 *
08998 *  A       (local input/local output) COMPLEX*16 array
08999 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
09000 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
09001 *          the local entries of the matrix A. On exit, the local entries
09002 *          of this array corresponding to the main diagonal of  sub( A )
09003 *          have been updated.
09004 *
09005 *  IA      (global input) INTEGER
09006 *          On entry, IA  specifies A's global row index, which points to
09007 *          the beginning of the submatrix sub( A ).
09008 *
09009 *  JA      (global input) INTEGER
09010 *          On entry, JA  specifies A's global column index, which points
09011 *          to the beginning of the submatrix sub( A ).
09012 *
09013 *  DESCA   (global and local input) INTEGER array
09014 *          On entry, DESCA  is an integer array of dimension DLEN_. This
09015 *          is the array descriptor for the matrix A.
09016 *
09017 *  -- Written on April 1, 1998 by
09018 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
09019 *
09020 *  =====================================================================
09021 *
09022 *     .. Parameters ..
09023       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
09024      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
09025      $                   RSRC_
09026       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
09027      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
09028      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
09029      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
09030 *     ..
09031 *     .. Local Scalars ..
09032       LOGICAL            GODOWN, GOLEFT
09033       INTEGER            I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW,
09034      $                   IMB1, IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP,
09035      $                   JJA, JOFFA, JOFFD, LCMT, LCMT00, LDA, LDAP1,
09036      $                   LMBLOC, LNBLOC, LOW, MB, MBLKD, MBLKS, MBLOC,
09037      $                   MRCOL, MRROW, MYCOL, MYROW, NB, NBLKD, NBLKS,
09038      $                   NBLOC, NP, NPCOL, NPROW, NQ, PMB, QNB, UPP
09039       COMPLEX*16         ATMP
09040 *     ..
09041 *     .. Local Scalars ..
09042       INTEGER            DESCA2( DLEN_ )
09043 *     ..
09044 *     .. External Subroutines ..
09045       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
09046      $                   PB_DESCTRANS
09047 *     ..
09048 *     .. Intrinsic Functions ..
09049       INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, MAX, MIN
09050 *     ..
09051 *     .. Executable Statements ..
09052 *
09053 *     Convert descriptor
09054 *
09055       CALL PB_DESCTRANS( DESCA, DESCA2 )
09056 *
09057 *     Get grid parameters
09058 *
09059       ICTXT = DESCA2( CTXT_ )
09060       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
09061 *
09062       IF( N.EQ.0 )
09063      $   RETURN
09064 *
09065       CALL PB_AINFOG2L( N, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
09066      $                  MYCOL, IMB1, INB1, NP, NQ, IIA, JJA, IAROW,
09067      $                  IACOL, MRROW, MRCOL )
09068 *
09069 *     Decide where the entries shall be stored in memory
09070 *
09071       IF( INPLACE ) THEN
09072          IIA = 1
09073          JJA = 1
09074       END IF
09075 *
09076 *     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
09077 *     ILOW, LOW, IUPP, and UPP.
09078 *
09079       MB = DESCA2( MB_ )
09080       NB = DESCA2( NB_ )
09081 *
09082       CALL PB_BINFO( 0, NP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL,
09083      $               LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
09084      $               LNBLOC, ILOW, LOW, IUPP, UPP )
09085 *
09086       IOFFA  = IIA - 1
09087       JOFFA  = JJA - 1
09088       LDA    = DESCA2( LLD_ )
09089       LDAP1  = LDA + 1
09090 *
09091       IF( DESCA2( RSRC_ ).LT.0 ) THEN
09092          PMB = MB
09093       ELSE
09094          PMB = NPROW * MB
09095       END IF
09096       IF( DESCA2( CSRC_ ).LT.0 ) THEN
09097          QNB = NB
09098       ELSE
09099          QNB = NPCOL * NB
09100       END IF
09101 *
09102 *     Handle the first block of rows or columns separately, and update
09103 *     LCMT00, MBLKS and NBLKS.
09104 *
09105       GODOWN = ( LCMT00.GT.IUPP )
09106       GOLEFT = ( LCMT00.LT.ILOW )
09107 *
09108       IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN
09109 *
09110 *        LCMT00 >= ILOW && LCMT00 <= IUPP
09111 *
09112          IF( LCMT00.GE.0 ) THEN
09113             IJOFFA = IOFFA+LCMT00 + ( JOFFA - 1 ) * LDA
09114             DO 10 I = 1, MIN( INBLOC, MAX( 0, IMBLOC - LCMT00 ) )
09115                ATMP = A( IJOFFA + I*LDAP1 )
09116                A( IJOFFA + I*LDAP1 ) = ALPHA +
09117      $                                 DCMPLX( ABS( DBLE(  ATMP ) ),
09118      $                                         ABS( DIMAG( ATMP ) ) )
09119    10       CONTINUE
09120          ELSE
09121             IJOFFA = IOFFA + ( JOFFA - LCMT00 - 1 ) * LDA
09122             DO 20 I = 1, MIN( IMBLOC, MAX( 0, INBLOC + LCMT00 ) )
09123                ATMP = A( IJOFFA + I*LDAP1 )
09124                A( IJOFFA + I*LDAP1 ) = ALPHA +
09125      $                                 DCMPLX( ABS( DBLE(  ATMP ) ),
09126      $                                         ABS( DIMAG( ATMP ) ) )
09127    20       CONTINUE
09128          END IF
09129          GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW )
09130          GODOWN = .NOT.GOLEFT
09131 *
09132       END IF
09133 *
09134       IF( GODOWN ) THEN
09135 *
09136          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
09137          MBLKS  = MBLKS - 1
09138          IOFFA  = IOFFA + IMBLOC
09139 *
09140    30    CONTINUE
09141          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
09142             LCMT00 = LCMT00 - PMB
09143             MBLKS  = MBLKS - 1
09144             IOFFA  = IOFFA + MB
09145             GO TO 30
09146          END IF
09147 *
09148          LCMT  = LCMT00
09149          MBLKD = MBLKS
09150          IOFFD = IOFFA
09151 *
09152          MBLOC = MB
09153    40    CONTINUE
09154          IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN
09155             IF( MBLKD.EQ.1 )
09156      $         MBLOC = LMBLOC
09157             IF( LCMT.GE.0 ) THEN
09158                IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
09159                DO 50 I = 1, MIN( INBLOC, MAX( 0, MBLOC - LCMT ) )
09160                   ATMP = A( IJOFFA + I*LDAP1 )
09161                   A( IJOFFA + I*LDAP1 ) = ALPHA +
09162      $                                    DCMPLX( ABS( DBLE(  ATMP ) ),
09163      $                                            ABS( DIMAG( ATMP ) ) )
09164    50          CONTINUE
09165             ELSE
09166                IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
09167                DO 60 I = 1, MIN( MBLOC, MAX( 0, INBLOC + LCMT ) )
09168                   ATMP = A( IJOFFA + I*LDAP1 )
09169                   A( IJOFFA + I*LDAP1 ) = ALPHA +
09170      $                                    DCMPLX( ABS( DBLE(  ATMP ) ),
09171      $                                            ABS( DIMAG( ATMP ) ) )
09172    60          CONTINUE
09173             END IF
09174             LCMT00 = LCMT
09175             LCMT   = LCMT - PMB
09176             MBLKS  = MBLKD
09177             MBLKD  = MBLKD - 1
09178             IOFFA  = IOFFD
09179             IOFFD  = IOFFD + MBLOC
09180             GO TO 40
09181          END IF
09182 *
09183          LCMT00 = LCMT00 + LOW - ILOW + QNB
09184          NBLKS  = NBLKS - 1
09185          JOFFA  = JOFFA + INBLOC
09186 *
09187       ELSE IF( GOLEFT ) THEN
09188 *
09189          LCMT00 = LCMT00 + LOW - ILOW + QNB
09190          NBLKS  = NBLKS - 1
09191          JOFFA  = JOFFA + INBLOC
09192 *
09193    70    CONTINUE
09194          IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN
09195             LCMT00 = LCMT00 + QNB
09196             NBLKS  = NBLKS - 1
09197             JOFFA  = JOFFA + NB
09198             GO TO 70
09199          END IF
09200 *
09201          LCMT  = LCMT00
09202          NBLKD = NBLKS
09203          JOFFD = JOFFA
09204 *
09205          NBLOC = NB
09206    80    CONTINUE
09207          IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN
09208             IF( NBLKD.EQ.1 )
09209      $         NBLOC = LNBLOC
09210             IF( LCMT.GE.0 ) THEN
09211                IJOFFA = IOFFA + LCMT + ( JOFFD - 1 ) * LDA
09212                DO 90 I = 1, MIN( NBLOC, MAX( 0, IMBLOC - LCMT ) )
09213                   ATMP = A( IJOFFA + I*LDAP1 )
09214                   A( IJOFFA + I*LDAP1 ) = ALPHA +
09215      $                                    DCMPLX( ABS( DBLE(  ATMP ) ),
09216      $                                            ABS( DIMAG( ATMP ) ) )
09217    90          CONTINUE
09218             ELSE
09219                IJOFFA = IOFFA + ( JOFFD - LCMT - 1 ) * LDA
09220                DO 100 I = 1, MIN( IMBLOC, MAX( 0, NBLOC + LCMT ) )
09221                   ATMP = A( IJOFFA + I*LDAP1 )
09222                   A( IJOFFA + I*LDAP1 ) = ALPHA +
09223      $                                    DCMPLX( ABS( DBLE(  ATMP ) ),
09224      $                                            ABS( DIMAG( ATMP ) ) )
09225   100          CONTINUE
09226             END IF
09227             LCMT00 = LCMT
09228             LCMT   = LCMT + QNB
09229             NBLKS  = NBLKD
09230             NBLKD  = NBLKD - 1
09231             JOFFA  = JOFFD
09232             JOFFD  = JOFFD + NBLOC
09233             GO TO 80
09234          END IF
09235 *
09236          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
09237          MBLKS  = MBLKS - 1
09238          IOFFA  = IOFFA + IMBLOC
09239 *
09240       END IF
09241 *
09242       NBLOC = NB
09243   110 CONTINUE
09244       IF( NBLKS.GT.0 ) THEN
09245          IF( NBLKS.EQ.1 )
09246      $      NBLOC = LNBLOC
09247   120    CONTINUE
09248          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
09249             LCMT00 = LCMT00 - PMB
09250             MBLKS  = MBLKS - 1
09251             IOFFA  = IOFFA + MB
09252             GO TO 120
09253          END IF
09254 *
09255          LCMT  = LCMT00
09256          MBLKD = MBLKS
09257          IOFFD = IOFFA
09258 *
09259          MBLOC = MB
09260   130    CONTINUE
09261          IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN
09262             IF( MBLKD.EQ.1 )
09263      $         MBLOC = LMBLOC
09264             IF( LCMT.GE.0 ) THEN
09265                IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
09266                DO 140 I = 1, MIN( NBLOC, MAX( 0, MBLOC - LCMT ) )
09267                   ATMP = A( IJOFFA + I*LDAP1 )
09268                   A( IJOFFA + I*LDAP1 ) = ALPHA +
09269      $                                    DCMPLX( ABS( DBLE(  ATMP ) ),
09270      $                                            ABS( DIMAG( ATMP ) ) )
09271   140          CONTINUE
09272             ELSE
09273                IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
09274                DO 150 I = 1, MIN( MBLOC, MAX( 0, NBLOC + LCMT ) )
09275                   ATMP = A( IJOFFA + I*LDAP1 )
09276                   A( IJOFFA + I*LDAP1 ) = ALPHA +
09277      $                                    DCMPLX( ABS( DBLE(  ATMP ) ),
09278      $                                            ABS( DIMAG( ATMP ) ) )
09279   150          CONTINUE
09280             END IF
09281             LCMT00 = LCMT
09282             LCMT   = LCMT - PMB
09283             MBLKS  = MBLKD
09284             MBLKD  = MBLKD - 1
09285             IOFFA  = IOFFD
09286             IOFFD  = IOFFD + MBLOC
09287             GO TO 130
09288          END IF
09289 *
09290          LCMT00 = LCMT00 + QNB
09291          NBLKS  = NBLKS - 1
09292          JOFFA  = JOFFA + NBLOC
09293          GO TO 110
09294 *
09295       END IF
09296 *
09297       RETURN
09298 *
09299 *     End of PZLADOM
09300 *
09301       END
09302       SUBROUTINE PB_PZLAPRNT( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT,
09303      $                        CMATNM, NOUT, WORK )
09304 *
09305 *  -- PBLAS test routine (version 2.0) --
09306 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
09307 *     and University of California, Berkeley.
09308 *     April 1, 1998
09309 *
09310 *     .. Scalar Arguments ..
09311       INTEGER            IA, ICPRNT, IRPRNT, JA, M, N, NOUT
09312 *     ..
09313 *     .. Array Arguments ..
09314       CHARACTER*(*)      CMATNM
09315       INTEGER            DESCA( * )
09316       COMPLEX*16         A( * ), WORK( * )
09317 *     ..
09318 *
09319 *  Purpose
09320 *  =======
09321 *
09322 *  PB_PZLAPRNT  prints to the standard output a submatrix sub( A ) deno-
09323 *  ting A(IA:IA+M-1,JA:JA+N-1). The local pieces are sent and printed by
09324 *  the process of coordinates (IRPRNT, ICPRNT).
09325 *
09326 *  Notes
09327 *  =====
09328 *
09329 *  A description  vector  is associated with each 2D block-cyclicly dis-
09330 *  tributed matrix.  This  vector  stores  the  information  required to
09331 *  establish the  mapping  between a  matrix entry and its corresponding
09332 *  process and memory location.
09333 *
09334 *  In  the  following  comments,   the character _  should  be  read  as
09335 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
09336 *  block cyclicly distributed matrix.  Its description vector is DESCA:
09337 *
09338 *  NOTATION         STORED IN       EXPLANATION
09339 *  ---------------- --------------- ------------------------------------
09340 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
09341 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
09342 *                                   the NPROW x NPCOL BLACS process grid
09343 *                                   A  is distributed over.  The context
09344 *                                   itself  is  global,  but  the handle
09345 *                                   (the integer value) may vary.
09346 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
09347 *                                   ted matrix A, M_A >= 0.
09348 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
09349 *                                   buted matrix A, N_A >= 0.
09350 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
09351 *                                   block of the matrix A, IMB_A > 0.
09352 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
09353 *                                   left   block   of   the   matrix  A,
09354 *                                   INB_A > 0.
09355 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
09356 *                                   bute the last  M_A-IMB_A rows of  A,
09357 *                                   MB_A > 0.
09358 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
09359 *                                   bute the last  N_A-INB_A  columns of
09360 *                                   A, NB_A > 0.
09361 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
09362 *                                   row of the matrix  A is distributed,
09363 *                                   NPROW > RSRC_A >= 0.
09364 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
09365 *                                   first  column of  A  is distributed.
09366 *                                   NPCOL > CSRC_A >= 0.
09367 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
09368 *                                   array  storing  the  local blocks of
09369 *                                   the distributed matrix A,
09370 *                                   IF( Lc( 1, N_A ) > 0 )
09371 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
09372 *                                   ELSE
09373 *                                      LLD_A >= 1.
09374 *
09375 *  Let K be the number of  rows of a matrix A starting at the global in-
09376 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
09377 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
09378 *  receive if these K rows were distributed over NPROW processes.  If  K
09379 *  is the number of columns of a matrix  A  starting at the global index
09380 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
09381 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
09382 *  these K columns were distributed over NPCOL processes.
09383 *
09384 *  The values of Lr() and Lc() may be determined via a call to the func-
09385 *  tion PB_NUMROC:
09386 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
09387 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
09388 *
09389 *  Arguments
09390 *  =========
09391 *
09392 *  M       (global input) INTEGER
09393 *          On entry,  M  specifies the number of rows of  the  submatrix
09394 *          sub( A ). M  must be at least zero.
09395 *
09396 *  N       (global input) INTEGER
09397 *          On entry, N  specifies the number of columns of the submatrix
09398 *          sub( A ). N must be at least zero.
09399 *
09400 *  A       (local input) COMPLEX*16 array
09401 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
09402 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
09403 *          the local entries of the matrix A.
09404 *
09405 *  IA      (global input) INTEGER
09406 *          On entry, IA  specifies A's global row index, which points to
09407 *          the beginning of the submatrix sub( A ).
09408 *
09409 *  JA      (global input) INTEGER
09410 *          On entry, JA  specifies A's global column index, which points
09411 *          to the beginning of the submatrix sub( A ).
09412 *
09413 *  DESCA   (global and local input) INTEGER array
09414 *          On entry, DESCA  is an integer array of dimension DLEN_. This
09415 *          is the array descriptor for the matrix A.
09416 *
09417 *  IRPRNT  (global input) INTEGER
09418 *          On entry, IRPRNT specifies the row index of the printing pro-
09419 *          cess.
09420 *
09421 *  ICPRNT  (global input) INTEGER
09422 *          On entry, ICPRNT specifies the  column  index of the printing
09423 *          process.
09424 *
09425 *  CMATNM  (global input) CHARACTER*(*)
09426 *          On entry, CMATNM is the name of the matrix to be printed.
09427 *
09428 *  NOUT    (global input) INTEGER
09429 *          On entry, NOUT specifies the output unit number. When NOUT is
09430 *          equal to 6, the submatrix is printed on the screen.
09431 *
09432 *  WORK    (local workspace) COMPLEX*16 array
09433 *          On entry, WORK is a work array of dimension at least equal to
09434 *          MAX( IMB_A, MB_A ).
09435 *
09436 *  -- Written on April 1, 1998 by
09437 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
09438 *
09439 *  =====================================================================
09440 *
09441 *     .. Parameters ..
09442       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
09443      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
09444      $                   RSRC_
09445       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
09446      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
09447      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
09448      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
09449 *     ..
09450 *     .. Local Scalars ..
09451       INTEGER            MYCOL, MYROW, NPCOL, NPROW, PCOL, PROW
09452 *     ..
09453 *     .. Local Arrays ..
09454       INTEGER            DESCA2( DLEN_ )
09455 *     ..
09456 *     .. External Subroutines ..
09457       EXTERNAL           BLACS_GRIDINFO, PB_DESCTRANS, PB_PZLAPRN2
09458 *     ..
09459 *     .. Executable Statements ..
09460 *
09461 *     Quick return if possible
09462 *
09463       IF( ( M.LE.0 ).OR.( N.LE.0 ) )
09464      $   RETURN
09465 *
09466 *     Convert descriptor
09467 *
09468       CALL PB_DESCTRANS( DESCA, DESCA2 )
09469 *
09470       CALL BLACS_GRIDINFO( DESCA2( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
09471 *
09472       IF( DESCA2( RSRC_ ).GE.0 ) THEN
09473          IF( DESCA2( CSRC_ ).GE.0 ) THEN
09474             CALL PB_PZLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT, ICPRNT,
09475      $                        CMATNM, NOUT, DESCA2( RSRC_ ),
09476      $                        DESCA2( CSRC_ ), WORK )
09477          ELSE
09478             DO 10 PCOL = 0, NPCOL - 1
09479                IF( ( MYROW.EQ.IRPRNT ).AND.( MYCOL.EQ.ICPRNT ) )
09480      $            WRITE( NOUT, * ) 'Colum-replicated array -- ' ,
09481      $                             'copy in process column: ', PCOL
09482                CALL PB_PZLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT,
09483      $                           ICPRNT, CMATNM, NOUT, DESCA2( RSRC_ ),
09484      $                           PCOL, WORK )
09485    10       CONTINUE
09486          END IF
09487       ELSE
09488          IF( DESCA2( CSRC_ ).GE.0 ) THEN
09489             DO 20 PROW = 0, NPROW - 1
09490                IF( ( MYROW.EQ.IRPRNT ).AND.( MYCOL.EQ.ICPRNT ) )
09491      $            WRITE( NOUT, * ) 'Row-replicated array -- ' ,
09492      $                             'copy in process row: ', PROW
09493                CALL PB_PZLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT,
09494      $                           ICPRNT, CMATNM, NOUT, PROW,
09495      $                           DESCA2( CSRC_ ), WORK )
09496    20       CONTINUE
09497          ELSE
09498             DO 40 PROW = 0, NPROW - 1
09499                DO 30 PCOL = 0, NPCOL - 1
09500                   IF( ( MYROW.EQ.IRPRNT ).AND.( MYCOL.EQ.ICPRNT ) )
09501      $               WRITE( NOUT, * ) 'Replicated array -- ' ,
09502      $                      'copy in process (', PROW, ',', PCOL, ')'
09503                   CALL PB_PZLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT,
09504      $                              ICPRNT, CMATNM, NOUT, PROW, PCOL,
09505      $                              WORK )
09506    30          CONTINUE
09507    40       CONTINUE
09508          END IF
09509       END IF
09510 *
09511       RETURN
09512 *
09513 *     End of PB_PZLAPRNT
09514 *
09515       END
09516       SUBROUTINE PB_PZLAPRN2( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT,
09517      $                        CMATNM, NOUT, PROW, PCOL, WORK )
09518 *
09519 *  -- PBLAS test routine (version 2.0) --
09520 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
09521 *     and University of California, Berkeley.
09522 *     April 1, 1998
09523 *
09524 *     .. Scalar Arguments ..
09525       INTEGER            IA, ICPRNT, IRPRNT, JA, M, N, NOUT, PCOL, PROW
09526 *     ..
09527 *     .. Array Arguments ..
09528       CHARACTER*(*)      CMATNM
09529       INTEGER            DESCA( * )
09530       COMPLEX*16         A( * ), WORK( * )
09531 *     ..
09532 *
09533 *     .. Parameters ..
09534       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
09535      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
09536      $                   RSRC_
09537       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
09538      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
09539      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
09540      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
09541 *     ..
09542 *     .. Local Scalars ..
09543       LOGICAL            AISCOLREP, AISROWREP
09544       INTEGER            H, I, IACOL, IAROW, IB, ICTXT, ICURCOL,
09545      $                   ICURROW, II, IIA, IN, J, JB, JJ, JJA, JN, K,
09546      $                   LDA, LDW, MYCOL, MYROW, NPCOL, NPROW
09547 *     ..
09548 *     .. External Subroutines ..
09549       EXTERNAL           BLACS_BARRIER, BLACS_GRIDINFO, PB_INFOG2L,
09550      $                   ZGERV2D, ZGESD2D
09551 *     ..
09552 *     .. Intrinsic Functions ..
09553       INTRINSIC          DBLE, DIMAG, MIN
09554 *     ..
09555 *     .. Executable Statements ..
09556 *
09557 *     Get grid parameters
09558 *
09559       ICTXT = DESCA( CTXT_ )
09560       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
09561       CALL PB_INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL,
09562      $                 IIA, JJA, IAROW, IACOL )
09563       II = IIA
09564       JJ = JJA
09565       IF( DESCA( RSRC_ ).LT.0 ) THEN
09566          AISROWREP = .TRUE.
09567          IAROW     = PROW
09568          ICURROW   = PROW
09569       ELSE
09570          AISROWREP = .FALSE.
09571          ICURROW   = IAROW
09572       END IF
09573       IF( DESCA( CSRC_ ).LT.0 ) THEN
09574          AISCOLREP = .TRUE.
09575          IACOL     = PCOL
09576          ICURCOL   = PCOL
09577       ELSE
09578          AISCOLREP = .FALSE.
09579          ICURCOL   = IACOL
09580       END IF
09581       LDA = DESCA( LLD_ )
09582       LDW = MAX( DESCA( IMB_ ), DESCA( MB_ ) )
09583 *
09584 *     Handle the first block of column separately
09585 *
09586       JB = DESCA( INB_ ) - JA + 1
09587       IF( JB.LE.0 )
09588      $   JB = ( (-JB) / DESCA( NB_ ) + 1 ) * DESCA( NB_ ) + JB
09589       JB = MIN( JB, N )
09590       JN = JA+JB-1
09591       DO 60 H = 0, JB-1
09592          IB = DESCA( IMB_ ) - IA + 1
09593          IF( IB.LE.0 )
09594      $      IB = ( (-IB) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
09595          IB = MIN( IB, M )
09596          IN = IA+IB-1
09597          IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN
09598             IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09599                DO 10 K = 0, IB-1
09600                   WRITE( NOUT, FMT = 9999 )
09601      $                   CMATNM, IA+K, JA+H,
09602      $                   DBLE( A( II+K+(JJ+H-1)*LDA ) ),
09603      $                   DIMAG( A( II+K+(JJ+H-1)*LDA ) )
09604    10          CONTINUE
09605             END IF
09606          ELSE
09607             IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN
09608                CALL ZGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ), LDA,
09609      $                       IRPRNT, ICPRNT )
09610             ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09611                CALL ZGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW, ICURCOL )
09612                DO 20 K = 1, IB
09613                   WRITE( NOUT, FMT = 9999 )
09614      $                   CMATNM, IA+K-1, JA+H, DBLE( WORK( K ) ),
09615      $                   DIMAG( WORK( K ) )
09616    20          CONTINUE
09617             END IF
09618          END IF
09619          IF( MYROW.EQ.ICURROW )
09620      $      II = II + IB
09621          IF( .NOT.AISROWREP )
09622      $      ICURROW = MOD( ICURROW+1, NPROW )
09623          CALL BLACS_BARRIER( ICTXT, 'All' )
09624 *
09625 *        Loop over remaining block of rows
09626 *
09627          DO 50 I = IN+1, IA+M-1, DESCA( MB_ )
09628             IB = MIN( DESCA( MB_ ), IA+M-I )
09629             IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN
09630                IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09631                   DO 30 K = 0, IB-1
09632                      WRITE( NOUT, FMT = 9999 )
09633      $                      CMATNM, I+K, JA+H,
09634      $                      DBLE( A( II+K+(JJ+H-1)*LDA ) ),
09635      $                      DIMAG( A( II+K+(JJ+H-1)*LDA ) )
09636    30             CONTINUE
09637                END IF
09638             ELSE
09639                IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN
09640                   CALL ZGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ),
09641      $                          LDA, IRPRNT, ICPRNT )
09642                ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09643                   CALL ZGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW,
09644      $                          ICURCOL )
09645                   DO 40 K = 1, IB
09646                      WRITE( NOUT, FMT = 9999 )
09647      $                      CMATNM, I+K-1, JA+H, DBLE( WORK( K ) ),
09648      $                      DIMAG( WORK( K ) )
09649    40             CONTINUE
09650                END IF
09651             END IF
09652             IF( MYROW.EQ.ICURROW )
09653      $         II = II + IB
09654             IF( .NOT.AISROWREP )
09655      $         ICURROW = MOD( ICURROW+1, NPROW )
09656             CALL BLACS_BARRIER( ICTXT, 'All' )
09657    50    CONTINUE
09658 *
09659          II = IIA
09660          ICURROW = IAROW
09661    60 CONTINUE
09662 *
09663       IF( MYCOL.EQ.ICURCOL )
09664      $   JJ = JJ + JB
09665       IF( .NOT.AISCOLREP )
09666      $   ICURCOL = MOD( ICURCOL+1, NPCOL )
09667       CALL BLACS_BARRIER( ICTXT, 'All' )
09668 *
09669 *     Loop over remaining column blocks
09670 *
09671       DO 130 J = JN+1, JA+N-1, DESCA( NB_ )
09672          JB = MIN(  DESCA( NB_ ), JA+N-J )
09673          DO 120 H = 0, JB-1
09674             IB = DESCA( IMB_ )-IA+1
09675             IF( IB.LE.0 )
09676      $         IB = ( (-IB) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
09677             IB = MIN( IB, M )
09678             IN = IA+IB-1
09679             IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN
09680                IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09681                   DO 70 K = 0, IB-1
09682                      WRITE( NOUT, FMT = 9999 )
09683      $                      CMATNM, IA+K, J+H,
09684      $                      DBLE( A( II+K+(JJ+H-1)*LDA ) ),
09685      $                      DIMAG( A( II+K+(JJ+H-1)*LDA ) )
09686    70             CONTINUE
09687                END IF
09688             ELSE
09689                IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN
09690                   CALL ZGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ),
09691      $                          LDA, IRPRNT, ICPRNT )
09692                ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09693                   CALL ZGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW,
09694      $                          ICURCOL )
09695                   DO 80 K = 1, IB
09696                      WRITE( NOUT, FMT = 9999 )
09697      $                      CMATNM, IA+K-1, J+H, DBLE( WORK( K ) ),
09698      $                      DIMAG( WORK( K ) )
09699    80             CONTINUE
09700                END IF
09701             END IF
09702             IF( MYROW.EQ.ICURROW )
09703      $         II = II + IB
09704             ICURROW = MOD( ICURROW+1, NPROW )
09705             CALL BLACS_BARRIER( ICTXT, 'All' )
09706 *
09707 *           Loop over remaining block of rows
09708 *
09709             DO 110 I = IN+1, IA+M-1, DESCA( MB_ )
09710                IB = MIN( DESCA( MB_ ), IA+M-I )
09711                IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN
09712                   IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09713                      DO 90 K = 0, IB-1
09714                         WRITE( NOUT, FMT = 9999 )
09715      $                         CMATNM, I+K, J+H,
09716      $                         DBLE( A( II+K+(JJ+H-1)*LDA ) ),
09717      $                         DIMAG( A( II+K+(JJ+H-1)*LDA ) )
09718    90                CONTINUE
09719                   END IF
09720                ELSE
09721                   IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN
09722                      CALL ZGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ),
09723      $                             LDA, IRPRNT, ICPRNT )
09724                    ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09725                      CALL ZGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW,
09726      $                             ICURCOL )
09727                      DO 100 K = 1, IB
09728                         WRITE( NOUT, FMT = 9999 )
09729      $                         CMATNM, I+K-1, J+H, DBLE( WORK( K ) ),
09730      $                         DIMAG( WORK( K ) )
09731   100                CONTINUE
09732                   END IF
09733                END IF
09734                IF( MYROW.EQ.ICURROW )
09735      $            II = II + IB
09736                IF( .NOT.AISROWREP )
09737      $            ICURROW = MOD( ICURROW+1, NPROW )
09738                CALL BLACS_BARRIER( ICTXT, 'All' )
09739   110       CONTINUE
09740 *
09741             II = IIA
09742             ICURROW = IAROW
09743   120    CONTINUE
09744 *
09745          IF( MYCOL.EQ.ICURCOL )
09746      $      JJ = JJ + JB
09747          IF( .NOT.AISCOLREP )
09748      $      ICURCOL = MOD( ICURCOL+1, NPCOL )
09749          CALL BLACS_BARRIER( ICTXT, 'All' )
09750 *
09751   130 CONTINUE
09752 *
09753  9999 FORMAT( 1X, A, '(', I6, ',', I6, ')=', D30.18, '+i*(',
09754      $        D30.18, ')' )
09755 *
09756       RETURN
09757 *
09758 *     End of PB_PZLAPRN2
09759 *
09760       END
09761       SUBROUTINE PB_ZFILLPAD( ICTXT, M, N, A, LDA, IPRE, IPOST, CHKVAL )
09762 *
09763 *  -- PBLAS test routine (version 2.0) --
09764 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
09765 *     and University of California, Berkeley.
09766 *     April 1, 1998
09767 *
09768 *     .. Scalar Arguments ..
09769       INTEGER            ICTXT, IPOST, IPRE, LDA, M, N
09770       COMPLEX*16         CHKVAL
09771 *     ..
09772 *     .. Array Arguments ..
09773       COMPLEX*16         A( * )
09774 *     ..
09775 *
09776 *  Purpose
09777 *  =======
09778 *
09779 *  PB_ZFILLPAD surrounds a two dimensional local array with a guard-zone
09780 *  initialized to the value CHKVAL. The user may later call the  routine
09781 *  PB_ZCHEKPAD to discover if the guardzone has been violated. There are
09782 *  three guardzones. The first is a buffer of size  IPRE  that is before
09783 *  the start of the array. The second is the buffer of size IPOST  which
09784 *  is after the end of the array to be padded. Finally, there is a guard
09785 *  zone inside every column of the array to be padded, in  the  elements
09786 *  of A(M+1:LDA, J).
09787 *
09788 *  Arguments
09789 *  =========
09790 *
09791 *  ICTXT   (local input) INTEGER
09792 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
09793 *          ting the global  context of the operation. The context itself
09794 *          is global, but the value of ICTXT is local.
09795 *
09796 *  M       (local input) INTEGER
09797 *          On entry, M  specifies the number of rows in the local  array
09798 *          A.  M must be at least zero.
09799 *
09800 *  N       (local input) INTEGER
09801 *          On entry, N  specifies the number of columns in the local ar-
09802 *          ray A. N must be at least zero.
09803 *
09804 *  A       (local input/local output) COMPLEX*16 array
09805 *          On entry,  A  is an array of dimension (LDA,N). On exit, this
09806 *          array is the padded array.
09807 *
09808 *  LDA     (local input) INTEGER
09809 *          On entry,  LDA  specifies  the leading dimension of the local
09810 *          array to be padded. LDA must be at least MAX( 1, M ).
09811 *
09812 *  IPRE    (local input) INTEGER
09813 *          On entry, IPRE specifies the size of  the  guard zone  to put
09814 *          before the start of the padded array.
09815 *
09816 *  IPOST   (local input) INTEGER
09817 *          On entry, IPOST specifies the size of the  guard zone  to put
09818 *          after the end of the padded array.
09819 *
09820 *  CHKVAL  (local input) COMPLEX*16
09821 *          On entry, CHKVAL specifies the value to pad the array with.
09822 *
09823 *  -- Written on April 1, 1998 by
09824 *     R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
09825 *
09826 *  =====================================================================
09827 *
09828 *     .. Local Scalars ..
09829       INTEGER            I, J, K
09830 *     ..
09831 *     .. Executable Statements ..
09832 *
09833 *     Put check buffer in front of A
09834 *
09835       IF( IPRE.GT.0 ) THEN
09836          DO 10 I = 1, IPRE
09837             A( I ) = CHKVAL
09838    10    CONTINUE
09839       ELSE
09840          WRITE( *, FMT = '(A)' )
09841      $          'WARNING no pre-guardzone in PB_ZFILLPAD'
09842       END IF
09843 *
09844 *     Put check buffer in back of A
09845 *
09846       IF( IPOST.GT.0 ) THEN
09847          J = IPRE+LDA*N+1
09848          DO 20 I = J, J+IPOST-1
09849             A( I ) = CHKVAL
09850    20    CONTINUE
09851       ELSE
09852          WRITE( *, FMT = '(A)' )
09853      $          'WARNING no post-guardzone in PB_ZFILLPAD'
09854       END IF
09855 *
09856 *     Put check buffer in all (LDA-M) gaps
09857 *
09858       IF( LDA.GT.M ) THEN
09859          K = IPRE + M + 1
09860          DO 40 J = 1, N
09861             DO 30 I = K, K + ( LDA - M ) - 1
09862                A( I ) = CHKVAL
09863    30       CONTINUE
09864             K = K + LDA
09865    40    CONTINUE
09866       END IF
09867 *
09868       RETURN
09869 *
09870 *     End of PB_ZFILLPAD
09871 *
09872       END
09873       SUBROUTINE PB_ZCHEKPAD( ICTXT, MESS, M, N, A, LDA, IPRE, IPOST,
09874      $                        CHKVAL )
09875 *
09876 *  -- PBLAS test routine (version 2.0) --
09877 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
09878 *     and University of California, Berkeley.
09879 *     April 1, 1998
09880 *
09881 *     .. Scalar Arguments ..
09882       INTEGER            ICTXT, IPOST, IPRE, LDA, M, N
09883       COMPLEX*16         CHKVAL
09884 *     ..
09885 *     .. Array Arguments ..
09886       CHARACTER*(*)      MESS
09887       COMPLEX*16         A( * )
09888 *     ..
09889 *
09890 *  Purpose
09891 *  =======
09892 *
09893 *  PB_ZCHEKPAD checks that the padding around a local array has not been
09894 *  overwritten since the call to PB_ZFILLPAD.  Three types of errors are
09895 *  reported:
09896 *
09897 *  1) Overwrite in pre-guardzone.  This indicates a memory overwrite has
09898 *  occurred in the  first  IPRE  elements which form a buffer before the
09899 *  beginning of A. Therefore, the error message:
09900 *     'Overwrite in  pre-guardzone: loc(  5) =         18.00000'
09901 *  tells that the 5th element of the IPRE long buffer has been overwrit-
09902 *  ten with the value 18, where it should still have the value CHKVAL.
09903 *
09904 *  2) Overwrite in post-guardzone. This indicates a memory overwrite has
09905 *  occurred in the last IPOST elements which form a buffer after the end
09906 *  of A. Error reports are refered from the end of A.  Therefore,
09907 *     'Overwrite in post-guardzone: loc( 19) =         24.00000'
09908 *  tells  that the  19th element after the end of A was overwritten with
09909 *  the value 24, where it should still have the value of CHKVAL.
09910 *
09911 *  3) Overwrite in lda-m gap.  Tells you elements between M and LDA were
09912 *  overwritten.  So,
09913 *     'Overwrite in lda-m gap: A( 12,  3) =         22.00000'
09914 *  tells  that the element at the 12th row and 3rd column of A was over-
09915 *  written with the value of 22, where it should still have the value of
09916 *  CHKVAL.
09917 *
09918 *  Arguments
09919 *  =========
09920 *
09921 *  ICTXT   (local input) INTEGER
09922 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
09923 *          ting the global  context of the operation. The context itself
09924 *          is global, but the value of ICTXT is local.
09925 *
09926 *  MESS    (local input) CHARACTER*(*)
09927 *          On entry, MESS is a ttring containing a user-defined message.
09928 *
09929 *  M       (local input) INTEGER
09930 *          On entry, M  specifies the number of rows in the local  array
09931 *          A.  M must be at least zero.
09932 *
09933 *  N       (local input) INTEGER
09934 *          On entry, N  specifies the number of columns in the local ar-
09935 *          ray A. N must be at least zero.
09936 *
09937 *  A       (local input) COMPLEX*16 array
09938 *          On entry,  A  is an array of dimension (LDA,N).
09939 *
09940 *  LDA     (local input) INTEGER
09941 *          On entry,  LDA  specifies  the leading dimension of the local
09942 *          array to be padded. LDA must be at least MAX( 1, M ).
09943 *
09944 *  IPRE    (local input) INTEGER
09945 *          On entry, IPRE specifies the size of  the  guard zone  to put
09946 *          before the start of the padded array.
09947 *
09948 *  IPOST   (local input) INTEGER
09949 *          On entry, IPOST specifies the size of the  guard zone  to put
09950 *          after the end of the padded array.
09951 *
09952 *  CHKVAL  (local input) COMPLEX*16
09953 *          On entry, CHKVAL specifies the value to pad the array with.
09954 *
09955 *
09956 *  -- Written on April 1, 1998 by
09957 *     R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
09958 *
09959 *  =====================================================================
09960 *
09961 *     .. Local Scalars ..
09962       CHARACTER*1        TOP
09963       INTEGER            I, IAM, IDUMM, INFO, J, K, MYCOL, MYROW, NPCOL,
09964      $                   NPROW
09965 *     ..
09966 *     .. External Subroutines ..
09967       EXTERNAL           BLACS_GRIDINFO, IGAMX2D, PB_TOPGET
09968 *     ..
09969 *     .. Intrinsic Functions ..
09970       INTRINSIC          DBLE, DIMAG
09971 *     ..
09972 *     .. Executable Statements ..
09973 *
09974 *     Get grid parameters
09975 *
09976       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
09977       IAM  = MYROW*NPCOL + MYCOL
09978       INFO = -1
09979 *
09980 *     Check buffer in front of A
09981 *
09982       IF( IPRE.GT.0 ) THEN
09983          DO 10 I = 1, IPRE
09984             IF( A( I ).NE.CHKVAL ) THEN
09985                WRITE( *, FMT = 9998 ) MYROW, MYCOL, MESS, ' pre', I,
09986      $                                DBLE( A( I ) ), DIMAG( A( I ) )
09987                INFO = IAM
09988             END IF
09989    10    CONTINUE
09990       ELSE
09991          WRITE( *, FMT = * ) 'WARNING no pre-guardzone in PB_ZCHEKPAD'
09992       END IF
09993 *
09994 *     Check buffer after A
09995 *
09996       IF( IPOST.GT.0 ) THEN
09997          J = IPRE+LDA*N+1
09998          DO 20 I = J, J+IPOST-1
09999             IF( A( I ).NE.CHKVAL ) THEN
10000                WRITE( *, FMT = 9998 ) MYROW, MYCOL, MESS, 'post',
10001      $                                I-J+1, DBLE( A( I ) ),
10002      $                                DIMAG( A( I ) )
10003                INFO = IAM
10004             END IF
10005    20    CONTINUE
10006       ELSE
10007          WRITE( *, FMT = * )
10008      $          'WARNING no post-guardzone buffer in PB_ZCHEKPAD'
10009       END IF
10010 *
10011 *     Check all (LDA-M) gaps
10012 *
10013       IF( LDA.GT.M ) THEN
10014          K = IPRE + M + 1
10015          DO 40 J = 1, N
10016             DO 30 I = K, K + (LDA-M) - 1
10017                IF( A( I ).NE.CHKVAL ) THEN
10018                   WRITE( *, FMT = 9997 ) MYROW, MYCOL, MESS,
10019      $               I-IPRE-LDA*(J-1), J, DBLE( A( I ) ),
10020      $               DIMAG( A( I ) )
10021                   INFO = IAM
10022                END IF
10023    30       CONTINUE
10024             K = K + LDA
10025    40    CONTINUE
10026       END IF
10027 *
10028       CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP )
10029       CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, IDUMM, IDUMM, -1,
10030      $              0, 0 )
10031       IF( IAM.EQ.0 .AND. INFO.GE.0 ) THEN
10032          WRITE( *, FMT = 9999 ) INFO / NPCOL, MOD( INFO, NPCOL ), MESS
10033       END IF
10034 *
10035  9999 FORMAT( '{', I5, ',', I5, '}:  Memory overwrite in ', A )
10036  9998 FORMAT( '{', I5, ',', I5, '}:  ', A, ' memory overwrite in ',
10037      $        A4, '-guardzone: loc(', I3, ') = ', G20.7, '+ i*',
10038      $        G20.7 )
10039  9997 FORMAT( '{', I5, ',', I5, '}: ', A, ' memory overwrite in ',
10040      $        'lda-m gap: loc(', I3, ',', I3, ') = ', G20.7,
10041      $        '+ i*', G20.7 )
10042 *
10043       RETURN
10044 *
10045 *     End of PB_ZCHEKPAD
10046 *
10047       END
10048       SUBROUTINE PB_ZLASET( UPLO, M, N, IOFFD, ALPHA, BETA, A, LDA )
10049 *
10050 *  -- PBLAS test routine (version 2.0) --
10051 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
10052 *     and University of California, Berkeley.
10053 *     April 1, 1998
10054 *
10055 *     .. Scalar Arguments ..
10056       CHARACTER*1        UPLO
10057       INTEGER            IOFFD, LDA, M, N
10058       COMPLEX*16         ALPHA, BETA
10059 *     ..
10060 *     .. Array Arguments ..
10061       COMPLEX*16         A( LDA, * )
10062 *     ..
10063 *
10064 *  Purpose
10065 *  =======
10066 *
10067 *  PB_ZLASET initializes a two-dimensional array A to beta on the diago-
10068 *  nal specified by IOFFD and alpha on the offdiagonals.
10069 *
10070 *  Arguments
10071 *  =========
10072 *
10073 *  UPLO    (global input) CHARACTER*1
10074 *          On entry,  UPLO  specifies  which trapezoidal part of the ar-
10075 *          ray A is to be set as follows:
10076 *             = 'L' or 'l':   Lower triangular part is set; the strictly
10077 *                             upper triangular part of A is not changed,
10078 *             = 'U' or 'u':   Upper triangular part is set; the strictly
10079 *                             lower triangular part of A is not changed,
10080 *             = 'D' or 'd'    Only the diagonal of A is set,
10081 *             Otherwise:      All of the array A is set.
10082 *
10083 *  M       (input) INTEGER
10084 *          On entry,  M  specifies the number of rows of the array A.  M
10085 *          must be at least zero.
10086 *
10087 *  N       (input) INTEGER
10088 *          On entry,  N  specifies the number of columns of the array A.
10089 *          N must be at least zero.
10090 *
10091 *  IOFFD   (input) INTEGER
10092 *          On entry, IOFFD specifies the position of the offdiagonal de-
10093 *          limiting the upper and lower trapezoidal part of A as follows
10094 *          (see the notes below):
10095 *
10096 *             IOFFD = 0  specifies the main diagonal A( i, i ),
10097 *                        with i = 1 ... MIN( M, N ),
10098 *             IOFFD > 0  specifies the subdiagonal   A( i+IOFFD, i ),
10099 *                        with i = 1 ... MIN( M-IOFFD, N ),
10100 *             IOFFD < 0  specifies the superdiagonal A( i, i-IOFFD ),
10101 *                        with i = 1 ... MIN( M, N+IOFFD ).
10102 *
10103 *  ALPHA   (input) COMPLEX*16
10104 *          On entry,  ALPHA specifies the value to which the offdiagonal
10105 *          array elements are set to.
10106 *
10107 *  BETA    (input) COMPLEX*16
10108 *          On entry, BETA  specifies the value to which the diagonal ar-
10109 *          ray elements are set to.
10110 *
10111 *  A       (input/output) COMPLEX*16 array
10112 *          On entry, A is an array of dimension  (LDA,N).  Before  entry
10113 *          with UPLO = 'U' or 'u', the leading m by n part of the  array
10114 *          A  must  contain  the upper trapezoidal part of the matrix as
10115 *          specified by IOFFD to be set, and  the  strictly lower trape-
10116 *          zoidal  part of A is not referenced; When IUPLO = 'L' or 'l',
10117 *          the leading m by n part of  the  array  A  must  contain  the
10118 *          lower trapezoidal part of the matrix as specified by IOFFD to
10119 *          be set,  and  the  strictly  upper  trapezoidal part of  A is
10120 *          not referenced.
10121 *
10122 *  LDA     (input) INTEGER
10123 *          On entry, LDA specifies the leading dimension of the array A.
10124 *          LDA must be at least max( 1, M ).
10125 *
10126 *  Notes
10127 *  =====
10128 *                           N                                    N
10129 *             ----------------------------                  -----------
10130 *            |       d                    |                |           |
10131 *          M |         d        'U'       |                |      'U'  |
10132 *            |  'L'     'D'               |                |d          |
10133 *            |             d              |              M |  d        |
10134 *             ----------------------------                 |   'D'     |
10135 *                                                          |      d    |
10136 *               IOFFD < 0                                  | 'L'    d  |
10137 *                                                          |          d|
10138 *                  N                                       |           |
10139 *             -----------                                   -----------
10140 *            |    d   'U'|
10141 *            |      d    |                                   IOFFD > 0
10142 *          M |       'D' |
10143 *            |          d|                              N
10144 *            |  'L'      |                 ----------------------------
10145 *            |           |                |          'U'               |
10146 *            |           |                |d                           |
10147 *            |           |                | 'D'                        |
10148 *            |           |                |    d                       |
10149 *            |           |                |'L'   d                     |
10150 *             -----------                  ----------------------------
10151 *
10152 *  -- Written on April 1, 1998 by
10153 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
10154 *
10155 *  =====================================================================
10156 *
10157 *     .. Local Scalars ..
10158       INTEGER            I, J, JTMP, MN
10159 *     ..
10160 *     .. External Functions ..
10161       LOGICAL            LSAME
10162       EXTERNAL           LSAME
10163 *     ..
10164 *     .. Intrinsic Functions ..
10165       INTRINSIC          MAX, MIN
10166 *     ..
10167 *     .. Executable Statements ..
10168 *
10169 *     Quick return if possible
10170 *
10171       IF( M.LE.0 .OR. N.LE.0 )
10172      $   RETURN
10173 *
10174 *     Start the operations
10175 *
10176       IF( LSAME( UPLO, 'L' ) ) THEN
10177 *
10178 *        Set the diagonal to BETA and the strictly lower triangular
10179 *        part of the array to ALPHA.
10180 *
10181          MN = MAX( 0, -IOFFD )
10182          DO 20 J = 1, MIN( MN, N )
10183             DO 10 I = 1, M
10184                A( I, J ) = ALPHA
10185    10       CONTINUE
10186    20    CONTINUE
10187          DO 40 J = MN + 1, MIN( M - IOFFD, N )
10188             JTMP = J + IOFFD
10189             A( JTMP, J ) = BETA
10190             DO 30 I = JTMP + 1, M
10191                A( I, J ) = ALPHA
10192    30       CONTINUE
10193    40    CONTINUE
10194 *
10195       ELSE IF( LSAME( UPLO, 'U' ) ) THEN
10196 *
10197 *        Set the diagonal to BETA and the strictly upper triangular
10198 *        part of the array to ALPHA.
10199 *
10200          MN = MIN( M - IOFFD, N )
10201          DO 60 J = MAX( 0, -IOFFD ) + 1, MN
10202             JTMP = J + IOFFD
10203             DO 50 I = 1, JTMP - 1
10204                A( I, J ) = ALPHA
10205    50       CONTINUE
10206             A( JTMP, J ) = BETA
10207    60    CONTINUE
10208          DO 80 J = MAX( 0, MN ) + 1, N
10209             DO 70 I = 1, M
10210                A( I, J ) = ALPHA
10211    70       CONTINUE
10212    80    CONTINUE
10213 *
10214       ELSE IF( LSAME( UPLO, 'D' ) ) THEN
10215 *
10216 *        Set the array to BETA on the diagonal.
10217 *
10218          DO 90 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N )
10219             A( J + IOFFD, J ) = BETA
10220    90    CONTINUE
10221 *
10222       ELSE
10223 *
10224 *        Set the array to BETA on the diagonal and ALPHA on the
10225 *        offdiagonal.
10226 *
10227          DO 110 J = 1, N
10228             DO 100 I = 1, M
10229                A( I, J ) = ALPHA
10230   100       CONTINUE
10231   110    CONTINUE
10232          IF( ALPHA.NE.BETA .AND. IOFFD.LT.M .AND. IOFFD.GT.-N ) THEN
10233             DO 120 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N )
10234                A( J + IOFFD, J ) = BETA
10235   120       CONTINUE
10236          END IF
10237 *
10238       END IF
10239 *
10240       RETURN
10241 *
10242 *     End of PB_ZLASET
10243 *
10244       END
10245       SUBROUTINE PB_ZLASCAL( UPLO, M, N, IOFFD, ALPHA, A, LDA )
10246 *
10247 *  -- PBLAS test routine (version 2.0) --
10248 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
10249 *     and University of California, Berkeley.
10250 *     April 1, 1998
10251 *
10252 *     .. Scalar Arguments ..
10253       CHARACTER*1        UPLO
10254       INTEGER            IOFFD, LDA, M, N
10255       COMPLEX*16         ALPHA
10256 *     ..
10257 *     .. Array Arguments ..
10258       COMPLEX*16         A( LDA, * )
10259 *     ..
10260 *
10261 *  Purpose
10262 *  =======
10263 *
10264 *  PB_ZLASCAL scales a two-dimensional array A by the scalar alpha.
10265 *
10266 *  Arguments
10267 *  =========
10268 *
10269 *  UPLO    (input) CHARACTER*1
10270 *          On entry,  UPLO  specifies  which trapezoidal part of the ar-
10271 *          ray A is to be scaled as follows:
10272 *             = 'L' or 'l':          the lower trapezoid of A is scaled,
10273 *             = 'U' or 'u':          the upper trapezoid of A is scaled,
10274 *             = 'D' or 'd':       diagonal specified by IOFFD is scaled,
10275 *             Otherwise:                   all of the array A is scaled.
10276 *
10277 *  M       (input) INTEGER
10278 *          On entry,  M  specifies the number of rows of the array A.  M
10279 *          must be at least zero.
10280 *
10281 *  N       (input) INTEGER
10282 *          On entry,  N  specifies the number of columns of the array A.
10283 *          N must be at least zero.
10284 *
10285 *  IOFFD   (input) INTEGER
10286 *          On entry, IOFFD specifies the position of the offdiagonal de-
10287 *          limiting the upper and lower trapezoidal part of A as follows
10288 *          (see the notes below):
10289 *
10290 *             IOFFD = 0  specifies the main diagonal A( i, i ),
10291 *                        with i = 1 ... MIN( M, N ),
10292 *             IOFFD > 0  specifies the subdiagonal   A( i+IOFFD, i ),
10293 *                        with i = 1 ... MIN( M-IOFFD, N ),
10294 *             IOFFD < 0  specifies the superdiagonal A( i, i-IOFFD ),
10295 *                        with i = 1 ... MIN( M, N+IOFFD ).
10296 *
10297 *  ALPHA   (input) COMPLEX*16
10298 *          On entry, ALPHA specifies the scalar alpha.
10299 *
10300 *  A       (input/output) COMPLEX*16 array
10301 *          On entry, A is an array of dimension  (LDA,N).  Before  entry
10302 *          with  UPLO = 'U' or 'u', the leading m by n part of the array
10303 *          A must contain the upper trapezoidal  part  of the matrix  as
10304 *          specified by  IOFFD to be scaled, and the strictly lower tra-
10305 *          pezoidal part of A is not referenced; When UPLO = 'L' or 'l',
10306 *          the leading m by n part of the array A must contain the lower
10307 *          trapezoidal  part  of  the matrix as specified by IOFFD to be
10308 *          scaled,  and  the strictly upper trapezoidal part of A is not
10309 *          referenced. On exit, the entries of the  trapezoid part of  A
10310 *          determined by UPLO and IOFFD are scaled.
10311 *
10312 *  LDA     (input) INTEGER
10313 *          On entry, LDA specifies the leading dimension of the array A.
10314 *          LDA must be at least max( 1, M ).
10315 *
10316 *  Notes
10317 *  =====
10318 *                           N                                    N
10319 *             ----------------------------                  -----------
10320 *            |       d                    |                |           |
10321 *          M |         d        'U'       |                |      'U'  |
10322 *            |  'L'     'D'               |                |d          |
10323 *            |             d              |              M |  d        |
10324 *             ----------------------------                 |   'D'     |
10325 *                                                          |      d    |
10326 *              IOFFD < 0                                   | 'L'    d  |
10327 *                                                          |          d|
10328 *                  N                                       |           |
10329 *             -----------                                   -----------
10330 *            |    d   'U'|
10331 *            |      d    |                                   IOFFD > 0
10332 *          M |       'D' |
10333 *            |          d|                              N
10334 *            |  'L'      |                 ----------------------------
10335 *            |           |                |          'U'               |
10336 *            |           |                |d                           |
10337 *            |           |                | 'D'                        |
10338 *            |           |                |    d                       |
10339 *            |           |                |'L'   d                     |
10340 *             -----------                  ----------------------------
10341 *
10342 *  -- Written on April 1, 1998 by
10343 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
10344 *
10345 *  =====================================================================
10346 *
10347 *     .. Local Scalars ..
10348       INTEGER            I, J, JTMP, MN
10349 *     ..
10350 *     .. External Functions ..
10351       LOGICAL            LSAME
10352       EXTERNAL           LSAME
10353 *     ..
10354 *     .. Intrinsic Functions ..
10355       INTRINSIC          MAX, MIN
10356 *     ..
10357 *     .. Executable Statements ..
10358 *
10359 *     Quick return if possible
10360 *
10361       IF( M.LE.0 .OR. N.LE.0 )
10362      $   RETURN
10363 *
10364 *     Start the operations
10365 *
10366       IF( LSAME( UPLO, 'L' ) ) THEN
10367 *
10368 *        Scales the lower triangular part of the array by ALPHA.
10369 *
10370          MN = MAX( 0, -IOFFD )
10371          DO 20 J = 1, MIN( MN, N )
10372             DO 10 I = 1, M
10373                A( I, J ) = ALPHA * A( I, J )
10374    10       CONTINUE
10375    20    CONTINUE
10376          DO 40 J = MN + 1, MIN( M - IOFFD, N )
10377             DO 30 I = J + IOFFD, M
10378                A( I, J ) = ALPHA * A( I, J )
10379    30       CONTINUE
10380    40    CONTINUE
10381 *
10382       ELSE IF( LSAME( UPLO, 'U' ) ) THEN
10383 *
10384 *        Scales the upper triangular part of the array by ALPHA.
10385 *
10386          MN = MIN( M - IOFFD, N )
10387          DO 60 J = MAX( 0, -IOFFD ) + 1, MN
10388             DO 50 I = 1, J + IOFFD
10389                A( I, J ) = ALPHA * A( I, J )
10390    50       CONTINUE
10391    60    CONTINUE
10392          DO 80 J = MAX( 0, MN ) + 1, N
10393             DO 70 I = 1, M
10394                A( I, J ) = ALPHA * A( I, J )
10395    70       CONTINUE
10396    80    CONTINUE
10397 *
10398       ELSE IF( LSAME( UPLO, 'D' ) ) THEN
10399 *
10400 *        Scales the diagonal entries by ALPHA.
10401 *
10402          DO 90 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N )
10403             JTMP = J + IOFFD
10404             A( JTMP, J ) = ALPHA * A( JTMP, J )
10405    90    CONTINUE
10406 *
10407       ELSE
10408 *
10409 *        Scales the entire array by ALPHA.
10410 *
10411          DO 110 J = 1, N
10412             DO 100 I = 1, M
10413                A( I, J ) = ALPHA * A( I, J )
10414   100       CONTINUE
10415   110    CONTINUE
10416 *
10417       END IF
10418 *
10419       RETURN
10420 *
10421 *     End of PB_ZLASCAL
10422 *
10423       END
10424       SUBROUTINE PB_ZLAGEN( UPLO, AFORM, A, LDA, LCMT00, IRAN, MBLKS,
10425      $                      IMBLOC, MB, LMBLOC, NBLKS, INBLOC, NB,
10426      $                      LNBLOC, JMP, IMULADD )
10427 *
10428 *  -- PBLAS test routine (version 2.0) --
10429 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
10430 *     and University of California, Berkeley.
10431 *     April 1, 1998
10432 *
10433 *     .. Scalar Arguments ..
10434       CHARACTER*1        UPLO, AFORM
10435       INTEGER            IMBLOC, INBLOC, LCMT00, LDA, LMBLOC, LNBLOC,
10436      $                   MB, MBLKS, NB, NBLKS
10437 *     ..
10438 *     .. Array Arguments ..
10439       INTEGER            IMULADD( 4, * ), IRAN( * ), JMP( * )
10440       COMPLEX*16         A( LDA, * )
10441 *     ..
10442 *
10443 *  Purpose
10444 *  =======
10445 *
10446 *  PB_ZLAGEN locally initializes an array A.
10447 *
10448 *  Arguments
10449 *  =========
10450 *
10451 *  UPLO    (global input) CHARACTER*1
10452 *          On entry, UPLO  specifies whether the lower (UPLO='L') trape-
10453 *          zoidal part or the upper (UPLO='U') trapezoidal part is to be
10454 *          generated  when  the  matrix  to be generated is symmetric or
10455 *          Hermitian. For  all  the  other values of AFORM, the value of
10456 *          this input argument is ignored.
10457 *
10458 *  AFORM   (global input) CHARACTER*1
10459 *          On entry, AFORM specifies the type of submatrix to be genera-
10460 *          ted as follows:
10461 *             AFORM = 'S', sub( A ) is a symmetric matrix,
10462 *             AFORM = 'H', sub( A ) is a Hermitian matrix,
10463 *             AFORM = 'T', sub( A ) is overrwritten  with  the transpose
10464 *                          of what would normally be generated,
10465 *             AFORM = 'C', sub( A ) is overwritten  with  the  conjugate
10466 *                          transpose  of  what would normally be genera-
10467 *                          ted.
10468 *             AFORM = 'N', a random submatrix is generated.
10469 *
10470 *  A       (local output) COMPLEX*16 array
10471 *          On entry,  A  is  an array of dimension (LLD_A, *).  On exit,
10472 *          this array contains the local entries of the randomly genera-
10473 *          ted submatrix sub( A ).
10474 *
10475 *  LDA     (local input) INTEGER
10476 *          On entry,  LDA  specifies  the local leading dimension of the
10477 *          array A. LDA must be at least one.
10478 *
10479 *  LCMT00  (global input) INTEGER
10480 *          On entry, LCMT00 is the LCM value specifying the off-diagonal
10481 *          of the underlying matrix of interest. LCMT00=0 specifies  the
10482 *          main diagonal, LCMT00 > 0 specifies a subdiagonal, LCMT00 < 0
10483 *          specifies superdiagonals.
10484 *
10485 *  IRAN    (local input) INTEGER array
10486 *          On entry, IRAN  is an array of dimension 2 containing respec-
10487 *          tively the 16-lower and 16-higher bits of the encoding of the
10488 *          entry of  the  random  sequence  corresponding locally to the
10489 *          first local array entry to generate. Usually,  this  array is
10490 *          computed by PB_SETLOCRAN.
10491 *
10492 *  MBLKS   (local input) INTEGER
10493 *          On entry, MBLKS specifies the local number of blocks of rows.
10494 *          MBLKS is at least zero.
10495 *
10496 *  IMBLOC  (local input) INTEGER
10497 *          On entry, IMBLOC specifies  the  number of rows (size) of the
10498 *          local uppest  blocks. IMBLOC is at least zero.
10499 *
10500 *  MB      (global input) INTEGER
10501 *          On entry, MB  specifies the blocking factor used to partition
10502 *          the rows of the matrix.  MB  must be at least one.
10503 *
10504 *  LMBLOC  (local input) INTEGER
10505 *          On entry, LMBLOC specifies the number of  rows  (size) of the
10506 *          local lowest blocks. LMBLOC is at least zero.
10507 *
10508 *  NBLKS   (local input) INTEGER
10509 *          On entry,  NBLKS  specifies the local number of blocks of co-
10510 *          lumns. NBLKS is at least zero.
10511 *
10512 *  INBLOC  (local input) INTEGER
10513 *          On entry,  INBLOC  specifies the number of columns (size)  of
10514 *          the local leftmost blocks. INBLOC is at least zero.
10515 *
10516 *  NB      (global input) INTEGER
10517 *          On entry, NB  specifies the blocking factor used to partition
10518 *          the the columns of the matrix.  NB  must be at least one.
10519 *
10520 *  LNBLOC  (local input) INTEGER
10521 *          On entry,  LNBLOC  specifies  the number of columns (size) of
10522 *          the local rightmost blocks. LNBLOC is at least zero.
10523 *
10524 *  JMP     (local input) INTEGER array
10525 *          On entry, JMP is an array of dimension JMP_LEN containing the
10526 *          different jump values used by the random matrix generator.
10527 *
10528 *  IMULADD (local input) INTEGER array
10529 *          On entry, IMULADD is an array of dimension (4, JMP_LEN).  The
10530 *          jth  column  of this array contains the encoded initial cons-
10531 *          tants a_j and c_j to  jump  from X( n ) to  X( n + JMP( j ) )
10532 *          (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
10533 *          contains respectively the 16-lower and 16-higher bits of  the
10534 *          constant a_j, and IMULADD(3:4,j)  contains  the 16-lower  and
10535 *          16-higher bits of the constant c_j.
10536 *
10537 *  -- Written on April 1, 1998 by
10538 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
10539 *
10540 *  =====================================================================
10541 *
10542 *     .. Parameters ..
10543       INTEGER            JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
10544      $                   JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
10545      $                   JMP_NQINBLOC, JMP_NQNB, JMP_ROW
10546       PARAMETER          ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3,
10547      $                   JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6,
10548      $                   JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9,
10549      $                   JMP_NQNB = 10, JMP_NQINBLOC = 11,
10550      $                   JMP_LEN = 11 )
10551       DOUBLE PRECISION   ZERO
10552       PARAMETER          ( ZERO = 0.0D+0 )
10553 *     ..
10554 *     .. Local Scalars ..
10555       INTEGER            I, IB, IBLK, II, IK, ITMP, JB, JBLK, JJ, JK,
10556      $                   JTMP, LCMTC, LCMTR, LOW, MNB, UPP
10557       COMPLEX*16         DUMMY
10558 *     ..
10559 *     .. Local Arrays ..
10560       INTEGER            IB0( 2 ), IB1( 2 ), IB2( 2 ), IB3( 2 )
10561 *     ..
10562 *     .. External Subroutines ..
10563       EXTERNAL           PB_JUMPIT
10564 *     ..
10565 *     .. External Functions ..
10566       LOGICAL            LSAME
10567       DOUBLE PRECISION   PB_DRAND
10568       EXTERNAL           LSAME, PB_DRAND
10569 *     ..
10570 *     .. Intrinsic Functions ..
10571       INTRINSIC          DBLE, DCMPLX, MAX, MIN
10572 *     ..
10573 *     .. Executable Statements ..
10574 *
10575       DO 10 I = 1, 2
10576          IB1( I ) = IRAN( I )
10577          IB2( I ) = IRAN( I )
10578          IB3( I ) = IRAN( I )
10579    10 CONTINUE
10580 *
10581       IF( LSAME( AFORM, 'N' ) ) THEN
10582 *
10583 *        Generate random matrix
10584 *
10585          JJ = 1
10586 *
10587          DO 50 JBLK = 1, NBLKS
10588 *
10589             IF( JBLK.EQ.1 ) THEN
10590                JB = INBLOC
10591             ELSE IF( JBLK.EQ.NBLKS ) THEN
10592                JB = LNBLOC
10593             ELSE
10594                JB = NB
10595             END IF
10596 *
10597             DO 40 JK = JJ, JJ + JB - 1
10598 *
10599                II = 1
10600 *
10601                DO 30 IBLK = 1, MBLKS
10602 *
10603                   IF( IBLK.EQ.1 ) THEN
10604                      IB = IMBLOC
10605                   ELSE IF( IBLK.EQ.MBLKS ) THEN
10606                      IB = LMBLOC
10607                   ELSE
10608                      IB = MB
10609                   END IF
10610 *
10611 *                 Blocks are IB by JB
10612 *
10613                   DO 20 IK = II, II + IB - 1
10614                      A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
10615      $                                     PB_DRAND( 0 ) )
10616    20             CONTINUE
10617 *
10618                   II = II + IB
10619 *
10620                   IF( IBLK.EQ.1 ) THEN
10621 *
10622 *                    Jump IMBLOC + ( NPROW - 1 ) * MB rows
10623 *
10624                      CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1,
10625      $                               IB0 )
10626 *
10627                   ELSE
10628 *
10629 *                    Jump NPROW * MB rows
10630 *
10631                      CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1, IB0 )
10632 *
10633                   END IF
10634 *
10635                   IB1( 1 ) = IB0( 1 )
10636                   IB1( 2 ) = IB0( 2 )
10637 *
10638    30          CONTINUE
10639 *
10640 *              Jump one column
10641 *
10642                CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 )
10643 *
10644                IB1( 1 ) = IB0( 1 )
10645                IB1( 2 ) = IB0( 2 )
10646                IB2( 1 ) = IB0( 1 )
10647                IB2( 2 ) = IB0( 2 )
10648 *
10649    40       CONTINUE
10650 *
10651             JJ = JJ + JB
10652 *
10653             IF( JBLK.EQ.1 ) THEN
10654 *
10655 *              Jump INBLOC + ( NPCOL - 1 ) * NB columns
10656 *
10657                CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 )
10658 *
10659             ELSE
10660 *
10661 *              Jump NPCOL * NB columns
10662 *
10663                CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 )
10664 *
10665             END IF
10666 *
10667             IB1( 1 ) = IB0( 1 )
10668             IB1( 2 ) = IB0( 2 )
10669             IB2( 1 ) = IB0( 1 )
10670             IB2( 2 ) = IB0( 2 )
10671             IB3( 1 ) = IB0( 1 )
10672             IB3( 2 ) = IB0( 2 )
10673 *
10674    50    CONTINUE
10675 *
10676       ELSE IF( LSAME( AFORM, 'T' ) ) THEN
10677 *
10678 *        Generate the transpose of the matrix that would be normally
10679 *        generated.
10680 *
10681          II = 1
10682 *
10683          DO 90 IBLK = 1, MBLKS
10684 *
10685             IF( IBLK.EQ.1 ) THEN
10686                IB = IMBLOC
10687             ELSE IF( IBLK.EQ.MBLKS ) THEN
10688                IB = LMBLOC
10689             ELSE
10690                IB = MB
10691             END IF
10692 *
10693             DO 80 IK = II, II + IB - 1
10694 *
10695                JJ = 1
10696 *
10697                DO 70 JBLK = 1, NBLKS
10698 *
10699                   IF( JBLK.EQ.1 ) THEN
10700                      JB = INBLOC
10701                   ELSE IF( JBLK.EQ.NBLKS ) THEN
10702                      JB = LNBLOC
10703                   ELSE
10704                      JB = NB
10705                   END IF
10706 *
10707 *                 Blocks are IB by JB
10708 *
10709                   DO 60 JK = JJ, JJ + JB - 1
10710                      A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
10711      $                                     PB_DRAND( 0 ) )
10712    60             CONTINUE
10713 *
10714                   JJ = JJ + JB
10715 *
10716                   IF( JBLK.EQ.1 ) THEN
10717 *
10718 *                    Jump INBLOC + ( NPCOL - 1 ) * NB columns
10719 *
10720                      CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
10721      $                               IB0 )
10722 *
10723                   ELSE
10724 *
10725 *                    Jump NPCOL * NB columns
10726 *
10727                      CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1, IB0 )
10728 *
10729                   END IF
10730 *
10731                   IB1( 1 ) = IB0( 1 )
10732                   IB1( 2 ) = IB0( 2 )
10733 *
10734    70          CONTINUE
10735 *
10736 *              Jump one row
10737 *
10738                CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
10739 *
10740                IB1( 1 ) = IB0( 1 )
10741                IB1( 2 ) = IB0( 2 )
10742                IB2( 1 ) = IB0( 1 )
10743                IB2( 2 ) = IB0( 2 )
10744 *
10745    80       CONTINUE
10746 *
10747             II = II + IB
10748 *
10749             IF( IBLK.EQ.1 ) THEN
10750 *
10751 *              Jump IMBLOC + ( NPROW - 1 ) * MB rows
10752 *
10753                CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
10754 *
10755             ELSE
10756 *
10757 *              Jump NPROW * MB rows
10758 *
10759                CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
10760 *
10761             END IF
10762 *
10763             IB1( 1 ) = IB0( 1 )
10764             IB1( 2 ) = IB0( 2 )
10765             IB2( 1 ) = IB0( 1 )
10766             IB2( 2 ) = IB0( 2 )
10767             IB3( 1 ) = IB0( 1 )
10768             IB3( 2 ) = IB0( 2 )
10769 *
10770    90    CONTINUE
10771 *
10772       ELSE IF( LSAME( AFORM, 'S' ) ) THEN
10773 *
10774 *        Generate a symmetric matrix
10775 *
10776          IF( LSAME( UPLO, 'L' ) ) THEN
10777 *
10778 *           generate lower trapezoidal part
10779 *
10780             JJ = 1
10781             LCMTC = LCMT00
10782 *
10783             DO 170 JBLK = 1, NBLKS
10784 *
10785                IF( JBLK.EQ.1 ) THEN
10786                   JB  = INBLOC
10787                   LOW = 1 - INBLOC
10788                ELSE IF( JBLK.EQ.NBLKS ) THEN
10789                   JB = LNBLOC
10790                   LOW = 1 - NB
10791                ELSE
10792                   JB  = NB
10793                   LOW = 1 - NB
10794                END IF
10795 *
10796                DO 160 JK = JJ, JJ + JB - 1
10797 *
10798                   II = 1
10799                   LCMTR = LCMTC
10800 *
10801                   DO 150 IBLK = 1, MBLKS
10802 *
10803                      IF( IBLK.EQ.1 ) THEN
10804                         IB  = IMBLOC
10805                         UPP = IMBLOC - 1
10806                      ELSE IF( IBLK.EQ.MBLKS ) THEN
10807                         IB  = LMBLOC
10808                         UPP = MB - 1
10809                      ELSE
10810                         IB  = MB
10811                         UPP = MB - 1
10812                      END IF
10813 *
10814 *                    Blocks are IB by JB
10815 *
10816                      IF( LCMTR.GT.UPP ) THEN
10817 *
10818                         DO 100 IK = II, II + IB - 1
10819                            DUMMY = DCMPLX( PB_DRAND( 0 ),
10820      $                                     PB_DRAND( 0 ) )
10821   100                   CONTINUE
10822 *
10823                      ELSE IF( LCMTR.GE.LOW ) THEN
10824 *
10825                         JTMP = JK - JJ + 1
10826                         MNB  = MAX( 0, -LCMTR )
10827 *
10828                         IF( JTMP.LE.MIN( MNB, JB ) ) THEN
10829 *
10830                            DO 110 IK = II, II + IB - 1
10831                               A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
10832      $                                              PB_DRAND( 0 ) )
10833   110                      CONTINUE
10834 *
10835                         ELSE IF( ( JTMP.GE.( MNB + 1 )         ) .AND.
10836      $                           ( JTMP.LE.MIN( IB-LCMTR, JB ) ) ) THEN
10837 *
10838                            ITMP = II + JTMP + LCMTR - 1
10839 *
10840                            DO 120 IK = II, ITMP - 1
10841                               DUMMY = DCMPLX( PB_DRAND( 0 ),
10842      $                                        PB_DRAND( 0 ) )
10843   120                      CONTINUE
10844 *
10845                            DO 130 IK = ITMP, II + IB - 1
10846                               A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
10847      $                                              PB_DRAND( 0 ) )
10848   130                      CONTINUE
10849 *
10850                         END IF
10851 *
10852                      ELSE
10853 *
10854                         DO 140 IK = II, II + IB - 1
10855                            A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
10856      $                                           PB_DRAND( 0 ) )
10857   140                   CONTINUE
10858 *
10859                      END IF
10860 *
10861                      II = II + IB
10862 *
10863                      IF( IBLK.EQ.1 ) THEN
10864 *
10865 *                       Jump IMBLOC + ( NPROW - 1 ) * MB rows
10866 *
10867                         LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
10868                         CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1,
10869      $                                  IB0 )
10870 *
10871                      ELSE
10872 *
10873 *                       Jump NPROW * MB rows
10874 *
10875                         LCMTR = LCMTR - JMP( JMP_NPMB )
10876                         CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1,
10877      $                                  IB0 )
10878 *
10879                      END IF
10880 *
10881                      IB1( 1 ) = IB0( 1 )
10882                      IB1( 2 ) = IB0( 2 )
10883 *
10884   150             CONTINUE
10885 *
10886 *                 Jump one column
10887 *
10888                   CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 )
10889 *
10890                   IB1( 1 ) = IB0( 1 )
10891                   IB1( 2 ) = IB0( 2 )
10892                   IB2( 1 ) = IB0( 1 )
10893                   IB2( 2 ) = IB0( 2 )
10894 *
10895   160          CONTINUE
10896 *
10897                JJ = JJ + JB
10898 *
10899                IF( JBLK.EQ.1 ) THEN
10900 *
10901 *                 Jump INBLOC + ( NPCOL - 1 ) * NB columns
10902 *
10903                   LCMTC = LCMTC + JMP( JMP_NQINBLOC )
10904                   CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 )
10905 *
10906                ELSE
10907 *
10908 *                 Jump NPCOL * NB columns
10909 *
10910                   LCMTC = LCMTC + JMP( JMP_NQNB )
10911                   CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 )
10912 *
10913                END IF
10914 *
10915                IB1( 1 ) = IB0( 1 )
10916                IB1( 2 ) = IB0( 2 )
10917                IB2( 1 ) = IB0( 1 )
10918                IB2( 2 ) = IB0( 2 )
10919                IB3( 1 ) = IB0( 1 )
10920                IB3( 2 ) = IB0( 2 )
10921 *
10922   170       CONTINUE
10923 *
10924          ELSE
10925 *
10926 *           generate upper trapezoidal part
10927 *
10928             II = 1
10929             LCMTR = LCMT00
10930 *
10931             DO 250 IBLK = 1, MBLKS
10932 *
10933                IF( IBLK.EQ.1 ) THEN
10934                   IB  = IMBLOC
10935                   UPP = IMBLOC - 1
10936                ELSE IF( IBLK.EQ.MBLKS ) THEN
10937                   IB  = LMBLOC
10938                   UPP = MB - 1
10939                ELSE
10940                   IB  = MB
10941                   UPP = MB - 1
10942                END IF
10943 *
10944                DO 240 IK = II, II + IB - 1
10945 *
10946                   JJ = 1
10947                   LCMTC = LCMTR
10948 *
10949                   DO 230 JBLK = 1, NBLKS
10950 *
10951                      IF( JBLK.EQ.1 ) THEN
10952                         JB  = INBLOC
10953                         LOW = 1 - INBLOC
10954                      ELSE IF( JBLK.EQ.NBLKS ) THEN
10955                         JB  = LNBLOC
10956                         LOW = 1 - NB
10957                      ELSE
10958                         JB  = NB
10959                         LOW = 1 - NB
10960                      END IF
10961 *
10962 *                    Blocks are IB by JB
10963 *
10964                      IF( LCMTC.LT.LOW ) THEN
10965 *
10966                         DO 180 JK = JJ, JJ + JB - 1
10967                            DUMMY = DCMPLX( PB_DRAND( 0 ),
10968      $                                     PB_DRAND( 0 ) )
10969   180                   CONTINUE
10970 *
10971                      ELSE IF( LCMTC.LE.UPP ) THEN
10972 *
10973                         ITMP = IK - II + 1
10974                         MNB  = MAX( 0, LCMTC )
10975 *
10976                         IF( ITMP.LE.MIN( MNB, IB ) ) THEN
10977 *
10978                            DO 190 JK = JJ, JJ + JB - 1
10979                               A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
10980      $                                              PB_DRAND( 0 ) )
10981   190                      CONTINUE
10982 *
10983                         ELSE IF( ( ITMP.GE.( MNB + 1 )         ) .AND.
10984      $                           ( ITMP.LE.MIN( JB+LCMTC, IB ) ) ) THEN
10985 *
10986                            JTMP = JJ + ITMP - LCMTC - 1
10987 *
10988                            DO 200 JK = JJ, JTMP - 1
10989                               DUMMY = DCMPLX( PB_DRAND( 0 ),
10990      $                                        PB_DRAND( 0 ) )
10991   200                      CONTINUE
10992 *
10993                            DO 210 JK = JTMP, JJ + JB - 1
10994                               A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
10995      $                                              PB_DRAND( 0 ) )
10996   210                      CONTINUE
10997 *
10998                         END IF
10999 *
11000                      ELSE
11001 *
11002                         DO 220 JK = JJ, JJ + JB - 1
11003                            A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
11004      $                                           PB_DRAND( 0 ) )
11005   220                   CONTINUE
11006 *
11007                      END IF
11008 *
11009                      JJ = JJ + JB
11010 *
11011                      IF( JBLK.EQ.1 ) THEN
11012 *
11013 *                       Jump INBLOC + ( NPCOL - 1 ) * NB columns
11014 *
11015                         LCMTC = LCMTC + JMP( JMP_NQINBLOC )
11016                         CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
11017      $                                  IB0 )
11018 *
11019                      ELSE
11020 *
11021 *                       Jump NPCOL * NB columns
11022 *
11023                         LCMTC = LCMTC + JMP( JMP_NQNB )
11024                         CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1,
11025      $                                  IB0 )
11026 *
11027                      END IF
11028 *
11029                      IB1( 1 ) = IB0( 1 )
11030                      IB1( 2 ) = IB0( 2 )
11031 *
11032   230             CONTINUE
11033 *
11034 *                 Jump one row
11035 *
11036                   CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
11037 *
11038                   IB1( 1 ) = IB0( 1 )
11039                   IB1( 2 ) = IB0( 2 )
11040                   IB2( 1 ) = IB0( 1 )
11041                   IB2( 2 ) = IB0( 2 )
11042 *
11043   240          CONTINUE
11044 *
11045                II = II + IB
11046 *
11047                IF( IBLK.EQ.1 ) THEN
11048 *
11049 *                 Jump IMBLOC + ( NPROW - 1 ) * MB rows
11050 *
11051                   LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
11052                   CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
11053 *
11054                ELSE
11055 *
11056 *                 Jump NPROW * MB rows
11057 *
11058                   LCMTR = LCMTR - JMP( JMP_NPMB )
11059                   CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
11060 *
11061                END IF
11062 *
11063                IB1( 1 ) = IB0( 1 )
11064                IB1( 2 ) = IB0( 2 )
11065                IB2( 1 ) = IB0( 1 )
11066                IB2( 2 ) = IB0( 2 )
11067                IB3( 1 ) = IB0( 1 )
11068                IB3( 2 ) = IB0( 2 )
11069 *
11070   250       CONTINUE
11071 *
11072          END IF
11073 *
11074       ELSE IF( LSAME( AFORM, 'C' ) ) THEN
11075 *
11076 *        Generate the conjugate transpose of the matrix that would be
11077 *        normally generated.
11078 *
11079          II = 1
11080 *
11081          DO 290 IBLK = 1, MBLKS
11082 *
11083             IF( IBLK.EQ.1 ) THEN
11084                IB = IMBLOC
11085             ELSE IF( IBLK.EQ.MBLKS ) THEN
11086                IB = LMBLOC
11087             ELSE
11088                IB = MB
11089             END IF
11090 *
11091             DO 280 IK = II, II + IB - 1
11092 *
11093                JJ = 1
11094 *
11095                DO 270 JBLK = 1, NBLKS
11096 *
11097                   IF( JBLK.EQ.1 ) THEN
11098                      JB = INBLOC
11099                   ELSE IF( JBLK.EQ.NBLKS ) THEN
11100                      JB = LNBLOC
11101                   ELSE
11102                      JB = NB
11103                   END IF
11104 *
11105 *                 Blocks are IB by JB
11106 *
11107                   DO 260 JK = JJ, JJ + JB - 1
11108                      A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
11109      $                                    -PB_DRAND( 0 ) )
11110   260             CONTINUE
11111 *
11112                   JJ = JJ + JB
11113 *
11114                   IF( JBLK.EQ.1 ) THEN
11115 *
11116 *                    Jump INBLOC + ( NPCOL - 1 ) * NB columns
11117 *
11118                      CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
11119      $                               IB0 )
11120 *
11121                   ELSE
11122 *
11123 *                    Jump NPCOL * NB columns
11124 *
11125                      CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1,
11126      $                               IB0 )
11127 *
11128                   END IF
11129 *
11130                   IB1( 1 ) = IB0( 1 )
11131                   IB1( 2 ) = IB0( 2 )
11132 *
11133   270          CONTINUE
11134 *
11135 *              Jump one row
11136 *
11137                CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
11138 *
11139                IB1( 1 ) = IB0( 1 )
11140                IB1( 2 ) = IB0( 2 )
11141                IB2( 1 ) = IB0( 1 )
11142                IB2( 2 ) = IB0( 2 )
11143 *
11144   280       CONTINUE
11145 *
11146             II = II + IB
11147 *
11148             IF( IBLK.EQ.1 ) THEN
11149 *
11150 *              Jump IMBLOC + ( NPROW - 1 ) * MB rows
11151 *
11152                CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
11153 *
11154             ELSE
11155 *
11156 *              Jump NPROW * MB rows
11157 *
11158                CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
11159 *
11160             END IF
11161 *
11162             IB1( 1 ) = IB0( 1 )
11163             IB1( 2 ) = IB0( 2 )
11164             IB2( 1 ) = IB0( 1 )
11165             IB2( 2 ) = IB0( 2 )
11166             IB3( 1 ) = IB0( 1 )
11167             IB3( 2 ) = IB0( 2 )
11168 *
11169   290    CONTINUE
11170 *
11171       ELSE IF( LSAME( AFORM, 'H' ) ) THEN
11172 *
11173 *        Generate a Hermitian matrix
11174 *
11175          IF( LSAME( UPLO, 'L' ) ) THEN
11176 *
11177 *           generate lower trapezoidal part
11178 *
11179             JJ = 1
11180             LCMTC = LCMT00
11181 *
11182             DO 370 JBLK = 1, NBLKS
11183 *
11184                IF( JBLK.EQ.1 ) THEN
11185                   JB  = INBLOC
11186                   LOW = 1 - INBLOC
11187                ELSE IF( JBLK.EQ.NBLKS ) THEN
11188                   JB = LNBLOC
11189                   LOW = 1 - NB
11190                ELSE
11191                   JB  = NB
11192                   LOW = 1 - NB
11193                END IF
11194 *
11195                DO 360 JK = JJ, JJ + JB - 1
11196 *
11197                   II = 1
11198                   LCMTR = LCMTC
11199 *
11200                   DO 350 IBLK = 1, MBLKS
11201 *
11202                      IF( IBLK.EQ.1 ) THEN
11203                         IB  = IMBLOC
11204                         UPP = IMBLOC - 1
11205                      ELSE IF( IBLK.EQ.MBLKS ) THEN
11206                         IB  = LMBLOC
11207                         UPP = MB - 1
11208                      ELSE
11209                         IB  = MB
11210                         UPP = MB - 1
11211                      END IF
11212 *
11213 *                    Blocks are IB by JB
11214 *
11215                      IF( LCMTR.GT.UPP ) THEN
11216 *
11217                         DO 300 IK = II, II + IB - 1
11218                            DUMMY = DCMPLX( PB_DRAND( 0 ),
11219      $                                     PB_DRAND( 0 ) )
11220   300                   CONTINUE
11221 *
11222                      ELSE IF( LCMTR.GE.LOW ) THEN
11223 *
11224                         JTMP = JK - JJ + 1
11225                         MNB  = MAX( 0, -LCMTR )
11226 *
11227                         IF( JTMP.LE.MIN( MNB, JB ) ) THEN
11228 *
11229                            DO 310 IK = II, II + IB - 1
11230                               A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
11231      $                                              PB_DRAND( 0 ) )
11232   310                      CONTINUE
11233 *
11234                         ELSE IF( ( JTMP.GE.( MNB + 1 )         ) .AND.
11235      $                           ( JTMP.LE.MIN( IB-LCMTR, JB ) ) ) THEN
11236 *
11237                            ITMP = II + JTMP + LCMTR - 1
11238 *
11239                            DO 320 IK = II, ITMP - 1
11240                               DUMMY = DCMPLX( PB_DRAND( 0 ),
11241      $                                        PB_DRAND( 0 ) )
11242   320                      CONTINUE
11243 *
11244                            IF( ITMP.LE.( II + IB - 1 ) ) THEN
11245                               DUMMY = DCMPLX( PB_DRAND( 0 ),
11246      $                                       -PB_DRAND( 0 ) )
11247                               A( ITMP, JK ) = DCMPLX( DBLE( DUMMY ),
11248      $                                                ZERO )
11249                            END IF
11250 *
11251                            DO 330 IK = ITMP + 1, II + IB - 1
11252                               A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
11253      $                                              PB_DRAND( 0 ) )
11254   330                      CONTINUE
11255 *
11256                         END IF
11257 *
11258                      ELSE
11259 *
11260                         DO 340 IK = II, II + IB - 1
11261                            A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
11262      $                                           PB_DRAND( 0 ) )
11263   340                   CONTINUE
11264 *
11265                      END IF
11266 *
11267                      II = II + IB
11268 *
11269                      IF( IBLK.EQ.1 ) THEN
11270 *
11271 *                       Jump IMBLOC + ( NPROW - 1 ) * MB rows
11272 *
11273                         LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
11274                         CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1,
11275      $                                  IB0 )
11276 *
11277                      ELSE
11278 *
11279 *                       Jump NPROW * MB rows
11280 *
11281                         LCMTR = LCMTR - JMP( JMP_NPMB )
11282                         CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1,
11283      $                                  IB0 )
11284 *
11285                      END IF
11286 *
11287                      IB1( 1 ) = IB0( 1 )
11288                      IB1( 2 ) = IB0( 2 )
11289 *
11290   350             CONTINUE
11291 *
11292 *                 Jump one column
11293 *
11294                   CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 )
11295 *
11296                   IB1( 1 ) = IB0( 1 )
11297                   IB1( 2 ) = IB0( 2 )
11298                   IB2( 1 ) = IB0( 1 )
11299                   IB2( 2 ) = IB0( 2 )
11300 *
11301   360          CONTINUE
11302 *
11303                JJ = JJ + JB
11304 *
11305                IF( JBLK.EQ.1 ) THEN
11306 *
11307 *                 Jump INBLOC + ( NPCOL - 1 ) * NB columns
11308 *
11309                   LCMTC = LCMTC + JMP( JMP_NQINBLOC )
11310                   CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 )
11311 *
11312                ELSE
11313 *
11314 *                 Jump NPCOL * NB columns
11315 *
11316                   LCMTC = LCMTC + JMP( JMP_NQNB )
11317                   CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 )
11318 *
11319                END IF
11320 *
11321                IB1( 1 ) = IB0( 1 )
11322                IB1( 2 ) = IB0( 2 )
11323                IB2( 1 ) = IB0( 1 )
11324                IB2( 2 ) = IB0( 2 )
11325                IB3( 1 ) = IB0( 1 )
11326                IB3( 2 ) = IB0( 2 )
11327 *
11328   370       CONTINUE
11329 *
11330          ELSE
11331 *
11332 *           generate upper trapezoidal part
11333 *
11334             II = 1
11335             LCMTR = LCMT00
11336 *
11337             DO 450 IBLK = 1, MBLKS
11338 *
11339                IF( IBLK.EQ.1 ) THEN
11340                   IB  = IMBLOC
11341                   UPP = IMBLOC - 1
11342                ELSE IF( IBLK.EQ.MBLKS ) THEN
11343                   IB  = LMBLOC
11344                   UPP = MB - 1
11345                ELSE
11346                   IB  = MB
11347                   UPP = MB - 1
11348                END IF
11349 *
11350                DO 440 IK = II, II + IB - 1
11351 *
11352                   JJ = 1
11353                   LCMTC = LCMTR
11354 *
11355                   DO 430 JBLK = 1, NBLKS
11356 *
11357                      IF( JBLK.EQ.1 ) THEN
11358                         JB  = INBLOC
11359                         LOW = 1 - INBLOC
11360                      ELSE IF( JBLK.EQ.NBLKS ) THEN
11361                         JB  = LNBLOC
11362                         LOW = 1 - NB
11363                      ELSE
11364                         JB  = NB
11365                         LOW = 1 - NB
11366                      END IF
11367 *
11368 *                    Blocks are IB by JB
11369 *
11370                      IF( LCMTC.LT.LOW ) THEN
11371 *
11372                         DO 380 JK = JJ, JJ + JB - 1
11373                            DUMMY = DCMPLX( PB_DRAND( 0 ),
11374      $                                    -PB_DRAND( 0 ) )
11375   380                   CONTINUE
11376 *
11377                      ELSE IF( LCMTC.LE.UPP ) THEN
11378 *
11379                         ITMP = IK - II + 1
11380                         MNB  = MAX( 0, LCMTC )
11381 *
11382                         IF( ITMP.LE.MIN( MNB, IB ) ) THEN
11383 *
11384                            DO 390 JK = JJ, JJ + JB - 1
11385                               A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
11386      $                                             -PB_DRAND( 0 ) )
11387   390                      CONTINUE
11388 *
11389                         ELSE IF( ( ITMP.GE.( MNB + 1 )         ) .AND.
11390      $                           ( ITMP.LE.MIN( JB+LCMTC, IB ) ) ) THEN
11391 *
11392                            JTMP = JJ + ITMP - LCMTC - 1
11393 *
11394                            DO 400 JK = JJ, JTMP - 1
11395                               DUMMY = DCMPLX( PB_DRAND( 0 ),
11396      $                                       -PB_DRAND( 0 ) )
11397   400                      CONTINUE
11398 *
11399                            IF( JTMP.LE.( JJ + JB - 1 ) ) THEN
11400                               DUMMY = DCMPLX( PB_DRAND( 0 ),
11401      $                                       -PB_DRAND( 0 ) )
11402                               A( IK, JTMP ) = DCMPLX( DBLE( DUMMY ),
11403      $                                                ZERO )
11404                            END IF
11405 *
11406                            DO 410 JK = JTMP + 1, JJ + JB - 1
11407                               A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
11408      $                                             -PB_DRAND( 0 ) )
11409   410                      CONTINUE
11410 *
11411                         END IF
11412 *
11413                      ELSE
11414 *
11415                         DO 420 JK = JJ, JJ + JB - 1
11416                            A( IK, JK ) = DCMPLX( PB_DRAND( 0 ),
11417      $                                          -PB_DRAND( 0 ) )
11418   420                   CONTINUE
11419 *
11420                      END IF
11421 *
11422                      JJ = JJ + JB
11423 *
11424                      IF( JBLK.EQ.1 ) THEN
11425 *
11426 *                       Jump INBLOC + ( NPCOL - 1 ) * NB columns
11427 *
11428                         LCMTC = LCMTC + JMP( JMP_NQINBLOC )
11429                         CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
11430      $                                  IB0 )
11431 *
11432                      ELSE
11433 *
11434 *                       Jump NPCOL * NB columns
11435 *
11436                         LCMTC = LCMTC + JMP( JMP_NQNB )
11437                         CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1,
11438      $                                  IB0 )
11439 *
11440                      END IF
11441 *
11442                      IB1( 1 ) = IB0( 1 )
11443                      IB1( 2 ) = IB0( 2 )
11444 *
11445   430             CONTINUE
11446 *
11447 *                 Jump one row
11448 *
11449                   CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
11450 *
11451                   IB1( 1 ) = IB0( 1 )
11452                   IB1( 2 ) = IB0( 2 )
11453                   IB2( 1 ) = IB0( 1 )
11454                   IB2( 2 ) = IB0( 2 )
11455 *
11456   440          CONTINUE
11457 *
11458                II = II + IB
11459 *
11460                IF( IBLK.EQ.1 ) THEN
11461 *
11462 *                 Jump IMBLOC + ( NPROW - 1 ) * MB rows
11463 *
11464                   LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
11465                   CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
11466 *
11467                ELSE
11468 *
11469 *                 Jump NPROW * MB rows
11470 *