ScaLAPACK  2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
pcblastst.f
Go to the documentation of this file.
00001       SUBROUTINE PCOPTEE( 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 *  PCOPTEE  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            PCCHKOPT
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 PCCHKOPT( 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 PCCHKOPT( 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 PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS )
00177 *
00178 *        Check 2nd option
00179 *
00180          APOS = 2
00181          CALL PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
00182 *
00183 *        Check 3rd option
00184 *
00185          APOS = 3
00186          CALL PCCHKOPT( 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 PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
00196 *
00197 *        Check 2'nd option
00198 *
00199          APOS = 2
00200          CALL PCCHKOPT( 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 PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'S', APOS )
00208 *
00209 *        Check 2nd option
00210 *
00211          APOS = 2
00212          CALL PCCHKOPT( 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 PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS )
00221 *
00222 *        Check 2'nd option
00223 *
00224          APOS = 2
00225          CALL PCCHKOPT( 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 PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'S', APOS )
00233 *
00234 *        Check 2nd option
00235 *
00236          APOS = 2
00237          CALL PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS )
00238 *
00239 *        Check 3rd option
00240 *
00241          APOS = 3
00242          CALL PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
00243 *
00244 *        Check 4th option
00245 *
00246          APOS = 4
00247          CALL PCCHKOPT( 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 PCCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
00256 *
00257       END IF
00258 *
00259       RETURN
00260 *
00261 *     End of PCOPTEE
00262 *
00263       END
00264       SUBROUTINE PCCHKOPT( 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 *  PCCHKOPT 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           PCCALLSUB, PCHKPBE, PCSETPBLAS
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 PCSETPBLAS( 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 PCCALLSUB( SUBPTR, SCODE )
00447       CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
00448 *
00449       RETURN
00450 *
00451 *     End of PCCHKOPT
00452 *
00453       END
00454       SUBROUTINE PCDIMEE( 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 *  PCDIMEE  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            PCCHKDIM
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 PCCHKDIM( 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 PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00625 *
00626 *        Check 2nd dimension
00627 *
00628          APOS = 3
00629          CALL PCCHKDIM( 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 PCCHKDIM( 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 PCCHKDIM( 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 PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00652 *
00653 *        Check 2nd dimension
00654 *
00655          APOS = 2
00656          CALL PCCHKDIM( 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 PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00666 *
00667 *        Check 2nd dimension
00668 *
00669          APOS = 4
00670          CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00671 *
00672 *        Check 3rd dimension
00673 *
00674          APOS = 5
00675          CALL PCCHKDIM( 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 PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00683 *
00684 *        Check 2nd dimension
00685 *
00686          APOS = 4
00687          CALL PCCHKDIM( 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 PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00696 *
00697 *        Check 2nd dimension
00698 *
00699          APOS = 4
00700          CALL PCCHKDIM( 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 PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00708 *
00709 *        Check 2nd dimension
00710 *
00711          APOS = 2
00712          CALL PCCHKDIM( 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 PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00720 *
00721 *        Check 2nd dimension
00722 *
00723          APOS = 6
00724          CALL PCCHKDIM( 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 PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00732 *
00733 *        Check 2nd dimension
00734 *
00735          APOS = 3
00736          CALL PCCHKDIM( 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 PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00744 *
00745 *        Check 2nd dimension
00746 *
00747          APOS = 4
00748          CALL PCCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00749 *
00750       END IF
00751 *
00752       RETURN
00753 *
00754 *     End of PCDIMEE
00755 *
00756       END
00757       SUBROUTINE PCCHKDIM( 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 *  PCCHKDIM 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           PCCALLSUB, PCHKPBE, PCSETPBLAS
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 PCSETPBLAS( 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 PCCALLSUB( SUBPTR, SCODE )
00928       CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
00929 *
00930       RETURN
00931 *
00932 *     End of PCCHKDIM
00933 *
00934       END
00935       SUBROUTINE PCVECEE( 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 *  PCVECEE  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            PCCHKMAT
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 PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01098 *
01099 *        Check 2nd vector
01100 *
01101          APOS = 7
01102          CALL PCCHKMAT( 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 PCCHKMAT( 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 PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01117 *
01118 *        Check 2nd vector
01119 *
01120          APOS = 8
01121          CALL PCCHKMAT( 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 PCCHKMAT( 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 PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01138 *
01139 *        Check 2nd vector
01140 *
01141          APOS = 15
01142          CALL PCCHKMAT( 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 PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01150 *
01151 *        Check 2nd vector
01152 *
01153          APOS = 14
01154          CALL PCCHKMAT( 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 PCCHKMAT( 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 PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01169 *
01170 *        Check 2nd vector
01171 *
01172          APOS = 9
01173          CALL PCCHKMAT( 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 PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01181 *
01182       END IF
01183 *
01184       RETURN
01185 *
01186 *     End of PCVECEE
01187 *
01188       END
01189       SUBROUTINE PCMATEE( 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 *  PCMATEE  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            PCCHKMAT
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 PCCHKMAT( 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 PCCHKMAT( 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 PCCHKMAT( 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 PCCHKMAT( 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 PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01382 *
01383 *        Check 2nd matrix
01384 *
01385          APOS = 11
01386          CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'B', APOS )
01387 *
01388 *        Check 3nd matrix
01389 *
01390          APOS = 16
01391          CALL PCCHKMAT( 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 PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01399 *
01400 *        Check 2nd matrix
01401 *
01402          APOS = 10
01403          CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'B', APOS )
01404 *
01405 *        Check 3nd matrix
01406 *
01407          APOS = 15
01408          CALL PCCHKMAT( 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 PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01416 *
01417 *        Check 2nd matrix
01418 *
01419          APOS = 11
01420          CALL PCCHKMAT( 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 PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01428 *
01429 *        Check 2nd matrix
01430 *
01431          APOS = 9
01432          CALL PCCHKMAT( 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 PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01440 *
01441 *        Check 2nd matrix
01442 *
01443          APOS = 12
01444          CALL PCCHKMAT( 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 PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01452 *
01453 *        Check 2nd matrix
01454 *
01455          APOS = 10
01456          CALL PCCHKMAT( 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 PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01464 *
01465 *        Check 2nd matrix
01466 *
01467          APOS = 11
01468          CALL PCCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'C', APOS )
01469 *
01470       END IF
01471 *
01472       RETURN
01473 *
01474 *     End of PCMATEE
01475 *
01476       END
01477       SUBROUTINE PCSETPBLAS( 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 *  PCSETPBLAS 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       REAL               RONE
01578       COMPLEX            ONE
01579       PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
01580      $                   RONE = 1.0E+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       REAL               USCLR
01590       COMPLEX            SCLR
01591       INTEGER            DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
01592      $                   DESCX( DLEN_ ), DESCY( DLEN_ )
01593       COMPLEX            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 PCSETPBLAS
01673 *
01674       END
01675       SUBROUTINE PCCHKMAT( 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 *  PCCHKMAT 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, PCCALLSUB, PCHKPBE, PCSETPBLAS
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 PCSETPBLAS( ICTXT )
01839          IA    = -1
01840          INFOT = ARGPOS + 1
01841          CALL PCCALLSUB( SUBPTR, SCODE )
01842          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01843 *
01844 *        Check JA. Set all other OK, bad JA
01845 *
01846          CALL PCSETPBLAS( ICTXT )
01847          JA    = -1
01848          INFOT = ARGPOS + 2
01849          CALL PCCALLSUB( 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 PCSETPBLAS( ICTXT )
01859             DESCA( I ) =  -2
01860             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
01861             CALL PCCALLSUB( 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 PCSETPBLAS( 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 PCCALLSUB( 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 PCSETPBLAS( ICTXT )
01904          IB    = -1
01905          INFOT = ARGPOS + 1
01906          CALL PCCALLSUB( SUBPTR, SCODE )
01907          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01908 *
01909 *        Check JB. Set all other OK, bad JB
01910 *
01911          CALL PCSETPBLAS( ICTXT )
01912          JB    = -1
01913          INFOT = ARGPOS + 2
01914          CALL PCCALLSUB( 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 PCSETPBLAS( ICTXT )
01924             DESCB( I ) =  -2
01925             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
01926             CALL PCCALLSUB( 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 PCSETPBLAS( 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 PCCALLSUB( 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 PCSETPBLAS( ICTXT )
01969          IC    = -1
01970          INFOT = ARGPOS + 1
01971          CALL PCCALLSUB( SUBPTR, SCODE )
01972          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01973 *
01974 *        Check JC. Set all other OK, bad JC
01975 *
01976          CALL PCSETPBLAS( ICTXT )
01977          JC    = -1
01978          INFOT = ARGPOS + 2
01979          CALL PCCALLSUB( 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 PCSETPBLAS( ICTXT )
01989             DESCC( I ) =  -2
01990             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
01991             CALL PCCALLSUB( 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 PCSETPBLAS( 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 PCCALLSUB( 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 PCSETPBLAS( ICTXT )
02034          IX    = -1
02035          INFOT = ARGPOS + 1
02036          CALL PCCALLSUB( SUBPTR, SCODE )
02037          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02038 *
02039 *        Check JX. Set all other OK, bad JX
02040 *
02041          CALL PCSETPBLAS( ICTXT )
02042          JX    = -1
02043          INFOT = ARGPOS + 2
02044          CALL PCCALLSUB( 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 PCSETPBLAS( ICTXT )
02054             DESCX( I ) =  -2
02055             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
02056             CALL PCCALLSUB( 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 PCSETPBLAS( 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 PCCALLSUB( 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 PCSETPBLAS( ICTXT )
02097          INCX  =  -1
02098          INFOT = ARGPOS + 4
02099          CALL PCCALLSUB( 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 PCSETPBLAS( ICTXT )
02107          IY    = -1
02108          INFOT = ARGPOS + 1
02109          CALL PCCALLSUB( SUBPTR, SCODE )
02110          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02111 *
02112 *        Check JY. Set all other OK, bad JY
02113 *
02114          CALL PCSETPBLAS( ICTXT )
02115          JY    = -1
02116          INFOT = ARGPOS + 2
02117          CALL PCCALLSUB( 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 PCSETPBLAS( ICTXT )
02127             DESCY( I ) =  -2
02128             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
02129             CALL PCCALLSUB( 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 PCSETPBLAS( 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 PCCALLSUB( 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 PCSETPBLAS( ICTXT )
02170          INCY =  -1
02171          INFOT = ARGPOS + 4
02172          CALL PCCALLSUB( SUBPTR, SCODE )
02173          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02174 *
02175       END IF
02176 *
02177       RETURN
02178 *
02179 *     End of PCCHKMAT
02180 *
02181       END
02182       SUBROUTINE PCCALLSUB( 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 *  PCCALLSUB 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       REAL               USCLR
02324       COMPLEX            SCLR
02325       INTEGER            DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
02326      $                   DESCX( DLEN_ ), DESCY( DLEN_ )
02327       COMPLEX            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 PCCALLSUB
02457 *
02458       END
02459       SUBROUTINE PCERRSET( 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       REAL               ERR, ERRMAX
02468       COMPLEX            X, XTRUE
02469 *     ..
02470 *
02471 *  Purpose
02472 *  =======
02473 *
02474 *  PCERRSET  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) REAL
02544 *          On exit, ERR specifies the absolute difference |XTRUE - X|.
02545 *
02546 *  ERRMAX  (local input/local output) REAL
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
02551 *          On entry, XTRUE specifies the true value.
02552 *
02553 *  X       (local input) COMPLEX
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       REAL               PSDIFF
02563       EXTERNAL           PSDIFF
02564 *     ..
02565 *     .. Intrinsic Functions ..
02566       INTRINSIC          ABS, AIMAG, MAX, REAL
02567 *     ..
02568 *     .. Executable Statements ..
02569 *
02570       ERR = ABS( PSDIFF( REAL( XTRUE ), REAL( X ) ) )
02571       ERR = MAX( ERR, ABS( PSDIFF( AIMAG( XTRUE ), AIMAG( X ) ) ) )
02572 *
02573       ERRMAX = MAX( ERRMAX, ERR )
02574 *
02575       RETURN
02576 *
02577 *     End of PCERRSET
02578 *
02579       END
02580       SUBROUTINE PCCHKVIN( 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       REAL               ERRMAX
02591 *     ..
02592 *     .. Array Arguments ..
02593       INTEGER            DESCX( * )
02594       COMPLEX            PX( * ), X( * )
02595 *     ..
02596 *
02597 *  Purpose
02598 *  =======
02599 *
02600 *  PCCHKVIN  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) REAL
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 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 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       REAL               ZERO
02726       PARAMETER          ( ZERO = 0.0E+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       REAL               ERR, EPS
02734 *     ..
02735 *     .. External Subroutines ..
02736       EXTERNAL           BLACS_GRIDINFO, PB_INFOG2L, PCERRSET, SGAMX2D
02737 *     ..
02738 *     .. External Functions ..
02739       REAL               PSLAMCH
02740       EXTERNAL           PSLAMCH
02741 *     ..
02742 *     .. Intrinsic Functions ..
02743       INTRINSIC          ABS, AIMAG, MAX, MIN, MOD, REAL
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 = PSLAMCH( 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 PCERRSET( 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 PCERRSET( 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 PCERRSET( 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 PCERRSET( 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 PCERRSET( 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 SGAMX2D( 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 PCCHKVIN
02873 *
02874       END
02875       SUBROUTINE PCCHKVOUT( 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            PX( * ), X( * )
02888 *     ..
02889 *
02890 *  Purpose
02891 *  =======
02892 *
02893 *  PCCHKVOUT  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 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 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       REAL               ZERO
03015       PARAMETER          ( ZERO = 0.0E+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       REAL               EPS, ERR, ERRMAX
03024 *     ..
03025 *     .. External Subroutines ..
03026       EXTERNAL           BLACS_GRIDINFO, PCERRSET, SGAMX2D
03027 *     ..
03028 *     .. External Functions ..
03029       INTEGER            PB_NUMROC
03030       REAL               PSLAMCH
03031       EXTERNAL           PSLAMCH, PB_NUMROC
03032 *     ..
03033 *     .. Intrinsic Functions ..
03034       INTRINSIC          ABS, AIMAG, MAX, MIN, MOD, REAL
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 = PSLAMCH( 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 PCERRSET( 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 PCERRSET( 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 PCERRSET( 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 PCERRSET( 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 PCERRSET( 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 PCERRSET( 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 PCERRSET( 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 PCERRSET( 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 SGAMX2D( 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 PCCHKVOUT
03329 *
03330       END
03331       SUBROUTINE PCCHKMIN( 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       REAL               ERRMAX
03341 *     ..
03342 *     .. Array Arguments ..
03343       INTEGER            DESCA( * )
03344       COMPLEX            PA( * ), A( * )
03345 *     ..
03346 *
03347 *  Purpose
03348 *  =======
03349 *
03350 *  PCCHKMIN  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) REAL
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 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 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       REAL               ZERO
03475       PARAMETER          ( ZERO = 0.0E+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       REAL               ERR, EPS
03483 *     ..
03484 *     .. External Subroutines ..
03485       EXTERNAL           BLACS_GRIDINFO, PB_INFOG2L, PCERRSET, SGAMX2D
03486 *     ..
03487 *     .. External Functions ..
03488       REAL               PSLAMCH
03489       EXTERNAL           PSLAMCH
03490 *     ..
03491 *     .. Intrinsic Functions ..
03492       INTRINSIC          ABS, AIMAG, MAX, MIN, MOD, REAL
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 = PSLAMCH( 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 PCERRSET( 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 PCERRSET( 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 PCERRSET( 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 PCERRSET( 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 SGAMX2D( 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 PCCHKMIN
03630 *
03631       END
03632       SUBROUTINE PCCHKMOUT( 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            A( * ), PA( * )
03645 *     ..
03646 *
03647 *  Purpose
03648 *  =======
03649 *
03650 *  PCCHKMOUT  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 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 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       REAL               ZERO
03771       PARAMETER          ( ZERO = 0.0E+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       REAL               EPS, ERR, ERRMAX
03779 *     ..
03780 *     .. External Subroutines ..
03781       EXTERNAL           BLACS_GRIDINFO, PCERRSET, SGAMX2D
03782 *     ..
03783 *     .. External Functions ..
03784       INTEGER            PB_NUMROC
03785       REAL               PSLAMCH
03786       EXTERNAL           PSLAMCH, 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 = PSLAMCH( 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 PCERRSET( 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 PCERRSET( 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 PCERRSET( 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 PCERRSET( 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 SGAMX2D( 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 PCCHKMOUT
03951 *
03952       END
03953       SUBROUTINE PCMPRNT( 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            A( LDA, * )
03967 *     ..
03968 *
03969 *  Purpose
03970 *  =======
03971 *
03972 *  PCMPRNT 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 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          AIMAG, REAL
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      $                         REAL( A( I, J ) ), AIMAG( A( I, J ) )
04050 *
04051    10       CONTINUE
04052 *
04053    20    CONTINUE
04054 *
04055       END IF
04056 *
04057  9999 FORMAT( 1X, A, '(', I6, ',', I6, ')=', E16.8, '+i*(',
04058      $        E16.8, ')' )
04059 *
04060       RETURN
04061 *
04062 *     End of PCMPRNT
04063 *
04064       END
04065       SUBROUTINE PCVPRNT( 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            X( * )
04079 *     ..
04080 *
04081 *  Purpose
04082 *  =======
04083 *
04084 *  PCVPRNT  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 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          AIMAG, REAL
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, REAL( X( I ) ),
04156      $                                AIMAG( X( I ) )
04157 *
04158    10    CONTINUE
04159 *
04160       END IF
04161 *
04162  9999 FORMAT( 1X, A, '(', I6, ')=', E16.8, '+i*(', E16.8, ')' )
04163 *
04164       RETURN
04165 *
04166 *     End of PCVPRNT
04167 *
04168       END
04169       SUBROUTINE PCMVCH( 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       REAL               ERR
04183       COMPLEX            ALPHA, BETA
04184 *     ..
04185 *     .. Array Arguments ..
04186       INTEGER            DESCA( * ), DESCX( * ), DESCY( * )
04187       REAL               G( * )
04188       COMPLEX            A( * ), PY( * ), X( * ), Y( * )
04189 *     ..
04190 *
04191 *  Purpose
04192 *  =======
04193 *
04194 *  PCMVCH 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
04286 *          On entry, ALPHA specifies the scalar alpha.
04287 *
04288 *  A       (local input) COMPLEX 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 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
04326 *          On entry, BETA specifies the scalar beta.
04327 *
04328 *  Y       (local input/local output) COMPLEX 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 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) REAL 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) REAL
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       REAL               RZERO, RONE
04377       PARAMETER          ( RZERO = 0.0E+0, RONE = 1.0E+0 )
04378       COMPLEX            ZERO, ONE
04379       PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ),
04380      $                   ONE = ( 1.0E+0, 0.0E+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       REAL               EPS, ERRI, GTMP
04389       COMPLEX            C, TBETA, YTMP
04390 *     ..
04391 *     .. External Subroutines ..
04392       EXTERNAL           BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D
04393 *     ..
04394 *     .. External Functions ..
04395       LOGICAL            LSAME
04396       REAL               PSLAMCH
04397       EXTERNAL           LSAME, PSLAMCH
04398 *     ..
04399 *     .. Intrinsic Functions ..
04400       INTRINSIC          ABS, AIMAG, CONJG, MAX, MIN, MOD, REAL, SQRT
04401 *     ..
04402 *     .. Statement Functions ..
04403       REAL               ABS1
04404       ABS1( C ) = ABS( REAL( C ) ) + ABS( AIMAG( C ) )
04405 *     ..
04406 *     .. Executable Statements ..
04407 *
04408       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
04409 *
04410       EPS = PSLAMCH( 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 + CONJG( 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 SGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
04596      $              MYCOL )
04597 *
04598       RETURN
04599 *
04600 *     End of PCMVCH
04601 *
04602       END
04603       SUBROUTINE PCVMCH( 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       REAL               ERR
04617       COMPLEX            ALPHA
04618 *     ..
04619 *     .. Array Arguments ..
04620       INTEGER            DESCA( * ), DESCX( * ), DESCY( * )
04621       REAL               G( * )
04622       COMPLEX            A( * ), PA( * ), X( * ), Y( * )
04623 *     ..
04624 *
04625 *  Purpose
04626 *  =======
04627 *
04628 *  PCVMCH 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
04725 *          On entry, ALPHA specifies the scalar alpha.
04726 *
04727 *  X       (local input) COMPLEX 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 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 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 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) REAL 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) REAL
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       REAL               ZERO, ONE
04813       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+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       REAL               EPS, ERRI, GTMP
04821       COMPLEX            ATMP, C
04822 *     ..
04823 *     .. External Subroutines ..
04824       EXTERNAL           BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D
04825 *     ..
04826 *     .. External Functions ..
04827       LOGICAL            LSAME
04828       REAL               PSLAMCH
04829       EXTERNAL           LSAME, PSLAMCH
04830 *     ..
04831 *     .. Intrinsic Functions ..
04832       INTRINSIC          ABS, AIMAG, CONJG, MAX, MIN, MOD, REAL, SQRT
04833 *     ..
04834 *     .. Statement Functions ..
04835       REAL               ABS1
04836       ABS1( C ) = ABS( REAL( C ) ) + ABS( AIMAG( C ) )
04837 *     ..
04838 *     .. Executable Statements ..
04839 *
04840       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
04841 *
04842       EPS = PSLAMCH( 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 ) * CONJG( 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 SGAMX2D( 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 PCVMCH
04970 *
04971       END
04972       SUBROUTINE PCVMCH2( 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       REAL               ERR
04986       COMPLEX            ALPHA
04987 *     ..
04988 *     .. Array Arguments ..
04989       INTEGER            DESCA( * ), DESCX( * ), DESCY( * )
04990       REAL               G( * )
04991       COMPLEX            A( * ), PA( * ), X( * ), Y( * )
04992 *     ..
04993 *
04994 *  Purpose
04995 *  =======
04996 *
04997 *  PCVMCH2 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
05086 *          On entry, ALPHA specifies the scalar alpha.
05087 *
05088 *  X       (local input) COMPLEX 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 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 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 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) REAL 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) REAL
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       REAL               ZERO, ONE
05174       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+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       REAL               EPS, ERRI, GTMP
05183       COMPLEX            C, ATMP
05184 *     ..
05185 *     .. External Subroutines ..
05186       EXTERNAL           BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D
05187 *     ..
05188 *     .. External Functions ..
05189       LOGICAL            LSAME
05190       REAL               PSLAMCH
05191       EXTERNAL           LSAME, PSLAMCH
05192 *     ..
05193 *     .. Intrinsic Functions ..
05194       INTRINSIC          ABS, AIMAG, CONJG, MAX, MIN, MOD, REAL, SQRT
05195 *     ..
05196 *     .. Statement Functions ..
05197       REAL               ABS1
05198       ABS1( C ) = ABS( REAL( C ) ) + ABS( AIMAG( C ) )
05199 *     ..
05200 *     .. Executable Statements ..
05201 *
05202       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
05203 *
05204       EPS = PSLAMCH( 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 ) * CONJG( Y( IOFFYJ ) )
05244             ATMP = ATMP + Y( IOFFYI ) * CONJG( ALPHA * X( IOFFXJ ) )
05245             GTMP = ABS1( ALPHA * X( IOFFXI ) ) * ABS1( Y( IOFFYJ ) )
05246             GTMP = GTMP + ABS1( Y( IOFFYI ) ) *
05247      $                    ABS1( CONJG( 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 SGAMX2D( 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 PCVMCH2
05331 *
05332       END
05333       SUBROUTINE PCMMCH( 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       REAL               ERR
05346       COMPLEX            ALPHA, BETA
05347 *     ..
05348 *     .. Array Arguments ..
05349       INTEGER            DESCA( * ), DESCB( * ), DESCC( * )
05350       REAL               G( * )
05351       COMPLEX            A( * ), B( * ), C( * ), CT( * ), PC( * )
05352 *     ..
05353 *
05354 *  Purpose
05355 *  =======
05356 *
05357 *  PCMMCH 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
05450 *          On entry, ALPHA specifies the scalar alpha.
05451 *
05452 *  A       (local input) COMPLEX 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 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
05485 *          On entry, BETA specifies the scalar beta.
05486 *
05487 *  C       (local input/local output) COMPLEX 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 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 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) REAL 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) REAL
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       REAL               RZERO, RONE
05535       PARAMETER          ( RZERO = 0.0E+0, RONE = 1.0E+0 )
05536       COMPLEX            ZERO
05537       PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+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       REAL               EPS, ERRI
05545       COMPLEX            Z
05546 *     ..
05547 *     .. External Subroutines ..
05548       EXTERNAL           BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D
05549 *     ..
05550 *     .. External Functions ..
05551       LOGICAL            LSAME
05552       REAL               PSLAMCH
05553       EXTERNAL           LSAME, PSLAMCH
05554 *     ..
05555 *     .. Intrinsic Functions ..
05556       INTRINSIC          ABS, AIMAG, CONJG, MAX, MIN, MOD, REAL, SQRT
05557 *     ..
05558 *     .. Statement Functions ..
05559       REAL               ABS1
05560       ABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) )
05561 *     ..
05562 *     .. Executable Statements ..
05563 *
05564       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
05565 *
05566       EPS = PSLAMCH( 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 ) + CONJG( 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      $                            CONJG( 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 ) + CONJG( A( IOFFA ) ) *
05653      $                                      CONJG( 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 ) + CONJG( 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      $                                      CONJG( 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 SGAMX2D( 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 PCMMCH
05784 *
05785       END
05786       SUBROUTINE PCMMCH1( 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       REAL               ERR
05799       COMPLEX            ALPHA, BETA
05800 *     ..
05801 *     .. Array Arguments ..
05802       INTEGER            DESCA( * ), DESCC( * )
05803       REAL               G( * )
05804       COMPLEX            A( * ), C( * ), CT( * ), PC( * )
05805 *     ..
05806 *
05807 *  Purpose
05808 *  =======
05809 *
05810 *  PCMMCH1 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
05901 *          On entry, ALPHA specifies the scalar alpha.
05902 *
05903 *  A       (local input) COMPLEX 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
05920 *          On entry, BETA specifies the scalar beta.
05921 *
05922 *  C       (local input/local output) COMPLEX 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 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 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) REAL 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) REAL
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       REAL               RZERO, RONE
05970       PARAMETER          ( RZERO = 0.0E+0, RONE = 1.0E+0 )
05971       COMPLEX            ZERO
05972       PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+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       REAL               EPS, ERRI
05980       COMPLEX            Z
05981 *     ..
05982 *     .. External Subroutines ..
05983       EXTERNAL           BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D
05984 *     ..
05985 *     .. External Functions ..
05986       LOGICAL            LSAME
05987       REAL               PSLAMCH
05988       EXTERNAL           LSAME, PSLAMCH
05989 *     ..
05990 *     .. Intrinsic Functions ..
05991       INTRINSIC          ABS, AIMAG, CONJG, MAX, MIN, MOD, REAL, SQRT
05992 *     ..
05993 *     .. Statement Functions ..
05994       REAL               ABS1
05995       ABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) )
05996 *     ..
05997 *     .. Executable Statements ..
05998 *
05999       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
06000 *
06001       EPS = PSLAMCH( 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      $                      CONJG( 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 ) + CONJG( A( IOFFAN ) ) * A( IOFFAK )
06067                   G( I ) = G( I ) + ABS1( CONJG( A( IOFFAN ) ) ) *
06068      $                     ABS1( A( IOFFAK ) )
06069    80          CONTINUE
06070    90       CONTINUE
06071          END IF
06072 *
06073          IOFFC = IC + IBEG - 1 + ( JC + J - 2 ) * LDC
06074 *
06075          DO 100 I = IBEG, IEND
06076             CT( I ) = ALPHA*CT( I ) + BETA * C( IOFFC )
06077             G( I ) = ABS1( ALPHA )*G( I ) +
06078      $               ABS1( BETA )*ABS1( C( IOFFC ) )
06079             C( IOFFC ) = CT( I )
06080             IOFFC = IOFFC + 1
06081   100    CONTINUE
06082 *
06083 *        Compute the error ratio for this result.
06084 *
06085          ERR  = RZERO
06086          INFO = 0
06087          LDPC = DESCC( LLD_ )
06088          IOFFC = IC + ( JC + J - 2 ) * LDC
06089          CALL PB_INFOG2L( IC, JC+J-1, DESCC, NPROW, NPCOL, MYROW, MYCOL,
06090      $                    IIC, JJC, ICROW, ICCOL )
06091          ICURROW = ICROW
06092          ROWREP  = ( ICROW.EQ.-1 )
06093          COLREP  = ( ICCOL.EQ.-1 )
06094 *
06095          IF( MYCOL.EQ.ICCOL .OR. COLREP ) THEN
06096 *
06097             IBB = DESCC( IMB_ ) - IC + 1
06098             IF( IBB.LE.0 )
06099      $         IBB = ( ( -IBB ) / DESCC( MB_ ) + 1 )*DESCC( MB_ ) + IBB
06100             IBB = MIN( IBB, N )
06101             IN = IC + IBB - 1
06102 *
06103             DO 110 I = IC, IN
06104 *
06105                IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
06106                   ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
06107      $                        C( IOFFC ) ) / EPS
06108                   IF( G( I-IC+1 ).NE.RZERO )
06109      $               ERRI = ERRI / G( I-IC+1 )
06110                   ERR = MAX( ERR, ERRI )
06111                   IF( ERR*SQRT( EPS ).GE.RONE )
06112      $               INFO = 1
06113                   IIC = IIC + 1
06114                END IF
06115 *
06116                IOFFC = IOFFC + 1
06117 *
06118   110       CONTINUE
06119 *
06120             ICURROW = MOD( ICURROW+1, NPROW )
06121 *
06122             DO 130 I = IN+1, IC+N-1, DESCC( MB_ )
06123                IBB = MIN( IC+N-I, DESCC( MB_ ) )
06124 *
06125                DO 120 KK = 0, IBB-1
06126 *
06127                   IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
06128                      ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
06129      $                           C( IOFFC ) )/EPS
06130                      IF( G( I+KK-IC+1 ).NE.RZERO )
06131      $                  ERRI = ERRI / G( I+KK-IC+1 )
06132                      ERR = MAX( ERR, ERRI )
06133                      IF( ERR*SQRT( EPS ).GE.RONE )
06134      $                  INFO = 1
06135                      IIC = IIC + 1
06136                   END IF
06137 *
06138                   IOFFC = IOFFC + 1
06139 *
06140   120          CONTINUE
06141 *
06142                ICURROW = MOD( ICURROW+1, NPROW )
06143 *
06144   130       CONTINUE
06145 *
06146          END IF
06147 *
06148 *        If INFO = 0, all results are at least half accurate.
06149 *
06150          CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL )
06151          CALL SGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
06152      $                 MYCOL )
06153          IF( INFO.NE.0 )
06154      $      GO TO 150
06155 *
06156   140 CONTINUE
06157 *
06158   150 CONTINUE
06159 *
06160       RETURN
06161 *
06162 *     End of PCMMCH1
06163 *
06164       END
06165       SUBROUTINE PCMMCH2( ICTXT, UPLO, TRANS, N, K, ALPHA, A, IA, JA,
06166      $                    DESCA, B, IB, JB, DESCB, BETA, C, PC, IC,
06167      $                    JC, DESCC, CT, G, ERR, INFO )
06168 *
06169 *  -- PBLAS test routine (version 2.0) --
06170 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
06171 *     and University of California, Berkeley.
06172 *     April 1, 1998
06173 *
06174 *     .. Scalar Arguments ..
06175       CHARACTER*1        TRANS, UPLO
06176       INTEGER            IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, N
06177       REAL               ERR
06178       COMPLEX            ALPHA, BETA
06179 *     ..
06180 *     .. Array Arguments ..
06181       INTEGER            DESCA( * ), DESCB( * ), DESCC( * )
06182       REAL               G( * )
06183       COMPLEX            A( * ), B( * ), C( * ), CT( * ),
06184      $                   PC( * )
06185 *     ..
06186 *
06187 *  Purpose
06188 *  =======
06189 *
06190 *  PCMMCH2 checks the results of the computational tests.
06191 *
06192 *  Notes
06193 *  =====
06194 *
06195 *  A description  vector  is associated with each 2D block-cyclicly dis-
06196 *  tributed matrix.  This  vector  stores  the  information  required to
06197 *  establish the  mapping  between a  matrix entry and its corresponding
06198 *  process and memory location.
06199 *
06200 *  In  the  following  comments,   the character _  should  be  read  as
06201 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
06202 *  block cyclicly distributed matrix.  Its description vector is DESCA:
06203 *
06204 *  NOTATION         STORED IN       EXPLANATION
06205 *  ---------------- --------------- ------------------------------------
06206 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
06207 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
06208 *                                   the NPROW x NPCOL BLACS process grid
06209 *                                   A  is distributed over.  The context
06210 *                                   itself  is  global,  but  the handle
06211 *                                   (the integer value) may vary.
06212 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
06213 *                                   ted matrix A, M_A >= 0.
06214 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
06215 *                                   buted matrix A, N_A >= 0.
06216 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
06217 *                                   block of the matrix A, IMB_A > 0.
06218 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
06219 *                                   left   block   of   the   matrix  A,
06220 *                                   INB_A > 0.
06221 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
06222 *                                   bute the last  M_A-IMB_A rows of  A,
06223 *                                   MB_A > 0.
06224 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
06225 *                                   bute the last  N_A-INB_A  columns of
06226 *                                   A, NB_A > 0.
06227 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
06228 *                                   row of the matrix  A is distributed,
06229 *                                   NPROW > RSRC_A >= 0.
06230 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
06231 *                                   first  column of  A  is distributed.
06232 *                                   NPCOL > CSRC_A >= 0.
06233 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
06234 *                                   array  storing  the  local blocks of
06235 *                                   the distributed matrix A,
06236 *                                   IF( Lc( 1, N_A ) > 0 )
06237 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
06238 *                                   ELSE
06239 *                                      LLD_A >= 1.
06240 *
06241 *  Let K be the number of  rows of a matrix A starting at the global in-
06242 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
06243 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
06244 *  receive if these K rows were distributed over NPROW processes.  If  K
06245 *  is the number of columns of a matrix  A  starting at the global index
06246 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
06247 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
06248 *  these K columns were distributed over NPCOL processes.
06249 *
06250 *  The values of Lr() and Lc() may be determined via a call to the func-
06251 *  tion PB_NUMROC:
06252 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
06253 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
06254 *
06255 *  Arguments
06256 *  =========
06257 *
06258 *  ICTXT   (local input) INTEGER
06259 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
06260 *          ting the global  context of the operation. The context itself
06261 *          is global, but the value of ICTXT is local.
06262 *
06263 *  UPLO    (global input) CHARACTER*1
06264 *          On entry,  UPLO  specifies which part of C should contain the
06265 *          result.
06266 *
06267 *  TRANS   (global input) CHARACTER*1
06268 *          On entry,  TRANS  specifies whether the matrices A and B have
06269 *          to  be  transposed  or not before computing the matrix-matrix
06270 *          product.
06271 *
06272 *  N       (global input) INTEGER
06273 *          On entry, N  specifies  the order  the submatrix operand C. N
06274 *          must be at least zero.
06275 *
06276 *  K       (global input) INTEGER
06277 *          On entry, K specifies the number of columns (resp. rows) of A
06278 *          and B when  TRANS = 'N' (resp. TRANS <> 'N').  K  must  be at
06279 *          least zero.
06280 *
06281 *  ALPHA   (global input) COMPLEX
06282 *          On entry, ALPHA specifies the scalar alpha.
06283 *
06284 *  A       (local input) COMPLEX array
06285 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
06286 *          array contains a local copy of the initial entire matrix PA.
06287 *
06288 *  IA      (global input) INTEGER
06289 *          On entry, IA  specifies A's global row index, which points to
06290 *          the beginning of the submatrix sub( A ).
06291 *
06292 *  JA      (global input) INTEGER
06293 *          On entry, JA  specifies A's global column index, which points
06294 *          to the beginning of the submatrix sub( A ).
06295 *
06296 *  DESCA   (global and local input) INTEGER array
06297 *          On entry, DESCA  is an integer array of dimension DLEN_. This
06298 *          is the array descriptor for the matrix A.
06299 *
06300 *  B       (local input) COMPLEX array
06301 *          On entry, B is an array of  dimension  (DESCB( M_ ),*).  This
06302 *          array contains a local copy of the initial entire matrix PB.
06303 *
06304 *  IB      (global input) INTEGER
06305 *          On entry, IB  specifies B's global row index, which points to
06306 *          the beginning of the submatrix sub( B ).
06307 *
06308 *  JB      (global input) INTEGER
06309 *          On entry, JB  specifies B's global column index, which points
06310 *          to the beginning of the submatrix sub( B ).
06311 *
06312 *  DESCB   (global and local input) INTEGER array
06313 *          On entry, DESCB  is an integer array of dimension DLEN_. This
06314 *          is the array descriptor for the matrix B.
06315 *
06316 *  BETA    (global input) COMPLEX
06317 *          On entry, BETA specifies the scalar beta.
06318 *
06319 *  C       (local input/local output) COMPLEX array
06320 *          On entry, C is an array of  dimension  (DESCC( M_ ),*).  This
06321 *          array contains a local copy of the initial entire matrix PC.
06322 *
06323 *  PC      (local input) COMPLEX array
06324 *          On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
06325 *          array contains the local pieces of the matrix PC.
06326 *
06327 *  IC      (global input) INTEGER
06328 *          On entry, IC  specifies C's global row index, which points to
06329 *          the beginning of the submatrix sub( C ).
06330 *
06331 *  JC      (global input) INTEGER
06332 *          On entry, JC  specifies C's global column index, which points
06333 *          to the beginning of the submatrix sub( C ).
06334 *
06335 *  DESCC   (global and local input) INTEGER array
06336 *          On entry, DESCC  is an integer array of dimension DLEN_. This
06337 *          is the array descriptor for the matrix C.
06338 *
06339 *  CT      (workspace) COMPLEX array
06340 *          On entry, CT is an array of dimension at least MAX(M,N,K). CT
06341 *          holds a copy of the current column of C.
06342 *
06343 *  G       (workspace) REAL array
06344 *          On entry, G  is  an array of dimension at least MAX(M,N,K). G
06345 *          is used to compute the gauges.
06346 *
06347 *  ERR     (global output) REAL
06348 *          On exit, ERR specifies the largest error in absolute value.
06349 *
06350 *  INFO    (global output) INTEGER
06351 *          On exit, if INFO <> 0, the result is less than half accurate.
06352 *
06353 *  -- Written on April 1, 1998 by
06354 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
06355 *
06356 *  =====================================================================
06357 *
06358 *     .. Parameters ..
06359       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
06360      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
06361      $                   RSRC_
06362       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
06363      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
06364      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
06365      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
06366       REAL               RZERO, RONE
06367       PARAMETER          ( RZERO = 0.0E+0, RONE = 1.0E+0 )
06368       COMPLEX            ZERO
06369       PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
06370 *     ..
06371 *     .. Local Scalars ..
06372       LOGICAL            COLREP, HTRAN, NOTRAN, ROWREP, TRAN, UPPER
06373       INTEGER            I, IBB, IBEG, ICCOL, ICROW, ICURROW, IEND, IIC,
06374      $                   IN, IOFFAK, IOFFAN, IOFFBK, IOFFBN, IOFFC, J,
06375      $                   JJC, KK, LDA, LDB, LDC, LDPC, MYCOL, MYROW,
06376      $                   NPCOL, NPROW
06377       REAL               EPS, ERRI
06378       COMPLEX            Z
06379 *     ..
06380 *     .. External Subroutines ..
06381       EXTERNAL           BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D
06382 *     ..
06383 *     .. External Functions ..
06384       LOGICAL            LSAME
06385       REAL               PSLAMCH
06386       EXTERNAL           LSAME, PSLAMCH
06387 *     ..
06388 *     .. Intrinsic Functions ..
06389       INTRINSIC          ABS, AIMAG, CONJG, MAX, MIN, MOD, REAL, SQRT
06390 *     ..
06391 *     .. Statement Functions ..
06392       REAL               ABS1
06393       ABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) )
06394 *     ..
06395 *     .. Executable Statements ..
06396 *
06397       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
06398 *
06399       EPS = PSLAMCH( ICTXT, 'eps' )
06400 *
06401       UPPER = LSAME( UPLO, 'U' )
06402       HTRAN = LSAME( TRANS, 'H' )
06403       NOTRAN = LSAME( TRANS, 'N' )
06404       TRAN = LSAME( TRANS, 'T' )
06405 *
06406       LDA = MAX( 1, DESCA( M_ ) )
06407       LDB = MAX( 1, DESCB( M_ ) )
06408       LDC = MAX( 1, DESCC( M_ ) )
06409 *
06410 *     Compute expected result in C using data in A, B and C.
06411 *     Compute gauges in G. This part of the computation is performed
06412 *     by every process in the grid.
06413 *
06414       DO 140 J = 1, N
06415 *
06416          IF( UPPER ) THEN
06417             IBEG = 1
06418             IEND = J
06419          ELSE
06420             IBEG = J
06421             IEND = N
06422          END IF
06423 *
06424          DO 10 I = 1, N
06425             CT( I ) = ZERO
06426             G( I )  = RZERO
06427    10    CONTINUE
06428 *
06429          IF( NOTRAN ) THEN
06430             DO 30 KK = 1, K
06431                IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA
06432                IOFFBK = IB + J - 1 + ( JB + KK - 2 ) * LDB
06433                DO 20 I = IBEG, IEND
06434                   IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA
06435                   IOFFBN = IB + I - 1 + ( JB + KK - 2 ) * LDB
06436                   CT( I ) = CT( I ) + ALPHA * (
06437      $                      A( IOFFAN ) * B( IOFFBK ) +
06438      $                      B( IOFFBN ) * A( IOFFAK ) )
06439                   G( I ) = G( I ) + ABS( ALPHA ) * (
06440      $                     ABS1( A( IOFFAN ) ) * ABS1( B( IOFFBK ) ) +
06441      $                     ABS1( B( IOFFBN ) ) * ABS1( A( IOFFAK ) ) )
06442    20          CONTINUE
06443    30       CONTINUE
06444          ELSE IF( TRAN ) THEN
06445             DO 50 KK = 1, K
06446                IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA
06447                IOFFBK = IB + KK - 1 + ( JB + J - 2 ) * LDB
06448                DO 40 I = IBEG, IEND
06449                   IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA
06450                   IOFFBN = IB + KK - 1 + ( JB + I - 2 ) * LDB
06451                   CT( I ) = CT( I ) + ALPHA * (
06452      $                      A( IOFFAN ) * B( IOFFBK ) +
06453      $                      B( IOFFBN ) * A( IOFFAK ) )
06454                   G( I ) = G( I ) + ABS( ALPHA ) * (
06455      $                     ABS1( A( IOFFAN ) ) * ABS1( B( IOFFBK ) ) +
06456      $                     ABS1( B( IOFFBN ) ) * ABS1( A( IOFFAK ) ) )
06457    40          CONTINUE
06458    50       CONTINUE
06459          ELSE IF( HTRAN ) THEN
06460             DO 70 KK = 1, K
06461                IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA
06462                IOFFBK = IB + J - 1 + ( JB + KK - 2 ) * LDB
06463                DO 60 I = IBEG, IEND
06464                   IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA
06465                   IOFFBN = IB + I - 1 + ( JB + KK - 2 ) * LDB
06466                   CT( I ) = CT( I ) +
06467      $                ALPHA * A( IOFFAN ) * CONJG( B( IOFFBK ) ) +
06468      $                B( IOFFBN ) * CONJG( ALPHA * A( IOFFAK ) )
06469                   G( I ) = G( I ) + ABS1( ALPHA ) * (
06470      $                     ABS1( A( IOFFAN ) ) * ABS1( B( IOFFBK ) ) +
06471      $                     ABS1( B( IOFFBN ) ) * ABS1( A( IOFFAK ) ) )
06472    60          CONTINUE
06473    70       CONTINUE
06474          ELSE
06475             DO 90 KK = 1, K
06476                IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA
06477                IOFFBK = IB + KK - 1 + ( JB + J - 2 ) * LDB
06478                DO 80 I = IBEG, IEND
06479                   IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA
06480                   IOFFBN = IB + KK - 1 + ( JB + I - 2 ) * LDB
06481                   CT( I ) = CT( I ) +
06482      $                   ALPHA * CONJG( A( IOFFAN ) ) * B( IOFFBK ) +
06483      $                   CONJG( ALPHA * B( IOFFBN ) ) * A( IOFFAK )
06484                   G( I ) = G( I ) + ABS1( ALPHA ) * (
06485      $                   ABS1( CONJG( A( IOFFAN ) ) * B( IOFFBK ) ) +
06486      $                   ABS1( CONJG( B( IOFFBN ) ) * A( IOFFAK ) ) )
06487    80          CONTINUE
06488    90       CONTINUE
06489          END IF
06490 *
06491          IOFFC = IC + IBEG - 1 + ( JC + J - 2 ) * LDC
06492 *
06493          DO 100 I = IBEG, IEND
06494             CT( I ) = CT( I ) + BETA * C( IOFFC )
06495             G( I ) = G( I ) + ABS1( BETA )*ABS1( C( IOFFC ) )
06496             C( IOFFC ) = CT( I )
06497             IOFFC = IOFFC + 1
06498   100    CONTINUE
06499 *
06500 *        Compute the error ratio for this result.
06501 *
06502          ERR  = RZERO
06503          INFO = 0
06504          LDPC = DESCC( LLD_ )
06505          IOFFC = IC + ( JC + J - 2 ) * LDC
06506          CALL PB_INFOG2L( IC, JC+J-1, DESCC, NPROW, NPCOL, MYROW, MYCOL,
06507      $                    IIC, JJC, ICROW, ICCOL )
06508          ICURROW = ICROW
06509          ROWREP  = ( ICROW.EQ.-1 )
06510          COLREP  = ( ICCOL.EQ.-1 )
06511 *
06512          IF( MYCOL.EQ.ICCOL .OR. COLREP ) THEN
06513 *
06514             IBB = DESCC( IMB_ ) - IC + 1
06515             IF( IBB.LE.0 )
06516      $         IBB = ( ( -IBB ) / DESCC( MB_ ) + 1 )*DESCC( MB_ ) + IBB
06517             IBB = MIN( IBB, N )
06518             IN = IC + IBB - 1
06519 *
06520             DO 110 I = IC, IN
06521 *
06522                IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
06523                   ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
06524      $                        C( IOFFC ) ) / EPS
06525                   IF( G( I-IC+1 ).NE.RZERO )
06526      $               ERRI = ERRI / G( I-IC+1 )
06527                   ERR = MAX( ERR, ERRI )
06528                   IF( ERR*SQRT( EPS ).GE.RONE )
06529      $               INFO = 1
06530                   IIC = IIC + 1
06531                END IF
06532 *
06533                IOFFC = IOFFC + 1
06534 *
06535   110       CONTINUE
06536 *
06537             ICURROW = MOD( ICURROW+1, NPROW )
06538 *
06539             DO 130 I = IN+1, IC+N-1, DESCC( MB_ )
06540                IBB = MIN( IC+N-I, DESCC( MB_ ) )
06541 *
06542                DO 120 KK = 0, IBB-1
06543 *
06544                   IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
06545                      ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
06546      $                           C( IOFFC ) )/EPS
06547                      IF( G( I+KK-IC+1 ).NE.RZERO )
06548      $                  ERRI = ERRI / G( I+KK-IC+1 )
06549                      ERR = MAX( ERR, ERRI )
06550                      IF( ERR*SQRT( EPS ).GE.RONE )
06551      $                  INFO = 1
06552                      IIC = IIC + 1
06553                   END IF
06554 *
06555                   IOFFC = IOFFC + 1
06556 *
06557   120          CONTINUE
06558 *
06559                ICURROW = MOD( ICURROW+1, NPROW )
06560 *
06561   130       CONTINUE
06562 *
06563          END IF
06564 *
06565 *        If INFO = 0, all results are at least half accurate.
06566 *
06567          CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL )
06568          CALL SGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
06569      $                 MYCOL )
06570          IF( INFO.NE.0 )
06571      $      GO TO 150
06572 *
06573   140 CONTINUE
06574 *
06575   150 CONTINUE
06576 *
06577       RETURN
06578 *
06579 *     End of PCMMCH2
06580 *
06581       END
06582       SUBROUTINE PCMMCH3( UPLO, TRANS, M, N, ALPHA, A, IA, JA, DESCA,
06583      $                    BETA, C, PC, IC, JC, DESCC, ERR, INFO )
06584 *
06585 *  -- PBLAS test routine (version 2.0) --
06586 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
06587 *     and University of California, Berkeley.
06588 *     April 1, 1998
06589 *
06590 *     .. Scalar Arguments ..
06591       CHARACTER*1        TRANS, UPLO
06592       INTEGER            IA, IC, INFO, JA, JC, M, N
06593       REAL               ERR
06594       COMPLEX            ALPHA, BETA
06595 *     ..
06596 *     .. Array Arguments ..
06597       INTEGER            DESCA( * ), DESCC( * )
06598       COMPLEX            A( * ), C( * ), PC( * )
06599 *     ..
06600 *
06601 *  Purpose
06602 *  =======
06603 *
06604 *  PCMMCH3 checks the results of the computational tests.
06605 *
06606 *  Notes
06607 *  =====
06608 *
06609 *  A description  vector  is associated with each 2D block-cyclicly dis-
06610 *  tributed matrix.  This  vector  stores  the  information  required to
06611 *  establish the  mapping  between a  matrix entry and its corresponding
06612 *  process and memory location.
06613 *
06614 *  In  the  following  comments,   the character _  should  be  read  as
06615 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
06616 *  block cyclicly distributed matrix.  Its description vector is DESCA:
06617 *
06618 *  NOTATION         STORED IN       EXPLANATION
06619 *  ---------------- --------------- ------------------------------------
06620 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
06621 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
06622 *                                   the NPROW x NPCOL BLACS process grid
06623 *                                   A  is distributed over.  The context
06624 *                                   itself  is  global,  but  the handle
06625 *                                   (the integer value) may vary.
06626 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
06627 *                                   ted matrix A, M_A >= 0.
06628 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
06629 *                                   buted matrix A, N_A >= 0.
06630 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
06631 *                                   block of the matrix A, IMB_A > 0.
06632 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
06633 *                                   left   block   of   the   matrix  A,
06634 *                                   INB_A > 0.
06635 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
06636 *                                   bute the last  M_A-IMB_A rows of  A,
06637 *                                   MB_A > 0.
06638 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
06639 *                                   bute the last  N_A-INB_A  columns of
06640 *                                   A, NB_A > 0.
06641 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
06642 *                                   row of the matrix  A is distributed,
06643 *                                   NPROW > RSRC_A >= 0.
06644 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
06645 *                                   first  column of  A  is distributed.
06646 *                                   NPCOL > CSRC_A >= 0.
06647 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
06648 *                                   array  storing  the  local blocks of
06649 *                                   the distributed matrix A,
06650 *                                   IF( Lc( 1, N_A ) > 0 )
06651 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
06652 *                                   ELSE
06653 *                                      LLD_A >= 1.
06654 *
06655 *  Let K be the number of  rows of a matrix A starting at the global in-
06656 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
06657 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
06658 *  receive if these K rows were distributed over NPROW processes.  If  K
06659 *  is the number of columns of a matrix  A  starting at the global index
06660 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
06661 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
06662 *  these K columns were distributed over NPCOL processes.
06663 *
06664 *  The values of Lr() and Lc() may be determined via a call to the func-
06665 *  tion PB_NUMROC:
06666 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
06667 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
06668 *
06669 *  Arguments
06670 *  =========
06671 *
06672 *  UPLO    (global input) CHARACTER*1
06673 *          On entry,  UPLO  specifies which part of C should contain the
06674 *          result.
06675 *
06676 *  TRANS   (global input) CHARACTER*1
06677 *          On entry,  TRANS  specifies  whether  the  matrix A has to be
06678 *          transposed  or not  before computing the  matrix-matrix addi-
06679 *          tion.
06680 *
06681 *  M       (global input) INTEGER
06682 *          On entry, M specifies the number of rows of C.
06683 *
06684 *  N       (global input) INTEGER
06685 *          On entry, N specifies the number of columns of C.
06686 *
06687 *  ALPHA   (global input) COMPLEX
06688 *          On entry, ALPHA specifies the scalar alpha.
06689 *
06690 *  A       (local input) COMPLEX array
06691 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
06692 *          array contains a local copy of the initial entire matrix PA.
06693 *
06694 *  IA      (global input) INTEGER
06695 *          On entry, IA  specifies A's global row index, which points to
06696 *          the beginning of the submatrix sub( A ).
06697 *
06698 *  JA      (global input) INTEGER
06699 *          On entry, JA  specifies A's global column index, which points
06700 *          to the beginning of the submatrix sub( A ).
06701 *
06702 *  DESCA   (global and local input) INTEGER array
06703 *          On entry, DESCA  is an integer array of dimension DLEN_. This
06704 *          is the array descriptor for the matrix A.
06705 *
06706 *  BETA    (global input) COMPLEX
06707 *          On entry, BETA specifies the scalar beta.
06708 *
06709 *  C       (local input/local output) COMPLEX array
06710 *          On entry, C is an array of  dimension  (DESCC( M_ ),*).  This
06711 *          array contains a local copy of the initial entire matrix PC.
06712 *
06713 *  PC      (local input) COMPLEX array
06714 *          On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
06715 *          array contains the local pieces of the matrix PC.
06716 *
06717 *  IC      (global input) INTEGER
06718 *          On entry, IC  specifies C's global row index, which points to
06719 *          the beginning of the submatrix sub( C ).
06720 *
06721 *  JC      (global input) INTEGER
06722 *          On entry, JC  specifies C's global column index, which points
06723 *          to the beginning of the submatrix sub( C ).
06724 *
06725 *  DESCC   (global and local input) INTEGER array
06726 *          On entry, DESCC  is an integer array of dimension DLEN_. This
06727 *          is the array descriptor for the matrix C.
06728 *
06729 *  ERR     (global output) REAL
06730 *          On exit, ERR specifies the largest error in absolute value.
06731 *
06732 *  INFO    (global output) INTEGER
06733 *          On exit, if INFO <> 0, the result is less than half accurate.
06734 *
06735 *  -- Written on April 1, 1998 by
06736 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
06737 *
06738 *  =====================================================================
06739 *
06740 *     .. Parameters ..
06741       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
06742      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
06743      $                   RSRC_
06744       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
06745      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
06746      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
06747      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
06748       REAL               ZERO
06749       PARAMETER          ( ZERO = 0.0E+0 )
06750 *     ..
06751 *     .. Local Scalars ..
06752       LOGICAL            COLREP, CTRAN, LOWER, NOTRAN, ROWREP, UPPER
06753       INTEGER            I, ICCOL, ICROW, ICTXT, IIC, IOFFA, IOFFC, J,
06754      $                   JJC, LDA, LDC, LDPC, MYCOL, MYROW, NPCOL,
06755      $                   NPROW
06756       REAL               ERR0, ERRI, PREC
06757 *     ..
06758 *     .. External Subroutines ..
06759       EXTERNAL           BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L,
06760      $                   PCERRAXPBY, SGAMX2D
06761 *     ..
06762 *     .. External Functions ..
06763       LOGICAL            LSAME
06764       REAL               PSLAMCH
06765       EXTERNAL           LSAME, PSLAMCH
06766 *     ..
06767 *     .. Intrinsic Functions ..
06768       INTRINSIC          ABS, CONJG, MAX
06769 *     ..
06770 *     .. Executable Statements ..
06771 *
06772       ICTXT = DESCC( CTXT_ )
06773       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
06774 *
06775       PREC   = PSLAMCH( ICTXT, 'eps' )
06776 *
06777       UPPER  = LSAME( UPLO,  'U' )
06778       LOWER  = LSAME( UPLO,  'L' )
06779       NOTRAN = LSAME( TRANS, 'N' )
06780       CTRAN  = LSAME( TRANS, 'C' )
06781 *
06782 *     Compute expected result in C using data in A and C. This part of
06783 *     the computation is performed by every process in the grid.
06784 *
06785       INFO   = 0
06786       ERR    = ZERO
06787 *
06788       LDA    = MAX( 1, DESCA( M_   ) )
06789       LDC    = MAX( 1, DESCC( M_   ) )
06790       LDPC   = MAX( 1, DESCC( LLD_ ) )
06791       ROWREP = ( DESCC( RSRC_ ).EQ.-1 )
06792       COLREP = ( DESCC( CSRC_ ).EQ.-1 )
06793 *
06794       IF( NOTRAN ) THEN
06795 *
06796          DO 20 J = JC, JC + N - 1
06797 *
06798             IOFFC = IC + ( J  - 1          ) * LDC
06799             IOFFA = IA + ( JA - 1 + J - JC ) * LDA
06800 *
06801             DO 10 I = IC, IC + M - 1
06802 *
06803                IF( UPPER ) THEN
06804                   IF( ( J - JC ).GE.( I - IC ) ) THEN
06805                      CALL PCERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06806      $                                C( IOFFC ), PREC )
06807                   ELSE
06808                      ERRI = ZERO
06809                   END IF
06810                ELSE IF( LOWER ) THEN
06811                   IF( ( J - JC ).LE.( I - IC ) ) THEN
06812                      CALL PCERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06813      $                                C( IOFFC ), PREC )
06814                   ELSE
06815                      ERRI = ZERO
06816                   END IF
06817                ELSE
06818                   CALL PCERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06819      $                             C( IOFFC ), PREC )
06820                END IF
06821 *
06822                CALL PB_INFOG2L( I, J, DESCC, NPROW, NPCOL, MYROW, MYCOL,
06823      $                          IIC, JJC, ICROW, ICCOL )
06824                IF( ( MYROW.EQ.ICROW .OR. ROWREP ) .AND.
06825      $             ( MYCOL.EQ.ICCOL .OR. COLREP ) ) THEN
06826                   ERR0 = ABS( PC( IIC+(JJC-1)*LDPC )-C( IOFFC ) )
06827                   IF( ERR0.GT.ERRI )
06828      $               INFO = 1
06829                   ERR = MAX( ERR, ERR0 )
06830                END IF
06831 *
06832                IOFFA = IOFFA + 1
06833                IOFFC = IOFFC + 1
06834 *
06835    10       CONTINUE
06836 *
06837    20    CONTINUE
06838 *
06839       ELSE IF( CTRAN ) THEN
06840 *
06841          DO 40 J = JC, JC + N - 1
06842 *
06843             IOFFC = IC +              ( J  - 1 ) * LDC
06844             IOFFA = IA + ( J - JC ) + ( JA - 1 ) * LDA
06845 *
06846             DO 30 I = IC, IC + M - 1
06847 *
06848                IF( UPPER ) THEN
06849                   IF( ( J - JC ).GE.( I - IC ) ) THEN
06850                      CALL PCERRAXPBY( ERRI, ALPHA, CONJG( A( IOFFA ) ),
06851      $                                BETA, C( IOFFC ), PREC )
06852                   ELSE
06853                      ERRI = ZERO
06854                   END IF
06855                ELSE IF( LOWER ) THEN
06856                   IF( ( J - JC ).LE.( I - IC ) ) THEN
06857                      CALL PCERRAXPBY( ERRI, ALPHA, CONJG( A( IOFFA ) ),
06858      $                                BETA, C( IOFFC ), PREC )
06859                   ELSE
06860                      ERRI = ZERO
06861                   END IF
06862                ELSE
06863                   CALL PCERRAXPBY( ERRI, ALPHA, CONJG( A( IOFFA ) ),
06864      $                             BETA, C( IOFFC ), PREC )
06865                END IF
06866 *
06867                CALL PB_INFOG2L( I, J, DESCC, NPROW, NPCOL, MYROW, MYCOL,
06868      $                          IIC, JJC, ICROW, ICCOL )
06869                IF( ( MYROW.EQ.ICROW .OR. ROWREP ) .AND.
06870      $             ( MYCOL.EQ.ICCOL .OR. COLREP ) ) THEN
06871                   ERR0 = ABS( PC( IIC+(JJC-1)*LDPC )-C( IOFFC ) )
06872                   IF( ERR0.GT.ERRI )
06873      $               INFO = 1
06874                   ERR = MAX( ERR, ERR0 )
06875                END IF
06876 *
06877                IOFFC = IOFFC + 1
06878                IOFFA = IOFFA + LDA
06879 *
06880    30       CONTINUE
06881 *
06882    40    CONTINUE
06883 *
06884       ELSE
06885 *
06886          DO 60 J = JC, JC + N - 1
06887 *
06888             IOFFC = IC +              ( J  - 1 ) * LDC
06889             IOFFA = IA + ( J - JC ) + ( JA - 1 ) * LDA
06890 *
06891             DO 50 I = IC, IC + M - 1
06892 *
06893                IF( UPPER ) THEN
06894                   IF( ( J - JC ).GE.( I - IC ) ) THEN
06895                      CALL PCERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06896      $                                C( IOFFC ), PREC )
06897                   ELSE
06898                      ERRI = ZERO
06899                   END IF
06900                ELSE IF( LOWER ) THEN
06901                   IF( ( J - JC ).LE.( I - IC ) ) THEN
06902                      CALL PCERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06903      $                                C( IOFFC ), PREC )
06904                   ELSE
06905                      ERRI = ZERO
06906                   END IF
06907                ELSE
06908                   CALL PCERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06909      $                             C( IOFFC ), PREC )
06910                END IF
06911 *
06912                CALL PB_INFOG2L( I, J, DESCC, NPROW, NPCOL, MYROW, MYCOL,
06913      $                          IIC, JJC, ICROW, ICCOL )
06914                IF( ( MYROW.EQ.ICROW .OR. ROWREP ) .AND.
06915      $             ( MYCOL.EQ.ICCOL .OR. COLREP ) ) THEN
06916                   ERR0 = ABS( PC( IIC+(JJC-1)*LDPC )-C( IOFFC ) )
06917                   IF( ERR0.GT.ERRI )
06918      $               INFO = 1
06919                   ERR = MAX( ERR, ERR0 )
06920                END IF
06921 *
06922                IOFFC = IOFFC + 1
06923                IOFFA = IOFFA + LDA
06924 *
06925    50       CONTINUE
06926 *
06927    60    CONTINUE
06928 *
06929       END IF
06930 *
06931 *     If INFO = 0, all results are at least half accurate.
06932 *
06933       CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL )
06934       CALL SGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
06935      $              MYCOL )
06936 *
06937       RETURN
06938 *
06939 *     End of PCMMCH3
06940 *
06941       END
06942       SUBROUTINE PCERRAXPBY( ERRBND, ALPHA, X, BETA, Y, PREC )
06943 *
06944 *  -- PBLAS test routine (version 2.0) --
06945 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
06946 *     and University of California, Berkeley.
06947 *     April 1, 1998
06948 *
06949 *     .. Scalar Arguments ..
06950       REAL               ERRBND, PREC
06951       COMPLEX            ALPHA, BETA, X, Y
06952 *     ..
06953 *
06954 *  Purpose
06955 *  =======
06956 *
06957 *  PCERRAXPBY  serially  computes  y := beta*y + alpha * x and returns a
06958 *  scaled relative acceptable error bound on the result.
06959 *
06960 *  Arguments
06961 *  =========
06962 *
06963 *  ERRBND  (global output) REAL
06964 *          On exit, ERRBND  specifies the scaled relative acceptable er-
06965 *          ror bound.
06966 *
06967 *  ALPHA   (global input) COMPLEX
06968 *          On entry, ALPHA specifies the scalar alpha.
06969 *
06970 *  X       (global input) COMPLEX
06971 *          On entry, X  specifies the scalar x to be scaled.
06972 *
06973 *  BETA    (global input) COMPLEX
06974 *          On entry, BETA specifies the scalar beta.
06975 *
06976 *  Y       (global input/global output) COMPLEX
06977 *          On entry,  Y  specifies  the scalar y to be added. On exit, Y
06978 *          contains the resulting scalar y.
06979 *
06980 *  PREC    (global input) REAL
06981 *          On entry, PREC specifies the machine precision.
06982 *
06983 *  -- Written on April 1, 1998 by
06984 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
06985 *
06986 *  =====================================================================
06987 *
06988 *     .. Parameters ..
06989       REAL               ONE, TWO, ZERO
06990       PARAMETER          ( ONE = 1.0E+0, TWO = 2.0E+0,
06991      $                   ZERO = 0.0E+0 )
06992 *     ..
06993 *     .. Local Scalars ..
06994       REAL               ADDBND, FACT, SUMINEG, SUMIPOS, SUMRNEG,
06995      $                   SUMRPOS
06996       COMPLEX            TMP
06997 *     ..
06998 *     .. Intrinsic Functions ..
06999 *     ..
07000 *     .. Executable Statements ..
07001 *
07002       SUMIPOS = ZERO
07003       SUMINEG = ZERO
07004       SUMRPOS = ZERO
07005       SUMRNEG = ZERO
07006       FACT = ONE + TWO * PREC
07007       ADDBND = TWO * TWO * TWO * PREC
07008 *
07009       TMP = ALPHA * X
07010       IF( REAL( TMP ).GE.ZERO ) THEN
07011          SUMRPOS = SUMRPOS + REAL( TMP ) * FACT
07012       ELSE
07013          SUMRNEG = SUMRNEG - REAL( TMP ) * FACT
07014       END IF
07015       IF( AIMAG( TMP ).GE.ZERO ) THEN
07016          SUMIPOS = SUMIPOS + AIMAG( TMP ) * FACT
07017       ELSE
07018          SUMINEG = SUMINEG - AIMAG( TMP ) * FACT
07019       END IF
07020 *
07021       TMP = BETA * Y
07022       IF( REAL( TMP ).GE.ZERO ) THEN
07023          SUMRPOS = SUMRPOS + REAL( TMP ) * FACT
07024       ELSE
07025          SUMRNEG = SUMRNEG - REAL( TMP ) * FACT
07026       END IF
07027       IF( AIMAG( TMP ).GE.ZERO ) THEN
07028          SUMIPOS = SUMIPOS + AIMAG( TMP ) * FACT
07029       ELSE
07030          SUMINEG = SUMINEG - AIMAG( TMP ) * FACT
07031       END IF
07032 *
07033       Y = ( BETA * Y ) + ( ALPHA * X )
07034 *
07035       ERRBND = ADDBND * MAX( MAX( SUMRPOS, SUMRNEG ),
07036      $                       MAX( SUMIPOS, SUMINEG ) )
07037 *
07038       RETURN
07039 *
07040 *     End of PCERRAXPBY
07041 *
07042       END
07043       SUBROUTINE PCIPSET( TOGGLE, N, A, IA, JA, DESCA )
07044 *
07045 *  -- PBLAS test routine (version 2.0) --
07046 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
07047 *     and University of California, Berkeley.
07048 *     April 1, 1998
07049 *
07050 *     .. Scalar Arguments ..
07051       CHARACTER*1        TOGGLE
07052       INTEGER            IA, JA, N
07053 *     ..
07054 *     .. Array Arguments ..
07055       INTEGER            DESCA( * )
07056       COMPLEX            A( * )
07057 *     ..
07058 *
07059 *  Purpose
07060 *  =======
07061 *
07062 *  PCIPSET  sets the imaginary part of the diagonal entries of an n by n
07063 *  matrix sub( A )  denoting  A( IA:IA+N-1, JA:JA+N-1 ). This is used to
07064 *  test the  PBLAS routines  for  complex Hermitian  matrices, which are
07065 *  either  not supposed to access or use the imaginary parts of the dia-
07066 *  gonals, or supposed to set  them to zero. The  value  used to set the
07067 *  imaginary part of the diagonals depends on the value of TOGGLE.
07068 *
07069 *  Notes
07070 *  =====
07071 *
07072 *  A description  vector  is associated with each 2D block-cyclicly dis-
07073 *  tributed matrix.  This  vector  stores  the  information  required to
07074 *  establish the  mapping  between a  matrix entry and its corresponding
07075 *  process and memory location.
07076 *
07077 *  In  the  following  comments,   the character _  should  be  read  as
07078 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
07079 *  block cyclicly distributed matrix.  Its description vector is DESCA:
07080 *
07081 *  NOTATION         STORED IN       EXPLANATION
07082 *  ---------------- --------------- ------------------------------------
07083 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
07084 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
07085 *                                   the NPROW x NPCOL BLACS process grid
07086 *                                   A  is distributed over.  The context
07087 *                                   itself  is  global,  but  the handle
07088 *                                   (the integer value) may vary.
07089 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
07090 *                                   ted matrix A, M_A >= 0.
07091 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
07092 *                                   buted matrix A, N_A >= 0.
07093 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
07094 *                                   block of the matrix A, IMB_A > 0.
07095 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
07096 *                                   left   block   of   the   matrix  A,
07097 *                                   INB_A > 0.
07098 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
07099 *                                   bute the last  M_A-IMB_A rows of  A,
07100 *                                   MB_A > 0.
07101 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
07102 *                                   bute the last  N_A-INB_A  columns of
07103 *                                   A, NB_A > 0.
07104 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
07105 *                                   row of the matrix  A is distributed,
07106 *                                   NPROW > RSRC_A >= 0.
07107 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
07108 *                                   first  column of  A  is distributed.
07109 *                                   NPCOL > CSRC_A >= 0.
07110 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
07111 *                                   array  storing  the  local blocks of
07112 *                                   the distributed matrix A,
07113 *                                   IF( Lc( 1, N_A ) > 0 )
07114 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
07115 *                                   ELSE
07116 *                                      LLD_A >= 1.
07117 *
07118 *  Let K be the number of  rows of a matrix A starting at the global in-
07119 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
07120 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
07121 *  receive if these K rows were distributed over NPROW processes.  If  K
07122 *  is the number of columns of a matrix  A  starting at the global index
07123 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
07124 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
07125 *  these K columns were distributed over NPCOL processes.
07126 *
07127 *  The values of Lr() and Lc() may be determined via a call to the func-
07128 *  tion PB_NUMROC:
07129 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
07130 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
07131 *
07132 *  Arguments
07133 *  =========
07134 *
07135 *  TOGGLE  (global input) CHARACTER*1
07136 *          On entry,  TOGGLE  specifies the set-value to be used as fol-
07137 *          lows:
07138 *             If TOGGLE = 'Z' or 'z', the  imaginary  part of the diago-
07139 *                                     nals are set to zero,
07140 *             If TOGGLE = 'B' or 'b', the  imaginary  part of the diago-
07141 *                                     nals are set to a large value.
07142 *
07143 *  N       (global input) INTEGER
07144 *          On entry,  N  specifies  the  order of sub( A ). N must be at
07145 *          least zero.
07146 *
07147 *  A       (local input/local output) pointer to COMPLEX
07148 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
07149 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
07150 *          the local entries of the matrix  A. On exit, the diagonals of
07151 *          sub( A ) have been updated as specified by TOGGLE.
07152 *
07153 *  IA      (global input) INTEGER
07154 *          On entry, IA  specifies A's global row index, which points to
07155 *          the beginning of the submatrix sub( A ).
07156 *
07157 *  JA      (global input) INTEGER
07158 *          On entry, JA  specifies A's global column index, which points
07159 *          to the beginning of the submatrix sub( A ).
07160 *
07161 *  DESCA   (global and local input) INTEGER array
07162 *          On entry, DESCA  is an integer array of dimension DLEN_. This
07163 *          is the array descriptor for the matrix A.
07164 *
07165 *  -- Written on April 1, 1998 by
07166 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
07167 *
07168 *  =====================================================================
07169 *
07170 *     .. Parameters ..
07171       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
07172      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
07173      $                   RSRC_
07174       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
07175      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
07176      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
07177      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
07178       REAL               ZERO
07179       PARAMETER          ( ZERO = 0.0E+0 )
07180 *     ..
07181 *     .. Local Scalars ..
07182       LOGICAL            COLREP, GODOWN, GOLEFT, ROWREP
07183       INTEGER            I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW,
07184      $                   IMB1, IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP,
07185      $                   JJA, JOFFA, JOFFD, LCMT, LCMT00, LDA, LDAP1,
07186      $                   LMBLOC, LNBLOC, LOW, MB, MBLKD, MBLKS, MBLOC,
07187      $                   MRCOL, MRROW, MYCOL, MYROW, NB, NBLKD, NBLKS,
07188      $                   NBLOC, NP, NPCOL, NPROW, NQ, PMB, QNB, UPP
07189       REAL               ALPHA, ATMP
07190 *     ..
07191 *     .. Local Arrays ..
07192       INTEGER            DESCA2( DLEN_ )
07193 *     ..
07194 *     .. External Subroutines ..
07195       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
07196      $                   PB_DESCTRANS
07197 *     ..
07198 *     .. External Functions ..
07199       LOGICAL            LSAME
07200       REAL               PSLAMCH
07201       EXTERNAL           LSAME, PSLAMCH
07202 *     ..
07203 *     .. Intrinsic Functions ..
07204       INTRINSIC          CMPLX, MAX, MIN, REAL
07205 *     ..
07206 *     .. Executable Statements ..
07207 *
07208 *     Convert descriptor
07209 *
07210       CALL PB_DESCTRANS( DESCA, DESCA2 )
07211 *
07212 *     Get grid parameters
07213 *
07214       ICTXT = DESCA2( CTXT_ )
07215       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
07216 *
07217       IF( N.LE.0 )
07218      $   RETURN
07219 *
07220       IF( LSAME( TOGGLE, 'Z' ) ) THEN
07221          ALPHA = ZERO
07222       ELSE IF( LSAME( TOGGLE, 'B' ) ) THEN
07223          ALPHA = PSLAMCH( ICTXT, 'Epsilon' )
07224          ALPHA = ALPHA / PSLAMCH( ICTXT, 'Safe minimum' )
07225       END IF
07226 *
07227       CALL PB_AINFOG2L( N, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
07228      $                  MYCOL, IMB1, INB1, NP, NQ, IIA, JJA, IAROW,
07229      $                  IACOL, MRROW, MRCOL )
07230 *
07231       IF( NP.LE.0 .OR. NQ.LE.0 )
07232      $   RETURN
07233 *
07234 *     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
07235 *     ILOW, LOW, IUPP, and UPP.
07236 *
07237       MB = DESCA2( MB_ )
07238       NB = DESCA2( NB_ )
07239       CALL PB_BINFO( 0, NP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL,
07240      $               LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
07241      $               LNBLOC, ILOW, LOW, IUPP, UPP )
07242 *
07243       IOFFA  = IIA - 1
07244       JOFFA  = JJA - 1
07245       ROWREP = ( DESCA2( RSRC_ ).EQ.-1 )
07246       COLREP = ( DESCA2( CSRC_ ).EQ.-1 )
07247       LDA    = DESCA2( LLD_ )
07248       LDAP1  = LDA + 1
07249 *
07250       IF( ROWREP ) THEN
07251          PMB = MB
07252       ELSE
07253          PMB = NPROW * MB
07254       END IF
07255       IF( COLREP ) THEN
07256          QNB = NB
07257       ELSE
07258          QNB = NPCOL * NB
07259       END IF
07260 *
07261 *     Handle the first block of rows or columns separately, and update
07262 *     LCMT00, MBLKS and NBLKS.
07263 *
07264       GODOWN = ( LCMT00.GT.IUPP )
07265       GOLEFT = ( LCMT00.LT.ILOW )
07266 *
07267       IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN
07268 *
07269 *        LCMT00 >= ILOW && LCMT00 <= IUPP
07270 *
07271          IF( LCMT00.GE.0 ) THEN
07272             IJOFFA = IOFFA + LCMT00 + ( JOFFA - 1 ) * LDA
07273             DO 10 I = 1, MIN( INBLOC, MAX( 0, IMBLOC - LCMT00 ) )
07274                ATMP = REAL( A( IJOFFA + I*LDAP1 ) )
07275                A( IJOFFA + I*LDAP1 ) = CMPLX( ATMP, ALPHA )
07276    10       CONTINUE
07277          ELSE
07278             IJOFFA = IOFFA + ( JOFFA - LCMT00 - 1 ) * LDA
07279             DO 20 I = 1, MIN( IMBLOC, MAX( 0, INBLOC + LCMT00 ) )
07280                ATMP = REAL( A( IJOFFA + I*LDAP1 ) )
07281                A( IJOFFA + I*LDAP1 ) = CMPLX( ATMP, ALPHA )
07282    20       CONTINUE
07283          END IF
07284          GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW )
07285          GODOWN = .NOT.GOLEFT
07286 *
07287       END IF
07288 *
07289       IF( GODOWN ) THEN
07290 *
07291          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
07292          MBLKS  = MBLKS - 1
07293          IOFFA  = IOFFA + IMBLOC
07294 *
07295    30    CONTINUE
07296          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
07297             LCMT00 = LCMT00 - PMB
07298             MBLKS  = MBLKS - 1
07299             IOFFA  = IOFFA + MB
07300             GO TO 30
07301          END IF
07302 *
07303          IF( MBLKS.LE.0 )
07304      $      RETURN
07305 *
07306          LCMT  = LCMT00
07307          MBLKD = MBLKS
07308          IOFFD = IOFFA
07309 *
07310          MBLOC = MB
07311    40    CONTINUE
07312          IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN
07313             IF( MBLKD.EQ.1 )
07314      $         MBLOC = LMBLOC
07315             IF( LCMT.GE.0 ) THEN
07316                IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
07317                DO 50 I = 1, MIN( INBLOC, MAX( 0, MBLOC - LCMT ) )
07318                   ATMP = REAL( A( IJOFFA + I*LDAP1 ) )
07319                   A( IJOFFA + I*LDAP1 ) = CMPLX( ATMP, ALPHA )
07320    50          CONTINUE
07321             ELSE
07322                IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
07323                DO 60 I = 1, MIN( MBLOC, MAX( 0, INBLOC + LCMT ) )
07324                   ATMP = REAL( A( IJOFFA + I*LDAP1 ) )
07325                   A( IJOFFA + I*LDAP1 ) = CMPLX( ATMP, ALPHA )
07326    60          CONTINUE
07327             END IF
07328             LCMT00 = LCMT
07329             LCMT   = LCMT - PMB
07330             MBLKS  = MBLKD
07331             MBLKD  = MBLKD - 1
07332             IOFFA  = IOFFD
07333             IOFFD  = IOFFD + MBLOC
07334             GO TO 40
07335          END IF
07336 *
07337          LCMT00 = LCMT00 + LOW - ILOW + QNB
07338          NBLKS  = NBLKS - 1
07339          JOFFA  = JOFFA + INBLOC
07340 *
07341       ELSE IF( GOLEFT ) THEN
07342 *
07343          LCMT00 = LCMT00 + LOW - ILOW + QNB
07344          NBLKS  = NBLKS - 1
07345          JOFFA  = JOFFA + INBLOC
07346 *
07347    70    CONTINUE
07348          IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN
07349             LCMT00 = LCMT00 + QNB
07350             NBLKS  = NBLKS - 1
07351             JOFFA  = JOFFA + NB
07352             GO TO 70
07353          END IF
07354 *
07355          IF( NBLKS.LE.0 )
07356      $      RETURN
07357 *
07358          LCMT  = LCMT00
07359          NBLKD = NBLKS
07360          JOFFD = JOFFA
07361 *
07362          NBLOC = NB
07363    80    CONTINUE
07364          IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN
07365             IF( NBLKD.EQ.1 )
07366      $         NBLOC = LNBLOC
07367             IF( LCMT.GE.0 ) THEN
07368                IJOFFA = IOFFA + LCMT + ( JOFFD - 1 ) * LDA
07369                DO 90 I = 1, MIN( NBLOC, MAX( 0, IMBLOC - LCMT ) )
07370                   ATMP = REAL( A( IJOFFA + I*LDAP1 ) )
07371                   A( IJOFFA + I*LDAP1 ) = CMPLX( ATMP, ALPHA )
07372    90          CONTINUE
07373             ELSE
07374                IJOFFA = IOFFA + ( JOFFD - LCMT - 1 ) * LDA
07375                DO 100 I = 1, MIN( IMBLOC, MAX( 0, NBLOC + LCMT ) )
07376                   ATMP = REAL( A( IJOFFA + I*LDAP1 ) )
07377                   A( IJOFFA + I*LDAP1 ) = CMPLX( ATMP, ALPHA )
07378   100          CONTINUE
07379             END IF
07380             LCMT00 = LCMT
07381             LCMT   = LCMT + QNB
07382             NBLKS  = NBLKD
07383             NBLKD  = NBLKD - 1
07384             JOFFA  = JOFFD
07385             JOFFD  = JOFFD + NBLOC
07386             GO TO 80
07387          END IF
07388 *
07389          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
07390          MBLKS  = MBLKS - 1
07391          IOFFA  = IOFFA + IMBLOC
07392 *
07393       END IF
07394 *
07395       NBLOC = NB
07396   110 CONTINUE
07397       IF( NBLKS.GT.0 ) THEN
07398          IF( NBLKS.EQ.1 )
07399      $      NBLOC = LNBLOC
07400   120    CONTINUE
07401          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
07402             LCMT00 = LCMT00 - PMB
07403             MBLKS  = MBLKS - 1
07404             IOFFA  = IOFFA + MB
07405             GO TO 120
07406          END IF
07407 *
07408          IF( MBLKS.LE.0 )
07409      $      RETURN
07410 *
07411          LCMT  = LCMT00
07412          MBLKD = MBLKS
07413          IOFFD = IOFFA
07414 *
07415          MBLOC = MB
07416   130    CONTINUE
07417          IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN
07418             IF( MBLKD.EQ.1 )
07419      $         MBLOC = LMBLOC
07420             IF( LCMT.GE.0 ) THEN
07421                IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
07422                DO 140 I = 1, MIN( NBLOC, MAX( 0, MBLOC - LCMT ) )
07423                   ATMP = REAL( A( IJOFFA + I*LDAP1 ) )
07424                   A( IJOFFA + I*LDAP1 ) = CMPLX( ATMP, ALPHA )
07425   140          CONTINUE
07426             ELSE
07427                IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
07428                DO 150 I = 1, MIN( MBLOC, MAX( 0, NBLOC + LCMT ) )
07429                   ATMP = REAL( A( IJOFFA + I*LDAP1 ) )
07430                   A( IJOFFA + I*LDAP1 ) = CMPLX( ATMP, ALPHA )
07431   150          CONTINUE
07432             END IF
07433             LCMT00 = LCMT
07434             LCMT   = LCMT - PMB
07435             MBLKS  = MBLKD
07436             MBLKD  = MBLKD - 1
07437             IOFFA  = IOFFD
07438             IOFFD  = IOFFD + MBLOC
07439             GO TO 130
07440          END IF
07441 *
07442          LCMT00 = LCMT00 + QNB
07443          NBLKS  = NBLKS - 1
07444          JOFFA  = JOFFA + NBLOC
07445          GO TO 110
07446 *
07447       END IF
07448 *
07449       RETURN
07450 *
07451 *     End of PCIPSET
07452 *
07453       END
07454       REAL               FUNCTION PSLAMCH( ICTXT, CMACH )
07455 *
07456 *  -- PBLAS test routine (version 2.0) --
07457 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
07458 *     and University of California, Berkeley.
07459 *     April 1, 1998
07460 *
07461 *     .. Scalar Arguments ..
07462       CHARACTER*1        CMACH
07463       INTEGER            ICTXT
07464 *     ..
07465 *
07466 *  Purpose
07467 *  =======
07468 *
07469 *
07470 *     .. Local Scalars ..
07471       CHARACTER*1        TOP
07472       INTEGER            IDUMM
07473       REAL               TEMP
07474 *     ..
07475 *     .. External Subroutines ..
07476       EXTERNAL           PB_TOPGET, SGAMN2D, SGAMX2D
07477 *     ..
07478 *     .. External Functions ..
07479       LOGICAL            LSAME
07480       REAL               SLAMCH
07481       EXTERNAL           LSAME, SLAMCH
07482 *     ..
07483 *     .. Executable Statements ..
07484 *
07485       TEMP = SLAMCH( CMACH )
07486 *
07487       IF( LSAME( CMACH, 'E' ).OR.LSAME( CMACH, 'S' ).OR.
07488      $    LSAME( CMACH, 'M' ).OR.LSAME( CMACH, 'U' ) ) THEN
07489          CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP )
07490          IDUMM = 0
07491          CALL SGAMX2D( ICTXT, 'All', TOP, 1, 1, TEMP, 1, IDUMM,
07492      $                 IDUMM, -1, -1, IDUMM )
07493       ELSE IF( LSAME( CMACH, 'L' ).OR.LSAME( CMACH, 'O' ) ) THEN
07494          CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP )
07495          IDUMM = 0
07496          CALL SGAMN2D( ICTXT, 'All', TOP, 1, 1, TEMP, 1, IDUMM,
07497      $                 IDUMM, -1, -1, IDUMM )
07498       END IF
07499 *
07500       PSLAMCH = TEMP
07501 *
07502       RETURN
07503 *
07504 *     End of PSLAMCH
07505 *
07506       END
07507       SUBROUTINE PCLASET( UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA )
07508 *
07509 *  -- PBLAS test routine (version 2.0) --
07510 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
07511 *     and University of California, Berkeley.
07512 *     April 1, 1998
07513 *
07514 *     .. Scalar Arguments ..
07515       CHARACTER*1        UPLO
07516       INTEGER            IA, JA, M, N
07517       COMPLEX            ALPHA, BETA
07518 *     ..
07519 *     .. Array Arguments ..
07520       INTEGER            DESCA( * )
07521       COMPLEX            A( * )
07522 *     ..
07523 *
07524 *  Purpose
07525 *  =======
07526 *
07527 *  PCLASET  initializes an m by n submatrix A(IA:IA+M-1,JA:JA+N-1) deno-
07528 *  ted  by  sub( A )  to beta on the diagonal and alpha on the offdiago-
07529 *  nals.
07530 *
07531 *  Notes
07532 *  =====
07533 *
07534 *  A description  vector  is associated with each 2D block-cyclicly dis-
07535 *  tributed matrix.  This  vector  stores  the  information  required to
07536 *  establish the  mapping  between a  matrix entry and its corresponding
07537 *  process and memory location.
07538 *
07539 *  In  the  following  comments,   the character _  should  be  read  as
07540 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
07541 *  block cyclicly distributed matrix.  Its description vector is DESCA:
07542 *
07543 *  NOTATION         STORED IN       EXPLANATION
07544 *  ---------------- --------------- ------------------------------------
07545 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
07546 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
07547 *                                   the NPROW x NPCOL BLACS process grid
07548 *                                   A  is distributed over.  The context
07549 *                                   itself  is  global,  but  the handle
07550 *                                   (the integer value) may vary.
07551 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
07552 *                                   ted matrix A, M_A >= 0.
07553 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
07554 *                                   buted matrix A, N_A >= 0.
07555 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
07556 *                                   block of the matrix A, IMB_A > 0.
07557 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
07558 *                                   left   block   of   the   matrix  A,
07559 *                                   INB_A > 0.
07560 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
07561 *                                   bute the last  M_A-IMB_A rows of  A,
07562 *                                   MB_A > 0.
07563 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
07564 *                                   bute the last  N_A-INB_A  columns of
07565 *                                   A, NB_A > 0.
07566 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
07567 *                                   row of the matrix  A is distributed,
07568 *                                   NPROW > RSRC_A >= 0.
07569 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
07570 *                                   first  column of  A  is distributed.
07571 *                                   NPCOL > CSRC_A >= 0.
07572 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
07573 *                                   array  storing  the  local blocks of
07574 *                                   the distributed matrix A,
07575 *                                   IF( Lc( 1, N_A ) > 0 )
07576 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
07577 *                                   ELSE
07578 *                                      LLD_A >= 1.
07579 *
07580 *  Let K be the number of  rows of a matrix A starting at the global in-
07581 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
07582 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
07583 *  receive if these K rows were distributed over NPROW processes.  If  K
07584 *  is the number of columns of a matrix  A  starting at the global index
07585 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
07586 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
07587 *  these K columns were distributed over NPCOL processes.
07588 *
07589 *  The values of Lr() and Lc() may be determined via a call to the func-
07590 *  tion PB_NUMROC:
07591 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
07592 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
07593 *
07594 *  Arguments
07595 *  =========
07596 *
07597 *  UPLO    (global input) CHARACTER*1
07598 *          On entry, UPLO specifies the part  of  the submatrix sub( A )
07599 *          to be set:
07600 *             = 'L' or 'l':   Lower triangular part is set; the strictly
07601 *                      upper triangular part of sub( A ) is not changed;
07602 *             = 'U' or 'u':   Upper triangular part is set; the strictly
07603 *                      lower triangular part of sub( A ) is not changed;
07604 *             Otherwise:  All of the matrix sub( A ) is set.
07605 *
07606 *  M       (global input) INTEGER
07607 *          On entry,  M  specifies the number of rows of  the  submatrix
07608 *          sub( A ). M  must be at least zero.
07609 *
07610 *  N       (global input) INTEGER
07611 *          On entry, N  specifies the number of columns of the submatrix
07612 *          sub( A ). N must be at least zero.
07613 *
07614 *  ALPHA   (global input) COMPLEX
07615 *          On entry,  ALPHA  specifies the scalar alpha, i.e., the cons-
07616 *          tant to which the offdiagonal elements are to be set.
07617 *
07618 *  BETA    (global input) COMPLEX
07619 *          On entry, BETA  specifies the scalar beta, i.e., the constant
07620 *          to which the diagonal elements are to be set.
07621 *
07622 *  A       (local input/local output) COMPLEX array
07623 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
07624 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
07625 *          the local entries of the matrix  A  to be  set.  On exit, the
07626 *          leading m by n submatrix sub( A ) is set as follows:
07627 *
07628 *          if UPLO = 'U',  A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=j-1, 1<=j<=N,
07629 *          if UPLO = 'L',  A(IA+i-1,JA+j-1) = ALPHA, j+1<=i<=M, 1<=j<=N,
07630 *          otherwise,      A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=M,   1<=j<=N,
07631 *                                                      and IA+i.NE.JA+j,
07632 *          and, for all UPLO,  A(IA+i-1,JA+i-1) = BETA,  1<=i<=min(M,N).
07633 *
07634 *  IA      (global input) INTEGER
07635 *          On entry, IA  specifies A's global row index, which points to
07636 *          the beginning of the submatrix sub( A ).
07637 *
07638 *  JA      (global input) INTEGER
07639 *          On entry, JA  specifies A's global column index, which points
07640 *          to the beginning of the submatrix sub( A ).
07641 *
07642 *  DESCA   (global and local input) INTEGER array
07643 *          On entry, DESCA  is an integer array of dimension DLEN_. This
07644 *          is the array descriptor for the matrix A.
07645 *
07646 *  -- Written on April 1, 1998 by
07647 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
07648 *
07649 *  =====================================================================
07650 *
07651 *     .. Parameters ..
07652       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
07653      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
07654      $                   RSRC_
07655       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
07656      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
07657      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
07658      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
07659 *     ..
07660 *     .. Local Scalars ..
07661       LOGICAL            GODOWN, GOLEFT, ISCOLREP, ISROWREP, LOWER,
07662      $                   UPPER
07663       INTEGER            IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1,
07664      $                   IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP, JJA,
07665      $                   JJMAX, JOFFA, JOFFD, LCMT, LCMT00, LDA, LMBLOC,
07666      $                   LNBLOC, LOW, M1, MB, MBLKD, MBLKS, MBLOC, MP,
07667      $                   MRCOL, MRROW, MYCOL, MYROW, N1, NB, NBLKD,
07668      $                   NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB, QNB, TMP1,
07669      $                   UPP
07670 *     ..
07671 *     .. Local Arrays ..
07672       INTEGER            DESCA2( DLEN_ )
07673 *     ..
07674 *     .. External Subroutines ..
07675       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
07676      $                   PB_CLASET, PB_DESCTRANS
07677 *     ..
07678 *     .. External Functions ..
07679       LOGICAL            LSAME
07680       EXTERNAL           LSAME
07681 *     ..
07682 *     .. Intrinsic Functions ..
07683       INTRINSIC          MIN
07684 *     ..
07685 *     .. Executable Statements ..
07686 *
07687       IF( M.EQ.0 .OR. N.EQ.0 )
07688      $   RETURN
07689 *
07690 *     Convert descriptor
07691 *
07692       CALL PB_DESCTRANS( DESCA, DESCA2 )
07693 *
07694 *     Get grid parameters
07695 *
07696       ICTXT = DESCA2( CTXT_ )
07697       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
07698 *
07699       CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
07700      $                  MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
07701      $                  IACOL, MRROW, MRCOL )
07702 *
07703       IF( MP.LE.0 .OR. NQ.LE.0 )
07704      $   RETURN
07705 *
07706       ISROWREP = ( DESCA2( RSRC_ ).LT.0 )
07707       ISCOLREP = ( DESCA2( CSRC_ ).LT.0 )
07708       LDA      = DESCA2( LLD_ )
07709 *
07710       UPPER = .NOT.( LSAME( UPLO, 'L' ) )
07711       LOWER = .NOT.( LSAME( UPLO, 'U' ) )
07712 *
07713       IF( ( ( LOWER.AND.UPPER ).AND.( ALPHA.EQ.BETA ) ).OR.
07714      $    (   ISROWREP        .AND.  ISCOLREP        ) ) THEN
07715          IF( ( MP.GT.0 ).AND.( NQ.GT.0 ) )
07716      $      CALL PB_CLASET( UPLO, MP, NQ, 0, ALPHA, BETA,
07717      $                      A( IIA + ( JJA - 1 ) * LDA ), LDA )
07718          RETURN
07719       END IF
07720 *
07721 *     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
07722 *     ILOW, LOW, IUPP, and UPP.
07723 *
07724       MB = DESCA2( MB_ )
07725       NB = DESCA2( NB_ )
07726       CALL PB_BINFO( 0, MP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL,
07727      $               LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
07728      $               LNBLOC, ILOW, LOW, IUPP, UPP )
07729 *
07730       IOFFA = IIA - 1
07731       JOFFA = JJA - 1
07732       IIMAX = IOFFA + MP
07733       JJMAX = JOFFA + NQ
07734 *
07735       IF( ISROWREP ) THEN
07736          PMB = MB
07737       ELSE
07738          PMB = NPROW * MB
07739       END IF
07740       IF( ISCOLREP ) THEN
07741          QNB = NB
07742       ELSE
07743          QNB = NPCOL * NB
07744       END IF
07745 *
07746       M1 = MP
07747       N1 = NQ
07748 *
07749 *     Handle the first block of rows or columns separately, and update
07750 *     LCMT00, MBLKS and NBLKS.
07751 *
07752       GODOWN = ( LCMT00.GT.IUPP )
07753       GOLEFT = ( LCMT00.LT.ILOW )
07754 *
07755       IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN
07756 *
07757 *        LCMT00 >= ILOW && LCMT00 <= IUPP
07758 *
07759          GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW )
07760          GODOWN = .NOT.GOLEFT
07761 *
07762          CALL PB_CLASET( UPLO, IMBLOC, INBLOC, LCMT00, ALPHA, BETA,
07763      $                   A( IIA+JOFFA*LDA ), LDA )
07764          IF( GODOWN ) THEN
07765             IF( UPPER .AND. NQ.GT.INBLOC )
07766      $         CALL PB_CLASET( 'All', IMBLOC, NQ-INBLOC, 0, ALPHA,
07767      $                         ALPHA, A( IIA+(JOFFA+INBLOC)*LDA ), LDA )
07768             IIA = IIA + IMBLOC
07769             M1  = M1 - IMBLOC
07770          ELSE
07771             IF( LOWER .AND. MP.GT.IMBLOC )
07772      $         CALL PB_CLASET( 'All', MP-IMBLOC, INBLOC, 0, ALPHA,
07773      $                         ALPHA, A( IIA+IMBLOC+JOFFA*LDA ), LDA )
07774             JJA = JJA + INBLOC
07775             N1  = N1 - INBLOC
07776          END IF
07777 *
07778       END IF
07779 *
07780       IF( GODOWN ) THEN
07781 *
07782          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
07783          MBLKS  = MBLKS - 1
07784          IOFFA  = IOFFA + IMBLOC
07785 *
07786    10    CONTINUE
07787          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
07788             LCMT00 = LCMT00 - PMB
07789             MBLKS  = MBLKS - 1
07790             IOFFA  = IOFFA + MB
07791             GO TO 10
07792          END IF
07793 *
07794          TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
07795          IF( UPPER .AND. TMP1.GT.0 ) THEN
07796             CALL PB_CLASET( 'All', TMP1, N1, 0, ALPHA, ALPHA,
07797      $                      A( IIA+JOFFA*LDA ), LDA )
07798             IIA = IIA + TMP1
07799             M1  = M1 - TMP1
07800          END IF
07801 *
07802          IF( MBLKS.LE.0 )
07803      $      RETURN
07804 *
07805          LCMT  = LCMT00
07806          MBLKD = MBLKS
07807          IOFFD = IOFFA
07808 *
07809          MBLOC = MB
07810    20    CONTINUE
07811          IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN
07812             IF( MBLKD.EQ.1 )
07813      $         MBLOC = LMBLOC
07814             CALL PB_CLASET( UPLO, MBLOC, INBLOC, LCMT, ALPHA, BETA,
07815      $                      A( IOFFD+1+JOFFA*LDA ), LDA )
07816             LCMT00 = LCMT
07817             LCMT   = LCMT - PMB
07818             MBLKS  = MBLKD
07819             MBLKD  = MBLKD - 1
07820             IOFFA  = IOFFD
07821             IOFFD  = IOFFD + MBLOC
07822             GO TO 20
07823          END IF
07824 *
07825          TMP1 = M1 - IOFFD + IIA - 1
07826          IF( LOWER .AND. TMP1.GT.0 )
07827      $      CALL PB_CLASET( 'ALL', TMP1, INBLOC, 0, ALPHA, ALPHA,
07828      $                      A( IOFFD+1+JOFFA*LDA ), LDA )
07829 *
07830          TMP1   = IOFFA - IIA + 1
07831          M1     = M1 - TMP1
07832          N1     = N1 - INBLOC
07833          LCMT00 = LCMT00 + LOW - ILOW + QNB
07834          NBLKS  = NBLKS - 1
07835          JOFFA  = JOFFA + INBLOC
07836 *
07837          IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 )
07838      $      CALL PB_CLASET( 'ALL', TMP1, N1, 0, ALPHA, ALPHA,
07839      $                      A( IIA+JOFFA*LDA ), LDA )
07840 *
07841          IIA = IOFFA + 1
07842          JJA = JOFFA + 1
07843 *
07844       ELSE IF( GOLEFT ) THEN
07845 *
07846          LCMT00 = LCMT00 + LOW - ILOW + QNB
07847          NBLKS  = NBLKS - 1
07848          JOFFA  = JOFFA + INBLOC
07849 *
07850    30    CONTINUE
07851          IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN
07852             LCMT00 = LCMT00 + QNB
07853             NBLKS  = NBLKS - 1
07854             JOFFA  = JOFFA + NB
07855             GO TO 30
07856          END IF
07857 *
07858          TMP1 = MIN( JOFFA, JJMAX ) - JJA + 1
07859          IF( LOWER .AND. TMP1.GT.0 ) THEN
07860             CALL PB_CLASET( 'All', M1, TMP1, 0, ALPHA, ALPHA,
07861      $                      A( IIA+(JJA-1)*LDA ), LDA )
07862             JJA = JJA + TMP1
07863             N1  = N1 - TMP1
07864          END IF
07865 *
07866          IF( NBLKS.LE.0 )
07867      $      RETURN
07868 *
07869          LCMT  = LCMT00
07870          NBLKD = NBLKS
07871          JOFFD = JOFFA
07872 *
07873          NBLOC = NB
07874    40    CONTINUE
07875          IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN
07876             IF( NBLKD.EQ.1 )
07877      $         NBLOC = LNBLOC
07878             CALL PB_CLASET( UPLO, IMBLOC, NBLOC, LCMT, ALPHA, BETA,
07879      $                      A( IIA+JOFFD*LDA ), LDA )
07880             LCMT00 = LCMT
07881             LCMT   = LCMT + QNB
07882             NBLKS  = NBLKD
07883             NBLKD  = NBLKD - 1
07884             JOFFA  = JOFFD
07885             JOFFD  = JOFFD + NBLOC
07886             GO TO 40
07887          END IF
07888 *
07889          TMP1 = N1 - JOFFD + JJA - 1
07890          IF( UPPER .AND. TMP1.GT.0 )
07891      $      CALL PB_CLASET( 'All', IMBLOC, TMP1, 0, ALPHA, ALPHA,
07892      $                      A( IIA+JOFFD*LDA ), LDA )
07893 *
07894          TMP1   = JOFFA - JJA + 1
07895          M1     = M1 - IMBLOC
07896          N1     = N1 - TMP1
07897          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
07898          MBLKS  = MBLKS - 1
07899          IOFFA  = IOFFA + IMBLOC
07900 *
07901          IF( LOWER .AND. M1.GT.0 .AND. TMP1.GT.0 )
07902      $      CALL PB_CLASET( 'All', M1, TMP1, 0, ALPHA, ALPHA,
07903      $                      A( IOFFA+1+(JJA-1)*LDA ), LDA )
07904 *
07905          IIA = IOFFA + 1
07906          JJA = JOFFA + 1
07907 *
07908       END IF
07909 *
07910       NBLOC = NB
07911    50 CONTINUE
07912       IF( NBLKS.GT.0 ) THEN
07913          IF( NBLKS.EQ.1 )
07914      $      NBLOC = LNBLOC
07915    60    CONTINUE
07916          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
07917             LCMT00 = LCMT00 - PMB
07918             MBLKS  = MBLKS - 1
07919             IOFFA  = IOFFA + MB
07920             GO TO 60
07921          END IF
07922 *
07923          TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
07924          IF( UPPER .AND. TMP1.GT.0 ) THEN
07925             CALL PB_CLASET( 'All', TMP1, N1, 0, ALPHA, ALPHA,
07926      $                      A( IIA+JOFFA*LDA ), LDA )
07927             IIA = IIA + TMP1
07928             M1  = M1 - TMP1
07929          END IF
07930 *
07931          IF( MBLKS.LE.0 )
07932      $      RETURN
07933 *
07934          LCMT  = LCMT00
07935          MBLKD = MBLKS
07936          IOFFD = IOFFA
07937 *
07938          MBLOC = MB
07939    70    CONTINUE
07940          IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN
07941             IF( MBLKD.EQ.1 )
07942      $         MBLOC = LMBLOC
07943             CALL PB_CLASET( UPLO, MBLOC, NBLOC, LCMT, ALPHA, BETA,
07944      $                      A( IOFFD+1+JOFFA*LDA ), LDA )
07945             LCMT00 = LCMT
07946             LCMT   = LCMT - PMB
07947             MBLKS  = MBLKD
07948             MBLKD  = MBLKD - 1
07949             IOFFA  = IOFFD
07950             IOFFD  = IOFFD + MBLOC
07951             GO TO 70
07952          END IF
07953 *
07954          TMP1 = M1 - IOFFD + IIA - 1
07955          IF( LOWER .AND. TMP1.GT.0 )
07956      $      CALL PB_CLASET( 'All', TMP1, NBLOC, 0, ALPHA, ALPHA,
07957      $                      A( IOFFD+1+JOFFA*LDA ), LDA )
07958 *
07959          TMP1   = MIN( IOFFA, IIMAX )  - IIA + 1
07960          M1     = M1 - TMP1
07961          N1     = N1 - NBLOC
07962          LCMT00 = LCMT00 + QNB
07963          NBLKS  = NBLKS - 1
07964          JOFFA  = JOFFA + NBLOC
07965 *
07966          IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 )
07967      $      CALL PB_CLASET( 'All', TMP1, N1, 0, ALPHA, ALPHA,
07968      $                      A( IIA+JOFFA*LDA ), LDA )
07969 *
07970          IIA = IOFFA + 1
07971          JJA = JOFFA + 1
07972 *
07973          GO TO 50
07974 *
07975       END IF
07976 *
07977       RETURN
07978 *
07979 *     End of PCLASET
07980 *
07981       END
07982       SUBROUTINE PCLASCAL( TYPE, M, N, ALPHA, A, IA, JA, DESCA )
07983 *
07984 *  -- PBLAS test routine (version 2.0) --
07985 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
07986 *     and University of California, Berkeley.
07987 *     April 1, 1998
07988 *
07989 *     .. Scalar Arguments ..
07990       CHARACTER*1        TYPE
07991       INTEGER            IA, JA, M, N
07992       COMPLEX            ALPHA
07993 *     ..
07994 *     .. Array Arguments ..
07995       INTEGER            DESCA( * )
07996       COMPLEX            A( * )
07997 *     ..
07998 *
07999 *  Purpose
08000 *  =======
08001 *
08002 *  PCLASCAL  scales the  m by n submatrix A(IA:IA+M-1,JA:JA+N-1) denoted
08003 *  by sub( A ) by the scalar alpha. TYPE  specifies if sub( A ) is full,
08004 *  upper triangular, lower triangular or upper Hessenberg.
08005 *
08006 *  Notes
08007 *  =====
08008 *
08009 *  A description  vector  is associated with each 2D block-cyclicly dis-
08010 *  tributed matrix.  This  vector  stores  the  information  required to
08011 *  establish the  mapping  between a  matrix entry and its corresponding
08012 *  process and memory location.
08013 *
08014 *  In  the  following  comments,   the character _  should  be  read  as
08015 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
08016 *  block cyclicly distributed matrix.  Its description vector is DESCA:
08017 *
08018 *  NOTATION         STORED IN       EXPLANATION
08019 *  ---------------- --------------- ------------------------------------
08020 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
08021 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
08022 *                                   the NPROW x NPCOL BLACS process grid
08023 *                                   A  is distributed over.  The context
08024 *                                   itself  is  global,  but  the handle
08025 *                                   (the integer value) may vary.
08026 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
08027 *                                   ted matrix A, M_A >= 0.
08028 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
08029 *                                   buted matrix A, N_A >= 0.
08030 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
08031 *                                   block of the matrix A, IMB_A > 0.
08032 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
08033 *                                   left   block   of   the   matrix  A,
08034 *                                   INB_A > 0.
08035 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
08036 *                                   bute the last  M_A-IMB_A rows of  A,
08037 *                                   MB_A > 0.
08038 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
08039 *                                   bute the last  N_A-INB_A  columns of
08040 *                                   A, NB_A > 0.
08041 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
08042 *                                   row of the matrix  A is distributed,
08043 *                                   NPROW > RSRC_A >= 0.
08044 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
08045 *                                   first  column of  A  is distributed.
08046 *                                   NPCOL > CSRC_A >= 0.
08047 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
08048 *                                   array  storing  the  local blocks of
08049 *                                   the distributed matrix A,
08050 *                                   IF( Lc( 1, N_A ) > 0 )
08051 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
08052 *                                   ELSE
08053 *                                      LLD_A >= 1.
08054 *
08055 *  Let K be the number of  rows of a matrix A starting at the global in-
08056 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
08057 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
08058 *  receive if these K rows were distributed over NPROW processes.  If  K
08059 *  is the number of columns of a matrix  A  starting at the global index
08060 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
08061 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
08062 *  these K columns were distributed over NPCOL processes.
08063 *
08064 *  The values of Lr() and Lc() may be determined via a call to the func-
08065 *  tion PB_NUMROC:
08066 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
08067 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
08068 *
08069 *  Arguments
08070 *  =========
08071 *
08072 *  TYPE    (global input) CHARACTER*1
08073 *          On entry,  TYPE  specifies the type of the input submatrix as
08074 *          follows:
08075 *             = 'L' or 'l':  sub( A ) is a lower triangular matrix,
08076 *             = 'U' or 'u':  sub( A ) is an upper triangular matrix,
08077 *             = 'H' or 'h':  sub( A ) is an upper Hessenberg matrix,
08078 *             otherwise sub( A ) is a  full matrix.
08079 *
08080 *  M       (global input) INTEGER
08081 *          On entry,  M  specifies the number of rows of  the  submatrix
08082 *          sub( A ). M  must be at least zero.
08083 *
08084 *  N       (global input) INTEGER
08085 *          On entry, N  specifies the number of columns of the submatrix
08086 *          sub( A ). N  must be at least zero.
08087 *
08088 *  ALPHA   (global input) COMPLEX
08089 *          On entry, ALPHA specifies the scalar alpha.
08090 *
08091 *  A       (local input/local output) COMPLEX array
08092 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
08093 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
08094 *          the local entries of the matrix  A.
08095 *          On exit, the local entries of this array corresponding to the
08096 *          to  the entries of the submatrix sub( A ) are  overwritten by
08097 *          the local entries of the m by n scaled submatrix.
08098 *
08099 *  IA      (global input) INTEGER
08100 *          On entry, IA  specifies A's global row index, which points to
08101 *          the beginning of the submatrix sub( A ).
08102 *
08103 *  JA      (global input) INTEGER
08104 *          On entry, JA  specifies A's global column index, which points
08105 *          to the beginning of the submatrix sub( A ).
08106 *
08107 *  DESCA   (global and local input) INTEGER array
08108 *          On entry, DESCA  is an integer array of dimension DLEN_. This
08109 *          is the array descriptor for the matrix A.
08110 *
08111 *  -- Written on April 1, 1998 by
08112 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
08113 *
08114 *  =====================================================================
08115 *
08116 *     .. Parameters ..
08117       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
08118      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
08119      $                   RSRC_
08120       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
08121      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
08122      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
08123      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
08124 *     ..
08125 *     .. Local Scalars ..
08126       CHARACTER*1        UPLO
08127       LOGICAL            GODOWN, GOLEFT, LOWER, UPPER
08128       INTEGER            IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1,
08129      $                   IMBLOC, INB1, INBLOC, IOFFA, IOFFD, ITYPE,
08130      $                   IUPP, JJA, JJMAX, JOFFA, JOFFD, LCMT, LCMT00,
08131      $                   LDA, LMBLOC, LNBLOC, LOW, M1, MB, MBLKD, MBLKS,
08132      $                   MBLOC, MP, MRCOL, MRROW, MYCOL, MYROW, N1, NB,
08133      $                   NBLKD, NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB,
08134      $                   QNB, TMP1, UPP
08135 *     ..
08136 *     .. Local Arrays ..
08137       INTEGER            DESCA2( DLEN_ )
08138 *     ..
08139 *     .. External Subroutines ..
08140       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
08141      $                   PB_CLASCAL, PB_DESCTRANS, PB_INFOG2L
08142 *     ..
08143 *     .. External Functions ..
08144       LOGICAL            LSAME
08145       INTEGER            PB_NUMROC
08146       EXTERNAL           LSAME, PB_NUMROC
08147 *     ..
08148 *     .. Intrinsic Functions ..
08149       INTRINSIC          MIN
08150 *     ..
08151 *     .. Executable Statements ..
08152 *
08153 *     Convert descriptor
08154 *
08155       CALL PB_DESCTRANS( DESCA, DESCA2 )
08156 *
08157 *     Get grid parameters
08158 *
08159       ICTXT = DESCA2( CTXT_ )
08160       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
08161 *
08162 *     Quick return if possible
08163 *
08164       IF( M.EQ.0 .OR. N.EQ.0 )
08165      $   RETURN
08166 *
08167       IF( LSAME( TYPE, 'L' ) ) THEN
08168          ITYPE = 1
08169          UPLO  = TYPE
08170          UPPER = .FALSE.
08171          LOWER = .TRUE.
08172          IOFFD = 0
08173       ELSE IF( LSAME( TYPE, 'U' ) ) THEN
08174          ITYPE = 2
08175          UPLO  = TYPE
08176          UPPER = .TRUE.
08177          LOWER = .FALSE.
08178          IOFFD = 0
08179       ELSE IF( LSAME( TYPE, 'H' ) ) THEN
08180          ITYPE = 3
08181          UPLO  = 'U'
08182          UPPER = .TRUE.
08183          LOWER = .FALSE.
08184          IOFFD = 1
08185       ELSE
08186          ITYPE = 0
08187          UPLO  = 'A'
08188          UPPER = .TRUE.
08189          LOWER = .TRUE.
08190          IOFFD = 0
08191       END IF
08192 *
08193 *     Compute local indexes
08194 *
08195       IF( ITYPE.EQ.0 ) THEN
08196 *
08197 *        Full matrix
08198 *
08199          CALL PB_INFOG2L( IA, JA, DESCA2, NPROW, NPCOL, MYROW, MYCOL,
08200      $                    IIA, JJA, IAROW, IACOL )
08201          MP = PB_NUMROC( M, IA, DESCA2( IMB_ ), DESCA2( MB_ ), MYROW,
08202      $                   DESCA2( RSRC_ ), NPROW )
08203          NQ = PB_NUMROC( N, JA, DESCA2( INB_ ), DESCA2( NB_ ), MYCOL,
08204      $                   DESCA2( CSRC_ ), NPCOL )
08205 *
08206          IF( MP.LE.0 .OR. NQ.LE.0 )
08207      $      RETURN
08208 *
08209          LDA   = DESCA2( LLD_ )
08210          IOFFA = IIA + ( JJA - 1 ) * LDA
08211 *
08212          CALL PB_CLASCAL( 'All', MP, NQ, 0, ALPHA, A( IOFFA ), LDA )
08213 *
08214       ELSE
08215 *
08216 *        Trapezoidal matrix
08217 *
08218          CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
08219      $                     MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
08220      $                     IACOL, MRROW, MRCOL )
08221 *
08222          IF( MP.LE.0 .OR. NQ.LE.0 )
08223      $      RETURN
08224 *
08225 *        Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
08226 *        LNBLOC, ILOW, LOW, IUPP, and UPP.
08227 *
08228          MB  = DESCA2( MB_ )
08229          NB  = DESCA2( NB_ )
08230          LDA = DESCA2( LLD_ )
08231 *
08232          CALL PB_BINFO( IOFFD, MP, NQ, IMB1, INB1, MB, NB, MRROW,
08233      $                  MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC,
08234      $                  LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP )
08235 *
08236          M1    = MP
08237          N1    = NQ
08238          IOFFA = IIA - 1
08239          JOFFA = JJA - 1
08240          IIMAX = IOFFA + MP
08241          JJMAX = JOFFA + NQ
08242 *
08243          IF( DESCA2( RSRC_ ).LT.0 ) THEN
08244             PMB = MB
08245          ELSE
08246             PMB = NPROW * MB
08247          END IF
08248          IF( DESCA2( CSRC_ ).LT.0 ) THEN
08249             QNB = NB
08250          ELSE
08251             QNB = NPCOL * NB
08252          END IF
08253 *
08254 *        Handle the first block of rows or columns separately, and
08255 *        update LCMT00, MBLKS and NBLKS.
08256 *
08257          GODOWN = ( LCMT00.GT.IUPP )
08258          GOLEFT = ( LCMT00.LT.ILOW )
08259 *
08260          IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN
08261 *
08262 *           LCMT00 >= ILOW && LCMT00 <= IUPP
08263 *
08264             GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW )
08265             GODOWN = .NOT.GOLEFT
08266 *
08267             CALL PB_CLASCAL( UPLO, IMBLOC, INBLOC, LCMT00, ALPHA,
08268      $                       A( IIA+JOFFA*LDA ), LDA )
08269             IF( GODOWN ) THEN
08270                IF( UPPER .AND. NQ.GT.INBLOC )
08271      $            CALL PB_CLASCAL( 'All', IMBLOC, NQ-INBLOC, 0, ALPHA,
08272      $                             A( IIA+(JOFFA+INBLOC)*LDA ), LDA )
08273                IIA = IIA + IMBLOC
08274                M1  = M1 - IMBLOC
08275             ELSE
08276                IF( LOWER .AND. MP.GT.IMBLOC )
08277      $            CALL PB_CLASCAL( 'All', MP-IMBLOC, INBLOC, 0, ALPHA,
08278      $                             A( IIA+IMBLOC+JOFFA*LDA ), LDA )
08279                JJA = JJA + INBLOC
08280                N1  = N1 - INBLOC
08281             END IF
08282 *
08283          END IF
08284 *
08285          IF( GODOWN ) THEN
08286 *
08287             LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
08288             MBLKS  = MBLKS - 1
08289             IOFFA  = IOFFA + IMBLOC
08290 *
08291    10       CONTINUE
08292             IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
08293                LCMT00 = LCMT00 - PMB
08294                MBLKS  = MBLKS - 1
08295                IOFFA  = IOFFA + MB
08296                GO TO 10
08297             END IF
08298 *
08299             TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
08300             IF( UPPER .AND. TMP1.GT.0 ) THEN
08301                CALL PB_CLASCAL( 'All', TMP1, N1, 0, ALPHA,
08302      $                          A( IIA+JOFFA*LDA ), LDA )
08303                IIA = IIA + TMP1
08304                M1  = M1 - TMP1
08305             END IF
08306 *
08307             IF( MBLKS.LE.0 )
08308      $         RETURN
08309 *
08310             LCMT  = LCMT00
08311             MBLKD = MBLKS
08312             IOFFD = IOFFA
08313 *
08314             MBLOC = MB
08315    20       CONTINUE
08316             IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN
08317                IF( MBLKD.EQ.1 )
08318      $            MBLOC = LMBLOC
08319                CALL PB_CLASCAL( UPLO, MBLOC, INBLOC, LCMT, ALPHA,
08320      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
08321                LCMT00 = LCMT
08322                LCMT   = LCMT - PMB
08323                MBLKS  = MBLKD
08324                MBLKD  = MBLKD - 1
08325                IOFFA  = IOFFD
08326                IOFFD  = IOFFD + MBLOC
08327                GO TO 20
08328             END IF
08329 *
08330             TMP1 = M1 - IOFFD + IIA - 1
08331             IF( LOWER .AND. TMP1.GT.0 )
08332      $         CALL PB_CLASCAL( 'All', TMP1, INBLOC, 0, ALPHA,
08333      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
08334 *
08335             TMP1   = IOFFA - IIA + 1
08336             M1     = M1 - TMP1
08337             N1     = N1 - INBLOC
08338             LCMT00 = LCMT00 + LOW - ILOW + QNB
08339             NBLKS  = NBLKS - 1
08340             JOFFA  = JOFFA + INBLOC
08341 *
08342             IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 )
08343      $         CALL PB_CLASCAL( 'All', TMP1, N1, 0, ALPHA,
08344      $                          A( IIA+JOFFA*LDA ), LDA )
08345 *
08346             IIA = IOFFA + 1
08347             JJA = JOFFA + 1
08348 *
08349          ELSE IF( GOLEFT ) THEN
08350 *
08351             LCMT00 = LCMT00 + LOW - ILOW + QNB
08352             NBLKS  = NBLKS - 1
08353             JOFFA  = JOFFA + INBLOC
08354 *
08355    30       CONTINUE
08356             IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN
08357                LCMT00 = LCMT00 + QNB
08358                NBLKS  = NBLKS - 1
08359                JOFFA  = JOFFA + NB
08360                GO TO 30
08361             END IF
08362 *
08363             TMP1 = MIN( JOFFA, JJMAX ) - JJA + 1
08364             IF( LOWER .AND. TMP1.GT.0 ) THEN
08365                CALL PB_CLASCAL( 'All', M1, TMP1, 0, ALPHA,
08366      $                          A( IIA+(JJA-1)*LDA ), LDA )
08367                JJA = JJA + TMP1
08368                N1  = N1 - TMP1
08369             END IF
08370 *
08371             IF( NBLKS.LE.0 )
08372      $         RETURN
08373 *
08374             LCMT  = LCMT00
08375             NBLKD = NBLKS
08376             JOFFD = JOFFA
08377 *
08378             NBLOC = NB
08379    40       CONTINUE
08380             IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN
08381                IF( NBLKD.EQ.1 )
08382      $            NBLOC = LNBLOC
08383                CALL PB_CLASCAL( UPLO, IMBLOC, NBLOC, LCMT, ALPHA,
08384      $                          A( IIA+JOFFD*LDA ), LDA )
08385                LCMT00 = LCMT
08386                LCMT   = LCMT + QNB
08387                NBLKS  = NBLKD
08388                NBLKD  = NBLKD - 1
08389                JOFFA  = JOFFD
08390                JOFFD  = JOFFD + NBLOC
08391                GO TO 40
08392             END IF
08393 *
08394             TMP1 = N1 - JOFFD + JJA - 1
08395             IF( UPPER .AND. TMP1.GT.0 )
08396      $         CALL PB_CLASCAL( 'All', IMBLOC, TMP1, 0, ALPHA,
08397      $                          A( IIA+JOFFD*LDA ), LDA )
08398 *
08399             TMP1   = JOFFA - JJA + 1
08400             M1     = M1 - IMBLOC
08401             N1     = N1 - TMP1
08402             LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
08403             MBLKS  = MBLKS - 1
08404             IOFFA  = IOFFA + IMBLOC
08405 *
08406             IF( LOWER .AND. M1.GT.0 .AND. TMP1.GT.0 )
08407      $         CALL PB_CLASCAL( 'All', M1, TMP1, 0, ALPHA,
08408      $                          A( IOFFA+1+(JJA-1)*LDA ), LDA )
08409 *
08410             IIA = IOFFA + 1
08411             JJA = JOFFA + 1
08412 *
08413          END IF
08414 *
08415          NBLOC = NB
08416    50    CONTINUE
08417          IF( NBLKS.GT.0 ) THEN
08418             IF( NBLKS.EQ.1 )
08419      $         NBLOC = LNBLOC
08420    60       CONTINUE
08421             IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
08422                LCMT00 = LCMT00 - PMB
08423                MBLKS  = MBLKS - 1
08424                IOFFA  = IOFFA + MB
08425                GO TO 60
08426             END IF
08427 *
08428             TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
08429             IF( UPPER .AND. TMP1.GT.0 ) THEN
08430                CALL PB_CLASCAL( 'All', TMP1, N1, 0, ALPHA,
08431      $                          A( IIA+JOFFA*LDA ), LDA )
08432                IIA = IIA + TMP1
08433                M1  = M1 - TMP1
08434             END IF
08435 *
08436             IF( MBLKS.LE.0 )
08437      $         RETURN
08438 *
08439             LCMT  = LCMT00
08440             MBLKD = MBLKS
08441             IOFFD = IOFFA
08442 *
08443             MBLOC = MB
08444    70       CONTINUE
08445             IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN
08446                IF( MBLKD.EQ.1 )
08447      $            MBLOC = LMBLOC
08448                CALL PB_CLASCAL( UPLO, MBLOC, NBLOC, LCMT, ALPHA,
08449      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
08450                LCMT00 = LCMT
08451                LCMT   = LCMT - PMB
08452                MBLKS  = MBLKD
08453                MBLKD  = MBLKD - 1
08454                IOFFA  = IOFFD
08455                IOFFD  = IOFFD + MBLOC
08456                GO TO 70
08457             END IF
08458 *
08459             TMP1 = M1 - IOFFD + IIA - 1
08460             IF( LOWER .AND. TMP1.GT.0 )
08461      $         CALL PB_CLASCAL( 'All', TMP1, NBLOC, 0, ALPHA,
08462      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
08463 *
08464             TMP1   = MIN( IOFFA, IIMAX )  - IIA + 1
08465             M1     = M1 - TMP1
08466             N1     = N1 - NBLOC
08467             LCMT00 = LCMT00 + QNB
08468             NBLKS  = NBLKS - 1
08469             JOFFA  = JOFFA + NBLOC
08470 *
08471             IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 )
08472      $         CALL PB_CLASCAL( 'All', TMP1, N1, 0, ALPHA,
08473      $                          A( IIA+JOFFA*LDA ), LDA )
08474 *
08475             IIA = IOFFA + 1
08476             JJA = JOFFA + 1
08477 *
08478             GO TO 50
08479 *
08480          END IF
08481 *
08482       END IF
08483 *
08484       RETURN
08485 *
08486 *     End of PCLASCAL
08487 *
08488       END
08489       SUBROUTINE PCLAGEN( INPLACE, AFORM, DIAG, OFFA, M, N, IA, JA,
08490      $                    DESCA, IASEED, A, LDA )
08491 *
08492 *  -- PBLAS test routine (version 2.0) --
08493 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
08494 *     and University of California, Berkeley.
08495 *     April 1, 1998
08496 *
08497 *     .. Scalar Arguments ..
08498       LOGICAL            INPLACE
08499       CHARACTER*1        AFORM, DIAG
08500       INTEGER            IA, IASEED, JA, LDA, M, N, OFFA
08501 *     ..
08502 *     .. Array Arguments ..
08503       INTEGER            DESCA( * )
08504       COMPLEX            A( LDA, * )
08505 *     ..
08506 *
08507 *  Purpose
08508 *  =======
08509 *
08510 *  PCLAGEN  generates  (or regenerates)  a  submatrix  sub( A ) denoting
08511 *  A(IA:IA+M-1,JA:JA+N-1).
08512 *
08513 *  Notes
08514 *  =====
08515 *
08516 *  A description  vector  is associated with each 2D block-cyclicly dis-
08517 *  tributed matrix.  This  vector  stores  the  information  required to
08518 *  establish the  mapping  between a  matrix entry and its corresponding
08519 *  process and memory location.
08520 *
08521 *  In  the  following  comments,   the character _  should  be  read  as
08522 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
08523 *  block cyclicly distributed matrix.  Its description vector is DESCA:
08524 *
08525 *  NOTATION         STORED IN       EXPLANATION
08526 *  ---------------- --------------- ------------------------------------
08527 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
08528 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
08529 *                                   the NPROW x NPCOL BLACS process grid
08530 *                                   A  is distributed over.  The context
08531 *                                   itself  is  global,  but  the handle
08532 *                                   (the integer value) may vary.
08533 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
08534 *                                   ted matrix A, M_A >= 0.
08535 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
08536 *                                   buted matrix A, N_A >= 0.
08537 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
08538 *                                   block of the matrix A, IMB_A > 0.
08539 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
08540 *                                   left   block   of   the   matrix  A,
08541 *                                   INB_A > 0.
08542 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
08543 *                                   bute the last  M_A-IMB_A rows of  A,
08544 *                                   MB_A > 0.
08545 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
08546 *                                   bute the last  N_A-INB_A  columns of
08547 *                                   A, NB_A > 0.
08548 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
08549 *                                   row of the matrix  A is distributed,
08550 *                                   NPROW > RSRC_A >= 0.
08551 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
08552 *                                   first  column of  A  is distributed.
08553 *                                   NPCOL > CSRC_A >= 0.
08554 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
08555 *                                   array  storing  the  local blocks of
08556 *                                   the distributed matrix A,
08557 *                                   IF( Lc( 1, N_A ) > 0 )
08558 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
08559 *                                   ELSE
08560 *                                      LLD_A >= 1.
08561 *
08562 *  Let K be the number of  rows of a matrix A starting at the global in-
08563 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
08564 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
08565 *  receive if these K rows were distributed over NPROW processes.  If  K
08566 *  is the number of columns of a matrix  A  starting at the global index
08567 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
08568 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
08569 *  these K columns were distributed over NPCOL processes.
08570 *
08571 *  The values of Lr() and Lc() may be determined via a call to the func-
08572 *  tion PB_NUMROC:
08573 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
08574 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
08575 *
08576 *  Arguments
08577 *  =========
08578 *
08579 *  INPLACE (global input) LOGICAL
08580 *          On entry, INPLACE specifies if the matrix should be generated
08581 *          in place or not. If INPLACE is .TRUE., the local random array
08582 *          to be generated  will start in memory at the local memory lo-
08583 *          cation A( 1, 1 ),  otherwise it will start at the local posi-
08584 *          tion induced by IA and JA.
08585 *
08586 *  AFORM   (global input) CHARACTER*1
08587 *          On entry, AFORM specifies the type of submatrix to be genera-
08588 *          ted as follows:
08589 *             AFORM = 'S', sub( A ) is a symmetric matrix,
08590 *             AFORM = 'H', sub( A ) is a Hermitian matrix,
08591 *             AFORM = 'T', sub( A ) is overrwritten  with  the transpose
08592 *                          of what would normally be generated,
08593 *             AFORM = 'C', sub( A ) is overwritten  with  the  conjugate
08594 *                          transpose  of  what would normally be genera-
08595 *                          ted.
08596 *             AFORM = 'N', a random submatrix is generated.
08597 *
08598 *  DIAG    (global input) CHARACTER*1
08599 *          On entry, DIAG specifies if the generated submatrix is diago-
08600 *          nally dominant or not as follows:
08601 *             DIAG = 'D' : sub( A ) is diagonally dominant,
08602 *             DIAG = 'N' : sub( A ) is not diagonally dominant.
08603 *
08604 *  OFFA    (global input) INTEGER
08605 *          On entry, OFFA  specifies  the  offdiagonal of the underlying
08606 *          matrix A(1:DESCA(M_),1:DESCA(N_)) of interest when the subma-
08607 *          trix is symmetric, Hermitian or diagonally dominant. OFFA = 0
08608 *          specifies the main diagonal,  OFFA > 0  specifies a subdiago-
08609 *          nal,  and OFFA < 0 specifies a superdiagonal (see further de-
08610 *          tails).
08611 *
08612 *  M       (global input) INTEGER
08613 *          On entry, M specifies the global number of matrix rows of the
08614 *          submatrix sub( A ) to be generated. M must be at least zero.
08615 *
08616 *  N       (global input) INTEGER
08617 *          On entry,  N specifies the global number of matrix columns of
08618 *          the  submatrix  sub( A )  to be generated. N must be at least
08619 *          zero.
08620 *
08621 *  IA      (global input) INTEGER
08622 *          On entry, IA  specifies A's global row index, which points to
08623 *          the beginning of the submatrix sub( A ).
08624 *
08625 *  JA      (global input) INTEGER
08626 *          On entry, JA  specifies A's global column index, which points
08627 *          to the beginning of the submatrix sub( A ).
08628 *
08629 *  DESCA   (global and local input) INTEGER array
08630 *          On entry, DESCA  is an integer array of dimension DLEN_. This
08631 *          is the array descriptor for the matrix A.
08632 *
08633 *  IASEED  (global input) INTEGER
08634 *          On entry, IASEED  specifies  the  seed number to generate the
08635 *          matrix A. IASEED must be at least zero.
08636 *
08637 *  A       (local output) COMPLEX array
08638 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
08639 *          at least Lc( 1, JA+N-1 ).  On  exit, this array  contains the
08640 *          local entries of the randomly generated submatrix sub( A ).
08641 *
08642 *  LDA     (local input) INTEGER
08643 *          On entry,  LDA  specifies  the local leading dimension of the
08644 *          array A. When INPLACE is .FALSE., LDA is usually DESCA(LLD_).
08645 *          This restriction is however not enforced, and this subroutine
08646 *          requires only that LDA >= MAX( 1, Mp ) where
08647 *
08648 *          Mp = PB_NUMROC( M, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ).
08649 *
08650 *          PB_NUMROC  is  a ScaLAPACK tool function; MYROW, MYCOL, NPROW
08651 *          and NPCOL  can  be determined by calling the BLACS subroutine
08652 *          BLACS_GRIDINFO.
08653 *
08654 *  Further Details
08655 *  ===============
08656 *
08657 *  OFFD  is  tied  to  the matrix described by  DESCA, as opposed to the
08658 *  piece that is currently  (re)generated.  This is a global information
08659 *  independent from the distribution  parameters.  Below are examples of
08660 *  the meaning of OFFD for a global 7 by 5 matrix:
08661 *
08662 *  ---------------------------------------------------------------------
08663 *  OFFD   |  0 -1 -2 -3 -4         0 -1 -2 -3 -4          0 -1 -2 -3 -4
08664 *  -------|-------------------------------------------------------------
08665 *         |     | OFFD=-1          |   OFFD=0                 OFFD=2
08666 *         |     V                  V
08667 *  0      |  .  d  .  .  .      -> d  .  .  .  .          .  .  .  .  .
08668 *  1      |  .  .  d  .  .         .  d  .  .  .          .  .  .  .  .
08669 *  2      |  .  .  .  d  .         .  .  d  .  .       -> d  .  .  .  .
08670 *  3      |  .  .  .  .  d         .  .  .  d  .          .  d  .  .  .
08671 *  4      |  .  .  .  .  .         .  .  .  .  d          .  .  d  .  .
08672 *  5      |  .  .  .  .  .         .  .  .  .  .          .  .  .  d  .
08673 *  6      |  .  .  .  .  .         .  .  .  .  .          .  .  .  .  d
08674 *  ---------------------------------------------------------------------
08675 *
08676 *  -- Written on April 1, 1998 by
08677 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
08678 *
08679 *  =====================================================================
08680 *
08681 *     .. Parameters ..
08682       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
08683      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
08684      $                   RSRC_
08685       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
08686      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
08687      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
08688      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
08689       INTEGER            JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
08690      $                   JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
08691      $                   JMP_NQINBLOC, JMP_NQNB, JMP_ROW
08692       PARAMETER          ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3,
08693      $                   JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6,
08694      $                   JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9,
08695      $                   JMP_NQNB = 10, JMP_NQINBLOC = 11,
08696      $                   JMP_LEN = 11 )
08697       REAL               ZERO
08698       PARAMETER          ( ZERO = 0.0E+0 )
08699 *     ..
08700 *     .. Local Scalars ..
08701       LOGICAL            DIAGDO, SYMM, HERM, NOTRAN
08702       INTEGER            CSRC, I, IACOL, IAROW, ICTXT, IIA, ILOCBLK,
08703      $                   ILOCOFF, ILOW, IMB, IMB1, IMBLOC, IMBVIR, INB,
08704      $                   INB1, INBLOC, INBVIR, INFO, IOFFDA, ITMP, IUPP,
08705      $                   IVIR, JJA, JLOCBLK, JLOCOFF, JVIR, LCMT00,
08706      $                   LMBLOC, LNBLOC, LOW, MAXMN, MB, MBLKS, MP,
08707      $                   MRCOL, MRROW, MYCDIST, MYCOL, MYRDIST, MYROW,
08708      $                   NB, NBLKS, NPCOL, NPROW, NQ, NVIR, RSRC, UPP
08709       COMPLEX            ALPHA
08710 *     ..
08711 *     .. Local Arrays ..
08712       INTEGER            DESCA2( DLEN_ ), IMULADD( 4, JMP_LEN ),
08713      $                   IRAN( 2 ), JMP( JMP_LEN ), MULADD0( 4 )
08714 *     ..
08715 *     .. External Subroutines ..
08716       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
08717      $                   PB_CHKMAT, PB_CLAGEN, PB_DESCTRANS, PB_INITJMP,
08718      $                   PB_INITMULADD, PB_JUMP, PB_JUMPIT, PB_LOCINFO,
08719      $                   PB_SETLOCRAN, PB_SETRAN, PCLADOM, PXERBLA
08720 *     ..
08721 *     .. External Functions ..
08722       LOGICAL            LSAME
08723       EXTERNAL           LSAME
08724 *     ..
08725 *     .. Intrinsic Functions ..
08726       INTRINSIC          CMPLX, MAX, MIN, REAL
08727 *     ..
08728 *     .. Data Statements ..
08729       DATA               ( MULADD0( I ), I = 1, 4 ) / 20077, 16838,
08730      $                   12345, 0 /
08731 *     ..
08732 *     .. Executable Statements ..
08733 *
08734 *     Convert descriptor
08735 *
08736       CALL PB_DESCTRANS( DESCA, DESCA2 )
08737 *
08738 *     Test the input arguments
08739 *
08740       ICTXT = DESCA2( CTXT_ )
08741       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
08742 *
08743 *     Test the input parameters
08744 *
08745       INFO = 0
08746       IF( NPROW.EQ.-1 ) THEN
08747          INFO = -( 1000 + CTXT_ )
08748       ELSE
08749          SYMM   = LSAME( AFORM, 'S' )
08750          HERM   = LSAME( AFORM, 'H' )
08751          NOTRAN = LSAME( AFORM, 'N' )
08752          DIAGDO = LSAME( DIAG, 'D' )
08753          IF( .NOT.( SYMM.OR.HERM.OR.NOTRAN ) .AND.
08754      $       .NOT.( LSAME( AFORM, 'T' )    ) .AND.
08755      $       .NOT.( LSAME( AFORM, 'C' )    ) ) THEN
08756             INFO = -2
08757          ELSE IF( ( .NOT.DIAGDO ) .AND.
08758      $            ( .NOT.LSAME( DIAG, 'N' ) ) ) THEN
08759             INFO = -3
08760          END IF
08761          CALL PB_CHKMAT( ICTXT, M, 5, N, 6, IA, JA, DESCA2, 10, INFO )
08762       END IF
08763 *
08764       IF( INFO.NE.0 ) THEN
08765          CALL PXERBLA( ICTXT, 'PCLAGEN', -INFO )
08766          RETURN
08767       END IF
08768 *
08769 *     Quick return if possible
08770 *
08771       IF( ( M.LE.0 ).OR.( N.LE.0 ) )
08772      $   RETURN
08773 *
08774 *     Start the operations
08775 *
08776       MB   = DESCA2( MB_   )
08777       NB   = DESCA2( NB_   )
08778       IMB  = DESCA2( IMB_  )
08779       INB  = DESCA2( INB_  )
08780       RSRC = DESCA2( RSRC_ )
08781       CSRC = DESCA2( CSRC_ )
08782 *
08783 *     Figure out local information about the distributed matrix operand
08784 *
08785       CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
08786      $                  MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
08787      $                  IACOL, MRROW, MRCOL )
08788 *
08789 *     Decide where the entries shall be stored in memory
08790 *
08791       IF( INPLACE ) THEN
08792          IIA = 1
08793          JJA = 1
08794       END IF
08795 *
08796 *     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
08797 *     ILOW, LOW, IUPP, and UPP.
08798 *
08799       IOFFDA = JA + OFFA - IA
08800       CALL PB_BINFO( IOFFDA, MP, NQ, IMB1, INB1, MB, NB, MRROW,
08801      $               MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC,
08802      $               LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP )
08803 *
08804 *     Initialize ILOCBLK, ILOCOFF, MYRDIST, JLOCBLK, JLOCOFF, MYCDIST
08805 *     This values correspond to the square virtual underlying matrix
08806 *     of size MAX( M_ + MAX( 0, -OFFA ), N_ + MAX( 0, OFFA ) ) used
08807 *     to set up the random sequence. For practical purposes, the size
08808 *     of this virtual matrix is upper bounded by M_ + N_ - 1.
08809 *
08810       ITMP   = MAX( 0, -OFFA )
08811       IVIR   = IA  + ITMP
08812       IMBVIR = IMB + ITMP
08813       NVIR   = DESCA2( M_ ) + ITMP
08814 *
08815       CALL PB_LOCINFO( IVIR, IMBVIR, MB, MYROW, RSRC, NPROW, ILOCBLK,
08816      $                 ILOCOFF, MYRDIST )
08817 *
08818       ITMP   = MAX( 0, OFFA )
08819       JVIR   = JA  + ITMP
08820       INBVIR = INB + ITMP
08821       NVIR   = MAX( MAX( NVIR, DESCA2( N_ ) + ITMP ),
08822      $              DESCA2( M_ ) + DESCA2( N_ ) - 1 )
08823 *
08824       CALL PB_LOCINFO( JVIR, INBVIR, NB, MYCOL, CSRC, NPCOL, JLOCBLK,
08825      $                 JLOCOFF, MYCDIST )
08826 *
08827       IF( SYMM .OR. HERM .OR. NOTRAN ) THEN
08828 *
08829          CALL PB_INITJMP( .TRUE., NVIR, IMBVIR, INBVIR, IMBLOC, INBLOC,
08830      $                    MB, NB, RSRC, CSRC, NPROW, NPCOL, 2, JMP )
08831 *
08832 *        Compute constants to jump JMP( * ) numbers in the sequence
08833 *
08834          CALL PB_INITMULADD( MULADD0, JMP, IMULADD )
08835 *
08836 *        Compute and set the random value corresponding to A( IA, JA )
08837 *
08838          CALL PB_SETLOCRAN( IASEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF,
08839      $                      MYRDIST, MYCDIST, NPROW, NPCOL, JMP,
08840      $                      IMULADD, IRAN )
08841 *
08842          CALL PB_CLAGEN( 'Lower', AFORM, A( IIA, JJA ), LDA, LCMT00,
08843      $                   IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC,
08844      $                   NB, LNBLOC, JMP, IMULADD )
08845 *
08846       END IF
08847 *
08848       IF( SYMM .OR. HERM .OR. ( .NOT. NOTRAN ) ) THEN
08849 *
08850          CALL PB_INITJMP( .FALSE., NVIR, IMBVIR, INBVIR, IMBLOC, INBLOC,
08851      $                    MB, NB, RSRC, CSRC, NPROW, NPCOL, 2, JMP )
08852 *
08853 *        Compute constants to jump JMP( * ) numbers in the sequence
08854 *
08855          CALL PB_INITMULADD( MULADD0, JMP, IMULADD )
08856 *
08857 *        Compute and set the random value corresponding to A( IA, JA )
08858 *
08859          CALL PB_SETLOCRAN( IASEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF,
08860      $                      MYRDIST, MYCDIST, NPROW, NPCOL, JMP,
08861      $                      IMULADD, IRAN )
08862 *
08863          CALL PB_CLAGEN( 'Upper', AFORM, A( IIA, JJA ), LDA, LCMT00,
08864      $                   IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC,
08865      $                   NB, LNBLOC, JMP, IMULADD )
08866 *
08867       END IF
08868 *
08869       IF( DIAGDO ) THEN
08870 *
08871          MAXMN = MAX( DESCA2( M_ ), DESCA2( N_ ) )
08872          IF( HERM ) THEN
08873             ALPHA = CMPLX( REAL( 2 * MAXMN ), ZERO )
08874          ELSE
08875             ALPHA = CMPLX( REAL( MAXMN ), REAL( MAXMN ) )
08876          END IF
08877 *
08878          IF( IOFFDA.GE.0 ) THEN
08879             CALL PCLADOM( INPLACE, MIN( MAX( 0, M-IOFFDA ), N ), ALPHA,
08880      $                    A, MIN( IA+IOFFDA, IA+M-1 ), JA, DESCA )
08881          ELSE
08882             CALL PCLADOM( INPLACE, MIN( M, MAX( 0, N+IOFFDA ) ), ALPHA,
08883      $                    A, IA, MIN( JA-IOFFDA, JA+N-1 ), DESCA )
08884          END IF
08885 *
08886       END IF
08887 *
08888       RETURN
08889 *
08890 *     End of PCLAGEN
08891 *
08892       END
08893       SUBROUTINE PCLADOM( INPLACE, N, ALPHA, A, IA, JA, DESCA )
08894 *
08895 *  -- PBLAS test routine (version 2.0) --
08896 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
08897 *     and University of California, Berkeley.
08898 *     April 1, 1998
08899 *
08900 *     .. Scalar Arguments ..
08901       LOGICAL            INPLACE
08902       INTEGER            IA, JA, N
08903       COMPLEX            ALPHA
08904 *     ..
08905 *     .. Array Arguments ..
08906       INTEGER            DESCA( * )
08907       COMPLEX            A( * )
08908 *     ..
08909 *
08910 *  Purpose
08911 *  =======
08912 *
08913 *  PCLADOM  adds alpha to the diagonal entries  of  an  n by n submatrix
08914 *  sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ).
08915 *
08916 *  Notes
08917 *  =====
08918 *
08919 *  A description  vector  is associated with each 2D block-cyclicly dis-
08920 *  tributed matrix.  This  vector  stores  the  information  required to
08921 *  establish the  mapping  between a  matrix entry and its corresponding
08922 *  process and memory location.
08923 *
08924 *  In  the  following  comments,   the character _  should  be  read  as
08925 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
08926 *  block cyclicly distributed matrix.  Its description vector is DESCA:
08927 *
08928 *  NOTATION         STORED IN       EXPLANATION
08929 *  ---------------- --------------- ------------------------------------
08930 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
08931 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
08932 *                                   the NPROW x NPCOL BLACS process grid
08933 *                                   A  is distributed over.  The context
08934 *                                   itself  is  global,  but  the handle
08935 *                                   (the integer value) may vary.
08936 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
08937 *                                   ted matrix A, M_A >= 0.
08938 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
08939 *                                   buted matrix A, N_A >= 0.
08940 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
08941 *                                   block of the matrix A, IMB_A > 0.
08942 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
08943 *                                   left   block   of   the   matrix  A,
08944 *                                   INB_A > 0.
08945 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
08946 *                                   bute the last  M_A-IMB_A rows of  A,
08947 *                                   MB_A > 0.
08948 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
08949 *                                   bute the last  N_A-INB_A  columns of
08950 *                                   A, NB_A > 0.
08951 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
08952 *                                   row of the matrix  A is distributed,
08953 *                                   NPROW > RSRC_A >= 0.
08954 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
08955 *                                   first  column of  A  is distributed.
08956 *                                   NPCOL > CSRC_A >= 0.
08957 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
08958 *                                   array  storing  the  local blocks of
08959 *                                   the distributed matrix A,
08960 *                                   IF( Lc( 1, N_A ) > 0 )
08961 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
08962 *                                   ELSE
08963 *                                      LLD_A >= 1.
08964 *
08965 *  Let K be the number of  rows of a matrix A starting at the global in-
08966 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
08967 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
08968 *  receive if these K rows were distributed over NPROW processes.  If  K
08969 *  is the number of columns of a matrix  A  starting at the global index
08970 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
08971 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
08972 *  these K columns were distributed over NPCOL processes.
08973 *
08974 *  The values of Lr() and Lc() may be determined via a call to the func-
08975 *  tion PB_NUMROC:
08976 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
08977 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
08978 *
08979 *  Arguments
08980 *  =========
08981 *
08982 *  INPLACE (global input) LOGICAL
08983 *          On entry, INPLACE specifies if the matrix should be generated
08984 *          in place or not. If INPLACE is .TRUE., the local random array
08985 *          to be generated  will start in memory at the local memory lo-
08986 *          cation A( 1, 1 ),  otherwise it will start at the local posi-
08987 *          tion induced by IA and JA.
08988 *
08989 *  N       (global input) INTEGER
08990 *          On entry,  N  specifies  the  global  order  of the submatrix
08991 *          sub( A ) to be modified. N must be at least zero.
08992 *
08993 *  ALPHA   (global input) COMPLEX
08994 *          On entry, ALPHA specifies the scalar alpha.
08995 *
08996 *  A       (local input/local output) COMPLEX array
08997 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
08998 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
08999 *          the local entries of the matrix A. On exit, the local entries
09000 *          of this array corresponding to the main diagonal of  sub( A )
09001 *          have been updated.
09002 *
09003 *  IA      (global input) INTEGER
09004 *          On entry, IA  specifies A's global row index, which points to
09005 *          the beginning of the submatrix sub( A ).
09006 *
09007 *  JA      (global input) INTEGER
09008 *          On entry, JA  specifies A's global column index, which points
09009 *          to the beginning of the submatrix sub( A ).
09010 *
09011 *  DESCA   (global and local input) INTEGER array
09012 *          On entry, DESCA  is an integer array of dimension DLEN_. This
09013 *          is the array descriptor for the matrix A.
09014 *
09015 *  -- Written on April 1, 1998 by
09016 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
09017 *
09018 *  =====================================================================
09019 *
09020 *     .. Parameters ..
09021       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
09022      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
09023      $                   RSRC_
09024       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
09025      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
09026      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
09027      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
09028 *     ..
09029 *     .. Local Scalars ..
09030       LOGICAL            GODOWN, GOLEFT
09031       INTEGER            I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW,
09032      $                   IMB1, IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP,
09033      $                   JJA, JOFFA, JOFFD, LCMT, LCMT00, LDA, LDAP1,
09034      $                   LMBLOC, LNBLOC, LOW, MB, MBLKD, MBLKS, MBLOC,
09035      $                   MRCOL, MRROW, MYCOL, MYROW, NB, NBLKD, NBLKS,
09036      $                   NBLOC, NP, NPCOL, NPROW, NQ, PMB, QNB, UPP
09037       COMPLEX            ATMP
09038 *     ..
09039 *     .. Local Scalars ..
09040       INTEGER            DESCA2( DLEN_ )
09041 *     ..
09042 *     .. External Subroutines ..
09043       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
09044      $                   PB_DESCTRANS
09045 *     ..
09046 *     .. Intrinsic Functions ..
09047       INTRINSIC          ABS, AIMAG, CMPLX, MAX, MIN, REAL
09048 *     ..
09049 *     .. Executable Statements ..
09050 *
09051 *     Convert descriptor
09052 *
09053       CALL PB_DESCTRANS( DESCA, DESCA2 )
09054 *
09055 *     Get grid parameters
09056 *
09057       ICTXT = DESCA2( CTXT_ )
09058       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
09059 *
09060       IF( N.EQ.0 )
09061      $   RETURN
09062 *
09063       CALL PB_AINFOG2L( N, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
09064      $                  MYCOL, IMB1, INB1, NP, NQ, IIA, JJA, IAROW,
09065      $                  IACOL, MRROW, MRCOL )
09066 *
09067 *     Decide where the entries shall be stored in memory
09068 *
09069       IF( INPLACE ) THEN
09070          IIA = 1
09071          JJA = 1
09072       END IF
09073 *
09074 *     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
09075 *     ILOW, LOW, IUPP, and UPP.
09076 *
09077       MB = DESCA2( MB_ )
09078       NB = DESCA2( NB_ )
09079 *
09080       CALL PB_BINFO( 0, NP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL,
09081      $               LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
09082      $               LNBLOC, ILOW, LOW, IUPP, UPP )
09083 *
09084       IOFFA  = IIA - 1
09085       JOFFA  = JJA - 1
09086       LDA    = DESCA2( LLD_ )
09087       LDAP1  = LDA + 1
09088 *
09089       IF( DESCA2( RSRC_ ).LT.0 ) THEN
09090          PMB = MB
09091       ELSE
09092          PMB = NPROW * MB
09093       END IF
09094       IF( DESCA2( CSRC_ ).LT.0 ) THEN
09095          QNB = NB
09096       ELSE
09097          QNB = NPCOL * NB
09098       END IF
09099 *
09100 *     Handle the first block of rows or columns separately, and update
09101 *     LCMT00, MBLKS and NBLKS.
09102 *
09103       GODOWN = ( LCMT00.GT.IUPP )
09104       GOLEFT = ( LCMT00.LT.ILOW )
09105 *
09106       IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN
09107 *
09108 *        LCMT00 >= ILOW && LCMT00 <= IUPP
09109 *
09110          IF( LCMT00.GE.0 ) THEN
09111             IJOFFA = IOFFA+LCMT00 + ( JOFFA - 1 ) * LDA
09112             DO 10 I = 1, MIN( INBLOC, MAX( 0, IMBLOC - LCMT00 ) )
09113                ATMP = A( IJOFFA + I*LDAP1 )
09114                A( IJOFFA + I*LDAP1 ) = ALPHA +
09115      $                                 CMPLX( ABS( REAL(  ATMP ) ),
09116      $                                        ABS( AIMAG( ATMP ) ) )
09117    10       CONTINUE
09118          ELSE
09119             IJOFFA = IOFFA + ( JOFFA - LCMT00 - 1 ) * LDA
09120             DO 20 I = 1, MIN( IMBLOC, MAX( 0, INBLOC + LCMT00 ) )
09121                ATMP = A( IJOFFA + I*LDAP1 )
09122                A( IJOFFA + I*LDAP1 ) = ALPHA +
09123      $                                 CMPLX( ABS( REAL(  ATMP ) ),
09124      $                                        ABS( AIMAG( ATMP ) ) )
09125    20       CONTINUE
09126          END IF
09127          GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW )
09128          GODOWN = .NOT.GOLEFT
09129 *
09130       END IF
09131 *
09132       IF( GODOWN ) THEN
09133 *
09134          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
09135          MBLKS  = MBLKS - 1
09136          IOFFA  = IOFFA + IMBLOC
09137 *
09138    30    CONTINUE
09139          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
09140             LCMT00 = LCMT00 - PMB
09141             MBLKS  = MBLKS - 1
09142             IOFFA  = IOFFA + MB
09143             GO TO 30
09144          END IF
09145 *
09146          LCMT  = LCMT00
09147          MBLKD = MBLKS
09148          IOFFD = IOFFA
09149 *
09150          MBLOC = MB
09151    40    CONTINUE
09152          IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN
09153             IF( MBLKD.EQ.1 )
09154      $         MBLOC = LMBLOC
09155             IF( LCMT.GE.0 ) THEN
09156                IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
09157                DO 50 I = 1, MIN( INBLOC, MAX( 0, MBLOC - LCMT ) )
09158                   ATMP = A( IJOFFA + I*LDAP1 )
09159                   A( IJOFFA + I*LDAP1 ) = ALPHA +
09160      $                                    CMPLX( ABS( REAL(  ATMP ) ),
09161      $                                           ABS( AIMAG( ATMP ) ) )
09162    50          CONTINUE
09163             ELSE
09164                IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
09165                DO 60 I = 1, MIN( MBLOC, MAX( 0, INBLOC + LCMT ) )
09166                   ATMP = A( IJOFFA + I*LDAP1 )
09167                   A( IJOFFA + I*LDAP1 ) = ALPHA +
09168      $                                    CMPLX( ABS( REAL(  ATMP ) ),
09169      $                                           ABS( AIMAG( ATMP ) ) )
09170    60          CONTINUE
09171             END IF
09172             LCMT00 = LCMT
09173             LCMT   = LCMT - PMB
09174             MBLKS  = MBLKD
09175             MBLKD  = MBLKD - 1
09176             IOFFA  = IOFFD
09177             IOFFD  = IOFFD + MBLOC
09178             GO TO 40
09179          END IF
09180 *
09181          LCMT00 = LCMT00 + LOW - ILOW + QNB
09182          NBLKS  = NBLKS - 1
09183          JOFFA  = JOFFA + INBLOC
09184 *
09185       ELSE IF( GOLEFT ) THEN
09186 *
09187          LCMT00 = LCMT00 + LOW - ILOW + QNB
09188          NBLKS  = NBLKS - 1
09189          JOFFA  = JOFFA + INBLOC
09190 *
09191    70    CONTINUE
09192          IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN
09193             LCMT00 = LCMT00 + QNB
09194             NBLKS  = NBLKS - 1
09195             JOFFA  = JOFFA + NB
09196             GO TO 70
09197          END IF
09198 *
09199          LCMT  = LCMT00
09200          NBLKD = NBLKS
09201          JOFFD = JOFFA
09202 *
09203          NBLOC = NB
09204    80    CONTINUE
09205          IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN
09206             IF( NBLKD.EQ.1 )
09207      $         NBLOC = LNBLOC
09208             IF( LCMT.GE.0 ) THEN
09209                IJOFFA = IOFFA + LCMT + ( JOFFD - 1 ) * LDA
09210                DO 90 I = 1, MIN( NBLOC, MAX( 0, IMBLOC - LCMT ) )
09211                   ATMP = A( IJOFFA + I*LDAP1 )
09212                   A( IJOFFA + I*LDAP1 ) = ALPHA +
09213      $                                    CMPLX( ABS( REAL(  ATMP ) ),
09214      $                                           ABS( AIMAG( ATMP ) ) )
09215    90          CONTINUE
09216             ELSE
09217                IJOFFA = IOFFA + ( JOFFD - LCMT - 1 ) * LDA
09218                DO 100 I = 1, MIN( IMBLOC, MAX( 0, NBLOC + LCMT ) )
09219                   ATMP = A( IJOFFA + I*LDAP1 )
09220                   A( IJOFFA + I*LDAP1 ) = ALPHA +
09221      $                                    CMPLX( ABS( REAL(  ATMP ) ),
09222      $                                           ABS( AIMAG( ATMP ) ) )
09223   100          CONTINUE
09224             END IF
09225             LCMT00 = LCMT
09226             LCMT   = LCMT + QNB
09227             NBLKS  = NBLKD
09228             NBLKD  = NBLKD - 1
09229             JOFFA  = JOFFD
09230             JOFFD  = JOFFD + NBLOC
09231             GO TO 80
09232          END IF
09233 *
09234          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
09235          MBLKS  = MBLKS - 1
09236          IOFFA  = IOFFA + IMBLOC
09237 *
09238       END IF
09239 *
09240       NBLOC = NB
09241   110 CONTINUE
09242       IF( NBLKS.GT.0 ) THEN
09243          IF( NBLKS.EQ.1 )
09244      $      NBLOC = LNBLOC
09245   120    CONTINUE
09246          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
09247             LCMT00 = LCMT00 - PMB
09248             MBLKS  = MBLKS - 1
09249             IOFFA  = IOFFA + MB
09250             GO TO 120
09251          END IF
09252 *
09253          LCMT  = LCMT00
09254          MBLKD = MBLKS
09255          IOFFD = IOFFA
09256 *
09257          MBLOC = MB
09258   130    CONTINUE
09259          IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN
09260             IF( MBLKD.EQ.1 )
09261      $         MBLOC = LMBLOC
09262             IF( LCMT.GE.0 ) THEN
09263                IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
09264                DO 140 I = 1, MIN( NBLOC, MAX( 0, MBLOC - LCMT ) )
09265                   ATMP = A( IJOFFA + I*LDAP1 )
09266                   A( IJOFFA + I*LDAP1 ) = ALPHA +
09267      $                                    CMPLX( ABS( REAL(  ATMP ) ),
09268      $                                           ABS( AIMAG( ATMP ) ) )
09269   140          CONTINUE
09270             ELSE
09271                IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
09272                DO 150 I = 1, MIN( MBLOC, MAX( 0, NBLOC + LCMT ) )
09273                   ATMP = A( IJOFFA + I*LDAP1 )
09274                   A( IJOFFA + I*LDAP1 ) = ALPHA +
09275      $                                    CMPLX( ABS( REAL(  ATMP ) ),
09276      $                                           ABS( AIMAG( ATMP ) ) )
09277   150          CONTINUE
09278             END IF
09279             LCMT00 = LCMT
09280             LCMT   = LCMT - PMB
09281             MBLKS  = MBLKD
09282             MBLKD  = MBLKD - 1
09283             IOFFA  = IOFFD
09284             IOFFD  = IOFFD + MBLOC
09285             GO TO 130
09286          END IF
09287 *
09288          LCMT00 = LCMT00 + QNB
09289          NBLKS  = NBLKS - 1
09290          JOFFA  = JOFFA + NBLOC
09291          GO TO 110
09292 *
09293       END IF
09294 *
09295       RETURN
09296 *
09297 *     End of PCLADOM
09298 *
09299       END
09300       SUBROUTINE PB_PCLAPRNT( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT,
09301      $                        CMATNM, NOUT, WORK )
09302 *
09303 *  -- PBLAS test routine (version 2.0) --
09304 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
09305 *     and University of California, Berkeley.
09306 *     April 1, 1998
09307 *
09308 *     .. Scalar Arguments ..
09309       INTEGER            IA, ICPRNT, IRPRNT, JA, M, N, NOUT
09310 *     ..
09311 *     .. Array Arguments ..
09312       CHARACTER*(*)      CMATNM
09313       INTEGER            DESCA( * )
09314       COMPLEX            A( * ), WORK( * )
09315 *     ..
09316 *
09317 *  Purpose
09318 *  =======
09319 *
09320 *  PB_PCLAPRNT  prints to the standard output a submatrix sub( A ) deno-
09321 *  ting A(IA:IA+M-1,JA:JA+N-1). The local pieces are sent and printed by
09322 *  the process of coordinates (IRPRNT, ICPRNT).
09323 *
09324 *  Notes
09325 *  =====
09326 *
09327 *  A description  vector  is associated with each 2D block-cyclicly dis-
09328 *  tributed matrix.  This  vector  stores  the  information  required to
09329 *  establish the  mapping  between a  matrix entry and its corresponding
09330 *  process and memory location.
09331 *
09332 *  In  the  following  comments,   the character _  should  be  read  as
09333 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
09334 *  block cyclicly distributed matrix.  Its description vector is DESCA:
09335 *
09336 *  NOTATION         STORED IN       EXPLANATION
09337 *  ---------------- --------------- ------------------------------------
09338 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
09339 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
09340 *                                   the NPROW x NPCOL BLACS process grid
09341 *                                   A  is distributed over.  The context
09342 *                                   itself  is  global,  but  the handle
09343 *                                   (the integer value) may vary.
09344 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
09345 *                                   ted matrix A, M_A >= 0.
09346 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
09347 *                                   buted matrix A, N_A >= 0.
09348 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
09349 *                                   block of the matrix A, IMB_A > 0.
09350 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
09351 *                                   left   block   of   the   matrix  A,
09352 *                                   INB_A > 0.
09353 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
09354 *                                   bute the last  M_A-IMB_A rows of  A,
09355 *                                   MB_A > 0.
09356 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
09357 *                                   bute the last  N_A-INB_A  columns of
09358 *                                   A, NB_A > 0.
09359 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
09360 *                                   row of the matrix  A is distributed,
09361 *                                   NPROW > RSRC_A >= 0.
09362 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
09363 *                                   first  column of  A  is distributed.
09364 *                                   NPCOL > CSRC_A >= 0.
09365 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
09366 *                                   array  storing  the  local blocks of
09367 *                                   the distributed matrix A,
09368 *                                   IF( Lc( 1, N_A ) > 0 )
09369 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
09370 *                                   ELSE
09371 *                                      LLD_A >= 1.
09372 *
09373 *  Let K be the number of  rows of a matrix A starting at the global in-
09374 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
09375 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
09376 *  receive if these K rows were distributed over NPROW processes.  If  K
09377 *  is the number of columns of a matrix  A  starting at the global index
09378 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
09379 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
09380 *  these K columns were distributed over NPCOL processes.
09381 *
09382 *  The values of Lr() and Lc() may be determined via a call to the func-
09383 *  tion PB_NUMROC:
09384 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
09385 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
09386 *
09387 *  Arguments
09388 *  =========
09389 *
09390 *  M       (global input) INTEGER
09391 *          On entry,  M  specifies the number of rows of  the  submatrix
09392 *          sub( A ). M  must be at least zero.
09393 *
09394 *  N       (global input) INTEGER
09395 *          On entry, N  specifies the number of columns of the submatrix
09396 *          sub( A ). N must be at least zero.
09397 *
09398 *  A       (local input) COMPLEX array
09399 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
09400 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
09401 *          the local entries of the matrix A.
09402 *
09403 *  IA      (global input) INTEGER
09404 *          On entry, IA  specifies A's global row index, which points to
09405 *          the beginning of the submatrix sub( A ).
09406 *
09407 *  JA      (global input) INTEGER
09408 *          On entry, JA  specifies A's global column index, which points
09409 *          to the beginning of the submatrix sub( A ).
09410 *
09411 *  DESCA   (global and local input) INTEGER array
09412 *          On entry, DESCA  is an integer array of dimension DLEN_. This
09413 *          is the array descriptor for the matrix A.
09414 *
09415 *  IRPRNT  (global input) INTEGER
09416 *          On entry, IRPRNT specifies the row index of the printing pro-
09417 *          cess.
09418 *
09419 *  ICPRNT  (global input) INTEGER
09420 *          On entry, ICPRNT specifies the  column  index of the printing
09421 *          process.
09422 *
09423 *  CMATNM  (global input) CHARACTER*(*)
09424 *          On entry, CMATNM is the name of the matrix to be printed.
09425 *
09426 *  NOUT    (global input) INTEGER
09427 *          On entry, NOUT specifies the output unit number. When NOUT is
09428 *          equal to 6, the submatrix is printed on the screen.
09429 *
09430 *  WORK    (local workspace) COMPLEX array
09431 *          On entry, WORK is a work array of dimension at least equal to
09432 *          MAX( IMB_A, MB_A ).
09433 *
09434 *  -- Written on April 1, 1998 by
09435 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
09436 *
09437 *  =====================================================================
09438 *
09439 *     .. Parameters ..
09440       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
09441      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
09442      $                   RSRC_
09443       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
09444      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
09445      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
09446      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
09447 *     ..
09448 *     .. Local Scalars ..
09449       INTEGER            MYCOL, MYROW, NPCOL, NPROW, PCOL, PROW
09450 *     ..
09451 *     .. Local Arrays ..
09452       INTEGER            DESCA2( DLEN_ )
09453 *     ..
09454 *     .. External Subroutines ..
09455       EXTERNAL           BLACS_GRIDINFO, PB_DESCTRANS, PB_PCLAPRN2
09456 *     ..
09457 *     .. Executable Statements ..
09458 *
09459 *     Quick return if possible
09460 *
09461       IF( ( M.LE.0 ).OR.( N.LE.0 ) )
09462      $   RETURN
09463 *
09464 *     Convert descriptor
09465 *
09466       CALL PB_DESCTRANS( DESCA, DESCA2 )
09467 *
09468       CALL BLACS_GRIDINFO( DESCA2( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
09469 *
09470       IF( DESCA2( RSRC_ ).GE.0 ) THEN
09471          IF( DESCA2( CSRC_ ).GE.0 ) THEN
09472             CALL PB_PCLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT, ICPRNT,
09473      $                        CMATNM, NOUT, DESCA2( RSRC_ ),
09474      $                        DESCA2( CSRC_ ), WORK )
09475          ELSE
09476             DO 10 PCOL = 0, NPCOL - 1
09477                IF( ( MYROW.EQ.IRPRNT ).AND.( MYCOL.EQ.ICPRNT ) )
09478      $            WRITE( NOUT, * ) 'Colum-replicated array -- ' ,
09479      $                             'copy in process column: ', PCOL
09480                CALL PB_PCLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT,
09481      $                           ICPRNT, CMATNM, NOUT, DESCA2( RSRC_ ),
09482      $                           PCOL, WORK )
09483    10       CONTINUE
09484          END IF
09485       ELSE
09486          IF( DESCA2( CSRC_ ).GE.0 ) THEN
09487             DO 20 PROW = 0, NPROW - 1
09488                IF( ( MYROW.EQ.IRPRNT ).AND.( MYCOL.EQ.ICPRNT ) )
09489      $            WRITE( NOUT, * ) 'Row-replicated array -- ' ,
09490      $                             'copy in process row: ', PROW
09491                CALL PB_PCLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT,
09492      $                           ICPRNT, CMATNM, NOUT, PROW,
09493      $                           DESCA2( CSRC_ ), WORK )
09494    20       CONTINUE
09495          ELSE
09496             DO 40 PROW = 0, NPROW - 1
09497                DO 30 PCOL = 0, NPCOL - 1
09498                   IF( ( MYROW.EQ.IRPRNT ).AND.( MYCOL.EQ.ICPRNT ) )
09499      $               WRITE( NOUT, * ) 'Replicated array -- ' ,
09500      $                      'copy in process (', PROW, ',', PCOL, ')'
09501                   CALL PB_PCLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT,
09502      $                              ICPRNT, CMATNM, NOUT, PROW, PCOL,
09503      $                              WORK )
09504    30          CONTINUE
09505    40       CONTINUE
09506          END IF
09507       END IF
09508 *
09509       RETURN
09510 *
09511 *     End of PB_PCLAPRNT
09512 *
09513       END
09514       SUBROUTINE PB_PCLAPRN2( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT,
09515      $                        CMATNM, NOUT, PROW, PCOL, WORK )
09516 *
09517 *  -- PBLAS test routine (version 2.0) --
09518 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
09519 *     and University of California, Berkeley.
09520 *     April 1, 1998
09521 *
09522 *     .. Scalar Arguments ..
09523       INTEGER            IA, ICPRNT, IRPRNT, JA, M, N, NOUT, PCOL, PROW
09524 *     ..
09525 *     .. Array Arguments ..
09526       CHARACTER*(*)      CMATNM
09527       INTEGER            DESCA( * )
09528       COMPLEX            A( * ), WORK( * )
09529 *     ..
09530 *
09531 *     .. Parameters ..
09532       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
09533      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
09534      $                   RSRC_
09535       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
09536      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
09537      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
09538      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
09539 *     ..
09540 *     .. Local Scalars ..
09541       LOGICAL            AISCOLREP, AISROWREP
09542       INTEGER            H, I, IACOL, IAROW, IB, ICTXT, ICURCOL,
09543      $                   ICURROW, II, IIA, IN, J, JB, JJ, JJA, JN, K,
09544      $                   LDA, LDW, MYCOL, MYROW, NPCOL, NPROW
09545 *     ..
09546 *     .. External Subroutines ..
09547       EXTERNAL           BLACS_BARRIER, BLACS_GRIDINFO, CGERV2D,
09548      $                   CGESD2D, PB_INFOG2L
09549 *     ..
09550 *     .. Intrinsic Functions ..
09551       INTRINSIC          AIMAG, MIN, REAL
09552 *     ..
09553 *     .. Executable Statements ..
09554 *
09555 *     Get grid parameters
09556 *
09557       ICTXT = DESCA( CTXT_ )
09558       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
09559       CALL PB_INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL,
09560      $                 IIA, JJA, IAROW, IACOL )
09561       II = IIA
09562       JJ = JJA
09563       IF( DESCA( RSRC_ ).LT.0 ) THEN
09564          AISROWREP = .TRUE.
09565          IAROW     = PROW
09566          ICURROW   = PROW
09567       ELSE
09568          AISROWREP = .FALSE.
09569          ICURROW   = IAROW
09570       END IF
09571       IF( DESCA( CSRC_ ).LT.0 ) THEN
09572          AISCOLREP = .TRUE.
09573          IACOL     = PCOL
09574          ICURCOL   = PCOL
09575       ELSE
09576          AISCOLREP = .FALSE.
09577          ICURCOL   = IACOL
09578       END IF
09579       LDA = DESCA( LLD_ )
09580       LDW = MAX( DESCA( IMB_ ), DESCA( MB_ ) )
09581 *
09582 *     Handle the first block of column separately
09583 *
09584       JB = DESCA( INB_ ) - JA + 1
09585       IF( JB.LE.0 )
09586      $   JB = ( (-JB) / DESCA( NB_ ) + 1 ) * DESCA( NB_ ) + JB
09587       JB = MIN( JB, N )
09588       JN = JA+JB-1
09589       DO 60 H = 0, JB-1
09590          IB = DESCA( IMB_ ) - IA + 1
09591          IF( IB.LE.0 )
09592      $      IB = ( (-IB) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
09593          IB = MIN( IB, M )
09594          IN = IA+IB-1
09595          IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN
09596             IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09597                DO 10 K = 0, IB-1
09598                   WRITE( NOUT, FMT = 9999 )
09599      $                   CMATNM, IA+K, JA+H,
09600      $                   REAL( A(II+K+(JJ+H-1)*LDA) ),
09601      $                   AIMAG( A(II+K+(JJ+H-1)*LDA) )
09602    10          CONTINUE
09603             END IF
09604          ELSE
09605             IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN
09606                CALL CGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ), LDA,
09607      $                       IRPRNT, ICPRNT )
09608             ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09609                CALL CGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW, ICURCOL )
09610                DO 20 K = 1, IB
09611                   WRITE( NOUT, FMT = 9999 )
09612      $                   CMATNM, IA+K-1, JA+H, REAL( WORK( K ) ),
09613      $                   AIMAG( WORK( K ) )
09614    20          CONTINUE
09615             END IF
09616          END IF
09617          IF( MYROW.EQ.ICURROW )
09618      $      II = II + IB
09619          IF( .NOT.AISROWREP )
09620      $      ICURROW = MOD( ICURROW+1, NPROW )
09621          CALL BLACS_BARRIER( ICTXT, 'All' )
09622 *
09623 *        Loop over remaining block of rows
09624 *
09625          DO 50 I = IN+1, IA+M-1, DESCA( MB_ )
09626             IB = MIN( DESCA( MB_ ), IA+M-I )
09627             IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN
09628                IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09629                   DO 30 K = 0, IB-1
09630                      WRITE( NOUT, FMT = 9999 )
09631      $                      CMATNM, I+K, JA+H,
09632      $                      REAL( A( II+K+(JJ+H-1)*LDA ) ),
09633      $                      AIMAG( A( II+K+(JJ+H-1)*LDA ) )
09634    30             CONTINUE
09635                END IF
09636             ELSE
09637                IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN
09638                   CALL CGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ),
09639      $                          LDA, IRPRNT, ICPRNT )
09640                ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09641                   CALL CGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW,
09642      $                          ICURCOL )
09643                   DO 40 K = 1, IB
09644                      WRITE( NOUT, FMT = 9999 )
09645      $                      CMATNM, I+K-1, JA+H, REAL( WORK( K ) ),
09646      $                      AIMAG( WORK( K ) )
09647    40             CONTINUE
09648                END IF
09649             END IF
09650             IF( MYROW.EQ.ICURROW )
09651      $         II = II + IB
09652             IF( .NOT.AISROWREP )
09653      $         ICURROW = MOD( ICURROW+1, NPROW )
09654             CALL BLACS_BARRIER( ICTXT, 'All' )
09655    50    CONTINUE
09656 *
09657          II = IIA
09658          ICURROW = IAROW
09659    60 CONTINUE
09660 *
09661       IF( MYCOL.EQ.ICURCOL )
09662      $   JJ = JJ + JB
09663       IF( .NOT.AISCOLREP )
09664      $   ICURCOL = MOD( ICURCOL+1, NPCOL )
09665       CALL BLACS_BARRIER( ICTXT, 'All' )
09666 *
09667 *     Loop over remaining column blocks
09668 *
09669       DO 130 J = JN+1, JA+N-1, DESCA( NB_ )
09670          JB = MIN(  DESCA( NB_ ), JA+N-J )
09671          DO 120 H = 0, JB-1
09672             IB = DESCA( IMB_ )-IA+1
09673             IF( IB.LE.0 )
09674      $         IB = ( (-IB) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
09675             IB = MIN( IB, M )
09676             IN = IA+IB-1
09677             IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN
09678                IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09679                   DO 70 K = 0, IB-1
09680                      WRITE( NOUT, FMT = 9999 )
09681      $                      CMATNM, IA+K, J+H,
09682      $                      REAL( A( II+K+(JJ+H-1)*LDA ) ),
09683      $                      AIMAG( A( II+K+(JJ+H-1)*LDA ) )
09684    70             CONTINUE
09685                END IF
09686             ELSE
09687                IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN
09688                   CALL CGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ),
09689      $                          LDA, IRPRNT, ICPRNT )
09690                ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09691                   CALL CGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW,
09692      $                          ICURCOL )
09693                   DO 80 K = 1, IB
09694                      WRITE( NOUT, FMT = 9999 )
09695      $                      CMATNM, IA+K-1, J+H, REAL( WORK( K ) ),
09696      $                      AIMAG( WORK( K ) )
09697    80             CONTINUE
09698                END IF
09699             END IF
09700             IF( MYROW.EQ.ICURROW )
09701      $         II = II + IB
09702             ICURROW = MOD( ICURROW+1, NPROW )
09703             CALL BLACS_BARRIER( ICTXT, 'All' )
09704 *
09705 *           Loop over remaining block of rows
09706 *
09707             DO 110 I = IN+1, IA+M-1, DESCA( MB_ )
09708                IB = MIN( DESCA( MB_ ), IA+M-I )
09709                IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN
09710                   IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09711                      DO 90 K = 0, IB-1
09712                         WRITE( NOUT, FMT = 9999 )
09713      $                         CMATNM, I+K, J+H,
09714      $                         REAL( A( II+K+(JJ+H-1)*LDA ) ),
09715      $                         AIMAG( A( II+K+(JJ+H-1)*LDA ) )
09716    90                CONTINUE
09717                   END IF
09718                ELSE
09719                   IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN
09720                      CALL CGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ),
09721      $                             LDA, IRPRNT, ICPRNT )
09722                    ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09723                      CALL CGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW,
09724      $                             ICURCOL )
09725                      DO 100 K = 1, IB
09726                         WRITE( NOUT, FMT = 9999 )
09727      $                         CMATNM, I+K-1, J+H, REAL( WORK( K ) ),
09728      $                         AIMAG( WORK( K ) )
09729   100                CONTINUE
09730                   END IF
09731                END IF
09732                IF( MYROW.EQ.ICURROW )
09733      $            II = II + IB
09734                IF( .NOT.AISROWREP )
09735      $            ICURROW = MOD( ICURROW+1, NPROW )
09736                CALL BLACS_BARRIER( ICTXT, 'All' )
09737   110       CONTINUE
09738 *
09739             II = IIA
09740             ICURROW = IAROW
09741   120    CONTINUE
09742 *
09743          IF( MYCOL.EQ.ICURCOL )
09744      $      JJ = JJ + JB
09745          IF( .NOT.AISCOLREP )
09746      $      ICURCOL = MOD( ICURCOL+1, NPCOL )
09747          CALL BLACS_BARRIER( ICTXT, 'All' )
09748 *
09749   130 CONTINUE
09750 *
09751  9999 FORMAT( 1X, A, '(', I6, ',', I6, ')=', E16.8, '+i*(',
09752      $        E16.8, ')' )
09753 *
09754       RETURN
09755 *
09756 *     End of PB_PCLAPRN2
09757 *
09758       END
09759       SUBROUTINE PB_CFILLPAD( ICTXT, M, N, A, LDA, IPRE, IPOST, CHKVAL )
09760 *
09761 *  -- PBLAS test routine (version 2.0) --
09762 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
09763 *     and University of California, Berkeley.
09764 *     April 1, 1998
09765 *
09766 *     .. Scalar Arguments ..
09767       INTEGER            ICTXT, IPOST, IPRE, LDA, M, N
09768       COMPLEX            CHKVAL
09769 *     ..
09770 *     .. Array Arguments ..
09771       COMPLEX            A( * )
09772 *     ..
09773 *
09774 *  Purpose
09775 *  =======
09776 *
09777 *  PB_CFILLPAD surrounds a two dimensional local array with a guard-zone
09778 *  initialized to the value CHKVAL. The user may later call the  routine
09779 *  PB_CCHEKPAD to discover if the guardzone has been violated. There are
09780 *  three guardzones. The first is a buffer of size  IPRE  that is before
09781 *  the start of the array. The second is the buffer of size IPOST  which
09782 *  is after the end of the array to be padded. Finally, there is a guard
09783 *  zone inside every column of the array to be padded, in  the  elements
09784 *  of A(M+1:LDA, J).
09785 *
09786 *  Arguments
09787 *  =========
09788 *
09789 *  ICTXT   (local input) INTEGER
09790 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
09791 *          ting the global  context of the operation. The context itself
09792 *          is global, but the value of ICTXT is local.
09793 *
09794 *  M       (local input) INTEGER
09795 *          On entry, M  specifies the number of rows in the local  array
09796 *          A.  M must be at least zero.
09797 *
09798 *  N       (local input) INTEGER
09799 *          On entry, N  specifies the number of columns in the local ar-
09800 *          ray A. N must be at least zero.
09801 *
09802 *  A       (local input/local output) COMPLEX array
09803 *          On entry,  A  is an array of dimension (LDA,N). On exit, this
09804 *          array is the padded array.
09805 *
09806 *  LDA     (local input) INTEGER
09807 *          On entry,  LDA  specifies  the leading dimension of the local
09808 *          array to be padded. LDA must be at least MAX( 1, M ).
09809 *
09810 *  IPRE    (local input) INTEGER
09811 *          On entry, IPRE specifies the size of  the  guard zone  to put
09812 *          before the start of the padded array.
09813 *
09814 *  IPOST   (local input) INTEGER
09815 *          On entry, IPOST specifies the size of the  guard zone  to put
09816 *          after the end of the padded array.
09817 *
09818 *  CHKVAL  (local input) COMPLEX
09819 *          On entry, CHKVAL specifies the value to pad the array with.
09820 *
09821 *  -- Written on April 1, 1998 by
09822 *     R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
09823 *
09824 *  =====================================================================
09825 *
09826 *     .. Local Scalars ..
09827       INTEGER            I, J, K
09828 *     ..
09829 *     .. Executable Statements ..
09830 *
09831 *     Put check buffer in front of A
09832 *
09833       IF( IPRE.GT.0 ) THEN
09834          DO 10 I = 1, IPRE
09835             A( I ) = CHKVAL
09836    10    CONTINUE
09837       ELSE
09838          WRITE( *, FMT = '(A)' )
09839      $          'WARNING no pre-guardzone in PB_CFILLPAD'
09840       END IF
09841 *
09842 *     Put check buffer in back of A
09843 *
09844       IF( IPOST.GT.0 ) THEN
09845          J = IPRE+LDA*N+1
09846          DO 20 I = J, J+IPOST-1
09847             A( I ) = CHKVAL
09848    20    CONTINUE
09849       ELSE
09850          WRITE( *, FMT = '(A)' )
09851      $          'WARNING no post-guardzone in PB_CFILLPAD'
09852       END IF
09853 *
09854 *     Put check buffer in all (LDA-M) gaps
09855 *
09856       IF( LDA.GT.M ) THEN
09857          K = IPRE + M + 1
09858          DO 40 J = 1, N
09859             DO 30 I = K, K + ( LDA - M ) - 1
09860                A( I ) = CHKVAL
09861    30       CONTINUE
09862             K = K + LDA
09863    40    CONTINUE
09864       END IF
09865 *
09866       RETURN
09867 *
09868 *     End of PB_CFILLPAD
09869 *
09870       END
09871       SUBROUTINE PB_CCHEKPAD( ICTXT, MESS, M, N, A, LDA, IPRE, IPOST,
09872      $                        CHKVAL )
09873 *
09874 *  -- PBLAS test routine (version 2.0) --
09875 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
09876 *     and University of California, Berkeley.
09877 *     April 1, 1998
09878 *
09879 *     .. Scalar Arguments ..
09880       INTEGER            ICTXT, IPOST, IPRE, LDA, M, N
09881       COMPLEX            CHKVAL
09882 *     ..
09883 *     .. Array Arguments ..
09884       CHARACTER*(*)      MESS
09885       COMPLEX            A( * )
09886 *     ..
09887 *
09888 *  Purpose
09889 *  =======
09890 *
09891 *  PB_CCHEKPAD checks that the padding around a local array has not been
09892 *  overwritten since the call to PB_CFILLPAD.  Three types of errors are
09893 *  reported:
09894 *
09895 *  1) Overwrite in pre-guardzone.  This indicates a memory overwrite has
09896 *  occurred in the  first  IPRE  elements which form a buffer before the
09897 *  beginning of A. Therefore, the error message:
09898 *     'Overwrite in  pre-guardzone: loc(  5) =         18.00000'
09899 *  tells that the 5th element of the IPRE long buffer has been overwrit-
09900 *  ten with the value 18, where it should still have the value CHKVAL.
09901 *
09902 *  2) Overwrite in post-guardzone. This indicates a memory overwrite has
09903 *  occurred in the last IPOST elements which form a buffer after the end
09904 *  of A. Error reports are refered from the end of A.  Therefore,
09905 *     'Overwrite in post-guardzone: loc( 19) =         24.00000'
09906 *  tells  that the  19th element after the end of A was overwritten with
09907 *  the value 24, where it should still have the value of CHKVAL.
09908 *
09909 *  3) Overwrite in lda-m gap.  Tells you elements between M and LDA were
09910 *  overwritten.  So,
09911 *     'Overwrite in lda-m gap: A( 12,  3) =         22.00000'
09912 *  tells  that the element at the 12th row and 3rd column of A was over-
09913 *  written with the value of 22, where it should still have the value of
09914 *  CHKVAL.
09915 *
09916 *  Arguments
09917 *  =========
09918 *
09919 *  ICTXT   (local input) INTEGER
09920 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
09921 *          ting the global  context of the operation. The context itself
09922 *          is global, but the value of ICTXT is local.
09923 *
09924 *  MESS    (local input) CHARACTER*(*)
09925 *          On entry, MESS is a ttring containing a user-defined message.
09926 *
09927 *  M       (local input) INTEGER
09928 *          On entry, M  specifies the number of rows in the local  array
09929 *          A.  M must be at least zero.
09930 *
09931 *  N       (local input) INTEGER
09932 *          On entry, N  specifies the number of columns in the local ar-
09933 *          ray A. N must be at least zero.
09934 *
09935 *  A       (local input) COMPLEX array
09936 *          On entry,  A  is an array of dimension (LDA,N).
09937 *
09938 *  LDA     (local input) INTEGER
09939 *          On entry,  LDA  specifies  the leading dimension of the local
09940 *          array to be padded. LDA must be at least MAX( 1, M ).
09941 *
09942 *  IPRE    (local input) INTEGER
09943 *          On entry, IPRE specifies the size of  the  guard zone  to put
09944 *          before the start of the padded array.
09945 *
09946 *  IPOST   (local input) INTEGER
09947 *          On entry, IPOST specifies the size of the  guard zone  to put
09948 *          after the end of the padded array.
09949 *
09950 *  CHKVAL  (local input) COMPLEX
09951 *          On entry, CHKVAL specifies the value to pad the array with.
09952 *
09953 *
09954 *  -- Written on April 1, 1998 by
09955 *     R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
09956 *
09957 *  =====================================================================
09958 *
09959 *     .. Local Scalars ..
09960       CHARACTER*1        TOP
09961       INTEGER            I, IAM, IDUMM, INFO, J, K, MYCOL, MYROW, NPCOL,
09962      $                   NPROW
09963 *     ..
09964 *     .. External Subroutines ..
09965       EXTERNAL           BLACS_GRIDINFO, IGAMX2D, PB_TOPGET
09966 *     ..
09967 *     .. Intrinsic Functions ..
09968       INTRINSIC          AIMAG, REAL
09969 *     ..
09970 *     .. Executable Statements ..
09971 *
09972 *     Get grid parameters
09973 *
09974       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
09975       IAM  = MYROW*NPCOL + MYCOL
09976       INFO = -1
09977 *
09978 *     Check buffer in front of A
09979 *
09980       IF( IPRE.GT.0 ) THEN
09981          DO 10 I = 1, IPRE
09982             IF( A( I ).NE.CHKVAL ) THEN
09983                WRITE( *, FMT = 9998 ) MYROW, MYCOL, MESS, ' pre', I,
09984      $                                REAL( A( I ) ), AIMAG( A( I ) )
09985                INFO = IAM
09986             END IF
09987    10    CONTINUE
09988       ELSE
09989          WRITE( *, FMT = * ) 'WARNING no pre-guardzone in PB_CCHEKPAD'
09990       END IF
09991 *
09992 *     Check buffer after A
09993 *
09994       IF( IPOST.GT.0 ) THEN
09995          J = IPRE+LDA*N+1
09996          DO 20 I = J, J+IPOST-1
09997             IF( A( I ).NE.CHKVAL ) THEN
09998                WRITE( *, FMT = 9998 ) MYROW, MYCOL, MESS, 'post',
09999      $                                I-J+1, REAL( A( I ) ),
10000      $                                AIMAG( A( I ) )
10001                INFO = IAM
10002             END IF
10003    20    CONTINUE
10004       ELSE
10005          WRITE( *, FMT = * )
10006      $          'WARNING no post-guardzone buffer in PB_CCHEKPAD'
10007       END IF
10008 *
10009 *     Check all (LDA-M) gaps
10010 *
10011       IF( LDA.GT.M ) THEN
10012          K = IPRE + M + 1
10013          DO 40 J = 1, N
10014             DO 30 I = K, K + (LDA-M) - 1
10015                IF( A( I ).NE.CHKVAL ) THEN
10016                   WRITE( *, FMT = 9997 ) MYROW, MYCOL, MESS,
10017      $               I-IPRE-LDA*(J-1), J, REAL( A( I ) ),
10018      $               AIMAG( A( I ) )
10019                   INFO = IAM
10020                END IF
10021    30       CONTINUE
10022             K = K + LDA
10023    40    CONTINUE
10024       END IF
10025 *
10026       CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP )
10027       CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, IDUMM, IDUMM, -1,
10028      $              0, 0 )
10029       IF( IAM.EQ.0 .AND. INFO.GE.0 ) THEN
10030          WRITE( *, FMT = 9999 ) INFO / NPCOL, MOD( INFO, NPCOL ), MESS
10031       END IF
10032 *
10033  9999 FORMAT( '{', I5, ',', I5, '}:  Memory overwrite in ', A )
10034  9998 FORMAT( '{', I5, ',', I5, '}:  ', A, ' memory overwrite in ',
10035      $        A4, '-guardzone: loc(', I3, ') = ', G11.4, '+ i*',
10036      $        G11.4 )
10037  9997 FORMAT( '{', I5, ',', I5, '}: ', A, ' memory overwrite in ',
10038      $        'lda-m gap: loc(', I3, ',', I3, ') = ', G11.4,
10039      $        '+ i*', G11.4 )
10040 *
10041       RETURN
10042 *
10043 *     End of PB_CCHEKPAD
10044 *
10045       END
10046       SUBROUTINE PB_CLASET( UPLO, M, N, IOFFD, ALPHA, BETA, A, LDA )
10047 *
10048 *  -- PBLAS test routine (version 2.0) --
10049 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
10050 *     and University of California, Berkeley.
10051 *     April 1, 1998
10052 *
10053 *     .. Scalar Arguments ..
10054       CHARACTER*1        UPLO
10055       INTEGER            IOFFD, LDA, M, N
10056       COMPLEX            ALPHA, BETA
10057 *     ..
10058 *     .. Array Arguments ..
10059       COMPLEX            A( LDA, * )
10060 *     ..
10061 *
10062 *  Purpose
10063 *  =======
10064 *
10065 *  PB_CLASET initializes a two-dimensional array A to beta on the diago-
10066 *  nal specified by IOFFD and alpha on the offdiagonals.
10067 *
10068 *  Arguments
10069 *  =========
10070 *
10071 *  UPLO    (global input) CHARACTER*1
10072 *          On entry,  UPLO  specifies  which trapezoidal part of the ar-
10073 *          ray A is to be set as follows:
10074 *             = 'L' or 'l':   Lower triangular part is set; the strictly
10075 *                             upper triangular part of A is not changed,
10076 *             = 'U' or 'u':   Upper triangular part is set; the strictly
10077 *                             lower triangular part of A is not changed,
10078 *             = 'D' or 'd'    Only the diagonal of A is set,
10079 *             Otherwise:      All of the array A is set.
10080 *
10081 *  M       (input) INTEGER
10082 *          On entry,  M  specifies the number of rows of the array A.  M
10083 *          must be at least zero.
10084 *
10085 *  N       (input) INTEGER
10086 *          On entry,  N  specifies the number of columns of the array A.
10087 *          N must be at least zero.
10088 *
10089 *  IOFFD   (input) INTEGER
10090 *          On entry, IOFFD specifies the position of the offdiagonal de-
10091 *          limiting the upper and lower trapezoidal part of A as follows
10092 *          (see the notes below):
10093 *
10094 *             IOFFD = 0  specifies the main diagonal A( i, i ),
10095 *                        with i = 1 ... MIN( M, N ),
10096 *             IOFFD > 0  specifies the subdiagonal   A( i+IOFFD, i ),
10097 *                        with i = 1 ... MIN( M-IOFFD, N ),
10098 *             IOFFD < 0  specifies the superdiagonal A( i, i-IOFFD ),
10099 *                        with i = 1 ... MIN( M, N+IOFFD ).
10100 *
10101 *  ALPHA   (input) COMPLEX
10102 *          On entry,  ALPHA specifies the value to which the offdiagonal
10103 *          array elements are set to.
10104 *
10105 *  BETA    (input) COMPLEX
10106 *          On entry, BETA  specifies the value to which the diagonal ar-
10107 *          ray elements are set to.
10108 *
10109 *  A       (input/output) COMPLEX array
10110 *          On entry, A is an array of dimension  (LDA,N).  Before  entry
10111 *          with UPLO = 'U' or 'u', the leading m by n part of the  array
10112 *          A  must  contain  the upper trapezoidal part of the matrix as
10113 *          specified by IOFFD to be set, and  the  strictly lower trape-
10114 *          zoidal  part of A is not referenced; When IUPLO = 'L' or 'l',
10115 *          the leading m by n part of  the  array  A  must  contain  the
10116 *          lower trapezoidal part of the matrix as specified by IOFFD to
10117 *          be set,  and  the  strictly  upper  trapezoidal part of  A is
10118 *          not referenced.
10119 *
10120 *  LDA     (input) INTEGER
10121 *          On entry, LDA specifies the leading dimension of the array A.
10122 *          LDA must be at least max( 1, M ).
10123 *
10124 *  Notes
10125 *  =====
10126 *                           N                                    N
10127 *             ----------------------------                  -----------
10128 *            |       d                    |                |           |
10129 *          M |         d        'U'       |                |      'U'  |
10130 *            |  'L'     'D'               |                |d          |
10131 *            |             d              |              M |  d        |
10132 *             ----------------------------                 |   'D'     |
10133 *                                                          |      d    |
10134 *               IOFFD < 0                                  | 'L'    d  |
10135 *                                                          |          d|
10136 *                  N                                       |           |
10137 *             -----------                                   -----------
10138 *            |    d   'U'|
10139 *            |      d    |                                   IOFFD > 0
10140 *          M |       'D' |
10141 *            |          d|                              N
10142 *            |  'L'      |                 ----------------------------
10143 *            |           |                |          'U'               |
10144 *            |           |                |d                           |
10145 *            |           |                | 'D'                        |
10146 *            |           |                |    d                       |
10147 *            |           |                |'L'   d                     |
10148 *             -----------                  ----------------------------
10149 *
10150 *  -- Written on April 1, 1998 by
10151 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
10152 *
10153 *  =====================================================================
10154 *
10155 *     .. Local Scalars ..
10156       INTEGER            I, J, JTMP, MN
10157 *     ..
10158 *     .. External Functions ..
10159       LOGICAL            LSAME
10160       EXTERNAL           LSAME
10161 *     ..
10162 *     .. Intrinsic Functions ..
10163       INTRINSIC          MAX, MIN
10164 *     ..
10165 *     .. Executable Statements ..
10166 *
10167 *     Quick return if possible
10168 *
10169       IF( M.LE.0 .OR. N.LE.0 )
10170      $   RETURN
10171 *
10172 *     Start the operations
10173 *
10174       IF( LSAME( UPLO, 'L' ) ) THEN
10175 *
10176 *        Set the diagonal to BETA and the strictly lower triangular
10177 *        part of the array to ALPHA.
10178 *
10179          MN = MAX( 0, -IOFFD )
10180          DO 20 J = 1, MIN( MN, N )
10181             DO 10 I = 1, M
10182                A( I, J ) = ALPHA
10183    10       CONTINUE
10184    20    CONTINUE
10185          DO 40 J = MN + 1, MIN( M - IOFFD, N )
10186             JTMP = J + IOFFD
10187             A( JTMP, J ) = BETA
10188             DO 30 I = JTMP + 1, M
10189                A( I, J ) = ALPHA
10190    30       CONTINUE
10191    40    CONTINUE
10192 *
10193       ELSE IF( LSAME( UPLO, 'U' ) ) THEN
10194 *
10195 *        Set the diagonal to BETA and the strictly upper triangular
10196 *        part of the array to ALPHA.
10197 *
10198          MN = MIN( M - IOFFD, N )
10199          DO 60 J = MAX( 0, -IOFFD ) + 1, MN
10200             JTMP = J + IOFFD
10201             DO 50 I = 1, JTMP - 1
10202                A( I, J ) = ALPHA
10203    50       CONTINUE
10204             A( JTMP, J ) = BETA
10205    60    CONTINUE
10206          DO 80 J = MAX( 0, MN ) + 1, N
10207             DO 70 I = 1, M
10208                A( I, J ) = ALPHA
10209    70       CONTINUE
10210    80    CONTINUE
10211 *
10212       ELSE IF( LSAME( UPLO, 'D' ) ) THEN
10213 *
10214 *        Set the array to BETA on the diagonal.
10215 *
10216          DO 90 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N )
10217             A( J + IOFFD, J ) = BETA
10218    90    CONTINUE
10219 *
10220       ELSE
10221 *
10222 *        Set the array to BETA on the diagonal and ALPHA on the
10223 *        offdiagonal.
10224 *
10225          DO 110 J = 1, N
10226             DO 100 I = 1, M
10227                A( I, J ) = ALPHA
10228   100       CONTINUE
10229   110    CONTINUE
10230          IF( ALPHA.NE.BETA .AND. IOFFD.LT.M .AND. IOFFD.GT.-N ) THEN
10231             DO 120 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N )
10232                A( J + IOFFD, J ) = BETA
10233   120       CONTINUE
10234          END IF
10235 *
10236       END IF
10237 *
10238       RETURN
10239 *
10240 *     End of PB_CLASET
10241 *
10242       END
10243       SUBROUTINE PB_CLASCAL( UPLO, M, N, IOFFD, ALPHA, A, LDA )
10244 *
10245 *  -- PBLAS test routine (version 2.0) --
10246 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
10247 *     and University of California, Berkeley.
10248 *     April 1, 1998
10249 *
10250 *     .. Scalar Arguments ..
10251       CHARACTER*1        UPLO
10252       INTEGER            IOFFD, LDA, M, N
10253       COMPLEX            ALPHA
10254 *     ..
10255 *     .. Array Arguments ..
10256       COMPLEX            A( LDA, * )
10257 *     ..
10258 *
10259 *  Purpose
10260 *  =======
10261 *
10262 *  PB_CLASCAL scales a two-dimensional array A by the scalar alpha.
10263 *
10264 *  Arguments
10265 *  =========
10266 *
10267 *  UPLO    (input) CHARACTER*1
10268 *          On entry,  UPLO  specifies  which trapezoidal part of the ar-
10269 *          ray A is to be scaled as follows:
10270 *             = 'L' or 'l':          the lower trapezoid of A is scaled,
10271 *             = 'U' or 'u':          the upper trapezoid of A is scaled,
10272 *             = 'D' or 'd':       diagonal specified by IOFFD is scaled,
10273 *             Otherwise:                   all of the array A is scaled.
10274 *
10275 *  M       (input) INTEGER
10276 *          On entry,  M  specifies the number of rows of the array A.  M
10277 *          must be at least zero.
10278 *
10279 *  N       (input) INTEGER
10280 *          On entry,  N  specifies the number of columns of the array A.
10281 *          N must be at least zero.
10282 *
10283 *  IOFFD   (input) INTEGER
10284 *          On entry, IOFFD specifies the position of the offdiagonal de-
10285 *          limiting the upper and lower trapezoidal part of A as follows
10286 *          (see the notes below):
10287 *
10288 *             IOFFD = 0  specifies the main diagonal A( i, i ),
10289 *                        with i = 1 ... MIN( M, N ),
10290 *             IOFFD > 0  specifies the subdiagonal   A( i+IOFFD, i ),
10291 *                        with i = 1 ... MIN( M-IOFFD, N ),
10292 *             IOFFD < 0  specifies the superdiagonal A( i, i-IOFFD ),
10293 *                        with i = 1 ... MIN( M, N+IOFFD ).
10294 *
10295 *  ALPHA   (input) COMPLEX
10296 *          On entry, ALPHA specifies the scalar alpha.
10297 *
10298 *  A       (input/output) COMPLEX array
10299 *          On entry, A is an array of dimension  (LDA,N).  Before  entry
10300 *          with  UPLO = 'U' or 'u', the leading m by n part of the array
10301 *          A must contain the upper trapezoidal  part  of the matrix  as
10302 *          specified by  IOFFD to be scaled, and the strictly lower tra-
10303 *          pezoidal part of A is not referenced; When UPLO = 'L' or 'l',
10304 *          the leading m by n part of the array A must contain the lower
10305 *          trapezoidal  part  of  the matrix as specified by IOFFD to be
10306 *          scaled,  and  the strictly upper trapezoidal part of A is not
10307 *          referenced. On exit, the entries of the  trapezoid part of  A
10308 *          determined by UPLO and IOFFD are scaled.
10309 *
10310 *  LDA     (input) INTEGER
10311 *          On entry, LDA specifies the leading dimension of the array A.
10312 *          LDA must be at least max( 1, M ).
10313 *
10314 *  Notes
10315 *  =====
10316 *                           N                                    N
10317 *             ----------------------------                  -----------
10318 *            |       d                    |                |           |
10319 *          M |         d        'U'       |                |      'U'  |
10320 *            |  'L'     'D'               |                |d          |
10321 *            |             d              |              M |  d        |
10322 *             ----------------------------                 |   'D'     |
10323 *                                                          |      d    |
10324 *              IOFFD < 0                                   | 'L'    d  |
10325 *                                                          |          d|
10326 *                  N                                       |           |
10327 *             -----------                                   -----------
10328 *            |    d   'U'|
10329 *            |      d    |                                   IOFFD > 0
10330 *          M |       'D' |
10331 *            |          d|                              N
10332 *            |  'L'      |                 ----------------------------
10333 *            |           |                |          'U'               |
10334 *            |           |                |d                           |
10335 *            |           |                | 'D'                        |
10336 *            |           |                |    d                       |
10337 *            |           |                |'L'   d                     |
10338 *             -----------                  ----------------------------
10339 *
10340 *  -- Written on April 1, 1998 by
10341 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
10342 *
10343 *  =====================================================================
10344 *
10345 *     .. Local Scalars ..
10346       INTEGER            I, J, JTMP, MN
10347 *     ..
10348 *     .. External Functions ..
10349       LOGICAL            LSAME
10350       EXTERNAL           LSAME
10351 *     ..
10352 *     .. Intrinsic Functions ..
10353       INTRINSIC          MAX, MIN
10354 *     ..
10355 *     .. Executable Statements ..
10356 *
10357 *     Quick return if possible
10358 *
10359       IF( M.LE.0 .OR. N.LE.0 )
10360      $   RETURN
10361 *
10362 *     Start the operations
10363 *
10364       IF( LSAME( UPLO, 'L' ) ) THEN
10365 *
10366 *        Scales the lower triangular part of the array by ALPHA.
10367 *
10368          MN = MAX( 0, -IOFFD )
10369          DO 20 J = 1, MIN( MN, N )
10370             DO 10 I = 1, M
10371                A( I, J ) = ALPHA * A( I, J )
10372    10       CONTINUE
10373    20    CONTINUE
10374          DO 40 J = MN + 1, MIN( M - IOFFD, N )
10375             DO 30 I = J + IOFFD, M
10376                A( I, J ) = ALPHA * A( I, J )
10377    30       CONTINUE
10378    40    CONTINUE
10379 *
10380       ELSE IF( LSAME( UPLO, 'U' ) ) THEN
10381 *
10382 *        Scales the upper triangular part of the array by ALPHA.
10383 *
10384          MN = MIN( M - IOFFD, N )
10385          DO 60 J = MAX( 0, -IOFFD ) + 1, MN
10386             DO 50 I = 1, J + IOFFD
10387                A( I, J ) = ALPHA * A( I, J )
10388    50       CONTINUE
10389    60    CONTINUE
10390          DO 80 J = MAX( 0, MN ) + 1, N
10391             DO 70 I = 1, M
10392                A( I, J ) = ALPHA * A( I, J )
10393    70       CONTINUE
10394    80    CONTINUE
10395 *
10396       ELSE IF( LSAME( UPLO, 'D' ) ) THEN
10397 *
10398 *        Scales the diagonal entries by ALPHA.
10399 *
10400          DO 90 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N )
10401             JTMP = J + IOFFD
10402             A( JTMP, J ) = ALPHA * A( JTMP, J )
10403    90    CONTINUE
10404 *
10405       ELSE
10406 *
10407 *        Scales the entire array by ALPHA.
10408 *
10409          DO 110 J = 1, N
10410             DO 100 I = 1, M
10411                A( I, J ) = ALPHA * A( I, J )
10412   100       CONTINUE
10413   110    CONTINUE
10414 *
10415       END IF
10416 *
10417       RETURN
10418 *
10419 *     End of PB_CLASCAL
10420 *
10421       END
10422       SUBROUTINE PB_CLAGEN( UPLO, AFORM, A, LDA, LCMT00, IRAN, MBLKS,
10423      $                      IMBLOC, MB, LMBLOC, NBLKS, INBLOC, NB,
10424      $                      LNBLOC, JMP, IMULADD )
10425 *
10426 *  -- PBLAS test routine (version 2.0) --
10427 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
10428 *     and University of California, Berkeley.
10429 *     April 1, 1998
10430 *
10431 *     .. Scalar Arguments ..
10432       CHARACTER*1        UPLO, AFORM
10433       INTEGER            IMBLOC, INBLOC, LCMT00, LDA, LMBLOC, LNBLOC,
10434      $                   MB, MBLKS, NB, NBLKS
10435 *     ..
10436 *     .. Array Arguments ..
10437       INTEGER            IMULADD( 4, * ), IRAN( * ), JMP( * )
10438       COMPLEX            A( LDA, * )
10439 *     ..
10440 *
10441 *  Purpose
10442 *  =======
10443 *
10444 *  PB_CLAGEN locally initializes an array A.
10445 *
10446 *  Arguments
10447 *  =========
10448 *
10449 *  UPLO    (global input) CHARACTER*1
10450 *          On entry, UPLO  specifies whether the lower (UPLO='L') trape-
10451 *          zoidal part or the upper (UPLO='U') trapezoidal part is to be
10452 *          generated  when  the  matrix  to be generated is symmetric or
10453 *          Hermitian. For  all  the  other values of AFORM, the value of
10454 *          this input argument is ignored.
10455 *
10456 *  AFORM   (global input) CHARACTER*1
10457 *          On entry, AFORM specifies the type of submatrix to be genera-
10458 *          ted as follows:
10459 *             AFORM = 'S', sub( A ) is a symmetric matrix,
10460 *             AFORM = 'H', sub( A ) is a Hermitian matrix,
10461 *             AFORM = 'T', sub( A ) is overrwritten  with  the transpose
10462 *                          of what would normally be generated,
10463 *             AFORM = 'C', sub( A ) is overwritten  with  the  conjugate
10464 *                          transpose  of  what would normally be genera-
10465 *                          ted.
10466 *             AFORM = 'N', a random submatrix is generated.
10467 *
10468 *  A       (local output) COMPLEX array
10469 *          On entry,  A  is  an array of dimension (LLD_A, *).  On exit,
10470 *          this array contains the local entries of the randomly genera-
10471 *          ted submatrix sub( A ).
10472 *
10473 *  LDA     (local input) INTEGER
10474 *          On entry,  LDA  specifies  the local leading dimension of the
10475 *          array A. LDA must be at least one.
10476 *
10477 *  LCMT00  (global input) INTEGER
10478 *          On entry, LCMT00 is the LCM value specifying the off-diagonal
10479 *          of the underlying matrix of interest. LCMT00=0 specifies  the
10480 *          main diagonal, LCMT00 > 0 specifies a subdiagonal, LCMT00 < 0
10481 *          specifies superdiagonals.
10482 *
10483 *  IRAN    (local input) INTEGER array
10484 *          On entry, IRAN  is an array of dimension 2 containing respec-
10485 *          tively the 16-lower and 16-higher bits of the encoding of the
10486 *          entry of  the  random  sequence  corresponding locally to the
10487 *          first local array entry to generate. Usually,  this  array is
10488 *          computed by PB_SETLOCRAN.
10489 *
10490 *  MBLKS   (local input) INTEGER
10491 *          On entry, MBLKS specifies the local number of blocks of rows.
10492 *          MBLKS is at least zero.
10493 *
10494 *  IMBLOC  (local input) INTEGER
10495 *          On entry, IMBLOC specifies  the  number of rows (size) of the
10496 *          local uppest  blocks. IMBLOC is at least zero.
10497 *
10498 *  MB      (global input) INTEGER
10499 *          On entry, MB  specifies the blocking factor used to partition
10500 *          the rows of the matrix.  MB  must be at least one.
10501 *
10502 *  LMBLOC  (local input) INTEGER
10503 *          On entry, LMBLOC specifies the number of  rows  (size) of the
10504 *          local lowest blocks. LMBLOC is at least zero.
10505 *
10506 *  NBLKS   (local input) INTEGER
10507 *          On entry,  NBLKS  specifies the local number of blocks of co-
10508 *          lumns. NBLKS is at least zero.
10509 *
10510 *  INBLOC  (local input) INTEGER
10511 *          On entry,  INBLOC  specifies the number of columns (size)  of
10512 *          the local leftmost blocks. INBLOC is at least zero.
10513 *
10514 *  NB      (global input) INTEGER
10515 *          On entry, NB  specifies the blocking factor used to partition
10516 *          the the columns of the matrix.  NB  must be at least one.
10517 *
10518 *  LNBLOC  (local input) INTEGER
10519 *          On entry,  LNBLOC  specifies  the number of columns (size) of
10520 *          the local rightmost blocks. LNBLOC is at least zero.
10521 *
10522 *  JMP     (local input) INTEGER array
10523 *          On entry, JMP is an array of dimension JMP_LEN containing the
10524 *          different jump values used by the random matrix generator.
10525 *
10526 *  IMULADD (local input) INTEGER array
10527 *          On entry, IMULADD is an array of dimension (4, JMP_LEN).  The
10528 *          jth  column  of this array contains the encoded initial cons-
10529 *          tants a_j and c_j to  jump  from X( n ) to  X( n + JMP( j ) )
10530 *          (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
10531 *          contains respectively the 16-lower and 16-higher bits of  the
10532 *          constant a_j, and IMULADD(3:4,j)  contains  the 16-lower  and
10533 *          16-higher bits of the constant c_j.
10534 *
10535 *  -- Written on April 1, 1998 by
10536 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
10537 *
10538 *  =====================================================================
10539 *
10540 *     .. Parameters ..
10541       INTEGER            JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
10542      $                   JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
10543      $                   JMP_NQINBLOC, JMP_NQNB, JMP_ROW
10544       PARAMETER          ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3,
10545      $                   JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6,
10546      $                   JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9,
10547      $                   JMP_NQNB = 10, JMP_NQINBLOC = 11,
10548      $                   JMP_LEN = 11 )
10549       REAL               ZERO
10550       PARAMETER          ( ZERO = 0.0E+0 )
10551 *     ..
10552 *     .. Local Scalars ..
10553       INTEGER            I, IB, IBLK, II, IK, ITMP, JB, JBLK, JJ, JK,
10554      $                   JTMP, LCMTC, LCMTR, LOW, MNB, UPP
10555       COMPLEX            DUMMY
10556 *     ..
10557 *     .. Local Arrays ..
10558       INTEGER            IB0( 2 ), IB1( 2 ), IB2( 2 ), IB3( 2 )
10559 *     ..
10560 *     .. External Subroutines ..
10561       EXTERNAL           PB_JUMPIT
10562 *     ..
10563 *     .. External Functions ..
10564       LOGICAL            LSAME
10565       REAL               PB_SRAND
10566       EXTERNAL           LSAME, PB_SRAND
10567 *     ..
10568 *     .. Intrinsic Functions ..
10569       INTRINSIC          CMPLX, MAX, MIN, REAL
10570 *     ..
10571 *     .. Executable Statements ..
10572 *
10573       DO 10 I = 1, 2
10574          IB1( I ) = IRAN( I )
10575          IB2( I ) = IRAN( I )
10576          IB3( I ) = IRAN( I )
10577    10 CONTINUE
10578 *
10579       IF( LSAME( AFORM, 'N' ) ) THEN
10580 *
10581 *        Generate random matrix
10582 *
10583          JJ = 1
10584 *
10585          DO 50 JBLK = 1, NBLKS
10586 *
10587             IF( JBLK.EQ.1 ) THEN
10588                JB = INBLOC
10589             ELSE IF( JBLK.EQ.NBLKS ) THEN
10590                JB = LNBLOC
10591             ELSE
10592                JB = NB
10593             END IF
10594 *
10595             DO 40 JK = JJ, JJ + JB - 1
10596 *
10597                II = 1
10598 *
10599                DO 30 IBLK = 1, MBLKS
10600 *
10601                   IF( IBLK.EQ.1 ) THEN
10602                      IB = IMBLOC
10603                   ELSE IF( IBLK.EQ.MBLKS ) THEN
10604                      IB = LMBLOC
10605                   ELSE
10606                      IB = MB
10607                   END IF
10608 *
10609 *                 Blocks are IB by JB
10610 *
10611                   DO 20 IK = II, II + IB - 1
10612                      A( IK, JK ) = CMPLX( PB_SRAND( 0 ), PB_SRAND( 0 ) )
10613    20             CONTINUE
10614 *
10615                   II = II + IB
10616 *
10617                   IF( IBLK.EQ.1 ) THEN
10618 *
10619 *                    Jump IMBLOC + ( NPROW - 1 ) * MB rows
10620 *
10621                      CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1,
10622      $                               IB0 )
10623 *
10624                   ELSE
10625 *
10626 *                    Jump NPROW * MB rows
10627 *
10628                      CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1, IB0 )
10629 *
10630                   END IF
10631 *
10632                   IB1( 1 ) = IB0( 1 )
10633                   IB1( 2 ) = IB0( 2 )
10634 *
10635    30          CONTINUE
10636 *
10637 *              Jump one column
10638 *
10639                CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 )
10640 *
10641                IB1( 1 ) = IB0( 1 )
10642                IB1( 2 ) = IB0( 2 )
10643                IB2( 1 ) = IB0( 1 )
10644                IB2( 2 ) = IB0( 2 )
10645 *
10646    40       CONTINUE
10647 *
10648             JJ = JJ + JB
10649 *
10650             IF( JBLK.EQ.1 ) THEN
10651 *
10652 *              Jump INBLOC + ( NPCOL - 1 ) * NB columns
10653 *
10654                CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 )
10655 *
10656             ELSE
10657 *
10658 *              Jump NPCOL * NB columns
10659 *
10660                CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 )
10661 *
10662             END IF
10663 *
10664             IB1( 1 ) = IB0( 1 )
10665             IB1( 2 ) = IB0( 2 )
10666             IB2( 1 ) = IB0( 1 )
10667             IB2( 2 ) = IB0( 2 )
10668             IB3( 1 ) = IB0( 1 )
10669             IB3( 2 ) = IB0( 2 )
10670 *
10671    50    CONTINUE
10672 *
10673       ELSE IF( LSAME( AFORM, 'T' ) ) THEN
10674 *
10675 *        Generate the transpose of the matrix that would be normally
10676 *        generated.
10677 *
10678          II = 1
10679 *
10680          DO 90 IBLK = 1, MBLKS
10681 *
10682             IF( IBLK.EQ.1 ) THEN
10683                IB = IMBLOC
10684             ELSE IF( IBLK.EQ.MBLKS ) THEN
10685                IB = LMBLOC
10686             ELSE
10687                IB = MB
10688             END IF
10689 *
10690             DO 80 IK = II, II + IB - 1
10691 *
10692                JJ = 1
10693 *
10694                DO 70 JBLK = 1, NBLKS
10695 *
10696                   IF( JBLK.EQ.1 ) THEN
10697                      JB = INBLOC
10698                   ELSE IF( JBLK.EQ.NBLKS ) THEN
10699                      JB = LNBLOC
10700                   ELSE
10701                      JB = NB
10702                   END IF
10703 *
10704 *                 Blocks are IB by JB
10705 *
10706                   DO 60 JK = JJ, JJ + JB - 1
10707                      A( IK, JK ) = CMPLX( PB_SRAND( 0 ), PB_SRAND( 0 ) )
10708    60             CONTINUE
10709 *
10710                   JJ = JJ + JB
10711 *
10712                   IF( JBLK.EQ.1 ) THEN
10713 *
10714 *                    Jump INBLOC + ( NPCOL - 1 ) * NB columns
10715 *
10716                      CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
10717      $                               IB0 )
10718 *
10719                   ELSE
10720 *
10721 *                    Jump NPCOL * NB columns
10722 *
10723                      CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1, IB0 )
10724 *
10725                   END IF
10726 *
10727                   IB1( 1 ) = IB0( 1 )
10728                   IB1( 2 ) = IB0( 2 )
10729 *
10730    70          CONTINUE
10731 *
10732 *              Jump one row
10733 *
10734                CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
10735 *
10736                IB1( 1 ) = IB0( 1 )
10737                IB1( 2 ) = IB0( 2 )
10738                IB2( 1 ) = IB0( 1 )
10739                IB2( 2 ) = IB0( 2 )
10740 *
10741    80       CONTINUE
10742 *
10743             II = II + IB
10744 *
10745             IF( IBLK.EQ.1 ) THEN
10746 *
10747 *              Jump IMBLOC + ( NPROW - 1 ) * MB rows
10748 *
10749                CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
10750 *
10751             ELSE
10752 *
10753 *              Jump NPROW * MB rows
10754 *
10755                CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
10756 *
10757             END IF
10758 *
10759             IB1( 1 ) = IB0( 1 )
10760             IB1( 2 ) = IB0( 2 )
10761             IB2( 1 ) = IB0( 1 )
10762             IB2( 2 ) = IB0( 2 )
10763             IB3( 1 ) = IB0( 1 )
10764             IB3( 2 ) = IB0( 2 )
10765 *
10766    90    CONTINUE
10767 *
10768       ELSE IF( LSAME( AFORM, 'S' ) ) THEN
10769 *
10770 *        Generate a symmetric matrix
10771 *
10772          IF( LSAME( UPLO, 'L' ) ) THEN
10773 *
10774 *           generate lower trapezoidal part
10775 *
10776             JJ = 1
10777             LCMTC = LCMT00
10778 *
10779             DO 170 JBLK = 1, NBLKS
10780 *
10781                IF( JBLK.EQ.1 ) THEN
10782                   JB  = INBLOC
10783                   LOW = 1 - INBLOC
10784                ELSE IF( JBLK.EQ.NBLKS ) THEN
10785                   JB = LNBLOC
10786                   LOW = 1 - NB
10787                ELSE
10788                   JB  = NB
10789                   LOW = 1 - NB
10790                END IF
10791 *
10792                DO 160 JK = JJ, JJ + JB - 1
10793 *
10794                   II = 1
10795                   LCMTR = LCMTC
10796 *
10797                   DO 150 IBLK = 1, MBLKS
10798 *
10799                      IF( IBLK.EQ.1 ) THEN
10800                         IB  = IMBLOC
10801                         UPP = IMBLOC - 1
10802                      ELSE IF( IBLK.EQ.MBLKS ) THEN
10803                         IB  = LMBLOC
10804                         UPP = MB - 1
10805                      ELSE
10806                         IB  = MB
10807                         UPP = MB - 1
10808                      END IF
10809 *
10810 *                    Blocks are IB by JB
10811 *
10812                      IF( LCMTR.GT.UPP ) THEN
10813 *
10814                         DO 100 IK = II, II + IB - 1
10815                            DUMMY = CMPLX( PB_SRAND( 0 ),
10816      $                                    PB_SRAND( 0 ) )
10817   100                   CONTINUE
10818 *
10819                      ELSE IF( LCMTR.GE.LOW ) THEN
10820 *
10821                         JTMP = JK - JJ + 1
10822                         MNB  = MAX( 0, -LCMTR )
10823 *
10824                         IF( JTMP.LE.MIN( MNB, JB ) ) THEN
10825 *
10826                            DO 110 IK = II, II + IB - 1
10827                               A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
10828      $                                             PB_SRAND( 0 ) )
10829   110                      CONTINUE
10830 *
10831                         ELSE IF( ( JTMP.GE.( MNB + 1 )         ) .AND.
10832      $                           ( JTMP.LE.MIN( IB-LCMTR, JB ) ) ) THEN
10833 *
10834                            ITMP = II + JTMP + LCMTR - 1
10835 *
10836                            DO 120 IK = II, ITMP - 1
10837                               DUMMY = CMPLX( PB_SRAND( 0 ),
10838      $                                       PB_SRAND( 0 ) )
10839   120                      CONTINUE
10840 *
10841                            DO 130 IK = ITMP, II + IB - 1
10842                               A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
10843      $                                             PB_SRAND( 0 ) )
10844   130                      CONTINUE
10845 *
10846                         END IF
10847 *
10848                      ELSE
10849 *
10850                         DO 140 IK = II, II + IB - 1
10851                            A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
10852      $                                          PB_SRAND( 0 ) )
10853   140                   CONTINUE
10854 *
10855                      END IF
10856 *
10857                      II = II + IB
10858 *
10859                      IF( IBLK.EQ.1 ) THEN
10860 *
10861 *                       Jump IMBLOC + ( NPROW - 1 ) * MB rows
10862 *
10863                         LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
10864                         CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1,
10865      $                                  IB0 )
10866 *
10867                      ELSE
10868 *
10869 *                       Jump NPROW * MB rows
10870 *
10871                         LCMTR = LCMTR - JMP( JMP_NPMB )
10872                         CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1,
10873      $                                  IB0 )
10874 *
10875                      END IF
10876 *
10877                      IB1( 1 ) = IB0( 1 )
10878                      IB1( 2 ) = IB0( 2 )
10879 *
10880   150             CONTINUE
10881 *
10882 *                 Jump one column
10883 *
10884                   CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 )
10885 *
10886                   IB1( 1 ) = IB0( 1 )
10887                   IB1( 2 ) = IB0( 2 )
10888                   IB2( 1 ) = IB0( 1 )
10889                   IB2( 2 ) = IB0( 2 )
10890 *
10891   160          CONTINUE
10892 *
10893                JJ = JJ + JB
10894 *
10895                IF( JBLK.EQ.1 ) THEN
10896 *
10897 *                 Jump INBLOC + ( NPCOL - 1 ) * NB columns
10898 *
10899                   LCMTC = LCMTC + JMP( JMP_NQINBLOC )
10900                   CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 )
10901 *
10902                ELSE
10903 *
10904 *                 Jump NPCOL * NB columns
10905 *
10906                   LCMTC = LCMTC + JMP( JMP_NQNB )
10907                   CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 )
10908 *
10909                END IF
10910 *
10911                IB1( 1 ) = IB0( 1 )
10912                IB1( 2 ) = IB0( 2 )
10913                IB2( 1 ) = IB0( 1 )
10914                IB2( 2 ) = IB0( 2 )
10915                IB3( 1 ) = IB0( 1 )
10916                IB3( 2 ) = IB0( 2 )
10917 *
10918   170       CONTINUE
10919 *
10920          ELSE
10921 *
10922 *           generate upper trapezoidal part
10923 *
10924             II = 1
10925             LCMTR = LCMT00
10926 *
10927             DO 250 IBLK = 1, MBLKS
10928 *
10929                IF( IBLK.EQ.1 ) THEN
10930                   IB  = IMBLOC
10931                   UPP = IMBLOC - 1
10932                ELSE IF( IBLK.EQ.MBLKS ) THEN
10933                   IB  = LMBLOC
10934                   UPP = MB - 1
10935                ELSE
10936                   IB  = MB
10937                   UPP = MB - 1
10938                END IF
10939 *
10940                DO 240 IK = II, II + IB - 1
10941 *
10942                   JJ = 1
10943                   LCMTC = LCMTR
10944 *
10945                   DO 230 JBLK = 1, NBLKS
10946 *
10947                      IF( JBLK.EQ.1 ) THEN
10948                         JB  = INBLOC
10949                         LOW = 1 - INBLOC
10950                      ELSE IF( JBLK.EQ.NBLKS ) THEN
10951                         JB  = LNBLOC
10952                         LOW = 1 - NB
10953                      ELSE
10954                         JB  = NB
10955                         LOW = 1 - NB
10956                      END IF
10957 *
10958 *                    Blocks are IB by JB
10959 *
10960                      IF( LCMTC.LT.LOW ) THEN
10961 *
10962                         DO 180 JK = JJ, JJ + JB - 1
10963                            DUMMY = CMPLX( PB_SRAND( 0 ), PB_SRAND( 0 ) )
10964   180                   CONTINUE
10965 *
10966                      ELSE IF( LCMTC.LE.UPP ) THEN
10967 *
10968                         ITMP = IK - II + 1
10969                         MNB  = MAX( 0, LCMTC )
10970 *
10971                         IF( ITMP.LE.MIN( MNB, IB ) ) THEN
10972 *
10973                            DO 190 JK = JJ, JJ + JB - 1
10974                               A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
10975      $                                             PB_SRAND( 0 ) )
10976   190                      CONTINUE
10977 *
10978                         ELSE IF( ( ITMP.GE.( MNB + 1 )         ) .AND.
10979      $                           ( ITMP.LE.MIN( JB+LCMTC, IB ) ) ) THEN
10980 *
10981                            JTMP = JJ + ITMP - LCMTC - 1
10982 *
10983                            DO 200 JK = JJ, JTMP - 1
10984                               DUMMY = CMPLX( PB_SRAND( 0 ),
10985      $                                       PB_SRAND( 0 ) )
10986   200                      CONTINUE
10987 *
10988                            DO 210 JK = JTMP, JJ + JB - 1
10989                               A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
10990      $                                             PB_SRAND( 0 ) )
10991   210                      CONTINUE
10992 *
10993                         END IF
10994 *
10995                      ELSE
10996 *
10997                         DO 220 JK = JJ, JJ + JB - 1
10998                            A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
10999      $                                          PB_SRAND( 0 ) )
11000   220                   CONTINUE
11001 *
11002                      END IF
11003 *
11004                      JJ = JJ + JB
11005 *
11006                      IF( JBLK.EQ.1 ) THEN
11007 *
11008 *                       Jump INBLOC + ( NPCOL - 1 ) * NB columns
11009 *
11010                         LCMTC = LCMTC + JMP( JMP_NQINBLOC )
11011                         CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
11012      $                                  IB0 )
11013 *
11014                      ELSE
11015 *
11016 *                       Jump NPCOL * NB columns
11017 *
11018                         LCMTC = LCMTC + JMP( JMP_NQNB )
11019                         CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1,
11020      $                                  IB0 )
11021 *
11022                      END IF
11023 *
11024                      IB1( 1 ) = IB0( 1 )
11025                      IB1( 2 ) = IB0( 2 )
11026 *
11027   230             CONTINUE
11028 *
11029 *                 Jump one row
11030 *
11031                   CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
11032 *
11033                   IB1( 1 ) = IB0( 1 )
11034                   IB1( 2 ) = IB0( 2 )
11035                   IB2( 1 ) = IB0( 1 )
11036                   IB2( 2 ) = IB0( 2 )
11037 *
11038   240          CONTINUE
11039 *
11040                II = II + IB
11041 *
11042                IF( IBLK.EQ.1 ) THEN
11043 *
11044 *                 Jump IMBLOC + ( NPROW - 1 ) * MB rows
11045 *
11046                   LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
11047                   CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
11048 *
11049                ELSE
11050 *
11051 *                 Jump NPROW * MB rows
11052 *
11053                   LCMTR = LCMTR - JMP( JMP_NPMB )
11054                   CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
11055 *
11056                END IF
11057 *
11058                IB1( 1 ) = IB0( 1 )
11059                IB1( 2 ) = IB0( 2 )
11060                IB2( 1 ) = IB0( 1 )
11061                IB2( 2 ) = IB0( 2 )
11062                IB3( 1 ) = IB0( 1 )
11063                IB3( 2 ) = IB0( 2 )
11064 *
11065   250       CONTINUE
11066 *
11067          END IF
11068 *
11069       ELSE IF( LSAME( AFORM, 'C' ) ) THEN
11070 *
11071 *        Generate the conjugate transpose of the matrix that would be
11072 *        normally generated.
11073 *
11074          II = 1
11075 *
11076          DO 290 IBLK = 1, MBLKS
11077 *
11078             IF( IBLK.EQ.1 ) THEN
11079                IB = IMBLOC
11080             ELSE IF( IBLK.EQ.MBLKS ) THEN
11081                IB = LMBLOC
11082             ELSE
11083                IB = MB
11084             END IF
11085 *
11086             DO 280 IK = II, II + IB - 1
11087 *
11088                JJ = 1
11089 *
11090                DO 270 JBLK = 1, NBLKS
11091 *
11092                   IF( JBLK.EQ.1 ) THEN
11093                      JB = INBLOC
11094                   ELSE IF( JBLK.EQ.NBLKS ) THEN
11095                      JB = LNBLOC
11096                   ELSE
11097                      JB = NB
11098                   END IF
11099 *
11100 *                 Blocks are IB by JB
11101 *
11102                   DO 260 JK = JJ, JJ + JB - 1
11103                      A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
11104      $                                   -PB_SRAND( 0 ) )
11105   260             CONTINUE
11106 *
11107                   JJ = JJ + JB
11108 *
11109                   IF( JBLK.EQ.1 ) THEN
11110 *
11111 *                    Jump INBLOC + ( NPCOL - 1 ) * NB columns
11112 *
11113                      CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
11114      $                               IB0 )
11115 *
11116                   ELSE
11117 *
11118 *                    Jump NPCOL * NB columns
11119 *
11120                      CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1,
11121      $                               IB0 )
11122 *
11123                   END IF
11124 *
11125                   IB1( 1 ) = IB0( 1 )
11126                   IB1( 2 ) = IB0( 2 )
11127 *
11128   270          CONTINUE
11129 *
11130 *              Jump one row
11131 *
11132                CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
11133 *
11134                IB1( 1 ) = IB0( 1 )
11135                IB1( 2 ) = IB0( 2 )
11136                IB2( 1 ) = IB0( 1 )
11137                IB2( 2 ) = IB0( 2 )
11138 *
11139   280       CONTINUE
11140 *
11141             II = II + IB
11142 *
11143             IF( IBLK.EQ.1 ) THEN
11144 *
11145 *              Jump IMBLOC + ( NPROW - 1 ) * MB rows
11146 *
11147                CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
11148 *
11149             ELSE
11150 *
11151 *              Jump NPROW * MB rows
11152 *
11153                CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
11154 *
11155             END IF
11156 *
11157             IB1( 1 ) = IB0( 1 )
11158             IB1( 2 ) = IB0( 2 )
11159             IB2( 1 ) = IB0( 1 )
11160             IB2( 2 ) = IB0( 2 )
11161             IB3( 1 ) = IB0( 1 )
11162             IB3( 2 ) = IB0( 2 )
11163 *
11164   290    CONTINUE
11165 *
11166       ELSE IF( LSAME( AFORM, 'H' ) ) THEN
11167 *
11168 *        Generate a Hermitian matrix
11169 *
11170          IF( LSAME( UPLO, 'L' ) ) THEN
11171 *
11172 *           generate lower trapezoidal part
11173 *
11174             JJ = 1
11175             LCMTC = LCMT00
11176 *
11177             DO 370 JBLK = 1, NBLKS
11178 *
11179                IF( JBLK.EQ.1 ) THEN
11180                   JB  = INBLOC
11181                   LOW = 1 - INBLOC
11182                ELSE IF( JBLK.EQ.NBLKS ) THEN
11183                   JB = LNBLOC
11184                   LOW = 1 - NB
11185                ELSE
11186                   JB  = NB
11187                   LOW = 1 - NB
11188                END IF
11189 *
11190                DO 360 JK = JJ, JJ + JB - 1
11191 *
11192                   II = 1
11193                   LCMTR = LCMTC
11194 *
11195                   DO 350 IBLK = 1, MBLKS
11196 *
11197                      IF( IBLK.EQ.1 ) THEN
11198                         IB  = IMBLOC
11199                         UPP = IMBLOC - 1
11200                      ELSE IF( IBLK.EQ.MBLKS ) THEN
11201                         IB  = LMBLOC
11202                         UPP = MB - 1
11203                      ELSE
11204                         IB  = MB
11205                         UPP = MB - 1
11206                      END IF
11207 *
11208 *                    Blocks are IB by JB
11209 *
11210                      IF( LCMTR.GT.UPP ) THEN
11211 *
11212                         DO 300 IK = II, II + IB - 1
11213                            DUMMY = CMPLX( PB_SRAND( 0 ),
11214      $                                    PB_SRAND( 0 ) )
11215   300                   CONTINUE
11216 *
11217                      ELSE IF( LCMTR.GE.LOW ) THEN
11218 *
11219                         JTMP = JK - JJ + 1
11220                         MNB  = MAX( 0, -LCMTR )
11221 *
11222                         IF( JTMP.LE.MIN( MNB, JB ) ) THEN
11223 *
11224                            DO 310 IK = II, II + IB - 1
11225                               A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
11226      $                                             PB_SRAND( 0 ) )
11227   310                      CONTINUE
11228 *
11229                         ELSE IF( ( JTMP.GE.( MNB + 1 )         ) .AND.
11230      $                           ( JTMP.LE.MIN( IB-LCMTR, JB ) ) ) THEN
11231 *
11232                            ITMP = II + JTMP + LCMTR - 1
11233 *
11234                            DO 320 IK = II, ITMP - 1
11235                               DUMMY = CMPLX( PB_SRAND( 0 ),
11236      $                                       PB_SRAND( 0 ) )
11237   320                      CONTINUE
11238 *
11239                            IF( ITMP.LE.( II + IB - 1 ) ) THEN
11240                               DUMMY = CMPLX( PB_SRAND( 0 ),
11241      $                                      -PB_SRAND( 0 ) )
11242                               A( ITMP, JK ) = CMPLX( REAL( DUMMY ),
11243      $                                               ZERO )
11244                            END IF
11245 *
11246                            DO 330 IK = ITMP + 1, II + IB - 1
11247                               A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
11248      $                                             PB_SRAND( 0 ) )
11249   330                      CONTINUE
11250 *
11251                         END IF
11252 *
11253                      ELSE
11254 *
11255                         DO 340 IK = II, II + IB - 1
11256                            A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
11257      $                                          PB_SRAND( 0 ) )
11258   340                   CONTINUE
11259 *
11260                      END IF
11261 *
11262                      II = II + IB
11263 *
11264                      IF( IBLK.EQ.1 ) THEN
11265 *
11266 *                       Jump IMBLOC + ( NPROW - 1 ) * MB rows
11267 *
11268                         LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
11269                         CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1,
11270      $                                  IB0 )
11271 *
11272                      ELSE
11273 *
11274 *                       Jump NPROW * MB rows
11275 *
11276                         LCMTR = LCMTR - JMP( JMP_NPMB )
11277                         CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1,
11278      $                                  IB0 )
11279 *
11280                      END IF
11281 *
11282                      IB1( 1 ) = IB0( 1 )
11283                      IB1( 2 ) = IB0( 2 )
11284 *
11285   350             CONTINUE
11286 *
11287 *                 Jump one column
11288 *
11289                   CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 )
11290 *
11291                   IB1( 1 ) = IB0( 1 )
11292                   IB1( 2 ) = IB0( 2 )
11293                   IB2( 1 ) = IB0( 1 )
11294                   IB2( 2 ) = IB0( 2 )
11295 *
11296   360          CONTINUE
11297 *
11298                JJ = JJ + JB
11299 *
11300                IF( JBLK.EQ.1 ) THEN
11301 *
11302 *                 Jump INBLOC + ( NPCOL - 1 ) * NB columns
11303 *
11304                   LCMTC = LCMTC + JMP( JMP_NQINBLOC )
11305                   CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 )
11306 *
11307                ELSE
11308 *
11309 *                 Jump NPCOL * NB columns
11310 *
11311                   LCMTC = LCMTC + JMP( JMP_NQNB )
11312                   CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 )
11313 *
11314                END IF
11315 *
11316                IB1( 1 ) = IB0( 1 )
11317                IB1( 2 ) = IB0( 2 )
11318                IB2( 1 ) = IB0( 1 )
11319                IB2( 2 ) = IB0( 2 )
11320                IB3( 1 ) = IB0( 1 )
11321                IB3( 2 ) = IB0( 2 )
11322 *
11323   370       CONTINUE
11324 *
11325          ELSE
11326 *
11327 *           generate upper trapezoidal part
11328 *
11329             II = 1
11330             LCMTR = LCMT00
11331 *
11332             DO 450 IBLK = 1, MBLKS
11333 *
11334                IF( IBLK.EQ.1 ) THEN
11335                   IB  = IMBLOC
11336                   UPP = IMBLOC - 1
11337                ELSE IF( IBLK.EQ.MBLKS ) THEN
11338                   IB  = LMBLOC
11339                   UPP = MB - 1
11340                ELSE
11341                   IB  = MB
11342                   UPP = MB - 1
11343                END IF
11344 *
11345                DO 440 IK = II, II + IB - 1
11346 *
11347                   JJ = 1
11348                   LCMTC = LCMTR
11349 *
11350                   DO 430 JBLK = 1, NBLKS
11351 *
11352                      IF( JBLK.EQ.1 ) THEN
11353                         JB  = INBLOC
11354                         LOW = 1 - INBLOC
11355                      ELSE IF( JBLK.EQ.NBLKS ) THEN
11356                         JB  = LNBLOC
11357                         LOW = 1 - NB
11358                      ELSE
11359                         JB  = NB
11360                         LOW = 1 - NB
11361                      END IF
11362 *
11363 *                    Blocks are IB by JB
11364 *
11365                      IF( LCMTC.LT.LOW ) THEN
11366 *
11367                         DO 380 JK = JJ, JJ + JB - 1
11368                            DUMMY = CMPLX( PB_SRAND( 0 ),
11369      $                                   -PB_SRAND( 0 ) )
11370   380                   CONTINUE
11371 *
11372                      ELSE IF( LCMTC.LE.UPP ) THEN
11373 *
11374                         ITMP = IK - II + 1
11375                         MNB  = MAX( 0, LCMTC )
11376 *
11377                         IF( ITMP.LE.MIN( MNB, IB ) ) THEN
11378 *
11379                            DO 390 JK = JJ, JJ + JB - 1
11380                               A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
11381      $                                            -PB_SRAND( 0 ) )
11382   390                      CONTINUE
11383 *
11384                         ELSE IF( ( ITMP.GE.( MNB + 1 )         ) .AND.
11385      $                           ( ITMP.LE.MIN( JB+LCMTC, IB ) ) ) THEN
11386 *
11387                            JTMP = JJ + ITMP - LCMTC - 1
11388 *
11389                            DO 400 JK = JJ, JTMP - 1
11390                               DUMMY = CMPLX( PB_SRAND( 0 ),
11391      $                                      -PB_SRAND( 0 ) )
11392   400                      CONTINUE
11393 *
11394                            IF( JTMP.LE.( JJ + JB - 1 ) ) THEN
11395                               DUMMY = CMPLX( PB_SRAND( 0 ),
11396      $                                      -PB_SRAND( 0 ) )
11397                               A( IK, JTMP ) = CMPLX( REAL( DUMMY ),
11398      $                                               ZERO )
11399                            END IF
11400 *
11401                            DO 410 JK = JTMP + 1, JJ + JB - 1
11402                               A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
11403      $                                            -PB_SRAND( 0 ) )
11404   410                      CONTINUE
11405 *
11406                         END IF
11407 *
11408                      ELSE
11409 *
11410                         DO 420 JK = JJ, JJ + JB - 1
11411                            A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
11412      $                                         -PB_SRAND( 0 ) )
11413   420                   CONTINUE
11414 *
11415                      END IF
11416 *
11417                      JJ = JJ + JB
11418 *
11419                      IF( JBLK.EQ.1 ) THEN
11420 *
11421 *                       Jump INBLOC + ( NPCOL - 1 ) * NB columns
11422 *
11423                         LCMTC = LCMTC + JMP( JMP_NQINBLOC )
11424                         CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
11425      $                                  IB0 )
11426 *
11427                      ELSE
11428 *
11429 *                       Jump NPCOL * NB columns
11430 *
11431                         LCMTC = LCMTC + JMP( JMP_NQNB )
11432                         CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1,
11433      $                                  IB0 )
11434 *
11435                      END IF
11436 *
11437                      IB1( 1 ) = IB0( 1 )
11438                      IB1( 2 ) = IB0( 2 )
11439 *
11440   430             CONTINUE
11441 *
11442 *                 Jump one row
11443 *
11444                   CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
11445 *
11446                   IB1( 1 ) = IB0( 1 )
11447                   IB1( 2 ) = IB0( 2 )
11448                   IB2( 1 ) = IB0( 1 )
11449                   IB2( 2 ) = IB0( 2 )
11450 *
11451   440          CONTINUE
11452 *
11453                II = II + IB
11454 *
11455                IF( IBLK.EQ.1 ) THEN
1145