ScaLAPACK  2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
pdblastst.f
Go to the documentation of this file.
00001       SUBROUTINE PDOPTEE( 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 *  PDOPTEE  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            PDCHKOPT
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 PDCHKOPT( 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 PDCHKOPT( 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 PDCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS )
00177 *
00178 *        Check 2nd option
00179 *
00180          APOS = 2
00181          CALL PDCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
00182 *
00183 *        Check 3rd option
00184 *
00185          APOS = 3
00186          CALL PDCHKOPT( 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 PDCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
00196 *
00197 *        Check 2'nd option
00198 *
00199          APOS = 2
00200          CALL PDCHKOPT( 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 PDCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'S', APOS )
00208 *
00209 *        Check 2nd option
00210 *
00211          APOS = 2
00212          CALL PDCHKOPT( 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 PDCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS )
00221 *
00222 *        Check 2'nd option
00223 *
00224          APOS = 2
00225          CALL PDCHKOPT( 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 PDCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'S', APOS )
00233 *
00234 *        Check 2nd option
00235 *
00236          APOS = 2
00237          CALL PDCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS )
00238 *
00239 *        Check 3rd option
00240 *
00241          APOS = 3
00242          CALL PDCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
00243 *
00244 *        Check 4th option
00245 *
00246          APOS = 4
00247          CALL PDCHKOPT( 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 PDCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
00256 *
00257       END IF
00258 *
00259       RETURN
00260 *
00261 *     End of PDOPTEE
00262 *
00263       END
00264       SUBROUTINE PDCHKOPT( 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 *  PDCHKOPT tests the option ARGNAM in any PBLAS routine.
00287 *
00288 *  Notes
00289 *  =====
00290 *
00291 *  A description  vector  is associated with each 2D block-cyclicly dis-
00292 *  tributed matrix.  This  vector  stores  the  information  required to
00293 *  establish the  mapping  between a  matrix entry and its corresponding
00294 *  process and memory location.
00295 *
00296 *  In  the  following  comments,   the character _  should  be  read  as
00297 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
00298 *  block cyclicly distributed matrix.  Its description vector is DESCA:
00299 *
00300 *  NOTATION         STORED IN       EXPLANATION
00301 *  ---------------- --------------- ------------------------------------
00302 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
00303 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
00304 *                                   the NPROW x NPCOL BLACS process grid
00305 *                                   A  is distributed over.  The context
00306 *                                   itself  is  global,  but  the handle
00307 *                                   (the integer value) may vary.
00308 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
00309 *                                   ted matrix A, M_A >= 0.
00310 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
00311 *                                   buted matrix A, N_A >= 0.
00312 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
00313 *                                   block of the matrix A, IMB_A > 0.
00314 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
00315 *                                   left   block   of   the   matrix  A,
00316 *                                   INB_A > 0.
00317 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
00318 *                                   bute the last  M_A-IMB_A rows of  A,
00319 *                                   MB_A > 0.
00320 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
00321 *                                   bute the last  N_A-INB_A  columns of
00322 *                                   A, NB_A > 0.
00323 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
00324 *                                   row of the matrix  A is distributed,
00325 *                                   NPROW > RSRC_A >= 0.
00326 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
00327 *                                   first  column of  A  is distributed.
00328 *                                   NPCOL > CSRC_A >= 0.
00329 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
00330 *                                   array  storing  the  local blocks of
00331 *                                   the distributed matrix A,
00332 *                                   IF( Lc( 1, N_A ) > 0 )
00333 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
00334 *                                   ELSE
00335 *                                      LLD_A >= 1.
00336 *
00337 *  Let K be the number of  rows of a matrix A starting at the global in-
00338 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
00339 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
00340 *  receive if these K rows were distributed over NPROW processes.  If  K
00341 *  is the number of columns of a matrix  A  starting at the global index
00342 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
00343 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
00344 *  these K columns were distributed over NPCOL processes.
00345 *
00346 *  The values of Lr() and Lc() may be determined via a call to the func-
00347 *  tion PB_NUMROC:
00348 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
00349 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
00350 *
00351 *  Arguments
00352 *  =========
00353 *
00354 *  ICTXT   (local input) INTEGER
00355 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
00356 *          ting the global  context of the operation. The context itself
00357 *          is global, but the value of ICTXT is local.
00358 *
00359 *  NOUT    (global input) INTEGER
00360 *          On entry, NOUT specifies the unit number for the output file.
00361 *          When NOUT is 6, output to screen,  when  NOUT is 0, output to
00362 *          stderr. NOUT is only defined for process 0.
00363 *
00364 *  SUBPTR  (global input) SUBROUTINE
00365 *          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
00366 *          EXTERNAL in the calling subroutine.
00367 *
00368 *  SCODE   (global input) INTEGER
00369 *          On entry, SCODE specifies the calling sequence code.
00370 *
00371 *  SNAME   (global input) CHARACTER*(*)
00372 *          On entry,  SNAME  specifies  the subroutine name calling this
00373 *          subprogram.
00374 *
00375 *  ARGNAM  (global input) CHARACTER*(*)
00376 *          On entry,  ARGNAM  specifies  the  name  of  the option to be
00377 *          checked. ARGNAM can either be 'D', 'S', 'A', 'B', or 'U'.
00378 *
00379 *  ARGPOS  (global input) INTEGER
00380 *          On entry, ARGPOS indicates the position of the option ARGNAM
00381 *          to be tested.
00382 *
00383 *  -- Written on April 1, 1998 by
00384 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
00385 *
00386 *  =====================================================================
00387 *
00388 *     .. Local Scalars ..
00389       INTEGER            INFOT
00390 *     ..
00391 *     .. External Subroutines ..
00392       EXTERNAL           PCHKPBE, PDCALLSUB, PDSETPBLAS
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 PDSETPBLAS( 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 PDCALLSUB( SUBPTR, SCODE )
00447       CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
00448 *
00449       RETURN
00450 *
00451 *     End of PDCHKOPT
00452 *
00453       END
00454       SUBROUTINE PDDIMEE( 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 *  PDDIMEE  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            PDCHKDIM
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 PDCHKDIM( 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 PDCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00625 *
00626 *        Check 2nd dimension
00627 *
00628          APOS = 3
00629          CALL PDCHKDIM( 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 PDCHKDIM( 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 PDCHKDIM( 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 PDCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00652 *
00653 *        Check 2nd dimension
00654 *
00655          APOS = 2
00656          CALL PDCHKDIM( 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 PDCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00666 *
00667 *        Check 2nd dimension
00668 *
00669          APOS = 4
00670          CALL PDCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00671 *
00672 *        Check 3rd dimension
00673 *
00674          APOS = 5
00675          CALL PDCHKDIM( 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 PDCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00683 *
00684 *        Check 2nd dimension
00685 *
00686          APOS = 4
00687          CALL PDCHKDIM( 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 PDCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00696 *
00697 *        Check 2nd dimension
00698 *
00699          APOS = 4
00700          CALL PDCHKDIM( 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 PDCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00708 *
00709 *        Check 2nd dimension
00710 *
00711          APOS = 2
00712          CALL PDCHKDIM( 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 PDCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00720 *
00721 *        Check 2nd dimension
00722 *
00723          APOS = 6
00724          CALL PDCHKDIM( 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 PDCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00732 *
00733 *        Check 2nd dimension
00734 *
00735          APOS = 3
00736          CALL PDCHKDIM( 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 PDCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00744 *
00745 *        Check 2nd dimension
00746 *
00747          APOS = 4
00748          CALL PDCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00749 *
00750       END IF
00751 *
00752       RETURN
00753 *
00754 *     End of PDDIMEE
00755 *
00756       END
00757       SUBROUTINE PDCHKDIM( 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 *  PDCHKDIM tests the dimension ARGNAM in any PBLAS routine.
00780 *
00781 *  Notes
00782 *  =====
00783 *
00784 *  A description  vector  is associated with each 2D block-cyclicly dis-
00785 *  tributed matrix.  This  vector  stores  the  information  required to
00786 *  establish the  mapping  between a  matrix entry and its corresponding
00787 *  process and memory location.
00788 *
00789 *  In  the  following  comments,   the character _  should  be  read  as
00790 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
00791 *  block cyclicly distributed matrix.  Its description vector is DESCA:
00792 *
00793 *  NOTATION         STORED IN       EXPLANATION
00794 *  ---------------- --------------- ------------------------------------
00795 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
00796 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
00797 *                                   the NPROW x NPCOL BLACS process grid
00798 *                                   A  is distributed over.  The context
00799 *                                   itself  is  global,  but  the handle
00800 *                                   (the integer value) may vary.
00801 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
00802 *                                   ted matrix A, M_A >= 0.
00803 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
00804 *                                   buted matrix A, N_A >= 0.
00805 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
00806 *                                   block of the matrix A, IMB_A > 0.
00807 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
00808 *                                   left   block   of   the   matrix  A,
00809 *                                   INB_A > 0.
00810 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
00811 *                                   bute the last  M_A-IMB_A rows of  A,
00812 *                                   MB_A > 0.
00813 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
00814 *                                   bute the last  N_A-INB_A  columns of
00815 *                                   A, NB_A > 0.
00816 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
00817 *                                   row of the matrix  A is distributed,
00818 *                                   NPROW > RSRC_A >= 0.
00819 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
00820 *                                   first  column of  A  is distributed.
00821 *                                   NPCOL > CSRC_A >= 0.
00822 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
00823 *                                   array  storing  the  local blocks of
00824 *                                   the distributed matrix A,
00825 *                                   IF( Lc( 1, N_A ) > 0 )
00826 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
00827 *                                   ELSE
00828 *                                      LLD_A >= 1.
00829 *
00830 *  Let K be the number of  rows of a matrix A starting at the global in-
00831 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
00832 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
00833 *  receive if these K rows were distributed over NPROW processes.  If  K
00834 *  is the number of columns of a matrix  A  starting at the global index
00835 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
00836 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
00837 *  these K columns were distributed over NPCOL processes.
00838 *
00839 *  The values of Lr() and Lc() may be determined via a call to the func-
00840 *  tion PB_NUMROC:
00841 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
00842 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
00843 *
00844 *  Arguments
00845 *  =========
00846 *
00847 *  ICTXT   (local input) INTEGER
00848 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
00849 *          ting the global  context of the operation. The context itself
00850 *          is global, but the value of ICTXT is local.
00851 *
00852 *  NOUT    (global input) INTEGER
00853 *          On entry, NOUT specifies the unit number for the output file.
00854 *          When NOUT is 6, output to screen,  when  NOUT is 0, output to
00855 *          stderr. NOUT is only defined for process 0.
00856 *
00857 *  SUBPTR  (global input) SUBROUTINE
00858 *          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
00859 *          EXTERNAL in the calling subroutine.
00860 *
00861 *  SCODE   (global input) INTEGER
00862 *          On entry, SCODE specifies the calling sequence code.
00863 *
00864 *  SNAME   (global input) CHARACTER*(*)
00865 *          On entry,  SNAME  specifies  the subroutine name calling this
00866 *          subprogram.
00867 *
00868 *  ARGNAM  (global input) CHARACTER*(*)
00869 *          On entry,  ARGNAM  specifies  the name of the dimension to be
00870 *          checked. ARGNAM can either be 'M', 'N' or 'K'.
00871 *
00872 *  ARGPOS  (global input) INTEGER
00873 *          On entry, ARGPOS indicates the position of the option ARGNAM
00874 *          to be tested.
00875 *
00876 *  -- Written on April 1, 1998 by
00877 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
00878 *
00879 *  =====================================================================
00880 *
00881 *     .. Local Scalars ..
00882       INTEGER            INFOT
00883 *     ..
00884 *     .. External Subroutines ..
00885       EXTERNAL           PCHKPBE, PDCALLSUB, PDSETPBLAS
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 PDSETPBLAS( 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 PDCALLSUB( SUBPTR, SCODE )
00928       CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
00929 *
00930       RETURN
00931 *
00932 *     End of PDCHKDIM
00933 *
00934       END
00935       SUBROUTINE PDVECEE( 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 *  PDVECEE  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            PDCHKMAT
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 PDCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01098 *
01099 *        Check 2nd vector
01100 *
01101          APOS = 7
01102          CALL PDCHKMAT( 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 PDCHKMAT( 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 PDCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01117 *
01118 *        Check 2nd vector
01119 *
01120          APOS = 8
01121          CALL PDCHKMAT( 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 PDCHKMAT( 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 PDCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01138 *
01139 *        Check 2nd vector
01140 *
01141          APOS = 15
01142          CALL PDCHKMAT( 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 PDCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01150 *
01151 *        Check 2nd vector
01152 *
01153          APOS = 14
01154          CALL PDCHKMAT( 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 PDCHKMAT( 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 PDCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01169 *
01170 *        Check 2nd vector
01171 *
01172          APOS = 9
01173          CALL PDCHKMAT( 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 PDCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01181 *
01182       END IF
01183 *
01184       RETURN
01185 *
01186 *     End of PDVECEE
01187 *
01188       END
01189       SUBROUTINE PDMATEE( 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 *  PDMATEE  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            PDCHKMAT
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 PDCHKMAT( 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 PDCHKMAT( 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 PDCHKMAT( 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 PDCHKMAT( 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 PDCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01382 *
01383 *        Check 2nd matrix
01384 *
01385          APOS = 11
01386          CALL PDCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'B', APOS )
01387 *
01388 *        Check 3nd matrix
01389 *
01390          APOS = 16
01391          CALL PDCHKMAT( 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 PDCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01399 *
01400 *        Check 2nd matrix
01401 *
01402          APOS = 10
01403          CALL PDCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'B', APOS )
01404 *
01405 *        Check 3nd matrix
01406 *
01407          APOS = 15
01408          CALL PDCHKMAT( 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 PDCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01416 *
01417 *        Check 2nd matrix
01418 *
01419          APOS = 11
01420          CALL PDCHKMAT( 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 PDCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01428 *
01429 *        Check 2nd matrix
01430 *
01431          APOS = 9
01432          CALL PDCHKMAT( 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 PDCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01440 *
01441 *        Check 2nd matrix
01442 *
01443          APOS = 12
01444          CALL PDCHKMAT( 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 PDCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01452 *
01453 *        Check 2nd matrix
01454 *
01455          APOS = 10
01456          CALL PDCHKMAT( 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 PDCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01464 *
01465 *        Check 2nd matrix
01466 *
01467          APOS = 11
01468          CALL PDCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'C', APOS )
01469 *
01470       END IF
01471 *
01472       RETURN
01473 *
01474 *     End of PDMATEE
01475 *
01476       END
01477       SUBROUTINE PDSETPBLAS( 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 *  PDSETPBLAS initializes *all* the dummy arguments to correct values.
01492 *
01493 *  Notes
01494 *  =====
01495 *
01496 *  A description  vector  is associated with each 2D block-cyclicly dis-
01497 *  tributed matrix.  This  vector  stores  the  information  required to
01498 *  establish the  mapping  between a  matrix entry and its corresponding
01499 *  process and memory location.
01500 *
01501 *  In  the  following  comments,   the character _  should  be  read  as
01502 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
01503 *  block cyclicly distributed matrix.  Its description vector is DESCA:
01504 *
01505 *  NOTATION         STORED IN       EXPLANATION
01506 *  ---------------- --------------- ------------------------------------
01507 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
01508 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
01509 *                                   the NPROW x NPCOL BLACS process grid
01510 *                                   A  is distributed over.  The context
01511 *                                   itself  is  global,  but  the handle
01512 *                                   (the integer value) may vary.
01513 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
01514 *                                   ted matrix A, M_A >= 0.
01515 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
01516 *                                   buted matrix A, N_A >= 0.
01517 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
01518 *                                   block of the matrix A, IMB_A > 0.
01519 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
01520 *                                   left   block   of   the   matrix  A,
01521 *                                   INB_A > 0.
01522 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
01523 *                                   bute the last  M_A-IMB_A rows of  A,
01524 *                                   MB_A > 0.
01525 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
01526 *                                   bute the last  N_A-INB_A  columns of
01527 *                                   A, NB_A > 0.
01528 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
01529 *                                   row of the matrix  A is distributed,
01530 *                                   NPROW > RSRC_A >= 0.
01531 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
01532 *                                   first  column of  A  is distributed.
01533 *                                   NPCOL > CSRC_A >= 0.
01534 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
01535 *                                   array  storing  the  local blocks of
01536 *                                   the distributed matrix A,
01537 *                                   IF( Lc( 1, N_A ) > 0 )
01538 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
01539 *                                   ELSE
01540 *                                      LLD_A >= 1.
01541 *
01542 *  Let K be the number of  rows of a matrix A starting at the global in-
01543 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
01544 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
01545 *  receive if these K rows were distributed over NPROW processes.  If  K
01546 *  is the number of columns of a matrix  A  starting at the global index
01547 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
01548 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
01549 *  these K columns were distributed over NPCOL processes.
01550 *
01551 *  The values of Lr() and Lc() may be determined via a call to the func-
01552 *  tion PB_NUMROC:
01553 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
01554 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
01555 *
01556 *  Arguments
01557 *  =========
01558 *
01559 *  ICTXT   (local input) INTEGER
01560 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
01561 *          ting the global  context of the operation. The context itself
01562 *          is global, but the value of ICTXT is local.
01563 *
01564 *  -- Written on April 1, 1998 by
01565 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
01566 *
01567 *  =====================================================================
01568 *
01569 *     .. Parameters ..
01570       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
01571      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
01572      $                   RSRC_
01573       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
01574      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
01575      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
01576      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
01577       DOUBLE PRECISION   ONE
01578       PARAMETER          ( ONE = 1.0D+0 )
01579 *     ..
01580 *     .. External Subroutines ..
01581       EXTERNAL           PB_DESCSET2
01582 *     ..
01583 *     .. Common Blocks ..
01584       CHARACTER*1        DIAG, SIDE, TRANSA, TRANSB, UPLO
01585       INTEGER            IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB,
01586      $                   JC, JX, JY, KDIM, MDIM, NDIM
01587       DOUBLE PRECISION   USCLR, SCLR
01588       INTEGER            DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
01589      $                   DESCX( DLEN_ ), DESCY( DLEN_ )
01590       DOUBLE PRECISION   A( 2, 2 ), B( 2, 2 ), C( 2, 2 ), X( 2 ), Y( 2 )
01591       COMMON             /PBLASC/DIAG, SIDE, TRANSA, TRANSB, UPLO
01592       COMMON             /PBLASD/DESCA, DESCB, DESCC, DESCX, DESCY
01593       COMMON             /PBLASI/IA, IB, IC, INCX, INCY, ISCLR, IX, IY,
01594      $                   JA, JB, JC, JX, JY
01595       COMMON             /PBLASM/A, B, C
01596       COMMON             /PBLASN/KDIM, MDIM, NDIM
01597       COMMON             /PBLASS/SCLR, USCLR
01598       COMMON             /PBLASV/X, Y
01599 *     ..
01600 *     .. Executable Statements ..
01601 *
01602 *     Set default values for options
01603 *
01604       DIAG   = 'N'
01605       SIDE   = 'L'
01606       TRANSA = 'N'
01607       TRANSB = 'N'
01608       UPLO   = 'U'
01609 *
01610 *     Set default values for scalars
01611 *
01612       KDIM   = 1
01613       MDIM   = 1
01614       NDIM   = 1
01615       ISCLR  = 1
01616       SCLR   = ONE
01617       USCLR  = ONE
01618 *
01619 *     Set default values for distributed matrix A
01620 *
01621       A( 1, 1 ) = ONE
01622       A( 2, 1 ) = ONE
01623       A( 1, 2 ) = ONE
01624       A( 2, 2 ) = ONE
01625       IA = 1
01626       JA = 1
01627       CALL PB_DESCSET2( DESCA, 2, 2, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
01628 *
01629 *     Set default values for distributed matrix B
01630 *
01631       B( 1, 1 ) = ONE
01632       B( 2, 1 ) = ONE
01633       B( 1, 2 ) = ONE
01634       B( 2, 2 ) = ONE
01635       IB = 1
01636       JB = 1
01637       CALL PB_DESCSET2( DESCB, 2, 2, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
01638 *
01639 *     Set default values for distributed matrix C
01640 *
01641       C( 1, 1 ) = ONE
01642       C( 2, 1 ) = ONE
01643       C( 1, 2 ) = ONE
01644       C( 2, 2 ) = ONE
01645       IC = 1
01646       JC = 1
01647       CALL PB_DESCSET2( DESCC, 2, 2, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
01648 *
01649 *     Set default values for distributed matrix X
01650 *
01651       X( 1 ) = ONE
01652       X( 2 ) = ONE
01653       IX = 1
01654       JX = 1
01655       CALL PB_DESCSET2( DESCX, 2, 1, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
01656       INCX = 1
01657 *
01658 *     Set default values for distributed matrix Y
01659 *
01660       Y( 1 ) = ONE
01661       Y( 2 ) = ONE
01662       IY = 1
01663       JY = 1
01664       CALL PB_DESCSET2( DESCY, 2, 1, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
01665       INCY = 1
01666 *
01667       RETURN
01668 *
01669 *     End of PDSETPBLAS
01670 *
01671       END
01672       SUBROUTINE PDCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, ARGNAM,
01673      $                     ARGPOS )
01674 *
01675 *  -- PBLAS test routine (version 2.0) --
01676 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
01677 *     and University of California, Berkeley.
01678 *     April 1, 1998
01679 *
01680 *     .. Scalar Arguments ..
01681       CHARACTER*1         ARGNAM
01682       INTEGER             ARGPOS, ICTXT, NOUT, SCODE
01683 *     ..
01684 *     .. Array Arguments ..
01685       CHARACTER*(*)       SNAME
01686 *     ..
01687 *     .. Subroutine Arguments ..
01688       EXTERNAL            SUBPTR
01689 *     ..
01690 *
01691 *  Purpose
01692 *  =======
01693 *
01694 *  PDCHKMAT tests the matrix (or vector) ARGNAM in any PBLAS routine.
01695 *
01696 *  Notes
01697 *  =====
01698 *
01699 *  A description  vector  is associated with each 2D block-cyclicly dis-
01700 *  tributed matrix.  This  vector  stores  the  information  required to
01701 *  establish the  mapping  between a  matrix entry and its corresponding
01702 *  process and memory location.
01703 *
01704 *  In  the  following  comments,   the character _  should  be  read  as
01705 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
01706 *  block cyclicly distributed matrix.  Its description vector is DESCA:
01707 *
01708 *  NOTATION         STORED IN       EXPLANATION
01709 *  ---------------- --------------- ------------------------------------
01710 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
01711 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
01712 *                                   the NPROW x NPCOL BLACS process grid
01713 *                                   A  is distributed over.  The context
01714 *                                   itself  is  global,  but  the handle
01715 *                                   (the integer value) may vary.
01716 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
01717 *                                   ted matrix A, M_A >= 0.
01718 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
01719 *                                   buted matrix A, N_A >= 0.
01720 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
01721 *                                   block of the matrix A, IMB_A > 0.
01722 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
01723 *                                   left   block   of   the   matrix  A,
01724 *                                   INB_A > 0.
01725 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
01726 *                                   bute the last  M_A-IMB_A rows of  A,
01727 *                                   MB_A > 0.
01728 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
01729 *                                   bute the last  N_A-INB_A  columns of
01730 *                                   A, NB_A > 0.
01731 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
01732 *                                   row of the matrix  A is distributed,
01733 *                                   NPROW > RSRC_A >= 0.
01734 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
01735 *                                   first  column of  A  is distributed.
01736 *                                   NPCOL > CSRC_A >= 0.
01737 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
01738 *                                   array  storing  the  local blocks of
01739 *                                   the distributed matrix A,
01740 *                                   IF( Lc( 1, N_A ) > 0 )
01741 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
01742 *                                   ELSE
01743 *                                      LLD_A >= 1.
01744 *
01745 *  Let K be the number of  rows of a matrix A starting at the global in-
01746 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
01747 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
01748 *  receive if these K rows were distributed over NPROW processes.  If  K
01749 *  is the number of columns of a matrix  A  starting at the global index
01750 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
01751 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
01752 *  these K columns were distributed over NPCOL processes.
01753 *
01754 *  The values of Lr() and Lc() may be determined via a call to the func-
01755 *  tion PB_NUMROC:
01756 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
01757 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
01758 *
01759 *  Arguments
01760 *  =========
01761 *
01762 *  ICTXT   (local input) INTEGER
01763 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
01764 *          ting the global  context of the operation. The context itself
01765 *          is global, but the value of ICTXT is local.
01766 *
01767 *  NOUT    (global input) INTEGER
01768 *          On entry, NOUT specifies the unit number for the output file.
01769 *          When NOUT is 6, output to screen,  when  NOUT is 0, output to
01770 *          stderr. NOUT is only defined for process 0.
01771 *
01772 *  SUBPTR  (global input) SUBROUTINE
01773 *          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
01774 *          EXTERNAL in the calling subroutine.
01775 *
01776 *  SCODE   (global input) INTEGER
01777 *          On entry, SCODE specifies the calling sequence code.
01778 *
01779 *  SNAME   (global input) CHARACTER*(*)
01780 *          On entry,  SNAME  specifies  the subroutine name calling this
01781 *          subprogram.
01782 *
01783 *  ARGNAM  (global input) CHARACTER*(*)
01784 *          On entry,  ARGNAM  specifies the name of the matrix or vector
01785 *          to be checked.  ARGNAM can either be 'A', 'B' or 'C' when one
01786 *          wants to check a matrix, and 'X' or 'Y' for a vector.
01787 *
01788 *  ARGPOS  (global input) INTEGER
01789 *          On entry, ARGPOS indicates the position of the first argument
01790 *          of the matrix (or vector) ARGNAM.
01791 *
01792 *  -- Written on April 1, 1998 by
01793 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
01794 *
01795 *  =====================================================================
01796 *
01797 *     .. Parameters ..
01798       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
01799      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
01800      $                   RSRC_
01801       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
01802      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
01803      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
01804      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
01805       INTEGER             DESCMULT
01806       PARAMETER           ( DESCMULT = 100 )
01807 *     ..
01808 *     .. Local Scalars ..
01809       INTEGER             I, INFOT, NPROW, NPCOL, MYROW, MYCOL
01810 *     ..
01811 *     .. External Subroutines ..
01812       EXTERNAL           BLACS_GRIDINFO, PCHKPBE, PDCALLSUB, PDSETPBLAS
01813 *     ..
01814 *     .. External Functions ..
01815       LOGICAL             LSAME
01816       EXTERNAL            LSAME
01817 *     ..
01818 *     .. Common Blocks ..
01819       INTEGER            IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB,
01820      $                   JC, JX, JY
01821       INTEGER            DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
01822      $                   DESCX( DLEN_ ), DESCY( DLEN_ )
01823       COMMON             /PBLASD/DESCA, DESCB, DESCC, DESCX, DESCY
01824       COMMON             /PBLASI/IA, IB, IC, INCX, INCY, ISCLR, IX, IY,
01825      $                   JA, JB, JC, JX, JY
01826 *     ..
01827 *     .. Executable Statements ..
01828 *
01829       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
01830 *
01831       IF( LSAME( ARGNAM, 'A' ) ) THEN
01832 *
01833 *        Check IA. Set all other OK, bad IA
01834 *
01835          CALL PDSETPBLAS( ICTXT )
01836          IA    = -1
01837          INFOT = ARGPOS + 1
01838          CALL PDCALLSUB( SUBPTR, SCODE )
01839          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01840 *
01841 *        Check JA. Set all other OK, bad JA
01842 *
01843          CALL PDSETPBLAS( ICTXT )
01844          JA    = -1
01845          INFOT = ARGPOS + 2
01846          CALL PDCALLSUB( SUBPTR, SCODE )
01847          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01848 *
01849 *        Check DESCA. Set all other OK, bad DESCA
01850 *
01851          DO 10 I = 1, DLEN_
01852 *
01853 *           Set I'th entry of DESCA to incorrect value, rest ok.
01854 *
01855             CALL PDSETPBLAS( ICTXT )
01856             DESCA( I ) =  -2
01857             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
01858             CALL PDCALLSUB( SUBPTR, SCODE )
01859             CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01860 *
01861 *           Extra tests for RSRCA, CSRCA, LDA
01862 *
01863             IF( ( I.EQ.RSRC_ ) .OR. ( I.EQ.CSRC_ ) .OR.
01864      $          ( I.EQ.LLD_ ) ) THEN
01865 *
01866                CALL PDSETPBLAS( ICTXT )
01867 *
01868 *              Test RSRCA >= NPROW
01869 *
01870                IF( I.EQ.RSRC_ )
01871      $            DESCA( I ) =  NPROW
01872 *
01873 *              Test CSRCA >= NPCOL
01874 *
01875                IF( I.EQ.CSRC_ )
01876      $            DESCA( I ) =  NPCOL
01877 *
01878 *              Test LDA >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
01879 *
01880                IF( I.EQ.LLD_ ) THEN
01881                   IF( MYROW.EQ.0 .AND.MYCOL.EQ.0 ) THEN
01882                      DESCA( I ) = 1
01883                   ELSE
01884                      DESCA( I ) = 0
01885                   END IF
01886                END IF
01887 *
01888                INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
01889                CALL PDCALLSUB( SUBPTR, SCODE )
01890                CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01891 *
01892             END IF
01893 *
01894    10    CONTINUE
01895 *
01896       ELSE IF( LSAME( ARGNAM, 'B' ) ) THEN
01897 *
01898 *        Check IB. Set all other OK, bad IB
01899 *
01900          CALL PDSETPBLAS( ICTXT )
01901          IB    = -1
01902          INFOT = ARGPOS + 1
01903          CALL PDCALLSUB( SUBPTR, SCODE )
01904          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01905 *
01906 *        Check JB. Set all other OK, bad JB
01907 *
01908          CALL PDSETPBLAS( ICTXT )
01909          JB    = -1
01910          INFOT = ARGPOS + 2
01911          CALL PDCALLSUB( SUBPTR, SCODE )
01912          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01913 *
01914 *        Check DESCB. Set all other OK, bad DESCB
01915 *
01916          DO 20 I = 1, DLEN_
01917 *
01918 *           Set I'th entry of DESCB to incorrect value, rest ok.
01919 *
01920             CALL PDSETPBLAS( ICTXT )
01921             DESCB( I ) =  -2
01922             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
01923             CALL PDCALLSUB( SUBPTR, SCODE )
01924             CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01925 *
01926 *           Extra tests for RSRCB, CSRCB, LDB
01927 *
01928             IF( ( I.EQ.RSRC_ ) .OR. ( I.EQ.CSRC_ ) .OR.
01929      $          ( I.EQ.LLD_ ) ) THEN
01930 *
01931                CALL PDSETPBLAS( ICTXT )
01932 *
01933 *              Test RSRCB >= NPROW
01934 *
01935                IF( I.EQ.RSRC_ )
01936      $            DESCB( I ) =  NPROW
01937 *
01938 *              Test CSRCB >= NPCOL
01939 *
01940                IF( I.EQ.CSRC_ )
01941      $            DESCB( I ) =  NPCOL
01942 *
01943 *              Test LDB >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
01944 *
01945                IF( I.EQ.LLD_ ) THEN
01946                   IF( MYROW.EQ.0 .AND.MYCOL.EQ.0 ) THEN
01947                      DESCB( I ) = 1
01948                   ELSE
01949                      DESCB( I ) = 0
01950                   END IF
01951                END IF
01952 *
01953                INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
01954                CALL PDCALLSUB( SUBPTR, SCODE )
01955                CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01956 *
01957             END IF
01958 *
01959    20    CONTINUE
01960 *
01961       ELSE IF( LSAME( ARGNAM, 'C' ) ) THEN
01962 *
01963 *        Check IC. Set all other OK, bad IC
01964 *
01965          CALL PDSETPBLAS( ICTXT )
01966          IC    = -1
01967          INFOT = ARGPOS + 1
01968          CALL PDCALLSUB( SUBPTR, SCODE )
01969          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01970 *
01971 *        Check JC. Set all other OK, bad JC
01972 *
01973          CALL PDSETPBLAS( ICTXT )
01974          JC    = -1
01975          INFOT = ARGPOS + 2
01976          CALL PDCALLSUB( SUBPTR, SCODE )
01977          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01978 *
01979 *        Check DESCC. Set all other OK, bad DESCC
01980 *
01981          DO 30 I = 1, DLEN_
01982 *
01983 *           Set I'th entry of DESCC to incorrect value, rest ok.
01984 *
01985             CALL PDSETPBLAS( ICTXT )
01986             DESCC( I ) =  -2
01987             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
01988             CALL PDCALLSUB( SUBPTR, SCODE )
01989             CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01990 *
01991 *           Extra tests for RSRCC, CSRCC, LDC
01992 *
01993             IF( ( I.EQ.RSRC_ ) .OR. ( I.EQ.CSRC_ ) .OR.
01994      $          ( I.EQ.LLD_ ) ) THEN
01995 *
01996                CALL PDSETPBLAS( ICTXT )
01997 *
01998 *              Test RSRCC >= NPROW
01999 *
02000                IF( I.EQ.RSRC_ )
02001      $            DESCC( I ) =  NPROW
02002 *
02003 *              Test CSRCC >= NPCOL
02004 *
02005                IF( I.EQ.CSRC_ )
02006      $            DESCC( I ) =  NPCOL
02007 *
02008 *              Test LDC >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
02009 *
02010                IF( I.EQ.LLD_ ) THEN
02011                   IF( MYROW.EQ.0 .AND.MYCOL.EQ.0 ) THEN
02012                      DESCC( I ) = 1
02013                   ELSE
02014                      DESCC( I ) = 0
02015                   END IF
02016                END IF
02017 *
02018                INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
02019                CALL PDCALLSUB( SUBPTR, SCODE )
02020                CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02021 *
02022             END IF
02023 *
02024    30    CONTINUE
02025 *
02026       ELSE IF( LSAME( ARGNAM, 'X' ) ) THEN
02027 *
02028 *        Check IX. Set all other OK, bad IX
02029 *
02030          CALL PDSETPBLAS( ICTXT )
02031          IX    = -1
02032          INFOT = ARGPOS + 1
02033          CALL PDCALLSUB( SUBPTR, SCODE )
02034          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02035 *
02036 *        Check JX. Set all other OK, bad JX
02037 *
02038          CALL PDSETPBLAS( ICTXT )
02039          JX    = -1
02040          INFOT = ARGPOS + 2
02041          CALL PDCALLSUB( SUBPTR, SCODE )
02042          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02043 *
02044 *        Check DESCX. Set all other OK, bad DESCX
02045 *
02046          DO 40 I = 1, DLEN_
02047 *
02048 *           Set I'th entry of DESCX to incorrect value, rest ok.
02049 *
02050             CALL PDSETPBLAS( ICTXT )
02051             DESCX( I ) =  -2
02052             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
02053             CALL PDCALLSUB( SUBPTR, SCODE )
02054             CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02055 *
02056 *           Extra tests for RSRCX, CSRCX, LDX
02057 *
02058             IF( ( I.EQ.RSRC_ ) .OR. ( I.EQ.CSRC_ ) .OR.
02059      $          ( I.EQ.LLD_ ) ) THEN
02060 *
02061                CALL PDSETPBLAS( ICTXT )
02062 *
02063 *              Test RSRCX >= NPROW
02064 *
02065                IF( I.EQ.RSRC_ )
02066      $            DESCX( I ) =  NPROW
02067 *
02068 *              Test CSRCX >= NPCOL
02069 *
02070                IF( I.EQ.CSRC_ )
02071      $            DESCX( I ) =  NPCOL
02072 *
02073 *              Test LDX >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
02074 *
02075                IF( I.EQ.LLD_ ) THEN
02076                   IF( MYROW.EQ.0 .AND.MYCOL.EQ.0 ) THEN
02077                      DESCX( I ) = 1
02078                   ELSE
02079                      DESCX( I ) = 0
02080                   END IF
02081                END IF
02082 *
02083                INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
02084                CALL PDCALLSUB( SUBPTR, SCODE )
02085                CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02086 *
02087             END IF
02088 *
02089    40    CONTINUE
02090 *
02091 *        Check INCX. Set all other OK, bad INCX
02092 *
02093          CALL PDSETPBLAS( ICTXT )
02094          INCX  =  -1
02095          INFOT = ARGPOS + 4
02096          CALL PDCALLSUB( SUBPTR, SCODE )
02097          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02098 *
02099       ELSE
02100 *
02101 *        Check IY. Set all other OK, bad IY
02102 *
02103          CALL PDSETPBLAS( ICTXT )
02104          IY    = -1
02105          INFOT = ARGPOS + 1
02106          CALL PDCALLSUB( SUBPTR, SCODE )
02107          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02108 *
02109 *        Check JY. Set all other OK, bad JY
02110 *
02111          CALL PDSETPBLAS( ICTXT )
02112          JY    = -1
02113          INFOT = ARGPOS + 2
02114          CALL PDCALLSUB( SUBPTR, SCODE )
02115          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02116 *
02117 *        Check DESCY. Set all other OK, bad DESCY
02118 *
02119          DO 50 I = 1, DLEN_
02120 *
02121 *           Set I'th entry of DESCY to incorrect value, rest ok.
02122 *
02123             CALL PDSETPBLAS( ICTXT )
02124             DESCY( I ) =  -2
02125             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
02126             CALL PDCALLSUB( SUBPTR, SCODE )
02127             CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02128 *
02129 *           Extra tests for RSRCY, CSRCY, LDY
02130 *
02131             IF( ( I.EQ.RSRC_ ) .OR. ( I.EQ.CSRC_ ) .OR.
02132      $          ( I.EQ.LLD_ ) ) THEN
02133 *
02134                CALL PDSETPBLAS( ICTXT )
02135 *
02136 *              Test RSRCY >= NPROW
02137 *
02138                IF( I.EQ.RSRC_ )
02139      $            DESCY( I ) = NPROW
02140 *
02141 *              Test CSRCY >= NPCOL
02142 *
02143                IF( I.EQ.CSRC_ )
02144      $            DESCY( I ) = NPCOL
02145 *
02146 *              Test LDY >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
02147 *
02148                IF( I.EQ.LLD_ ) THEN
02149                   IF( MYROW.EQ.0 .AND.MYCOL.EQ.0 ) THEN
02150                      DESCY( I ) = 1
02151                   ELSE
02152                      DESCY( I ) = 0
02153                   END IF
02154                END IF
02155 *
02156                INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
02157                CALL PDCALLSUB( SUBPTR, SCODE )
02158                CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02159 *
02160             END IF
02161 *
02162    50    CONTINUE
02163 *
02164 *        Check INCY. Set all other OK, bad INCY
02165 *
02166          CALL PDSETPBLAS( ICTXT )
02167          INCY =  -1
02168          INFOT = ARGPOS + 4
02169          CALL PDCALLSUB( SUBPTR, SCODE )
02170          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02171 *
02172       END IF
02173 *
02174       RETURN
02175 *
02176 *     End of PDCHKMAT
02177 *
02178       END
02179       SUBROUTINE PDCALLSUB( SUBPTR, SCODE )
02180 *
02181 *  -- PBLAS test routine (version 2.0) --
02182 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
02183 *     and University of California, Berkeley.
02184 *     April 1, 1998
02185 *
02186 *     .. Scalar Arguments ..
02187       INTEGER             SCODE
02188 *     ..
02189 *     .. Subroutine Arguments ..
02190       EXTERNAL            SUBPTR
02191 *     ..
02192 *
02193 *  Purpose
02194 *  =======
02195 *
02196 *  PDCALLSUB calls the subroutine SUBPTR with the calling sequence iden-
02197 *  tified by SCODE.
02198 *
02199 *  Notes
02200 *  =====
02201 *
02202 *  A description  vector  is associated with each 2D block-cyclicly dis-
02203 *  tributed matrix.  This  vector  stores  the  information  required to
02204 *  establish the  mapping  between a  matrix entry and its corresponding
02205 *  process and memory location.
02206 *
02207 *  In  the  following  comments,   the character _  should  be  read  as
02208 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
02209 *  block cyclicly distributed matrix.  Its description vector is DESCA:
02210 *
02211 *  NOTATION         STORED IN       EXPLANATION
02212 *  ---------------- --------------- ------------------------------------
02213 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
02214 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
02215 *                                   the NPROW x NPCOL BLACS process grid
02216 *                                   A  is distributed over.  The context
02217 *                                   itself  is  global,  but  the handle
02218 *                                   (the integer value) may vary.
02219 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
02220 *                                   ted matrix A, M_A >= 0.
02221 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
02222 *                                   buted matrix A, N_A >= 0.
02223 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
02224 *                                   block of the matrix A, IMB_A > 0.
02225 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
02226 *                                   left   block   of   the   matrix  A,
02227 *                                   INB_A > 0.
02228 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
02229 *                                   bute the last  M_A-IMB_A rows of  A,
02230 *                                   MB_A > 0.
02231 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
02232 *                                   bute the last  N_A-INB_A  columns of
02233 *                                   A, NB_A > 0.
02234 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
02235 *                                   row of the matrix  A is distributed,
02236 *                                   NPROW > RSRC_A >= 0.
02237 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
02238 *                                   first  column of  A  is distributed.
02239 *                                   NPCOL > CSRC_A >= 0.
02240 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
02241 *                                   array  storing  the  local blocks of
02242 *                                   the distributed matrix A,
02243 *                                   IF( Lc( 1, N_A ) > 0 )
02244 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
02245 *                                   ELSE
02246 *                                      LLD_A >= 1.
02247 *
02248 *  Let K be the number of  rows of a matrix A starting at the global in-
02249 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
02250 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
02251 *  receive if these K rows were distributed over NPROW processes.  If  K
02252 *  is the number of columns of a matrix  A  starting at the global index
02253 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
02254 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
02255 *  these K columns were distributed over NPCOL processes.
02256 *
02257 *  The values of Lr() and Lc() may be determined via a call to the func-
02258 *  tion PB_NUMROC:
02259 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
02260 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
02261 *
02262 *  Arguments
02263 *  =========
02264 *
02265 *  SUBPTR  (global input) SUBROUTINE
02266 *          On entry,  SUBPTR  is  a  subroutine. SUBPTR must be declared
02267 *          EXTERNAL in the calling subroutine.
02268 *
02269 *  SCODE   (global input) INTEGER
02270 *          On entry, SCODE specifies the calling sequence code.
02271 *
02272 *  Calling sequence encodings
02273 *  ==========================
02274 *
02275 *  code Formal argument list                                Examples
02276 *
02277 *  11   (n,      v1,v2)                                     _SWAP, _COPY
02278 *  12   (n,s1,   v1   )                                     _SCAL, _SCAL
02279 *  13   (n,s1,   v1,v2)                                     _AXPY, _DOT_
02280 *  14   (n,s1,i1,v1   )                                     _AMAX
02281 *  15   (n,u1,   v1   )                                     _ASUM, _NRM2
02282 *
02283 *  21   (     trans,     m,n,s1,m1,v1,s2,v2)                _GEMV
02284 *  22   (uplo,             n,s1,m1,v1,s2,v2)                _SYMV, _HEMV
02285 *  23   (uplo,trans,diag,  n,   m1,v1      )                _TRMV, _TRSV
02286 *  24   (                m,n,s1,v1,v2,m1)                   _GER_
02287 *  25   (uplo,             n,s1,v1,   m1)                   _SYR
02288 *  26   (uplo,             n,u1,v1,   m1)                   _HER
02289 *  27   (uplo,             n,s1,v1,v2,m1)                   _SYR2, _HER2
02290 *
02291 *  31   (          transa,transb,     m,n,k,s1,m1,m2,s2,m3) _GEMM
02292 *  32   (side,uplo,                   m,n,  s1,m1,m2,s2,m3) _SYMM, _HEMM
02293 *  33   (     uplo,trans,               n,k,s1,m1,   s2,m3) _SYRK
02294 *  34   (     uplo,trans,               n,k,u1,m1,   u2,m3) _HERK
02295 *  35   (     uplo,trans,               n,k,s1,m1,m2,s2,m3) _SYR2K
02296 *  36   (     uplo,trans,               n,k,s1,m1,m2,u2,m3) _HER2K
02297 *  37   (                             m,n,  s1,m1,   s2,m3) _TRAN_
02298 *  38   (side,uplo,transa,       diag,m,n,  s1,m1,m2      ) _TRMM, _TRSM
02299 *  39   (          trans,             m,n,  s1,m1,   s2,m3) _GEADD
02300 *  40   (     uplo,trans,             m,n,  s1,m1,   s2,m3) _TRADD
02301 *
02302 *  -- Written on April 1, 1998 by
02303 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
02304 *
02305 *  =====================================================================
02306 *
02307 *     .. Parameters ..
02308       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
02309      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
02310      $                   RSRC_
02311       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
02312      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
02313      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
02314      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
02315 *     ..
02316 *     .. Common Blocks ..
02317       CHARACTER*1        DIAG, SIDE, TRANSA, TRANSB, UPLO
02318       INTEGER            IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB,
02319      $                   JC, JX, JY, KDIM, MDIM, NDIM
02320       DOUBLE PRECISION   USCLR, SCLR
02321       INTEGER            DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
02322      $                   DESCX( DLEN_ ), DESCY( DLEN_ )
02323       DOUBLE PRECISION   A( 2, 2 ), B( 2, 2 ), C( 2, 2 ), X( 2 ), Y( 2 )
02324       COMMON             /PBLASC/DIAG, SIDE, TRANSA, TRANSB, UPLO
02325       COMMON             /PBLASD/DESCA, DESCB, DESCC, DESCX, DESCY
02326       COMMON             /PBLASI/IA, IB, IC, INCX, INCY, ISCLR, IX, IY,
02327      $                   JA, JB, JC, JX, JY
02328       COMMON             /PBLASM/A, B, C
02329       COMMON             /PBLASN/KDIM, MDIM, NDIM
02330       COMMON             /PBLASS/SCLR, USCLR
02331       COMMON             /PBLASV/X, Y
02332 *     ..
02333 *     .. Executable Statements ..
02334 *
02335 *     Level 1 PBLAS
02336 *
02337       IF( SCODE.EQ.11 ) THEN
02338 *
02339          CALL SUBPTR( NDIM, X, IX, JX, DESCX, INCX, Y, IY, JY, DESCY,
02340      $                INCY )
02341 *
02342       ELSE IF( SCODE.EQ.12 ) THEN
02343 *
02344          CALL SUBPTR( NDIM, SCLR, X, IX, JX, DESCX, INCX )
02345 *
02346       ELSE IF( SCODE.EQ.13 ) THEN
02347 *
02348          CALL SUBPTR( NDIM, SCLR, X, IX, JX, DESCX, INCX, Y, IY, JY,
02349      $                DESCY, INCY )
02350 *
02351       ELSE IF( SCODE.EQ.14 ) THEN
02352 *
02353          CALL SUBPTR( NDIM, SCLR, ISCLR, X, IX, JX, DESCX, INCX )
02354 *
02355       ELSE IF( SCODE.EQ.15 ) THEN
02356 *
02357          CALL SUBPTR( NDIM, USCLR, X, IX, JX, DESCX, INCX )
02358 *
02359 *     Level 2 PBLAS
02360 *
02361       ELSE IF( SCODE.EQ.21 ) THEN
02362 *
02363          CALL SUBPTR( TRANSA, MDIM, NDIM, SCLR, A, IA, JA, DESCA, X, IX,
02364      $                JX, DESCX, INCX, SCLR, Y, IY, JY, DESCY, INCY )
02365 *
02366       ELSE IF( SCODE.EQ.22 ) THEN
02367 *
02368          CALL SUBPTR( UPLO, NDIM, SCLR, A, IA, JA, DESCA, X, IX, JX,
02369      $                DESCX, INCX, SCLR, Y, IY, JY, DESCY, INCY )
02370 *
02371       ELSE IF( SCODE.EQ.23 ) THEN
02372 *
02373          CALL SUBPTR( UPLO, TRANSA, DIAG, NDIM, A, IA, JA, DESCA, X, IX,
02374      $                JX, DESCX, INCX )
02375 *
02376       ELSE IF( SCODE.EQ.24 ) THEN
02377 *
02378          CALL SUBPTR( MDIM, NDIM, SCLR, X, IX, JX, DESCX, INCX, Y, IY,
02379      $                JY, DESCY, INCY, A, IA, JA, DESCA )
02380 *
02381       ELSE IF( SCODE.EQ.25 ) THEN
02382 *
02383          CALL SUBPTR( UPLO, NDIM, SCLR, X, IX, JX, DESCX, INCX, A, IA,
02384      $                JA, DESCA )
02385 *
02386       ELSE IF( SCODE.EQ.26 ) THEN
02387 *
02388          CALL SUBPTR( UPLO, NDIM, USCLR, X, IX, JX, DESCX, INCX, A, IA,
02389      $                JA, DESCA )
02390 *
02391       ELSE IF( SCODE.EQ.27 ) THEN
02392 *
02393          CALL SUBPTR( UPLO, NDIM, SCLR, X, IX, JX, DESCX, INCX, Y, IY,
02394      $                JY, DESCY, INCY, A, IA, JA, DESCA )
02395 *
02396 *     Level 3 PBLAS
02397 *
02398       ELSE IF( SCODE.EQ.31 ) THEN
02399 *
02400          CALL SUBPTR( TRANSA, TRANSB, MDIM, NDIM, KDIM, SCLR, A, IA, JA,
02401      $                DESCA, B, IB, JB, DESCB, SCLR, C, IC, JC, DESCC )
02402 *
02403       ELSE IF( SCODE.EQ.32 ) THEN
02404 *
02405          CALL SUBPTR( SIDE, UPLO, MDIM, NDIM, SCLR, A, IA, JA, DESCA, B,
02406      $                IB, JB, DESCB, SCLR, C, IC, JC, DESCC )
02407 *
02408       ELSE IF( SCODE.EQ.33 ) THEN
02409 *
02410          CALL SUBPTR( UPLO, TRANSA, NDIM, KDIM, SCLR, A, IA, JA, DESCA,
02411      $                SCLR, C, IC, JC, DESCC )
02412 *
02413       ELSE IF( SCODE.EQ.34 ) THEN
02414 *
02415          CALL SUBPTR( UPLO, TRANSA, NDIM, KDIM, USCLR, A, IA, JA, DESCA,
02416      $                USCLR, C, IC, JC, DESCC )
02417 *
02418       ELSE IF( SCODE.EQ.35 ) THEN
02419 *
02420          CALL SUBPTR( UPLO, TRANSA, NDIM, KDIM, SCLR, A, IA, JA, DESCA,
02421      $                B, IB, JB, DESCB, SCLR, C, IC, JC, DESCC )
02422 *
02423       ELSE IF( SCODE.EQ.36 ) THEN
02424 *
02425          CALL SUBPTR( UPLO, TRANSA, NDIM, KDIM, SCLR, A, IA, JA, DESCA,
02426      $                B, IB, JB, DESCB, USCLR, C, IC, JC, DESCC )
02427 *
02428       ELSE IF( SCODE.EQ.37 ) THEN
02429 *
02430          CALL SUBPTR( MDIM, NDIM, SCLR, A, IA, JA, DESCA, SCLR, C, IC,
02431      $                JC, DESCC )
02432 *
02433       ELSE IF( SCODE.EQ.38 ) THEN
02434 *
02435          CALL SUBPTR( SIDE, UPLO, TRANSA, DIAG, MDIM, NDIM, SCLR, A, IA,
02436      $                JA, DESCA, B, IB, JB, DESCB )
02437 *
02438       ELSE IF( SCODE.EQ.39 ) THEN
02439 *
02440          CALL SUBPTR( TRANSA, MDIM, NDIM, SCLR, A, IA, JA, DESCA, SCLR,
02441      $                C, IC, JC, DESCC )
02442 *
02443       ELSE IF( SCODE.EQ.40 ) THEN
02444 *
02445          CALL SUBPTR( UPLO, TRANSA, MDIM, NDIM, SCLR, A, IA, JA, DESCA,
02446      $                SCLR, C, IC, JC, DESCC )
02447 *
02448       END IF
02449 *
02450       RETURN
02451 *
02452 *     End of PDCALLSUB
02453 *
02454       END
02455       SUBROUTINE PDERRSET( ERR, ERRMAX, XTRUE, X )
02456 *
02457 *  -- PBLAS test routine (version 2.0) --
02458 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
02459 *     and University of California, Berkeley.
02460 *     April 1, 1998
02461 *
02462 *     .. Scalar Arguments ..
02463       DOUBLE PRECISION   ERR, ERRMAX, X, XTRUE
02464 *     ..
02465 *
02466 *  Purpose
02467 *  =======
02468 *
02469 *  PDERRSET  computes the absolute difference ERR = |XTRUE - X| and com-
02470 *  pares it with zero. ERRMAX accumulates the absolute error difference.
02471 *
02472 *  Notes
02473 *  =====
02474 *
02475 *  A description  vector  is associated with each 2D block-cyclicly dis-
02476 *  tributed matrix.  This  vector  stores  the  information  required to
02477 *  establish the  mapping  between a  matrix entry and its corresponding
02478 *  process and memory location.
02479 *
02480 *  In  the  following  comments,   the character _  should  be  read  as
02481 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
02482 *  block cyclicly distributed matrix.  Its description vector is DESCA:
02483 *
02484 *  NOTATION         STORED IN       EXPLANATION
02485 *  ---------------- --------------- ------------------------------------
02486 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
02487 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
02488 *                                   the NPROW x NPCOL BLACS process grid
02489 *                                   A  is distributed over.  The context
02490 *                                   itself  is  global,  but  the handle
02491 *                                   (the integer value) may vary.
02492 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
02493 *                                   ted matrix A, M_A >= 0.
02494 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
02495 *                                   buted matrix A, N_A >= 0.
02496 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
02497 *                                   block of the matrix A, IMB_A > 0.
02498 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
02499 *                                   left   block   of   the   matrix  A,
02500 *                                   INB_A > 0.
02501 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
02502 *                                   bute the last  M_A-IMB_A rows of  A,
02503 *                                   MB_A > 0.
02504 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
02505 *                                   bute the last  N_A-INB_A  columns of
02506 *                                   A, NB_A > 0.
02507 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
02508 *                                   row of the matrix  A is distributed,
02509 *                                   NPROW > RSRC_A >= 0.
02510 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
02511 *                                   first  column of  A  is distributed.
02512 *                                   NPCOL > CSRC_A >= 0.
02513 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
02514 *                                   array  storing  the  local blocks of
02515 *                                   the distributed matrix A,
02516 *                                   IF( Lc( 1, N_A ) > 0 )
02517 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
02518 *                                   ELSE
02519 *                                      LLD_A >= 1.
02520 *
02521 *  Let K be the number of  rows of a matrix A starting at the global in-
02522 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
02523 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
02524 *  receive if these K rows were distributed over NPROW processes.  If  K
02525 *  is the number of columns of a matrix  A  starting at the global index
02526 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
02527 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
02528 *  these K columns were distributed over NPCOL processes.
02529 *
02530 *  The values of Lr() and Lc() may be determined via a call to the func-
02531 *  tion PB_NUMROC:
02532 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
02533 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
02534 *
02535 *  Arguments
02536 *  =========
02537 *
02538 *  ERR     (local output) DOUBLE PRECISION
02539 *          On exit, ERR specifies the absolute difference |XTRUE - X|.
02540 *
02541 *  ERRMAX  (local input/local output) DOUBLE PRECISION
02542 *          On entry,  ERRMAX  specifies  a previously computed error. On
02543 *          exit ERRMAX is the accumulated error MAX( ERRMAX, ERR ).
02544 *
02545 *  XTRUE   (local input) DOUBLE PRECISION
02546 *          On entry, XTRUE specifies the true value.
02547 *
02548 *  X       (local input) DOUBLE PRECISION
02549 *          On entry, X specifies the value to be compared to XTRUE.
02550 *
02551 *  -- Written on April 1, 1998 by
02552 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
02553 *
02554 *  =====================================================================
02555 *
02556 *     .. External Functions ..
02557       DOUBLE PRECISION   PDDIFF
02558       EXTERNAL           PDDIFF
02559 *     ..
02560 *     .. Intrinsic Functions ..
02561       INTRINSIC          ABS, MAX
02562 *     ..
02563 *     .. Executable Statements ..
02564 *
02565       ERR = ABS( PDDIFF( XTRUE, X ) )
02566 *
02567       ERRMAX = MAX( ERRMAX, ERR )
02568 *
02569       RETURN
02570 *
02571 *     End of PDERRSET
02572 *
02573       END
02574       SUBROUTINE PDCHKVIN( ERRMAX, N, X, PX, IX, JX, DESCX, INCX,
02575      $                     INFO )
02576 *
02577 *  -- PBLAS test routine (version 2.0) --
02578 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
02579 *     and University of California, Berkeley.
02580 *     April 1, 1998
02581 *
02582 *     .. Scalar Arguments ..
02583       INTEGER            INCX, INFO, IX, JX, N
02584       DOUBLE PRECISION   ERRMAX
02585 *     ..
02586 *     .. Array Arguments ..
02587       INTEGER            DESCX( * )
02588       DOUBLE PRECISION   PX( * ), X( * )
02589 *     ..
02590 *
02591 *  Purpose
02592 *  =======
02593 *
02594 *  PDCHKVIN  checks that the submatrix sub( PX ) remained unchanged. The
02595 *  local  array  entries are compared element by element, and their dif-
02596 *  ference  is tested against 0.0 as well as the epsilon machine. Notice
02597 *  that  this difference should be numerically exactly the zero machine,
02598 *  but  because of the possible fluctuation of some of the data we flag-
02599 *  ged differently a difference less than twice the epsilon machine. The
02600 *  largest error is also returned.
02601 *
02602 *  Notes
02603 *  =====
02604 *
02605 *  A description  vector  is associated with each 2D block-cyclicly dis-
02606 *  tributed matrix.  This  vector  stores  the  information  required to
02607 *  establish the  mapping  between a  matrix entry and its corresponding
02608 *  process and memory location.
02609 *
02610 *  In  the  following  comments,   the character _  should  be  read  as
02611 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
02612 *  block cyclicly distributed matrix.  Its description vector is DESCA:
02613 *
02614 *  NOTATION         STORED IN       EXPLANATION
02615 *  ---------------- --------------- ------------------------------------
02616 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
02617 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
02618 *                                   the NPROW x NPCOL BLACS process grid
02619 *                                   A  is distributed over.  The context
02620 *                                   itself  is  global,  but  the handle
02621 *                                   (the integer value) may vary.
02622 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
02623 *                                   ted matrix A, M_A >= 0.
02624 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
02625 *                                   buted matrix A, N_A >= 0.
02626 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
02627 *                                   block of the matrix A, IMB_A > 0.
02628 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
02629 *                                   left   block   of   the   matrix  A,
02630 *                                   INB_A > 0.
02631 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
02632 *                                   bute the last  M_A-IMB_A rows of  A,
02633 *                                   MB_A > 0.
02634 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
02635 *                                   bute the last  N_A-INB_A  columns of
02636 *                                   A, NB_A > 0.
02637 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
02638 *                                   row of the matrix  A is distributed,
02639 *                                   NPROW > RSRC_A >= 0.
02640 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
02641 *                                   first  column of  A  is distributed.
02642 *                                   NPCOL > CSRC_A >= 0.
02643 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
02644 *                                   array  storing  the  local blocks of
02645 *                                   the distributed matrix A,
02646 *                                   IF( Lc( 1, N_A ) > 0 )
02647 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
02648 *                                   ELSE
02649 *                                      LLD_A >= 1.
02650 *
02651 *  Let K be the number of  rows of a matrix A starting at the global in-
02652 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
02653 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
02654 *  receive if these K rows were distributed over NPROW processes.  If  K
02655 *  is the number of columns of a matrix  A  starting at the global index
02656 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
02657 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
02658 *  these K columns were distributed over NPCOL processes.
02659 *
02660 *  The values of Lr() and Lc() may be determined via a call to the func-
02661 *  tion PB_NUMROC:
02662 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
02663 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
02664 *
02665 *  Arguments
02666 *  =========
02667 *
02668 *  ERRMAX  (global output) DOUBLE PRECISION
02669 *          On exit,  ERRMAX  specifies the largest absolute element-wise
02670 *          difference between sub( X ) and sub( PX ).
02671 *
02672 *  N       (global input) INTEGER
02673 *          On entry,  N  specifies  the  length of the subvector operand
02674 *          sub( X ). N must be at least zero.
02675 *
02676 *  X       (local input) DOUBLE PRECISION array
02677 *          On entry, X is an array of  dimension  (DESCX( M_ ),*).  This
02678 *          array contains a local copy of the initial entire matrix PX.
02679 *
02680 *  PX      (local input) DOUBLE PRECISION array
02681 *          On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
02682 *          array contains the local entries of the matrix PX.
02683 *
02684 *  IX      (global input) INTEGER
02685 *          On entry, IX  specifies X's global row index, which points to
02686 *          the beginning of the submatrix sub( X ).
02687 *
02688 *  JX      (global input) INTEGER
02689 *          On entry, JX  specifies X's global column index, which points
02690 *          to the beginning of the submatrix sub( X ).
02691 *
02692 *  DESCX   (global and local input) INTEGER array
02693 *          On entry, DESCX  is an integer array of dimension DLEN_. This
02694 *          is the array descriptor for the matrix X.
02695 *
02696 *  INCX    (global input) INTEGER
02697 *          On entry,  INCX   specifies  the  global  increment  for  the
02698 *          elements of  X.  Only two values of  INCX   are  supported in
02699 *          this version, namely 1 and M_X. INCX  must not be zero.
02700 *
02701 *  INFO    (global output) INTEGER
02702 *          On exit, if INFO = 0, no error has been found,
02703 *          If INFO > 0, the maximum abolute error found is in (0,eps],
02704 *          If INFO < 0, the maximum abolute error found is in (eps,+oo).
02705 *
02706 *  -- Written on April 1, 1998 by
02707 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
02708 *
02709 *  =====================================================================
02710 *
02711 *     .. Parameters ..
02712       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
02713      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
02714      $                   RSRC_
02715       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
02716      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
02717      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
02718      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
02719       DOUBLE PRECISION   ZERO
02720       PARAMETER          ( ZERO = 0.0D+0 )
02721 *     ..
02722 *     .. Local Scalars ..
02723       LOGICAL            COLREP, ROWREP
02724       INTEGER            I, IB, ICTXT, ICURCOL, ICURROW, IIX, IN, IXCOL,
02725      $                   IXROW, J, JB, JJX, JN, KK, LDPX, LDX, LL,
02726      $                   MYCOL, MYROW, NPCOL, NPROW
02727       DOUBLE PRECISION   ERR, EPS
02728 *     ..
02729 *     .. External Subroutines ..
02730       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, PB_INFOG2L, PDERRSET
02731 *     ..
02732 *     .. External Functions ..
02733       DOUBLE PRECISION   PDLAMCH
02734       EXTERNAL           PDLAMCH
02735 *     ..
02736 *     .. Intrinsic Functions ..
02737       INTRINSIC          ABS, MAX, MIN, MOD
02738 *     ..
02739 *     .. Executable Statements ..
02740 *
02741       INFO = 0
02742       ERRMAX = ZERO
02743 *
02744 *     Quick return if possible
02745 *
02746       IF( N.LE.0 )
02747      $   RETURN
02748 *
02749       ICTXT = DESCX( CTXT_ )
02750       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
02751 *
02752       EPS = PDLAMCH( ICTXT, 'eps' )
02753 *
02754       CALL PB_INFOG2L( IX, JX, DESCX, NPROW, NPCOL, MYROW, MYCOL, IIX,
02755      $                 JJX, IXROW, IXCOL )
02756 *
02757       LDX    = DESCX( M_ )
02758       LDPX   = DESCX( LLD_ )
02759       ROWREP = ( IXROW.EQ.-1 )
02760       COLREP = ( IXCOL.EQ.-1 )
02761 *
02762       IF( N.EQ.1 ) THEN
02763 *
02764          IF( ( MYROW.EQ.IXROW .OR. ROWREP ) .AND.
02765      $       ( MYCOL.EQ.IXCOL .OR. COLREP ) )
02766      $      CALL PDERRSET( ERR, ERRMAX, X( IX+(JX-1)*LDX ),
02767      $                     PX( IIX+(JJX-1)*LDPX ) )
02768 *
02769       ELSE IF( INCX.EQ.DESCX( M_ ) ) THEN
02770 *
02771 *        sub( X ) is a row vector
02772 *
02773          JB = DESCX( INB_ ) - JX + 1
02774          IF( JB.LE.0 )
02775      $      JB = ( ( -JB ) / DESCX( NB_ ) + 1 ) * DESCX( NB_ ) + JB
02776          JB = MIN( JB, N )
02777          JN = JX + JB - 1
02778 *
02779          IF( MYROW.EQ.IXROW .OR. ROWREP ) THEN
02780 *
02781             ICURCOL = IXCOL
02782             IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN
02783                DO 10 J = JX, JN
02784                   CALL PDERRSET( ERR, ERRMAX, X( IX+(J-1)*LDX ),
02785      $                           PX( IIX+(JJX-1)*LDPX ) )
02786                   JJX = JJX + 1
02787    10          CONTINUE
02788             END IF
02789             ICURCOL = MOD( ICURCOL+1, NPCOL )
02790 *
02791             DO 30 J = JN+1, JX+N-1, DESCX( NB_ )
02792                JB = MIN( JX+N-J, DESCX( NB_ ) )
02793 *
02794                IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN
02795 *
02796                   DO 20 KK = 0, JB-1
02797                      CALL PDERRSET( ERR, ERRMAX, X( IX+(J+KK-1)*LDX ),
02798      $                              PX( IIX+(JJX+KK-1)*LDPX ) )
02799    20             CONTINUE
02800 *
02801                   JJX = JJX + JB
02802 *
02803                END IF
02804 *
02805                ICURCOL = MOD( ICURCOL+1, NPCOL )
02806 *
02807    30       CONTINUE
02808 *
02809          END IF
02810 *
02811       ELSE
02812 *
02813 *        sub( X ) is a column vector
02814 *
02815          IB = DESCX( IMB_ ) - IX + 1
02816          IF( IB.LE.0 )
02817      $      IB = ( ( -IB ) / DESCX( MB_ ) + 1 ) * DESCX( MB_ ) + IB
02818          IB = MIN( IB, N )
02819          IN = IX + IB - 1
02820 *
02821          IF( MYCOL.EQ.IXCOL .OR. COLREP ) THEN
02822 *
02823             ICURROW = IXROW
02824             IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
02825                DO 40 I = IX, IN
02826                   CALL PDERRSET( ERR, ERRMAX, X( I+(JX-1)*LDX ),
02827      $                           PX( IIX+(JJX-1)*LDPX ) )
02828                   IIX = IIX + 1
02829    40          CONTINUE
02830             END IF
02831             ICURROW = MOD( ICURROW+1, NPROW )
02832 *
02833             DO 60 I = IN+1, IX+N-1, DESCX( MB_ )
02834                IB = MIN( IX+N-I, DESCX( MB_ ) )
02835 *
02836                IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
02837 *
02838                   DO 50 KK = 0, IB-1
02839                      CALL PDERRSET( ERR, ERRMAX, X( I+KK+(JX-1)*LDX ),
02840      $                              PX( IIX+KK+(JJX-1)*LDPX ) )
02841    50             CONTINUE
02842 *
02843                   IIX = IIX + IB
02844 *
02845                END IF
02846 *
02847                ICURROW = MOD( ICURROW+1, NPROW )
02848 *
02849    60       CONTINUE
02850 *
02851          END IF
02852 *
02853       END IF
02854 *
02855       CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERRMAX, 1, KK, LL, -1,
02856      $              -1, -1 )
02857 *
02858       IF( ERRMAX.GT.ZERO .AND. ERRMAX.LE.EPS ) THEN
02859          INFO = 1
02860       ELSE IF( ERRMAX.GT.EPS ) THEN
02861          INFO = -1
02862       END IF
02863 *
02864       RETURN
02865 *
02866 *     End of PDCHKVIN
02867 *
02868       END
02869       SUBROUTINE PDCHKVOUT( N, X, PX, IX, JX, DESCX, INCX, INFO )
02870 *
02871 *  -- PBLAS test routine (version 2.0) --
02872 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
02873 *     and University of California, Berkeley.
02874 *     April 1, 1998
02875 *
02876 *     .. Scalar Arguments ..
02877       INTEGER            INCX, INFO, IX, JX, N
02878 *     ..
02879 *     .. Array Arguments ..
02880       INTEGER            DESCX( * )
02881       DOUBLE PRECISION   PX( * ), X( * )
02882 *     ..
02883 *
02884 *  Purpose
02885 *  =======
02886 *
02887 *  PDCHKVOUT  checks  that the matrix PX \ sub( PX ) remained unchanged.
02888 *  The  local array  entries  are compared element by element, and their
02889 *  difference  is tested against 0.0 as well as the epsilon machine. No-
02890 *  tice that this  difference should be numerically exactly the zero ma-
02891 *  chine, but because  of  the  possible movement of some of the data we
02892 *  flagged differently a difference less than twice the epsilon machine.
02893 *  The largest error is reported.
02894 *
02895 *  Notes
02896 *  =====
02897 *
02898 *  A description  vector  is associated with each 2D block-cyclicly dis-
02899 *  tributed matrix.  This  vector  stores  the  information  required to
02900 *  establish the  mapping  between a  matrix entry and its corresponding
02901 *  process and memory location.
02902 *
02903 *  In  the  following  comments,   the character _  should  be  read  as
02904 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
02905 *  block cyclicly distributed matrix.  Its description vector is DESCA:
02906 *
02907 *  NOTATION         STORED IN       EXPLANATION
02908 *  ---------------- --------------- ------------------------------------
02909 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
02910 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
02911 *                                   the NPROW x NPCOL BLACS process grid
02912 *                                   A  is distributed over.  The context
02913 *                                   itself  is  global,  but  the handle
02914 *                                   (the integer value) may vary.
02915 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
02916 *                                   ted matrix A, M_A >= 0.
02917 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
02918 *                                   buted matrix A, N_A >= 0.
02919 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
02920 *                                   block of the matrix A, IMB_A > 0.
02921 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
02922 *                                   left   block   of   the   matrix  A,
02923 *                                   INB_A > 0.
02924 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
02925 *                                   bute the last  M_A-IMB_A rows of  A,
02926 *                                   MB_A > 0.
02927 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
02928 *                                   bute the last  N_A-INB_A  columns of
02929 *                                   A, NB_A > 0.
02930 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
02931 *                                   row of the matrix  A is distributed,
02932 *                                   NPROW > RSRC_A >= 0.
02933 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
02934 *                                   first  column of  A  is distributed.
02935 *                                   NPCOL > CSRC_A >= 0.
02936 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
02937 *                                   array  storing  the  local blocks of
02938 *                                   the distributed matrix A,
02939 *                                   IF( Lc( 1, N_A ) > 0 )
02940 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
02941 *                                   ELSE
02942 *                                      LLD_A >= 1.
02943 *
02944 *  Let K be the number of  rows of a matrix A starting at the global in-
02945 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
02946 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
02947 *  receive if these K rows were distributed over NPROW processes.  If  K
02948 *  is the number of columns of a matrix  A  starting at the global index
02949 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
02950 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
02951 *  these K columns were distributed over NPCOL processes.
02952 *
02953 *  The values of Lr() and Lc() may be determined via a call to the func-
02954 *  tion PB_NUMROC:
02955 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
02956 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
02957 *
02958 *  Arguments
02959 *  =========
02960 *
02961 *  N       (global input) INTEGER
02962 *          On entry,  N  specifies  the  length of the subvector operand
02963 *          sub( X ). N must be at least zero.
02964 *
02965 *  X       (local input) DOUBLE PRECISION array
02966 *          On entry, X is an array of  dimension  (DESCX( M_ ),*).  This
02967 *          array contains a local copy of the initial entire matrix PX.
02968 *
02969 *  PX      (local input) DOUBLE PRECISION array
02970 *          On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
02971 *          array contains the local entries of the matrix PX.
02972 *
02973 *  IX      (global input) INTEGER
02974 *          On entry, IX  specifies X's global row index, which points to
02975 *          the beginning of the submatrix sub( X ).
02976 *
02977 *  JX      (global input) INTEGER
02978 *          On entry, JX  specifies X's global column index, which points
02979 *          to the beginning of the submatrix sub( X ).
02980 *
02981 *  DESCX   (global and local input) INTEGER array
02982 *          On entry, DESCX  is an integer array of dimension DLEN_. This
02983 *          is the array descriptor for the matrix X.
02984 *
02985 *  INCX    (global input) INTEGER
02986 *          On entry,  INCX   specifies  the  global  increment  for  the
02987 *          elements of  X.  Only two values of  INCX   are  supported in
02988 *          this version, namely 1 and M_X. INCX  must not be zero.
02989 *
02990 *  INFO    (global output) INTEGER
02991 *          On exit, if INFO = 0, no error has been found,
02992 *          If INFO > 0, the maximum abolute error found is in (0,eps],
02993 *          If INFO < 0, the maximum abolute error found is in (eps,+oo).
02994 *
02995 *  -- Written on April 1, 1998 by
02996 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
02997 *
02998 *  =====================================================================
02999 *
03000 *     .. Parameters ..
03001       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
03002      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
03003      $                   RSRC_
03004       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
03005      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
03006      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
03007      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
03008       DOUBLE PRECISION   ZERO
03009       PARAMETER          ( ZERO = 0.0D+0 )
03010 *     ..
03011 *     .. Local Scalars ..
03012       LOGICAL            COLREP, ROWREP
03013       INTEGER            I, IB, ICTXT, ICURCOL, ICURROW, II, IMBX, INBX,
03014      $                   J, JB, JJ, KK, LDPX, LDX, LL, MBX, MPALL,
03015      $                   MYCOL, MYCOLDIST, MYROW, MYROWDIST, NBX, NPCOL,
03016      $                   NPROW, NQALL
03017       DOUBLE PRECISION   EPS, ERR, ERRMAX
03018 *     ..
03019 *     .. External Subroutines ..
03020       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, PDERRSET
03021 *     ..
03022 *     .. External Functions ..
03023       INTEGER            PB_NUMROC
03024       DOUBLE PRECISION   PDLAMCH
03025       EXTERNAL           PDLAMCH, PB_NUMROC
03026 *     ..
03027 *     .. Intrinsic Functions ..
03028       INTRINSIC          ABS, MAX, MIN, MOD
03029 *     ..
03030 *     .. Executable Statements ..
03031 *
03032       INFO = 0
03033       ERRMAX = ZERO
03034 *
03035 *     Quick return if possible
03036 *
03037       IF( ( DESCX( M_ ).LE.0 ).OR.( DESCX( N_ ).LE.0 ) )
03038      $   RETURN
03039 *
03040 *     Start the operations
03041 *
03042       ICTXT = DESCX( CTXT_ )
03043       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
03044 *
03045       EPS = PDLAMCH( ICTXT, 'eps' )
03046 *
03047       MPALL   = PB_NUMROC( DESCX( M_ ), 1, DESCX( IMB_ ), DESCX( MB_ ),
03048      $                     MYROW, DESCX( RSRC_ ), NPROW )
03049       NQALL   = PB_NUMROC( DESCX( N_ ), 1, DESCX( INB_ ), DESCX( NB_ ),
03050      $                     MYCOL, DESCX( CSRC_ ), NPCOL )
03051 *
03052       MBX     = DESCX( MB_ )
03053       NBX     = DESCX( NB_ )
03054       LDX     = DESCX( M_ )
03055       LDPX    = DESCX( LLD_ )
03056       ICURROW = DESCX( RSRC_ )
03057       ICURCOL = DESCX( CSRC_ )
03058       ROWREP  = ( ICURROW.EQ.-1 )
03059       COLREP  = ( ICURCOL.EQ.-1 )
03060       IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
03061          IMBX = DESCX( IMB_ )
03062       ELSE
03063          IMBX = MBX
03064       END IF
03065       IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN
03066          INBX = DESCX( INB_ )
03067       ELSE
03068          INBX = NBX
03069       END IF
03070       IF( ROWREP ) THEN
03071          MYROWDIST = 0
03072       ELSE
03073          MYROWDIST = MOD( MYROW - ICURROW + NPROW, NPROW )
03074       END IF
03075       IF( COLREP ) THEN
03076          MYCOLDIST = 0
03077       ELSE
03078          MYCOLDIST = MOD( MYCOL - ICURCOL + NPCOL, NPCOL )
03079       END IF
03080       II = 1
03081       JJ = 1
03082 *
03083       IF( INCX.EQ.DESCX( M_ ) ) THEN
03084 *
03085 *        sub( X ) is a row vector
03086 *
03087          IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
03088 *
03089             I = 1
03090             IF( MYCOLDIST.EQ.0 ) THEN
03091                J = 1
03092             ELSE
03093                J = DESCX( INB_ ) + ( MYCOLDIST - 1 ) * NBX + 1
03094             END IF
03095             JB = MIN( MAX( 0, DESCX( N_ ) - J + 1 ), INBX )
03096             IB = MIN( DESCX( M_ ), DESCX( IMB_ ) )
03097 *
03098             DO 20 KK = 0, JB-1
03099                DO 10 LL = 0, IB-1
03100                   IF( I+LL.NE.IX .OR. J+KK.LT.JX .OR. J+KK.GT.JX+N-1 )
03101      $               CALL PDERRSET( ERR, ERRMAX,
03102      $                              X( I+LL+(J+KK-1)*LDX ),
03103      $                              PX( II+LL+(JJ+KK-1)*LDPX ) )
03104    10          CONTINUE
03105    20       CONTINUE
03106             IF( COLREP ) THEN
03107                J = J + INBX
03108             ELSE
03109                J = J + INBX + ( NPCOL - 1 ) * NBX
03110             END IF
03111 *
03112             DO 50 JJ = INBX+1, NQALL, NBX
03113                JB = MIN( NQALL-JJ+1, NBX )
03114 *
03115                DO 40 KK = 0, JB-1
03116                   DO 30 LL = 0, IB-1
03117                      IF( I+LL.NE.IX .OR. J+KK.LT.JX .OR.
03118      $                   J+KK.GT.JX+N-1 )
03119      $                  CALL PDERRSET( ERR, ERRMAX,
03120      $                                 X( I+LL+(J+KK-1)*LDX ),
03121      $                                 PX( II+LL+(JJ+KK-1)*LDPX ) )
03122    30             CONTINUE
03123    40          CONTINUE
03124 *
03125                IF( COLREP ) THEN
03126                   J = J + NBX
03127                ELSE
03128                   J = J + NPCOL * NBX
03129                END IF
03130 *
03131    50       CONTINUE
03132 *
03133             II = II + IB
03134 *
03135          END IF
03136 *
03137          ICURROW = MOD( ICURROW + 1, NPROW )
03138 *
03139          DO 110 I = DESCX( IMB_ ) + 1, DESCX( M_ ), MBX
03140             IB = MIN( DESCX( M_ ) - I + 1, MBX )
03141 *
03142             IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
03143 *
03144                IF( MYCOLDIST.EQ.0 ) THEN
03145                   J = 1
03146                ELSE
03147                   J = DESCX( INB_ ) + ( MYCOLDIST - 1 ) * NBX + 1
03148                END IF
03149 *
03150                JJ = 1
03151                JB = MIN( MAX( 0, DESCX( N_ ) - J + 1 ), INBX )
03152                DO 70 KK = 0, JB-1
03153                   DO 60 LL = 0, IB-1
03154                      IF( I+LL.NE.IX .OR. J+KK.LT.JX .OR.
03155      $                   J+KK.GT.JX+N-1 )
03156      $                  CALL PDERRSET( ERR, ERRMAX,
03157      $                                 X( I+LL+(J+KK-1)*LDX ),
03158      $                                 PX( II+LL+(JJ+KK-1)*LDPX ) )
03159    60             CONTINUE
03160    70          CONTINUE
03161                IF( COLREP ) THEN
03162                   J = J + INBX
03163                ELSE
03164                   J = J + INBX + ( NPCOL - 1 ) * NBX
03165                END IF
03166 *
03167                DO 100 JJ = INBX+1, NQALL, NBX
03168                   JB = MIN( NQALL-JJ+1, NBX )
03169 *
03170                   DO 90 KK = 0, JB-1
03171                      DO 80 LL = 0, IB-1
03172                         IF( I+LL.NE.IX .OR. J+KK.LT.JX .OR.
03173      $                      J+KK.GT.JX+N-1 )
03174      $                     CALL PDERRSET( ERR, ERRMAX,
03175      $                                    X( I+LL+(J+KK-1)*LDX ),
03176      $                                    PX( II+LL+(JJ+KK-1)*LDPX ) )
03177    80                CONTINUE
03178    90             CONTINUE
03179 *
03180                   IF( COLREP ) THEN
03181                      J = J + NBX
03182                   ELSE
03183                      J = J + NPCOL * NBX
03184                   END IF
03185 *
03186   100          CONTINUE
03187 *
03188                II = II + IB
03189 *
03190             END IF
03191 *
03192             ICURROW = MOD( ICURROW + 1, NPROW )
03193 *
03194   110    CONTINUE
03195 *
03196       ELSE
03197 *
03198 *        sub( X ) is a column vector
03199 *
03200          IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN
03201 *
03202             J = 1
03203             IF( MYROWDIST.EQ.0 ) THEN
03204                I = 1
03205             ELSE
03206                I = DESCX( IMB_ ) + ( MYROWDIST - 1 ) * MBX + 1
03207             END IF
03208             IB = MIN( MAX( 0, DESCX( M_ ) - I + 1 ), IMBX )
03209             JB = MIN( DESCX( N_ ), DESCX( INB_ ) )
03210 *
03211             DO 130 KK = 0, JB-1
03212                DO 120 LL = 0, IB-1
03213                   IF( J+KK.NE.JX .OR. I+LL.LT.IX .OR. I+LL.GT.IX+N-1 )
03214      $               CALL PDERRSET( ERR, ERRMAX,
03215      $                              X( I+LL+(J+KK-1)*LDX ),
03216      $                              PX( II+LL+(JJ+KK-1)*LDPX ) )
03217   120          CONTINUE
03218   130       CONTINUE
03219             IF( ROWREP ) THEN
03220                I = I + IMBX
03221             ELSE
03222                I = I + IMBX + ( NPROW - 1 ) * MBX
03223             END IF
03224 *
03225             DO 160 II = IMBX+1, MPALL, MBX
03226                IB = MIN( MPALL-II+1, MBX )
03227 *
03228                DO 150 KK = 0, JB-1
03229                   DO 140 LL = 0, IB-1
03230                      IF( J+KK.NE.JX .OR. I+LL.LT.IX .OR.
03231      $                   I+LL.GT.IX+N-1 )
03232      $                  CALL PDERRSET( ERR, ERRMAX,
03233      $                                 X( I+LL+(J+KK-1)*LDX ),
03234      $                                 PX( II+LL+(JJ+KK-1)*LDPX ) )
03235   140             CONTINUE
03236   150          CONTINUE
03237 *
03238                IF( ROWREP ) THEN
03239                   I = I + MBX
03240                ELSE
03241                   I = I + NPROW * MBX
03242                END IF
03243 *
03244   160       CONTINUE
03245 *
03246             JJ = JJ + JB
03247 *
03248          END IF
03249 *
03250          ICURCOL = MOD( ICURCOL + 1, NPCOL )
03251 *
03252          DO 220 J = DESCX( INB_ ) + 1, DESCX( N_ ), NBX
03253             JB = MIN( DESCX( N_ ) - J + 1, NBX )
03254 *
03255             IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN
03256 *
03257                IF( MYROWDIST.EQ.0 ) THEN
03258                   I = 1
03259                ELSE
03260                   I = DESCX( IMB_ ) + ( MYROWDIST - 1 ) * MBX + 1
03261                END IF
03262 *
03263                II = 1
03264                IB = MIN( MAX( 0, DESCX( M_ ) - I + 1 ), IMBX )
03265                DO 180 KK = 0, JB-1
03266                   DO 170 LL = 0, IB-1
03267                      IF( J+KK.NE.JX .OR. I+LL.LT.IX .OR.
03268      $                   I+LL.GT.IX+N-1 )
03269      $                  CALL PDERRSET( ERR, ERRMAX,
03270      $                                 X( I+LL+(J+KK-1)*LDX ),
03271      $                                 PX( II+LL+(JJ+KK-1)*LDPX ) )
03272   170             CONTINUE
03273   180          CONTINUE
03274                IF( ROWREP ) THEN
03275                   I = I + IMBX
03276                ELSE
03277                   I = I + IMBX + ( NPROW - 1 ) * MBX
03278                END IF
03279 *
03280                DO 210 II = IMBX+1, MPALL, MBX
03281                   IB = MIN( MPALL-II+1, MBX )
03282 *
03283                   DO 200 KK = 0, JB-1
03284                      DO 190 LL = 0, IB-1
03285                         IF( J+KK.NE.JX .OR. I+LL.LT.IX .OR.
03286      $                      I+LL.GT.IX+N-1 )
03287      $                     CALL PDERRSET( ERR, ERRMAX,
03288      $                                    X( I+LL+(J+KK-1)*LDX ),
03289      $                                    PX( II+LL+(JJ+KK-1)*LDPX ) )
03290   190                CONTINUE
03291   200             CONTINUE
03292 *
03293                   IF( ROWREP ) THEN
03294                      I = I + MBX
03295                   ELSE
03296                      I = I + NPROW * MBX
03297                   END IF
03298 *
03299   210          CONTINUE
03300 *
03301                JJ = JJ + JB
03302 *
03303             END IF
03304 *
03305             ICURCOL = MOD( ICURCOL + 1, NPCOL )
03306 *
03307   220    CONTINUE
03308 *
03309       END IF
03310 *
03311       CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERRMAX, 1, KK, LL, -1,
03312      $              -1, -1 )
03313 *
03314       IF( ERRMAX.GT.ZERO .AND. ERRMAX.LE.EPS ) THEN
03315          INFO = 1
03316       ELSE IF( ERRMAX.GT.EPS ) THEN
03317          INFO = -1
03318       END IF
03319 *
03320       RETURN
03321 *
03322 *     End of PDCHKVOUT
03323 *
03324       END
03325       SUBROUTINE PDCHKMIN( ERRMAX, M, N, A, PA, IA, JA, DESCA, INFO )
03326 *
03327 *  -- PBLAS test routine (version 2.0) --
03328 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
03329 *     and University of California, Berkeley.
03330 *     April 1, 1998
03331 *
03332 *     .. Scalar Arguments ..
03333       INTEGER            IA, INFO, JA, M, N
03334       DOUBLE PRECISION   ERRMAX
03335 *     ..
03336 *     .. Array Arguments ..
03337       INTEGER            DESCA( * )
03338       DOUBLE PRECISION   PA( * ), A( * )
03339 *     ..
03340 *
03341 *  Purpose
03342 *  =======
03343 *
03344 *  PDCHKMIN  checks that the submatrix sub( PA ) remained unchanged. The
03345 *  local  array  entries are compared element by element, and their dif-
03346 *  ference  is tested against 0.0 as well as the epsilon machine. Notice
03347 *  that  this difference should be numerically exactly the zero machine,
03348 *  but  because of the possible fluctuation of some of the data we flag-
03349 *  ged differently a difference less than twice the epsilon machine. The
03350 *  largest error is also returned.
03351 *
03352 *  Notes
03353 *  =====
03354 *
03355 *  A description  vector  is associated with each 2D block-cyclicly dis-
03356 *  tributed matrix.  This  vector  stores  the  information  required to
03357 *  establish the  mapping  between a  matrix entry and its corresponding
03358 *  process and memory location.
03359 *
03360 *  In  the  following  comments,   the character _  should  be  read  as
03361 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
03362 *  block cyclicly distributed matrix.  Its description vector is DESCA:
03363 *
03364 *  NOTATION         STORED IN       EXPLANATION
03365 *  ---------------- --------------- ------------------------------------
03366 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
03367 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
03368 *                                   the NPROW x NPCOL BLACS process grid
03369 *                                   A  is distributed over.  The context
03370 *                                   itself  is  global,  but  the handle
03371 *                                   (the integer value) may vary.
03372 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
03373 *                                   ted matrix A, M_A >= 0.
03374 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
03375 *                                   buted matrix A, N_A >= 0.
03376 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
03377 *                                   block of the matrix A, IMB_A > 0.
03378 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
03379 *                                   left   block   of   the   matrix  A,
03380 *                                   INB_A > 0.
03381 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
03382 *                                   bute the last  M_A-IMB_A rows of  A,
03383 *                                   MB_A > 0.
03384 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
03385 *                                   bute the last  N_A-INB_A  columns of
03386 *                                   A, NB_A > 0.
03387 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
03388 *                                   row of the matrix  A is distributed,
03389 *                                   NPROW > RSRC_A >= 0.
03390 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
03391 *                                   first  column of  A  is distributed.
03392 *                                   NPCOL > CSRC_A >= 0.
03393 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
03394 *                                   array  storing  the  local blocks of
03395 *                                   the distributed matrix A,
03396 *                                   IF( Lc( 1, N_A ) > 0 )
03397 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
03398 *                                   ELSE
03399 *                                      LLD_A >= 1.
03400 *
03401 *  Let K be the number of  rows of a matrix A starting at the global in-
03402 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
03403 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
03404 *  receive if these K rows were distributed over NPROW processes.  If  K
03405 *  is the number of columns of a matrix  A  starting at the global index
03406 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
03407 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
03408 *  these K columns were distributed over NPCOL processes.
03409 *
03410 *  The values of Lr() and Lc() may be determined via a call to the func-
03411 *  tion PB_NUMROC:
03412 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
03413 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
03414 *
03415 *  Arguments
03416 *  =========
03417 *
03418 *  ERRMAX  (global output) DOUBLE PRECISION
03419 *          On exit,  ERRMAX  specifies the largest absolute element-wise
03420 *          difference between sub( A ) and sub( PA ).
03421 *
03422 *  M       (global input) INTEGER
03423 *          On entry,  M  specifies  the  number of rows of the submatrix
03424 *          operand sub( A ). M must be at least zero.
03425 *
03426 *  N       (global input) INTEGER
03427 *          On entry, N  specifies the number of columns of the submatrix
03428 *          operand sub( A ). N must be at least zero.
03429 *
03430 *  A       (local input) DOUBLE PRECISION array
03431 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
03432 *          array contains a local copy of the initial entire matrix PA.
03433 *
03434 *  PA      (local input) DOUBLE PRECISION array
03435 *          On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
03436 *          array contains the local entries of the matrix PA.
03437 *
03438 *  IA      (global input) INTEGER
03439 *          On entry, IA  specifies A's global row index, which points to
03440 *          the beginning of the submatrix sub( A ).
03441 *
03442 *  JA      (global input) INTEGER
03443 *          On entry, JA  specifies A's global column index, which points
03444 *          to the beginning of the submatrix sub( A ).
03445 *
03446 *  DESCA   (global and local input) INTEGER array
03447 *          On entry, DESCA  is an integer array of dimension DLEN_. This
03448 *          is the array descriptor for the matrix A.
03449 *
03450 *  INFO    (global output) INTEGER
03451 *          On exit, if INFO = 0, no error has been found,
03452 *          If INFO > 0, the maximum abolute error found is in (0,eps],
03453 *          If INFO < 0, the maximum abolute error found is in (eps,+oo).
03454 *
03455 *  -- Written on April 1, 1998 by
03456 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
03457 *
03458 *  =====================================================================
03459 *
03460 *     .. Parameters ..
03461       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
03462      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
03463      $                   RSRC_
03464       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
03465      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
03466      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
03467      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
03468       DOUBLE PRECISION   ZERO
03469       PARAMETER          ( ZERO = 0.0D+0 )
03470 *     ..
03471 *     .. Local Scalars ..
03472       LOGICAL            COLREP, ROWREP
03473       INTEGER            H, I, IACOL, IAROW, IB, ICTXT, ICURCOL,
03474      $                   ICURROW, II, IIA, IN, J, JB, JJ, JJA, JN, K,
03475      $                   KK, LDA, LDPA, LL, MYCOL, MYROW, NPCOL, NPROW
03476       DOUBLE PRECISION   ERR, EPS
03477 *     ..
03478 *     .. External Subroutines ..
03479       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, PB_INFOG2L, PDERRSET
03480 *     ..
03481 *     .. External Functions ..
03482       DOUBLE PRECISION   PDLAMCH
03483       EXTERNAL           PDLAMCH
03484 *     ..
03485 *     .. Intrinsic Functions ..
03486       INTRINSIC          ABS, MAX, MIN, MOD
03487 *     ..
03488 *     .. Executable Statements ..
03489 *
03490       INFO   = 0
03491       ERRMAX = ZERO
03492 *
03493 *     Quick return if posssible
03494 *
03495       IF( ( M.EQ.0 ).OR.( N.EQ.0 ) )
03496      $   RETURN
03497 *
03498 *     Start the operations
03499 *
03500       ICTXT = DESCA( CTXT_ )
03501       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
03502 *
03503       EPS = PDLAMCH( ICTXT, 'eps' )
03504 *
03505       CALL PB_INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL, IIA,
03506      $                 JJA, IAROW, IACOL )
03507 *
03508       II      = IIA
03509       JJ      = JJA
03510       LDA     = DESCA( M_ )
03511       LDPA    = DESCA( LLD_ )
03512       ICURROW = IAROW
03513       ICURCOL = IACOL
03514       ROWREP  = ( IAROW.EQ.-1 )
03515       COLREP  = ( IACOL.EQ.-1 )
03516 *
03517 *     Handle the first block of column separately
03518 *
03519       JB = DESCA( INB_ ) - JA  + 1
03520       IF( JB.LE.0 )
03521      $   JB = ( ( -JB ) / DESCA( NB_ ) + 1 ) * DESCA( NB_ ) + JB
03522       JB = MIN( JB, N )
03523       JN = JA + JB - 1
03524 *
03525       IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN
03526 *
03527          DO 40 H = 0, JB-1
03528             IB = DESCA( IMB_ ) - IA  + 1
03529             IF( IB.LE.0 )
03530      $         IB = ( ( -IB ) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
03531             IB = MIN( IB, M )
03532             IN = IA + IB - 1
03533             IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
03534                DO 10 K = 0, IB-1
03535                   CALL PDERRSET( ERR, ERRMAX, A( IA+K+(JA+H-1)*LDA ),
03536      $                           PA( II+K+(JJ+H-1)*LDPA ) )
03537    10          CONTINUE
03538                II = II + IB
03539             END IF
03540             ICURROW = MOD( ICURROW+1, NPROW )
03541 *
03542 *           Loop over remaining block of rows
03543 *
03544             DO 30 I = IN+1, IA+M-1, DESCA( MB_ )
03545                IB = MIN( DESCA( MB_ ), IA+M-I )
03546                IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
03547                   DO 20 K = 0, IB-1
03548                      CALL PDERRSET( ERR, ERRMAX, A( I+K+(JA+H-1)*LDA ),
03549      $                              PA( II+K+(JJ+H-1)*LDPA ) )
03550    20             CONTINUE
03551                   II = II + IB
03552                END IF
03553                ICURROW = MOD( ICURROW+1, NPROW )
03554    30       CONTINUE
03555 *
03556             II = IIA
03557             ICURROW = IAROW
03558    40    CONTINUE
03559 *
03560          JJ = JJ + JB
03561 *
03562       END IF
03563 *
03564       ICURCOL = MOD( ICURCOL+1, NPCOL )
03565 *
03566 *     Loop over remaining column blocks
03567 *
03568       DO 90 J = JN+1, JA+N-1, DESCA( NB_ )
03569          JB = MIN(  DESCA( NB_ ), JA+N-J )
03570          IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN
03571             DO 80 H = 0, JB-1
03572                IB = DESCA( IMB_ ) - IA  + 1
03573                IF( IB.LE.0 )
03574      $            IB = ( ( -IB ) / DESCA( MB_ ) + 1 )*DESCA( MB_ ) + IB
03575                IB = MIN( IB, M )
03576                IN = IA + IB - 1
03577                IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
03578                   DO 50 K = 0, IB-1
03579                      CALL PDERRSET( ERR, ERRMAX, A( IA+K+(J+H-1)*LDA ),
03580      $                              PA( II+K+(JJ+H-1)*LDPA ) )
03581    50             CONTINUE
03582                   II = II + IB
03583                END IF
03584                ICURROW = MOD( ICURROW+1, NPROW )
03585 *
03586 *              Loop over remaining block of rows
03587 *
03588                DO 70 I = IN+1, IA+M-1, DESCA( MB_ )
03589                   IB = MIN( DESCA( MB_ ), IA+M-I )
03590                   IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
03591                      DO 60 K = 0, IB-1
03592                         CALL PDERRSET( ERR, ERRMAX,
03593      $                                 A( I+K+(J+H-1)*LDA ),
03594      $                                 PA( II+K+(JJ+H-1)*LDPA ) )
03595    60                CONTINUE
03596                      II = II + IB
03597                   END IF
03598                   ICURROW = MOD( ICURROW+1, NPROW )
03599    70          CONTINUE
03600 *
03601                II = IIA
03602                ICURROW = IAROW
03603    80       CONTINUE
03604 *
03605             JJ = JJ + JB
03606          END IF
03607 *
03608          ICURCOL = MOD( ICURCOL+1, NPCOL )
03609 *
03610    90 CONTINUE
03611 *
03612       CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERRMAX, 1, KK, LL, -1,
03613      $              -1, -1 )
03614 *
03615       IF( ERRMAX.GT.ZERO .AND. ERRMAX.LE.EPS ) THEN
03616          INFO = 1
03617       ELSE IF( ERRMAX.GT.EPS ) THEN
03618          INFO = -1
03619       END IF
03620 *
03621       RETURN
03622 *
03623 *     End of PDCHKMIN
03624 *
03625       END
03626       SUBROUTINE PDCHKMOUT( M, N, A, PA, IA, JA, DESCA, INFO )
03627 *
03628 *  -- PBLAS test routine (version 2.0) --
03629 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
03630 *     and University of California, Berkeley.
03631 *     April 1, 1998
03632 *
03633 *     .. Scalar Arguments ..
03634       INTEGER            IA, INFO, JA, M, N
03635 *     ..
03636 *     .. Array Arguments ..
03637       INTEGER            DESCA( * )
03638       DOUBLE PRECISION   A( * ), PA( * )
03639 *     ..
03640 *
03641 *  Purpose
03642 *  =======
03643 *
03644 *  PDCHKMOUT  checks  that the matrix PA \ sub( PA ) remained unchanged.
03645 *  The  local array  entries  are compared element by element, and their
03646 *  difference  is tested against 0.0 as well as the epsilon machine. No-
03647 *  tice that this  difference should be numerically exactly the zero ma-
03648 *  chine, but because  of  the  possible movement of some of the data we
03649 *  flagged differently a difference less than twice the epsilon machine.
03650 *  The largest error is reported.
03651 *
03652 *  Notes
03653 *  =====
03654 *
03655 *  A description  vector  is associated with each 2D block-cyclicly dis-
03656 *  tributed matrix.  This  vector  stores  the  information  required to
03657 *  establish the  mapping  between a  matrix entry and its corresponding
03658 *  process and memory location.
03659 *
03660 *  In  the  following  comments,   the character _  should  be  read  as
03661 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
03662 *  block cyclicly distributed matrix.  Its description vector is DESCA:
03663 *
03664 *  NOTATION         STORED IN       EXPLANATION
03665 *  ---------------- --------------- ------------------------------------
03666 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
03667 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
03668 *                                   the NPROW x NPCOL BLACS process grid
03669 *                                   A  is distributed over.  The context
03670 *                                   itself  is  global,  but  the handle
03671 *                                   (the integer value) may vary.
03672 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
03673 *                                   ted matrix A, M_A >= 0.
03674 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
03675 *                                   buted matrix A, N_A >= 0.
03676 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
03677 *                                   block of the matrix A, IMB_A > 0.
03678 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
03679 *                                   left   block   of   the   matrix  A,
03680 *                                   INB_A > 0.
03681 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
03682 *                                   bute the last  M_A-IMB_A rows of  A,
03683 *                                   MB_A > 0.
03684 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
03685 *                                   bute the last  N_A-INB_A  columns of
03686 *                                   A, NB_A > 0.
03687 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
03688 *                                   row of the matrix  A is distributed,
03689 *                                   NPROW > RSRC_A >= 0.
03690 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
03691 *                                   first  column of  A  is distributed.
03692 *                                   NPCOL > CSRC_A >= 0.
03693 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
03694 *                                   array  storing  the  local blocks of
03695 *                                   the distributed matrix A,
03696 *                                   IF( Lc( 1, N_A ) > 0 )
03697 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
03698 *                                   ELSE
03699 *                                      LLD_A >= 1.
03700 *
03701 *  Let K be the number of  rows of a matrix A starting at the global in-
03702 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
03703 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
03704 *  receive if these K rows were distributed over NPROW processes.  If  K
03705 *  is the number of columns of a matrix  A  starting at the global index
03706 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
03707 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
03708 *  these K columns were distributed over NPCOL processes.
03709 *
03710 *  The values of Lr() and Lc() may be determined via a call to the func-
03711 *  tion PB_NUMROC:
03712 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
03713 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
03714 *
03715 *  Arguments
03716 *  =========
03717 *
03718 *  M       (global input) INTEGER
03719 *          On entry,  M  specifies  the  number of rows of the submatrix
03720 *          sub( PA ). M must be at least zero.
03721 *
03722 *  N       (global input) INTEGER
03723 *          On entry, N specifies the  number of columns of the submatrix
03724 *          sub( PA ). N must be at least zero.
03725 *
03726 *  A       (local input) DOUBLE PRECISION array
03727 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
03728 *          array contains a local copy of the initial entire matrix PA.
03729 *
03730 *  PA      (local input) DOUBLE PRECISION array
03731 *          On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
03732 *          array contains the local entries of the matrix PA.
03733 *
03734 *  IA      (global input) INTEGER
03735 *          On entry, IA  specifies A's global row index, which points to
03736 *          the beginning of the submatrix sub( A ).
03737 *
03738 *  JA      (global input) INTEGER
03739 *          On entry, JA  specifies A's global column index, which points
03740 *          to the beginning of the submatrix sub( A ).
03741 *
03742 *  DESCA   (global and local input) INTEGER array
03743 *          On entry, DESCA  is an integer array of dimension DLEN_. This
03744 *          is the array descriptor for the matrix A.
03745 *
03746 *  INFO    (global output) INTEGER
03747 *          On exit, if INFO = 0, no error has been found,
03748 *          If INFO > 0, the maximum abolute error found is in (0,eps],
03749 *          If INFO < 0, the maximum abolute error found is in (eps,+oo).
03750 *
03751 *  -- Written on April 1, 1998 by
03752 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
03753 *
03754 *  =====================================================================
03755 *
03756 *     .. Parameters ..
03757       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
03758      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
03759      $                   RSRC_
03760       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
03761      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
03762      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
03763      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
03764       DOUBLE PRECISION   ZERO
03765       PARAMETER          ( ZERO = 0.0D+0 )
03766 *     ..
03767 *     .. Local Scalars ..
03768       LOGICAL            COLREP, ROWREP
03769       INTEGER            I, IB, ICTXT, ICURCOL, II, IMBA, J, JB, JJ, KK,
03770      $                   LDA, LDPA, LL, MPALL, MYCOL, MYROW, MYROWDIST,
03771      $                   NPCOL, NPROW
03772       DOUBLE PRECISION   EPS, ERR, ERRMAX
03773 *     ..
03774 *     .. External Subroutines ..
03775       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, PDERRSET
03776 *     ..
03777 *     .. External Functions ..
03778       INTEGER            PB_NUMROC
03779       DOUBLE PRECISION   PDLAMCH
03780       EXTERNAL           PDLAMCH, PB_NUMROC
03781 *     ..
03782 *     .. Intrinsic Functions ..
03783       INTRINSIC          MAX, MIN, MOD
03784 *     ..
03785 *     .. Executable Statements ..
03786 *
03787       INFO = 0
03788       ERRMAX = ZERO
03789 *
03790 *     Quick return if possible
03791 *
03792       IF( ( DESCA( M_ ).LE.0 ).OR.( DESCA( N_ ).LE.0 ) )
03793      $   RETURN
03794 *
03795 *     Start the operations
03796 *
03797       ICTXT = DESCA( CTXT_ )
03798       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
03799 *
03800       EPS = PDLAMCH( ICTXT, 'eps' )
03801 *
03802       MPALL = PB_NUMROC( DESCA( M_ ), 1, DESCA( IMB_ ), DESCA( MB_ ),
03803      $                   MYROW, DESCA( RSRC_ ), NPROW )
03804 *
03805       LDA    = DESCA( M_ )
03806       LDPA   = DESCA( LLD_ )
03807 *
03808       II = 1
03809       JJ = 1
03810       ROWREP  = ( DESCA( RSRC_ ).EQ.-1 )
03811       COLREP  = ( DESCA( CSRC_ ).EQ.-1 )
03812       ICURCOL = DESCA( CSRC_ )
03813       IF( MYROW.EQ.DESCA( RSRC_ ) .OR. ROWREP ) THEN
03814          IMBA = DESCA( IMB_ )
03815       ELSE
03816          IMBA = DESCA( MB_ )
03817       END IF
03818       IF( ROWREP ) THEN
03819          MYROWDIST = 0
03820       ELSE
03821          MYROWDIST = MOD( MYROW - DESCA( RSRC_ ) + NPROW, NPROW )
03822       END IF
03823 *
03824       IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN
03825 *
03826          J = 1
03827          IF( MYROWDIST.EQ.0 ) THEN
03828             I = 1
03829          ELSE
03830             I = DESCA( IMB_ ) + ( MYROWDIST - 1 ) * DESCA( MB_ ) + 1
03831          END IF
03832          IB = MIN( MAX( 0, DESCA( M_ ) - I + 1 ), IMBA )
03833          JB = MIN( DESCA( N_ ), DESCA( INB_ ) )
03834 *
03835          DO 20 KK = 0, JB-1
03836             DO 10 LL = 0, IB-1
03837                IF( I+LL.LT.IA .OR. I+LL.GT.IA+M-1 .OR.
03838      $             J+KK.LT.JA .OR. J+KK.GT.JA+N-1 )
03839      $            CALL PDERRSET( ERR, ERRMAX, A( I+LL+(J+KK-1)*LDA ),
03840      $                           PA( II+LL+(JJ+KK-1)*LDPA ) )
03841    10       CONTINUE
03842    20    CONTINUE
03843          IF( ROWREP ) THEN
03844             I = I + IMBA
03845          ELSE
03846             I = I + IMBA + ( NPROW - 1 ) * DESCA( MB_ )
03847          END IF
03848 *
03849          DO 50 II = IMBA + 1, MPALL, DESCA( MB_ )
03850             IB = MIN( MPALL-II+1, DESCA( MB_ ) )
03851 *
03852             DO 40 KK = 0, JB-1
03853                DO 30 LL = 0, IB-1
03854                   IF( I+LL.LT.IA .OR. I+LL.GT.IA+M-1 .OR.
03855      $                J+KK.LT.JA .OR. J+KK.GT.JA+N-1 )
03856      $               CALL PDERRSET( ERR, ERRMAX,
03857      $                              A( I+LL+(J+KK-1)*LDA ),
03858      $                              PA( II+LL+(JJ+KK-1)*LDPA ) )
03859    30          CONTINUE
03860    40       CONTINUE
03861 *
03862             IF( ROWREP ) THEN
03863                I = I + DESCA( MB_ )
03864             ELSE
03865                I = I + NPROW * DESCA( MB_ )
03866             END IF
03867 *
03868    50    CONTINUE
03869 *
03870          JJ = JJ + JB
03871 *
03872       END IF
03873 *
03874       ICURCOL = MOD( ICURCOL + 1, NPCOL )
03875 *
03876       DO 110 J = DESCA( INB_ ) + 1, DESCA( N_ ), DESCA( NB_ )
03877          JB = MIN( DESCA( N_ ) - J + 1, DESCA( NB_ ) )
03878 *
03879          IF( MYCOL.EQ.ICURCOL .OR. COLREP ) THEN
03880 *
03881             IF( MYROWDIST.EQ.0 ) THEN
03882                I = 1
03883             ELSE
03884                I = DESCA( IMB_ ) + ( MYROWDIST - 1 ) * DESCA( MB_ ) + 1
03885             END IF
03886 *
03887             II = 1
03888             IB = MIN( MAX( 0, DESCA( M_ ) - I + 1 ), IMBA )
03889             DO 70 KK = 0, JB-1
03890                DO 60 LL = 0, IB-1
03891                   IF( I+LL.LT.IA .OR. I+LL.GT.IA+M-1 .OR.
03892      $                J+KK.LT.JA .OR. J+KK.GT.JA+N-1 )
03893      $               CALL PDERRSET( ERR, ERRMAX,
03894      $                              A( I+LL+(J+KK-1)*LDA ),
03895      $                              PA( II+LL+(JJ+KK-1)*LDPA ) )
03896    60          CONTINUE
03897    70       CONTINUE
03898             IF( ROWREP ) THEN
03899                I = I + IMBA
03900             ELSE
03901                I = I + IMBA + ( NPROW - 1 ) * DESCA( MB_ )
03902             END IF
03903 *
03904             DO 100 II = IMBA+1, MPALL, DESCA( MB_ )
03905                IB = MIN( MPALL-II+1, DESCA( MB_ ) )
03906 *
03907                DO 90 KK = 0, JB-1
03908                   DO 80 LL = 0, IB-1
03909                      IF( I+LL.LT.IA .OR. I+LL.GT.IA+M-1 .OR.
03910      $                   J+KK.LT.JA .OR. J+KK.GT.JA+N-1 )
03911      $                  CALL PDERRSET( ERR, ERRMAX,
03912      $                                 A( I+LL+(J+KK-1)*LDA ),
03913      $                                 PA( II+LL+(JJ+KK-1)*LDPA ) )
03914    80             CONTINUE
03915    90          CONTINUE
03916 *
03917                IF( ROWREP ) THEN
03918                   I = I + DESCA( MB_ )
03919                ELSE
03920                   I = I + NPROW * DESCA( MB_ )
03921                END IF
03922 *
03923   100       CONTINUE
03924 *
03925             JJ = JJ + JB
03926 *
03927          END IF
03928 *
03929          ICURCOL = MOD( ICURCOL + 1, NPCOL )
03930 *                                                           INSERT MODE
03931   110 CONTINUE
03932 *
03933       CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERRMAX, 1, KK, LL, -1,
03934      $              -1, -1 )
03935 *
03936       IF( ERRMAX.GT.ZERO .AND. ERRMAX.LE.EPS ) THEN
03937          INFO = 1
03938       ELSE IF( ERRMAX.GT.EPS ) THEN
03939          INFO = -1
03940       END IF
03941 *
03942       RETURN
03943 *
03944 *     End of PDCHKMOUT
03945 *
03946       END
03947       SUBROUTINE PDMPRNT( ICTXT, NOUT, M, N, A, LDA, IRPRNT, ICPRNT,
03948      $                    CMATNM )
03949 *
03950 *  -- PBLAS test routine (version 2.0) --
03951 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
03952 *     and University of California, Berkeley.
03953 *     April 1, 1998
03954 *
03955 *     .. Scalar Arguments ..
03956       INTEGER            ICPRNT, ICTXT, IRPRNT, LDA, M, N, NOUT
03957 *     ..
03958 *     .. Array Arguments ..
03959       CHARACTER*(*)      CMATNM
03960       DOUBLE PRECISION   A( LDA, * )
03961 *     ..
03962 *
03963 *  Purpose
03964 *  =======
03965 *
03966 *  PDMPRNT prints to the standard output an array A of size m by n. Only
03967 *  the process of coordinates ( IRPRNT, ICPRNT ) is printing.
03968 *
03969 *  Arguments
03970 *  =========
03971 *
03972 *  ICTXT   (local input) INTEGER
03973 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
03974 *          ting the global  context of the operation. The context itself
03975 *          is global, but the value of ICTXT is local.
03976 *
03977 *  NOUT    (global input) INTEGER
03978 *          On entry, NOUT specifies the unit number for the output file.
03979 *          When NOUT is 6, output to screen,  when  NOUT is 0, output to
03980 *          stderr. NOUT is only defined for process 0.
03981 *
03982 *  M       (global input) INTEGER
03983 *          On entry, M  specifies the number of rows of the matrix A.  M
03984 *          must be at least zero.
03985 *
03986 *  N       (global input) INTEGER
03987 *          On entry, N  specifies the number of columns of the matrix A.
03988 *          N must be at least zero.
03989 *
03990 *  A       (local input) DOUBLE PRECISION array
03991 *          On entry,  A  is an array of dimension (LDA,N). The leading m
03992 *          by n part of this array is printed.
03993 *
03994 *  LDA     (local input) INTEGER
03995 *          On entry, LDA  specifies the leading dimension of  the  local
03996 *          array A to be printed. LDA must be at least MAX( 1, M ).
03997 *
03998 *  IRPRNT  (global input) INTEGER
03999 *          On entry, IRPRNT  specifies the process row coordinate of the
04000 *          printing process.
04001 *
04002 *  ICPRNT  (global input) INTEGER
04003 *          On entry,  ICPRNT  specifies the process column coordinate of
04004 *          the printing process.
04005 *
04006 *  CMATNM  (global input) CHARACTER*(*)
04007 *          On entry, CMATNM specifies the identifier of the matrix to be
04008 *          printed.
04009 *
04010 *  -- Written on April 1, 1998 by
04011 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
04012 *
04013 *  =====================================================================
04014 *
04015 *     .. Local Scalars ..
04016       INTEGER            I, J, MYCOL, MYROW, NPCOL, NPROW
04017 *     ..
04018 *     .. External Subroutines ..
04019       EXTERNAL           BLACS_GRIDINFO
04020 *     ..
04021 *     .. Executable Statements ..
04022 *
04023 *     Quick return if possible
04024 *
04025       IF( ( M.LE.0 ).OR.( N.LE.0 ) )
04026      $   RETURN
04027 *
04028 *     Get grid parameters
04029 *
04030       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
04031 *
04032       IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
04033 *
04034          WRITE( NOUT, FMT = * )
04035          DO 20 J = 1, N
04036 *
04037             DO 10 I = 1, M
04038 *
04039                WRITE( NOUT, FMT = 9999 ) CMATNM, I, J, A( I, J )
04040 *
04041    10       CONTINUE
04042 *
04043    20    CONTINUE
04044 *
04045       END IF
04046 *
04047  9999 FORMAT( 1X, A, '(', I6, ',', I6, ')=', D30.18 )
04048 *
04049       RETURN
04050 *
04051 *     End of PDMPRNT
04052 *
04053       END
04054       SUBROUTINE PDVPRNT( ICTXT, NOUT, N, X, INCX, IRPRNT, ICPRNT,
04055      $                    CVECNM )
04056 *
04057 *  -- PBLAS test routine (version 2.0) --
04058 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
04059 *     and University of California, Berkeley.
04060 *     April 1, 1998
04061 *
04062 *     .. Scalar Arguments ..
04063       INTEGER            ICPRNT, ICTXT, INCX, IRPRNT, N, NOUT
04064 *     ..
04065 *     .. Array Arguments ..
04066       CHARACTER*(*)      CVECNM
04067       DOUBLE PRECISION   X( * )
04068 *     ..
04069 *
04070 *  Purpose
04071 *  =======
04072 *
04073 *  PDVPRNT  prints  to the standard output an vector x of length n. Only
04074 *  the process of coordinates ( IRPRNT, ICPRNT ) is printing.
04075 *
04076 *  Arguments
04077 *  =========
04078 *
04079 *  ICTXT   (local input) INTEGER
04080 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
04081 *          ting the global  context of the operation. The context itself
04082 *          is global, but the value of ICTXT is local.
04083 *
04084 *  NOUT    (global input) INTEGER
04085 *          On entry, NOUT specifies the unit number for the output file.
04086 *          When NOUT is 6, output to screen,  when  NOUT is 0, output to
04087 *          stderr. NOUT is only defined for process 0.
04088 *
04089 *  N       (global input) INTEGER
04090 *          On entry, N  specifies the length of the vector X.  N must be
04091 *          at least zero.
04092 *
04093 *  X       (global input) DOUBLE PRECISION array
04094 *          On   entry,   X   is   an   array   of   dimension  at  least
04095 *          ( 1 + ( n - 1 )*abs( INCX ) ).  Before  entry,  the incremen-
04096 *          ted array X must contain the vector x.
04097 *
04098 *  INCX    (global input) INTEGER.
04099 *          On entry, INCX specifies the increment for the elements of X.
04100 *          INCX must not be zero.
04101 *
04102 *  IRPRNT  (global input) INTEGER
04103 *          On entry, IRPRNT  specifies the process row coordinate of the
04104 *          printing process.
04105 *
04106 *  ICPRNT  (global input) INTEGER
04107 *          On entry,  ICPRNT  specifies the process column coordinate of
04108 *          the printing process.
04109 *
04110 *  CVECNM  (global input) CHARACTER*(*)
04111 *          On entry, CVECNM specifies the identifier of the vector to be
04112 *          printed.
04113 *
04114 *  -- Written on April 1, 1998 by
04115 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
04116 *
04117 *  =====================================================================
04118 *
04119 *     .. Local Scalars ..
04120       INTEGER            I, MYCOL, MYROW, NPCOL, NPROW
04121 *     ..
04122 *     .. External Subroutines ..
04123       EXTERNAL           BLACS_GRIDINFO
04124 *     ..
04125 *     .. Executable Statements ..
04126 *
04127 *     Quick return if possible
04128 *
04129       IF( N.LE.0 )
04130      $   RETURN
04131 *
04132 *     Get grid parameters
04133 *
04134       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
04135 *
04136       IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
04137 *
04138          WRITE( NOUT, FMT = * )
04139          DO 10 I = 1, 1 + ( N-1 )*INCX, INCX
04140 *
04141             WRITE( NOUT, FMT = 9999 ) CVECNM, I, X( I )
04142 *
04143    10    CONTINUE
04144 *
04145       END IF
04146 *
04147  9999 FORMAT( 1X, A, '(', I6, ')=', D30.18 )
04148 *
04149       RETURN
04150 *
04151 *     End of PDVPRNT
04152 *
04153       END
04154       SUBROUTINE PDMVCH( ICTXT, TRANS, M, N, ALPHA, A, IA, JA, DESCA,
04155      $                   X, IX, JX, DESCX, INCX, BETA, Y, PY, IY, JY,
04156      $                   DESCY, INCY, G, ERR, INFO )
04157 *
04158 *  -- PBLAS test routine (version 2.0) --
04159 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
04160 *     and University of California, Berkeley.
04161 *     April 1, 1998
04162 *
04163 *     .. Scalar Arguments ..
04164       CHARACTER*1        TRANS
04165       INTEGER            IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
04166      $                   JY, M, N
04167       DOUBLE PRECISION   ALPHA, BETA, ERR
04168 *     ..
04169 *     .. Array Arguments ..
04170       INTEGER            DESCA( * ), DESCX( * ), DESCY( * )
04171       DOUBLE PRECISION   A( * ), G( * ), PY( * ), X( * ), Y( * )
04172 *     ..
04173 *
04174 *  Purpose
04175 *  =======
04176 *
04177 *  PDMVCH checks the results of the computational tests.
04178 *
04179 *  Notes
04180 *  =====
04181 *
04182 *  A description  vector  is associated with each 2D block-cyclicly dis-
04183 *  tributed matrix.  This  vector  stores  the  information  required to
04184 *  establish the  mapping  between a  matrix entry and its corresponding
04185 *  process and memory location.
04186 *
04187 *  In  the  following  comments,   the character _  should  be  read  as
04188 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
04189 *  block cyclicly distributed matrix.  Its description vector is DESCA:
04190 *
04191 *  NOTATION         STORED IN       EXPLANATION
04192 *  ---------------- --------------- ------------------------------------
04193 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
04194 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
04195 *                                   the NPROW x NPCOL BLACS process grid
04196 *                                   A  is distributed over.  The context
04197 *                                   itself  is  global,  but  the handle
04198 *                                   (the integer value) may vary.
04199 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
04200 *                                   ted matrix A, M_A >= 0.
04201 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
04202 *                                   buted matrix A, N_A >= 0.
04203 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
04204 *                                   block of the matrix A, IMB_A > 0.
04205 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
04206 *                                   left   block   of   the   matrix  A,
04207 *                                   INB_A > 0.
04208 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
04209 *                                   bute the last  M_A-IMB_A rows of  A,
04210 *                                   MB_A > 0.
04211 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
04212 *                                   bute the last  N_A-INB_A  columns of
04213 *                                   A, NB_A > 0.
04214 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
04215 *                                   row of the matrix  A is distributed,
04216 *                                   NPROW > RSRC_A >= 0.
04217 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
04218 *                                   first  column of  A  is distributed.
04219 *                                   NPCOL > CSRC_A >= 0.
04220 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
04221 *                                   array  storing  the  local blocks of
04222 *                                   the distributed matrix A,
04223 *                                   IF( Lc( 1, N_A ) > 0 )
04224 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
04225 *                                   ELSE
04226 *                                      LLD_A >= 1.
04227 *
04228 *  Let K be the number of  rows of a matrix A starting at the global in-
04229 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
04230 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
04231 *  receive if these K rows were distributed over NPROW processes.  If  K
04232 *  is the number of columns of a matrix  A  starting at the global index
04233 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
04234 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
04235 *  these K columns were distributed over NPCOL processes.
04236 *
04237 *  The values of Lr() and Lc() may be determined via a call to the func-
04238 *  tion PB_NUMROC:
04239 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
04240 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
04241 *
04242 *  Arguments
04243 *  =========
04244 *
04245 *  ICTXT   (local input) INTEGER
04246 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
04247 *          ting the global  context of the operation. The context itself
04248 *          is global, but the value of ICTXT is local.
04249 *
04250 *  TRANS   (global input) CHARACTER*1
04251 *          On entry,  TRANS  specifies which matrix-vector product is to
04252 *          be computed as follows:
04253 *             If TRANS = 'N',
04254 *                sub( Y ) = BETA * sub( Y ) + sub( A )  * sub( X ),
04255 *             otherwise
04256 *                sub( Y ) = BETA * sub( Y ) + sub( A )' * sub( X ).
04257 *
04258 *  M       (global input) INTEGER
04259 *          On entry,  M  specifies  the  number of rows of the submatrix
04260 *          operand matrix A. M must be at least zero.
04261 *
04262 *  N       (global input) INTEGER
04263 *          On entry,  N  specifies  the  number of columns of the subma-
04264 *          trix operand matrix A. N must be at least zero.
04265 *
04266 *  ALPHA   (global input) DOUBLE PRECISION
04267 *          On entry, ALPHA specifies the scalar alpha.
04268 *
04269 *  A       (local input) DOUBLE PRECISION array
04270 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
04271 *          array contains a local copy of the initial entire matrix PA.
04272 *
04273 *  IA      (global input) INTEGER
04274 *          On entry, IA  specifies A's global row index, which points to
04275 *          the beginning of the submatrix sub( A ).
04276 *
04277 *  JA      (global input) INTEGER
04278 *          On entry, JA  specifies A's global column index, which points
04279 *          to the beginning of the submatrix sub( A ).
04280 *
04281 *  DESCA   (global and local input) INTEGER array
04282 *          On entry, DESCA  is an integer array of dimension DLEN_. This
04283 *          is the array descriptor for the matrix A.
04284 *
04285 *  X       (local input) DOUBLE PRECISION array
04286 *          On entry, X is an array of  dimension  (DESCX( M_ ),*).  This
04287 *          array contains a local copy of the initial entire matrix PX.
04288 *
04289 *  IX      (global input) INTEGER
04290 *          On entry, IX  specifies X's global row index, which points to
04291 *          the beginning of the submatrix sub( X ).
04292 *
04293 *  JX      (global input) INTEGER
04294 *          On entry, JX  specifies X's global column index, which points
04295 *          to the beginning of the submatrix sub( X ).
04296 *
04297 *  DESCX   (global and local input) INTEGER array
04298 *          On entry, DESCX  is an integer array of dimension DLEN_. This
04299 *          is the array descriptor for the matrix X.
04300 *
04301 *  INCX    (global input) INTEGER
04302 *          On entry,  INCX   specifies  the  global  increment  for  the
04303 *          elements of  X.  Only two values of  INCX   are  supported in
04304 *          this version, namely 1 and M_X. INCX  must not be zero.
04305 *
04306 *  BETA    (global input) DOUBLE PRECISION
04307 *          On entry, BETA specifies the scalar beta.
04308 *
04309 *  Y       (local input/local output) DOUBLE PRECISION array
04310 *          On entry, Y is an array of  dimension  (DESCY( M_ ),*).  This
04311 *          array contains a local copy of the initial entire matrix PY.
04312 *
04313 *  PY      (local input) DOUBLE PRECISION array
04314 *          On entry, PY is an array of dimension (DESCY( LLD_ ),*). This
04315 *          array contains the local entries of the matrix PY.
04316 *
04317 *  IY      (global input) INTEGER
04318 *          On entry, IY  specifies Y's global row index, which points to
04319 *          the beginning of the submatrix sub( Y ).
04320 *
04321 *  JY      (global input) INTEGER
04322 *          On entry, JY  specifies Y's global column index, which points
04323 *          to the beginning of the submatrix sub( Y ).
04324 *
04325 *  DESCY   (global and local input) INTEGER array
04326 *          On entry, DESCY  is an integer array of dimension DLEN_. This
04327 *          is the array descriptor for the matrix Y.
04328 *
04329 *  INCY    (global input) INTEGER
04330 *          On entry,  INCY   specifies  the  global  increment  for  the
04331 *          elements of  Y.  Only two values of  INCY   are  supported in
04332 *          this version, namely 1 and M_Y. INCY  must not be zero.
04333 *
04334 *  G       (workspace) DOUBLE PRECISION array
04335 *          On entry, G is an array of dimension at least MAX( M, N ).  G
04336 *          is used to compute the gauges.
04337 *
04338 *  ERR     (global output) DOUBLE PRECISION
04339 *          On exit, ERR specifies the largest error in absolute value.
04340 *
04341 *  INFO    (global output) INTEGER
04342 *          On exit, if INFO <> 0, the result is less than half accurate.
04343 *
04344 *  -- Written on April 1, 1998 by
04345 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
04346 *
04347 *  =====================================================================
04348 *
04349 *     .. Parameters ..
04350       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
04351      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
04352      $                   RSRC_
04353       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
04354      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
04355      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
04356      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
04357       DOUBLE PRECISION   ZERO, ONE
04358       PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
04359 *     ..
04360 *     .. Local Scalars ..
04361       LOGICAL            COLREP, ROWREP, TRAN
04362       INTEGER            I, IB, ICURCOL, ICURROW, IIY, IN, IOFFA, IOFFX,
04363      $                   IOFFY, IYCOL, IYROW, J, JB, JJY, JN, KK, LDA,
04364      $                   LDPY, LDX, LDY, ML, MYCOL, MYROW, NL, NPCOL,
04365      $                   NPROW
04366       DOUBLE PRECISION   EPS, ERRI, GTMP, TBETA, YTMP
04367 *     ..
04368 *     .. External Subroutines ..
04369       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L
04370 *     ..
04371 *     .. External Functions ..
04372       LOGICAL            LSAME
04373       DOUBLE PRECISION   PDLAMCH
04374       EXTERNAL           LSAME, PDLAMCH
04375 *     ..
04376 *     .. Intrinsic Functions ..
04377       INTRINSIC          ABS, MAX, MIN, MOD, SQRT
04378 *     ..
04379 *     .. Executable Statements ..
04380 *
04381       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
04382 *
04383       EPS = PDLAMCH( ICTXT, 'eps' )
04384 *
04385       IF( M.EQ.0 .OR. N.EQ.0 ) THEN
04386          TBETA = ONE
04387       ELSE
04388          TBETA = BETA
04389       END IF
04390 *
04391       TRAN = LSAME( TRANS, 'T' ).OR.LSAME( TRANS, 'C' )
04392       IF( TRAN ) THEN
04393          ML = N
04394          NL = M
04395       ELSE
04396          ML = M
04397          NL = N
04398       END IF
04399 *
04400       LDA = MAX( 1, DESCA( M_ ) )
04401       LDX = MAX( 1, DESCX( M_ ) )
04402       LDY = MAX( 1, DESCY( M_ ) )
04403 *
04404 *     Compute expected result in Y using data in A, X and Y.
04405 *     Compute gauges in G. This part of the computation is performed
04406 *     by every process in the grid.
04407 *
04408       IOFFY = IY + ( JY - 1 ) * LDY
04409       DO 30 I = 1, ML
04410          YTMP = ZERO
04411          GTMP = ZERO
04412          IOFFX = IX + ( JX - 1 ) * LDX
04413          IF( TRAN )THEN
04414             IOFFA = IA + ( JA + I - 2 ) * LDA
04415             DO 10 J = 1, NL
04416                YTMP = YTMP + A( IOFFA ) * X( IOFFX )
04417                GTMP = GTMP + ABS( A( IOFFA ) * X( IOFFX ) )
04418                IOFFA = IOFFA + 1
04419                IOFFX = IOFFX + INCX
04420    10       CONTINUE
04421          ELSE
04422             IOFFA = IA + I - 1 + ( JA - 1 ) * LDA
04423             DO 20 J = 1, NL
04424                YTMP = YTMP + A( IOFFA ) * X( IOFFX )
04425                GTMP = GTMP + ABS( A( IOFFA ) * X( IOFFX ) )
04426                IOFFA = IOFFA + LDA
04427                IOFFX = IOFFX + INCX
04428    20       CONTINUE
04429          END IF
04430          G( I ) = ABS( ALPHA ) * GTMP + ABS( TBETA * Y( IOFFY ) )
04431          Y( IOFFY ) = ALPHA * YTMP + TBETA * Y( IOFFY )
04432          IOFFY = IOFFY + INCY
04433    30 CONTINUE
04434 *
04435 *     Compute the error ratio for this result.
04436 *
04437       ERR  = ZERO
04438       INFO = 0
04439       LDPY = DESCY( LLD_ )
04440       IOFFY = IY + ( JY - 1 ) * LDY
04441       CALL PB_INFOG2L( IY, JY, DESCY, NPROW, NPCOL, MYROW, MYCOL, IIY,
04442      $                 JJY, IYROW, IYCOL )
04443       ICURROW = IYROW
04444       ICURCOL = IYCOL
04445       ROWREP  = ( IYROW.EQ.-1 )
04446       COLREP  = ( IYCOL.EQ.-1 )
04447 *
04448       IF( INCY.EQ.DESCY( M_ ) ) THEN
04449 *
04450 *        sub( Y ) is a row vector
04451 *
04452          JB = DESCY( INB_ ) - JY + 1
04453          IF( JB.LE.0 )
04454      $      JB = ( ( -JB ) / DESCY( NB_ ) + 1 ) * DESCY( NB_ ) + JB
04455          JB = MIN( JB, ML )
04456          JN = JY + JB - 1
04457 *
04458          DO 50 J = JY, JN
04459 *
04460             IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND.
04461      $          ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN
04462                ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) ) / EPS
04463                IF( G( J-JY+1 ).NE.ZERO )
04464      $            ERRI = ERRI / G( J-JY+1 )
04465                ERR = MAX( ERR, ERRI )
04466                IF( ERR*SQRT( EPS ).GE.ONE )
04467      $            INFO = 1
04468                JJY = JJY + 1
04469             END IF
04470 *
04471             IOFFY = IOFFY + INCY
04472 *
04473    50    CONTINUE
04474 *
04475          ICURCOL = MOD( ICURCOL+1, NPCOL )
04476 *
04477          DO 70 J = JN+1, JY+ML-1, DESCY( NB_ )
04478             JB = MIN( JY+ML-J, DESCY( NB_ ) )
04479 *
04480             DO 60 KK = 0, JB-1
04481 *
04482                IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND.
04483      $             ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN
04484                   ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) )/EPS
04485                   IF( G( J+KK-JY+1 ).NE.ZERO )
04486      $               ERRI = ERRI / G( J+KK-JY+1 )
04487                   ERR = MAX( ERR, ERRI )
04488                   IF( ERR*SQRT( EPS ).GE.ONE )
04489      $               INFO = 1
04490                   JJY = JJY + 1
04491                END IF
04492 *
04493                IOFFY = IOFFY + INCY
04494 *
04495    60       CONTINUE
04496 *
04497             ICURCOL = MOD( ICURCOL+1, NPCOL )
04498 *
04499    70    CONTINUE
04500 *
04501       ELSE
04502 *
04503 *        sub( Y ) is a column vector
04504 *
04505          IB = DESCY( IMB_ ) - IY + 1
04506          IF( IB.LE.0 )
04507      $      IB = ( ( -IB ) / DESCY( MB_ ) + 1 ) * DESCY( MB_ ) + IB
04508          IB = MIN( IB, ML )
04509          IN = IY + IB - 1
04510 *
04511          DO 80 I = IY, IN
04512 *
04513             IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND.
04514      $          ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN
04515                ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) ) / EPS
04516                IF( G( I-IY+1 ).NE.ZERO )
04517      $            ERRI = ERRI / G( I-IY+1 )
04518                ERR = MAX( ERR, ERRI )
04519                IF( ERR*SQRT( EPS ).GE.ONE )
04520      $            INFO = 1
04521                IIY = IIY + 1
04522             END IF
04523 *
04524             IOFFY = IOFFY + INCY
04525 *
04526    80    CONTINUE
04527 *
04528          ICURROW = MOD( ICURROW+1, NPROW )
04529 *
04530          DO 100 I = IN+1, IY+ML-1, DESCY( MB_ )
04531             IB = MIN( IY+ML-I, DESCY( MB_ ) )
04532 *
04533             DO 90 KK = 0, IB-1
04534 *
04535                IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND.
04536      $             ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN
04537                   ERRI = ABS( PY( IIY+(JJY-1)*LDPY ) - Y( IOFFY ) )/EPS
04538                   IF( G( I+KK-IY+1 ).NE.ZERO )
04539      $               ERRI = ERRI / G( I+KK-IY+1 )
04540                   ERR = MAX( ERR, ERRI )
04541                   IF( ERR*SQRT( EPS ).GE.ONE )
04542      $               INFO = 1
04543                   IIY = IIY + 1
04544                END IF
04545 *
04546                IOFFY = IOFFY + INCY
04547 *
04548    90       CONTINUE
04549 *
04550             ICURROW = MOD( ICURROW+1, NPROW )
04551 *
04552   100    CONTINUE
04553 *
04554       END IF
04555 *
04556 *     If INFO = 0, all results are at least half accurate.
04557 *
04558       CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL )
04559       CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
04560      $              MYCOL )
04561 *
04562       RETURN
04563 *
04564 *     End of PDMVCH
04565 *
04566       END
04567       SUBROUTINE PDVMCH( ICTXT, UPLO, M, N, ALPHA, X, IX, JX, DESCX,
04568      $                   INCX, Y, IY, JY, DESCY, INCY, A, PA, IA, JA,
04569      $                   DESCA, G, ERR, INFO )
04570 *
04571 *  -- PBLAS test routine (version 2.0) --
04572 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
04573 *     and University of California, Berkeley.
04574 *     April 1, 1998
04575 *
04576 *     .. Scalar Arguments ..
04577       CHARACTER*1        UPLO
04578       INTEGER            IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
04579      $                   JY, M, N
04580       DOUBLE PRECISION   ALPHA, ERR
04581 *     ..
04582 *     .. Array Arguments ..
04583       INTEGER            DESCA( * ), DESCX( * ), DESCY( * )
04584       DOUBLE PRECISION   A( * ), G( * ), PA( * ), X( * ), Y( * )
04585 *     ..
04586 *
04587 *  Purpose
04588 *  =======
04589 *
04590 *  PDVMCH checks the results of the computational tests.
04591 *
04592 *  Notes
04593 *  =====
04594 *
04595 *  A description  vector  is associated with each 2D block-cyclicly dis-
04596 *  tributed matrix.  This  vector  stores  the  information  required to
04597 *  establish the  mapping  between a  matrix entry and its corresponding
04598 *  process and memory location.
04599 *
04600 *  In  the  following  comments,   the character _  should  be  read  as
04601 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
04602 *  block cyclicly distributed matrix.  Its description vector is DESCA:
04603 *
04604 *  NOTATION         STORED IN       EXPLANATION
04605 *  ---------------- --------------- ------------------------------------
04606 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
04607 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
04608 *                                   the NPROW x NPCOL BLACS process grid
04609 *                                   A  is distributed over.  The context
04610 *                                   itself  is  global,  but  the handle
04611 *                                   (the integer value) may vary.
04612 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
04613 *                                   ted matrix A, M_A >= 0.
04614 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
04615 *                                   buted matrix A, N_A >= 0.
04616 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
04617 *                                   block of the matrix A, IMB_A > 0.
04618 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
04619 *                                   left   block   of   the   matrix  A,
04620 *                                   INB_A > 0.
04621 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
04622 *                                   bute the last  M_A-IMB_A rows of  A,
04623 *                                   MB_A > 0.
04624 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
04625 *                                   bute the last  N_A-INB_A  columns of
04626 *                                   A, NB_A > 0.
04627 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
04628 *                                   row of the matrix  A is distributed,
04629 *                                   NPROW > RSRC_A >= 0.
04630 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
04631 *                                   first  column of  A  is distributed.
04632 *                                   NPCOL > CSRC_A >= 0.
04633 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
04634 *                                   array  storing  the  local blocks of
04635 *                                   the distributed matrix A,
04636 *                                   IF( Lc( 1, N_A ) > 0 )
04637 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
04638 *                                   ELSE
04639 *                                      LLD_A >= 1.
04640 *
04641 *  Let K be the number of  rows of a matrix A starting at the global in-
04642 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
04643 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
04644 *  receive if these K rows were distributed over NPROW processes.  If  K
04645 *  is the number of columns of a matrix  A  starting at the global index
04646 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
04647 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
04648 *  these K columns were distributed over NPCOL processes.
04649 *
04650 *  The values of Lr() and Lc() may be determined via a call to the func-
04651 *  tion PB_NUMROC:
04652 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
04653 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
04654 *
04655 *  Arguments
04656 *  =========
04657 *
04658 *  ICTXT   (local input) INTEGER
04659 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
04660 *          ting the global  context of the operation. The context itself
04661 *          is global, but the value of ICTXT is local.
04662 *
04663 *  UPLO    (global input) CHARACTER*1
04664 *          On entry, UPLO specifies which part of the submatrix sub( A )
04665 *          is to be referenced as follows:
04666 *             If UPLO = 'L', only the lower triangular part,
04667 *             If UPLO = 'U', only the upper triangular part,
04668 *             else the entire matrix is to be referenced.
04669 *
04670 *  M       (global input) INTEGER
04671 *          On entry,  M  specifies  the  number of rows of the submatrix
04672 *          operand matrix A. M must be at least zero.
04673 *
04674 *  N       (global input) INTEGER
04675 *          On entry,  N  specifies  the  number of columns of the subma-
04676 *          trix operand matrix A. N must be at least zero.
04677 *
04678 *  ALPHA   (global input) DOUBLE PRECISION
04679 *          On entry, ALPHA specifies the scalar alpha.
04680 *
04681 *  X       (local input) DOUBLE PRECISION array
04682 *          On entry, X is an array of  dimension  (DESCX( M_ ),*).  This
04683 *          array contains a local copy of the initial entire matrix PX.
04684 *
04685 *  IX      (global input) INTEGER
04686 *          On entry, IX  specifies X's global row index, which points to
04687 *          the beginning of the submatrix sub( X ).
04688 *
04689 *  JX      (global input) INTEGER
04690 *          On entry, JX  specifies X's global column index, which points
04691 *          to the beginning of the submatrix sub( X ).
04692 *
04693 *  DESCX   (global and local input) INTEGER array
04694 *          On entry, DESCX  is an integer array of dimension DLEN_. This
04695 *          is the array descriptor for the matrix X.
04696 *
04697 *  INCX    (global input) INTEGER
04698 *          On entry,  INCX   specifies  the  global  increment  for  the
04699 *          elements of  X.  Only two values of  INCX   are  supported in
04700 *          this version, namely 1 and M_X. INCX  must not be zero.
04701 *
04702 *  Y       (local input) DOUBLE PRECISION array
04703 *          On entry, Y is an array of  dimension  (DESCY( M_ ),*).  This
04704 *          array contains a local copy of the initial entire matrix PY.
04705 *
04706 *  IY      (global input) INTEGER
04707 *          On entry, IY  specifies Y's global row index, which points to
04708 *          the beginning of the submatrix sub( Y ).
04709 *
04710 *  JY      (global input) INTEGER
04711 *          On entry, JY  specifies Y's global column index, which points
04712 *          to the beginning of the submatrix sub( Y ).
04713 *
04714 *  DESCY   (global and local input) INTEGER array
04715 *          On entry, DESCY  is an integer array of dimension DLEN_. This
04716 *          is the array descriptor for the matrix Y.
04717 *
04718 *  INCY    (global input) INTEGER
04719 *          On entry,  INCY   specifies  the  global  increment  for  the
04720 *          elements of  Y.  Only two values of  INCY   are  supported in
04721 *          this version, namely 1 and M_Y. INCY  must not be zero.
04722 *
04723 *  A       (local input/local output) DOUBLE PRECISION array
04724 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
04725 *          array contains a local copy of the initial entire matrix PA.
04726 *
04727 *  PA      (local input) DOUBLE PRECISION array
04728 *          On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
04729 *          array contains the local entries of the matrix PA.
04730 *
04731 *  IA      (global input) INTEGER
04732 *          On entry, IA  specifies A's global row index, which points to
04733 *          the beginning of the submatrix sub( A ).
04734 *
04735 *  JA      (global input) INTEGER
04736 *          On entry, JA  specifies A's global column index, which points
04737 *          to the beginning of the submatrix sub( A ).
04738 *
04739 *  DESCA   (global and local input) INTEGER array
04740 *          On entry, DESCA  is an integer array of dimension DLEN_. This
04741 *          is the array descriptor for the matrix A.
04742 *
04743 *  G       (workspace) DOUBLE PRECISION array
04744 *          On entry, G is an array of dimension at least MAX( M, N ).  G
04745 *          is used to compute the gauges.
04746 *
04747 *  ERR     (global output) DOUBLE PRECISION
04748 *          On exit, ERR specifies the largest error in absolute value.
04749 *
04750 *  INFO    (global output) INTEGER
04751 *          On exit, if INFO <> 0, the result is less than half accurate.
04752 *
04753 *  -- Written on April 1, 1998 by
04754 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
04755 *
04756 *  =====================================================================
04757 *
04758 *     .. Parameters ..
04759       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
04760      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
04761      $                   RSRC_
04762       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
04763      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
04764      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
04765      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
04766       DOUBLE PRECISION   ZERO, ONE
04767       PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
04768 *     ..
04769 *     .. Local Scalars ..
04770       LOGICAL            COLREP, LOWER, ROWREP, UPPER
04771       INTEGER            I, IACOL, IAROW, IB, IBEG, ICURROW, IEND, IIA,
04772      $                   IN, IOFFA, IOFFX, IOFFY, J, JJA, KK, LDA, LDPA,
04773      $                   LDX, LDY, MYCOL, MYROW, NPCOL, NPROW
04774       DOUBLE PRECISION   ATMP, EPS, ERRI, GTMP
04775 *     ..
04776 *     .. External Subroutines ..
04777       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L
04778 *     ..
04779 *     .. External Functions ..
04780       LOGICAL            LSAME
04781       DOUBLE PRECISION   PDLAMCH
04782       EXTERNAL           LSAME, PDLAMCH
04783 *     ..
04784 *     .. Intrinsic Functions ..
04785       INTRINSIC          ABS, MAX, MIN, MOD, SQRT
04786 *     ..
04787 *     .. Executable Statements ..
04788 *
04789       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
04790 *
04791       EPS = PDLAMCH( ICTXT, 'eps' )
04792 *
04793       UPPER = LSAME( UPLO, 'U' )
04794       LOWER = LSAME( UPLO, 'L' )
04795 *
04796       LDA = MAX( 1, DESCA( M_ ) )
04797       LDX = MAX( 1, DESCX( M_ ) )
04798       LDY = MAX( 1, DESCY( M_ ) )
04799 *
04800 *     Compute expected result in A using data in A, X and Y.
04801 *     Compute gauges in G. This part of the computation is performed
04802 *     by every process in the grid.
04803 *
04804       DO 70 J = 1, N
04805 *
04806          IOFFY = IY + ( JY - 1 ) * LDY + ( J - 1 ) * INCY
04807 *
04808          IF( LOWER ) THEN
04809             IBEG = J
04810             IEND = M
04811             DO 10 I = 1, J-1
04812                G( I ) = ZERO
04813    10       CONTINUE
04814          ELSE IF( UPPER ) THEN
04815             IBEG = 1
04816             IEND = J
04817             DO 20 I = J+1, M
04818                G( I ) = ZERO
04819    20       CONTINUE
04820          ELSE
04821             IBEG = 1
04822             IEND = M
04823          END IF
04824 *
04825          DO 30 I = IBEG, IEND
04826 *
04827             IOFFX = IX + ( JX - 1 ) * LDX + ( I - 1 ) * INCX
04828             IOFFA = IA + I - 1 + ( JA + J - 2 ) * LDA
04829             ATMP = X( IOFFX ) * Y( IOFFY )
04830             GTMP = ABS( X( IOFFX ) * Y( IOFFY ) )
04831             G( I ) = ABS( ALPHA ) * GTMP + ABS( A( IOFFA ) )
04832             A( IOFFA ) = ALPHA * ATMP + A( IOFFA )
04833 *
04834    30    CONTINUE
04835 *
04836 *        Compute the error ratio for this result.
04837 *
04838          INFO = 0
04839          ERR  = ZERO
04840          LDPA = DESCA( LLD_ )
04841          IOFFA = IA + ( JA + J - 2 ) * LDA
04842          CALL PB_INFOG2L( IA, JA+J-1, DESCA, NPROW, NPCOL, MYROW, MYCOL,
04843      $                    IIA, JJA, IAROW, IACOL )
04844          ROWREP = ( IAROW.EQ.-1 )
04845          COLREP = ( IACOL.EQ.-1 )
04846 *
04847          IF( MYCOL.EQ.IACOL .OR. COLREP ) THEN
04848 *
04849             ICURROW = IAROW
04850             IB = DESCA( IMB_ ) - IA + 1
04851             IF( IB.LE.0 )
04852      $         IB = ( ( -IB ) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
04853             IB = MIN( IB, M )
04854             IN = IA + IB - 1
04855 *
04856             DO 40 I = IA, IN
04857 *
04858                IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
04859                   ERRI = ABS( PA( IIA+(JJA-1)*LDPA ) - A( IOFFA ) )/EPS
04860                   IF( G( I-IA+1 ).NE.ZERO )
04861      $               ERRI = ERRI / G( I-IA+1 )
04862                   ERR = MAX( ERR, ERRI )
04863                   IF( ERR*SQRT( EPS ).GE.ONE )
04864      $               INFO = 1
04865                   IIA = IIA + 1
04866                END IF
04867 *
04868                IOFFA = IOFFA + 1
04869 *
04870    40       CONTINUE
04871 *
04872             ICURROW = MOD( ICURROW+1, NPROW )
04873 *
04874             DO 60 I = IN+1, IA+M-1, DESCA( MB_ )
04875                IB = MIN( IA+M-I, DESCA( MB_ ) )
04876 *
04877                DO 50 KK = 0, IB-1
04878 *
04879                   IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
04880                      ERRI = ABS( PA( IIA+(JJA-1)*LDPA )-A( IOFFA ) )/EPS
04881                      IF( G( I+KK-IA+1 ).NE.ZERO )
04882      $                  ERRI = ERRI / G( I+KK-IA+1 )
04883                      ERR = MAX( ERR, ERRI )
04884                      IF( ERR*SQRT( EPS ).GE.ONE )
04885      $                  INFO = 1
04886                      IIA = IIA + 1
04887                   END IF
04888 *
04889                   IOFFA = IOFFA + 1
04890 *
04891    50          CONTINUE
04892 *
04893                ICURROW = MOD( ICURROW+1, NPROW )
04894 *
04895    60       CONTINUE
04896 *
04897          END IF
04898 *
04899 *        If INFO = 0, all results are at least half accurate.
04900 *
04901          CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL )
04902          CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
04903      $                 MYCOL )
04904          IF( INFO.NE.0 )
04905      $      GO TO 80
04906 *
04907    70 CONTINUE
04908 *
04909    80 CONTINUE
04910 *
04911       RETURN
04912 *
04913 *     End of PDVMCH
04914 *
04915       END
04916       SUBROUTINE PDVMCH2( ICTXT, UPLO, M, N, ALPHA, X, IX, JX, DESCX,
04917      $                    INCX, Y, IY, JY, DESCY, INCY, A, PA, IA,
04918      $                    JA, DESCA, G, ERR, INFO )
04919 *
04920 *  -- PBLAS test routine (version 2.0) --
04921 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
04922 *     and University of California, Berkeley.
04923 *     April 1, 1998
04924 *
04925 *     .. Scalar Arguments ..
04926       CHARACTER*1        UPLO
04927       INTEGER            IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
04928      $                   JY, M, N
04929       DOUBLE PRECISION   ALPHA, ERR
04930 *     ..
04931 *     .. Array Arguments ..
04932       INTEGER            DESCA( * ), DESCX( * ), DESCY( * )
04933       DOUBLE PRECISION   A( * ), G( * ), PA( * ), X( * ), Y( * )
04934 *     ..
04935 *
04936 *  Purpose
04937 *  =======
04938 *
04939 *  PDVMCH2 checks the results of the computational tests.
04940 *
04941 *  Notes
04942 *  =====
04943 *
04944 *  A description  vector  is associated with each 2D block-cyclicly dis-
04945 *  tributed matrix.  This  vector  stores  the  information  required to
04946 *  establish the  mapping  between a  matrix entry and its corresponding
04947 *  process and memory location.
04948 *
04949 *  In  the  following  comments,   the character _  should  be  read  as
04950 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
04951 *  block cyclicly distributed matrix.  Its description vector is DESCA:
04952 *
04953 *  NOTATION         STORED IN       EXPLANATION
04954 *  ---------------- --------------- ------------------------------------
04955 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
04956 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
04957 *                                   the NPROW x NPCOL BLACS process grid
04958 *                                   A  is distributed over.  The context
04959 *                                   itself  is  global,  but  the handle
04960 *                                   (the integer value) may vary.
04961 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
04962 *                                   ted matrix A, M_A >= 0.
04963 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
04964 *                                   buted matrix A, N_A >= 0.
04965 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
04966 *                                   block of the matrix A, IMB_A > 0.
04967 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
04968 *                                   left   block   of   the   matrix  A,
04969 *                                   INB_A > 0.
04970 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
04971 *                                   bute the last  M_A-IMB_A rows of  A,
04972 *                                   MB_A > 0.
04973 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
04974 *                                   bute the last  N_A-INB_A  columns of
04975 *                                   A, NB_A > 0.
04976 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
04977 *                                   row of the matrix  A is distributed,
04978 *                                   NPROW > RSRC_A >= 0.
04979 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
04980 *                                   first  column of  A  is distributed.
04981 *                                   NPCOL > CSRC_A >= 0.
04982 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
04983 *                                   array  storing  the  local blocks of
04984 *                                   the distributed matrix A,
04985 *                                   IF( Lc( 1, N_A ) > 0 )
04986 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
04987 *                                   ELSE
04988 *                                      LLD_A >= 1.
04989 *
04990 *  Let K be the number of  rows of a matrix A starting at the global in-
04991 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
04992 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
04993 *  receive if these K rows were distributed over NPROW processes.  If  K
04994 *  is the number of columns of a matrix  A  starting at the global index
04995 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
04996 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
04997 *  these K columns were distributed over NPCOL processes.
04998 *
04999 *  The values of Lr() and Lc() may be determined via a call to the func-
05000 *  tion PB_NUMROC:
05001 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
05002 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
05003 *
05004 *  Arguments
05005 *  =========
05006 *
05007 *  ICTXT   (local input) INTEGER
05008 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
05009 *          ting the global  context of the operation. The context itself
05010 *          is global, but the value of ICTXT is local.
05011 *
05012 *  UPLO    (global input) CHARACTER*1
05013 *          On entry, UPLO specifies which part of the submatrix sub( A )
05014 *          is to be referenced as follows:
05015 *             If UPLO = 'L', only the lower triangular part,
05016 *             If UPLO = 'U', only the upper triangular part,
05017 *             else the entire matrix is to be referenced.
05018 *
05019 *  M       (global input) INTEGER
05020 *          On entry,  M  specifies  the  number of rows of the submatrix
05021 *          operand matrix A. M must be at least zero.
05022 *
05023 *  N       (global input) INTEGER
05024 *          On entry,  N  specifies  the  number of columns of the subma-
05025 *          trix operand matrix A. N must be at least zero.
05026 *
05027 *  ALPHA   (global input) DOUBLE PRECISION
05028 *          On entry, ALPHA specifies the scalar alpha.
05029 *
05030 *  X       (local input) DOUBLE PRECISION array
05031 *          On entry, X is an array of  dimension  (DESCX( M_ ),*).  This
05032 *          array contains a local copy of the initial entire matrix PX.
05033 *
05034 *  IX      (global input) INTEGER
05035 *          On entry, IX  specifies X's global row index, which points to
05036 *          the beginning of the submatrix sub( X ).
05037 *
05038 *  JX      (global input) INTEGER
05039 *          On entry, JX  specifies X's global column index, which points
05040 *          to the beginning of the submatrix sub( X ).
05041 *
05042 *  DESCX   (global and local input) INTEGER array
05043 *          On entry, DESCX  is an integer array of dimension DLEN_. This
05044 *          is the array descriptor for the matrix X.
05045 *
05046 *  INCX    (global input) INTEGER
05047 *          On entry,  INCX   specifies  the  global  increment  for  the
05048 *          elements of  X.  Only two values of  INCX   are  supported in
05049 *          this version, namely 1 and M_X. INCX  must not be zero.
05050 *
05051 *  Y       (local input) DOUBLE PRECISION array
05052 *          On entry, Y is an array of  dimension  (DESCY( M_ ),*).  This
05053 *          array contains a local copy of the initial entire matrix PY.
05054 *
05055 *  IY      (global input) INTEGER
05056 *          On entry, IY  specifies Y's global row index, which points to
05057 *          the beginning of the submatrix sub( Y ).
05058 *
05059 *  JY      (global input) INTEGER
05060 *          On entry, JY  specifies Y's global column index, which points
05061 *          to the beginning of the submatrix sub( Y ).
05062 *
05063 *  DESCY   (global and local input) INTEGER array
05064 *          On entry, DESCY  is an integer array of dimension DLEN_. This
05065 *          is the array descriptor for the matrix Y.
05066 *
05067 *  INCY    (global input) INTEGER
05068 *          On entry,  INCY   specifies  the  global  increment  for  the
05069 *          elements of  Y.  Only two values of  INCY   are  supported in
05070 *          this version, namely 1 and M_Y. INCY  must not be zero.
05071 *
05072 *  A       (local input/local output) DOUBLE PRECISION array
05073 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
05074 *          array contains a local copy of the initial entire matrix PA.
05075 *
05076 *  PA      (local input) DOUBLE PRECISION array
05077 *          On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
05078 *          array contains the local entries of the matrix PA.
05079 *
05080 *  IA      (global input) INTEGER
05081 *          On entry, IA  specifies A's global row index, which points to
05082 *          the beginning of the submatrix sub( A ).
05083 *
05084 *  JA      (global input) INTEGER
05085 *          On entry, JA  specifies A's global column index, which points
05086 *          to the beginning of the submatrix sub( A ).
05087 *
05088 *  DESCA   (global and local input) INTEGER array
05089 *          On entry, DESCA  is an integer array of dimension DLEN_. This
05090 *          is the array descriptor for the matrix A.
05091 *
05092 *  G       (workspace) DOUBLE PRECISION array
05093 *          On entry, G is an array of dimension at least MAX( M, N ).  G
05094 *          is used to compute the gauges.
05095 *
05096 *  ERR     (global output) DOUBLE PRECISION
05097 *          On exit, ERR specifies the largest error in absolute value.
05098 *
05099 *  INFO    (global output) INTEGER
05100 *          On exit, if INFO <> 0, the result is less than half accurate.
05101 *
05102 *  -- Written on April 1, 1998 by
05103 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
05104 *
05105 *  =====================================================================
05106 *
05107 *     .. Parameters ..
05108       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
05109      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
05110      $                   RSRC_
05111       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
05112      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
05113      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
05114      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
05115       DOUBLE PRECISION   ZERO, ONE
05116       PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
05117 *     ..
05118 *     .. Local Scalars ..
05119       LOGICAL            COLREP, LOWER, ROWREP, UPPER
05120       INTEGER            I, IACOL, IAROW, IB, IBEG, ICURROW, IEND, IIA,
05121      $                   IN, IOFFA, IOFFXI, IOFFXJ, IOFFYI, IOFFYJ, J,
05122      $                   JJA, KK, LDA, LDPA, LDX, LDY, MYCOL, MYROW,
05123      $                   NPCOL, NPROW
05124       DOUBLE PRECISION   EPS, ERRI, GTMP, ATMP
05125 *     ..
05126 *     .. External Subroutines ..
05127       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L
05128 *     ..
05129 *     .. External Functions ..
05130       LOGICAL            LSAME
05131       DOUBLE PRECISION   PDLAMCH
05132       EXTERNAL           LSAME, PDLAMCH
05133 *     ..
05134 *     .. Intrinsic Functions ..
05135       INTRINSIC          ABS, MAX, MIN, MOD, SQRT
05136 *     ..
05137 *     .. Executable Statements ..
05138 *
05139       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
05140 *
05141       EPS = PDLAMCH( ICTXT, 'eps' )
05142 *
05143       UPPER = LSAME( UPLO, 'U' )
05144       LOWER = LSAME( UPLO, 'L' )
05145 *
05146       LDA = MAX( 1, DESCA( M_ ) )
05147       LDX = MAX( 1, DESCX( M_ ) )
05148       LDY = MAX( 1, DESCY( M_ ) )
05149 *
05150 *     Compute expected result in A using data in A, X and Y.
05151 *     Compute gauges in G. This part of the computation is performed
05152 *     by every process in the grid.
05153 *
05154       DO 70 J = 1, N
05155 *
05156          IOFFXJ = IX + ( JX - 1 ) * LDX + ( J - 1 ) * INCX
05157          IOFFYJ = IY + ( JY - 1 ) * LDY + ( J - 1 ) * INCY
05158 *
05159          IF( LOWER ) THEN
05160             IBEG = J
05161             IEND = M
05162             DO 10 I = 1, J-1
05163                G( I ) = ZERO
05164    10       CONTINUE
05165          ELSE IF( UPPER ) THEN
05166             IBEG = 1
05167             IEND = J
05168             DO 20 I = J+1, M
05169                G( I ) = ZERO
05170    20       CONTINUE
05171          ELSE
05172             IBEG = 1
05173             IEND = M
05174          END IF
05175 *
05176          DO 30 I = IBEG, IEND
05177             IOFFA = IA + I - 1 + ( JA + J - 2 ) * LDA
05178             IOFFXI = IX + ( JX - 1 ) * LDX + ( I - 1 ) * INCX
05179             IOFFYI = IY + ( JY - 1 ) * LDY + ( I - 1 ) * INCY
05180             ATMP = X( IOFFXI ) * Y( IOFFYJ )
05181             ATMP = ATMP + Y( IOFFYI ) * X( IOFFXJ )
05182             GTMP = ABS( X( IOFFXI ) * Y( IOFFYJ ) )
05183             GTMP = GTMP + ABS( Y( IOFFYI ) * X( IOFFXJ ) )
05184             G( I ) = ABS( ALPHA ) * GTMP + ABS( A( IOFFA ) )
05185             A( IOFFA ) = ALPHA*ATMP + A( IOFFA )
05186 *
05187    30    CONTINUE
05188 *
05189 *        Compute the error ratio for this result.
05190 *
05191          INFO = 0
05192          ERR  = ZERO
05193          LDPA = DESCA( LLD_ )
05194          IOFFA = IA + ( JA + J - 2 ) * LDA
05195          CALL PB_INFOG2L( IA, JA+J-1, DESCA, NPROW, NPCOL, MYROW, MYCOL,
05196      $                    IIA, JJA, IAROW, IACOL )
05197          ROWREP = ( IAROW.EQ.-1 )
05198          COLREP = ( IACOL.EQ.-1 )
05199 *
05200          IF( MYCOL.EQ.IACOL .OR. COLREP ) THEN
05201 *
05202             ICURROW = IAROW
05203             IB = DESCA( IMB_ ) - IA + 1
05204             IF( IB.LE.0 )
05205      $         IB = ( ( -IB ) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
05206             IB = MIN( IB, M )
05207             IN = IA + IB - 1
05208 *
05209             DO 40 I = IA, IN
05210 *
05211                IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
05212                   ERRI = ABS( PA( IIA+(JJA-1)*LDPA ) - A( IOFFA ) )/EPS
05213                   IF( G( I-IA+1 ).NE.ZERO )
05214      $               ERRI = ERRI / G( I-IA+1 )
05215                   ERR = MAX( ERR, ERRI )
05216                   IF( ERR*SQRT( EPS ).GE.ONE )
05217      $               INFO = 1
05218                   IIA = IIA + 1
05219                END IF
05220 *
05221                IOFFA = IOFFA + 1
05222 *
05223    40       CONTINUE
05224 *
05225             ICURROW = MOD( ICURROW+1, NPROW )
05226 *
05227             DO 60 I = IN+1, IA+M-1, DESCA( MB_ )
05228                IB = MIN( IA+M-I, DESCA( MB_ ) )
05229 *
05230                DO 50 KK = 0, IB-1
05231 *
05232                   IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
05233                      ERRI = ABS( PA( IIA+(JJA-1)*LDPA )-A( IOFFA ) )/EPS
05234                      IF( G( I+KK-IA+1 ).NE.ZERO )
05235      $                  ERRI = ERRI / G( I+KK-IA+1 )
05236                      ERR = MAX( ERR, ERRI )
05237                      IF( ERR*SQRT( EPS ).GE.ONE )
05238      $                  INFO = 1
05239                      IIA = IIA + 1
05240                   END IF
05241 *
05242                   IOFFA = IOFFA + 1
05243 *
05244    50          CONTINUE
05245 *
05246                ICURROW = MOD( ICURROW+1, NPROW )
05247 *
05248    60       CONTINUE
05249 *
05250          END IF
05251 *
05252 *        If INFO = 0, all results are at least half accurate.
05253 *
05254          CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL )
05255          CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
05256      $                 MYCOL )
05257          IF( INFO.NE.0 )
05258      $      GO TO 80
05259 *
05260    70 CONTINUE
05261 *
05262    80 CONTINUE
05263 *
05264       RETURN
05265 *
05266 *     End of PDVMCH2
05267 *
05268       END
05269       SUBROUTINE PDMMCH( ICTXT, TRANSA, TRANSB, M, N, K, ALPHA, A, IA,
05270      $                   JA, DESCA, B, IB, JB, DESCB, BETA, C, PC, IC,
05271      $                   JC, DESCC, CT, G, ERR, INFO )
05272 *
05273 *  -- PBLAS test routine (version 2.0) --
05274 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
05275 *     and University of California, Berkeley.
05276 *     April 1, 1998
05277 *
05278 *     .. Scalar Arguments ..
05279       CHARACTER*1        TRANSA, TRANSB
05280       INTEGER            IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, M, N
05281       DOUBLE PRECISION   ALPHA, BETA, ERR
05282 *     ..
05283 *     .. Array Arguments ..
05284       INTEGER            DESCA( * ), DESCB( * ), DESCC( * )
05285       DOUBLE PRECISION   A( * ), B( * ), C( * ), CT( * ), G( * ),
05286      $                   PC( * )
05287 *     ..
05288 *
05289 *  Purpose
05290 *  =======
05291 *
05292 *  PDMMCH checks the results of the computational tests.
05293 *
05294 *  Notes
05295 *  =====
05296 *
05297 *  A description  vector  is associated with each 2D block-cyclicly dis-
05298 *  tributed matrix.  This  vector  stores  the  information  required to
05299 *  establish the  mapping  between a  matrix entry and its corresponding
05300 *  process and memory location.
05301 *
05302 *  In  the  following  comments,   the character _  should  be  read  as
05303 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
05304 *  block cyclicly distributed matrix.  Its description vector is DESCA:
05305 *
05306 *  NOTATION         STORED IN       EXPLANATION
05307 *  ---------------- --------------- ------------------------------------
05308 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
05309 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
05310 *                                   the NPROW x NPCOL BLACS process grid
05311 *                                   A  is distributed over.  The context
05312 *                                   itself  is  global,  but  the handle
05313 *                                   (the integer value) may vary.
05314 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
05315 *                                   ted matrix A, M_A >= 0.
05316 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
05317 *                                   buted matrix A, N_A >= 0.
05318 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
05319 *                                   block of the matrix A, IMB_A > 0.
05320 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
05321 *                                   left   block   of   the   matrix  A,
05322 *                                   INB_A > 0.
05323 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
05324 *                                   bute the last  M_A-IMB_A rows of  A,
05325 *                                   MB_A > 0.
05326 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
05327 *                                   bute the last  N_A-INB_A  columns of
05328 *                                   A, NB_A > 0.
05329 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
05330 *                                   row of the matrix  A is distributed,
05331 *                                   NPROW > RSRC_A >= 0.
05332 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
05333 *                                   first  column of  A  is distributed.
05334 *                                   NPCOL > CSRC_A >= 0.
05335 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
05336 *                                   array  storing  the  local blocks of
05337 *                                   the distributed matrix A,
05338 *                                   IF( Lc( 1, N_A ) > 0 )
05339 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
05340 *                                   ELSE
05341 *                                      LLD_A >= 1.
05342 *
05343 *  Let K be the number of  rows of a matrix A starting at the global in-
05344 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
05345 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
05346 *  receive if these K rows were distributed over NPROW processes.  If  K
05347 *  is the number of columns of a matrix  A  starting at the global index
05348 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
05349 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
05350 *  these K columns were distributed over NPCOL processes.
05351 *
05352 *  The values of Lr() and Lc() may be determined via a call to the func-
05353 *  tion PB_NUMROC:
05354 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
05355 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
05356 *
05357 *  Arguments
05358 *  =========
05359 *
05360 *  ICTXT   (local input) INTEGER
05361 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
05362 *          ting the global  context of the operation. The context itself
05363 *          is global, but the value of ICTXT is local.
05364 *
05365 *  TRANSA  (global input) CHARACTER*1
05366 *          On entry, TRANSA specifies if the matrix  operand  A is to be
05367 *          transposed.
05368 *
05369 *  TRANSB  (global input) CHARACTER*1
05370 *          On entry, TRANSB specifies if the matrix  operand  B is to be
05371 *          transposed.
05372 *
05373 *  M       (global input) INTEGER
05374 *          On entry, M specifies the number of rows of C.
05375 *
05376 *  N       (global input) INTEGER
05377 *          On entry, N specifies the number of columns of C.
05378 *
05379 *  K       (global input) INTEGER
05380 *          On entry, K specifies the number of columns (resp. rows) of A
05381 *          when  TRANSA = 'N'  (resp. TRANSA <> 'N')  in PxGEMM, PxSYRK,
05382 *          PxSYR2K, PxHERK and PxHER2K.
05383 *
05384 *  ALPHA   (global input) DOUBLE PRECISION
05385 *          On entry, ALPHA specifies the scalar alpha.
05386 *
05387 *  A       (local input) DOUBLE PRECISION array
05388 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
05389 *          array contains a local copy of the initial entire matrix PA.
05390 *
05391 *  IA      (global input) INTEGER
05392 *          On entry, IA  specifies A's global row index, which points to
05393 *          the beginning of the submatrix sub( A ).
05394 *
05395 *  JA      (global input) INTEGER
05396 *          On entry, JA  specifies A's global column index, which points
05397 *          to the beginning of the submatrix sub( A ).
05398 *
05399 *  DESCA   (global and local input) INTEGER array
05400 *          On entry, DESCA  is an integer array of dimension DLEN_. This
05401 *          is the array descriptor for the matrix A.
05402 *
05403 *  B       (local input) DOUBLE PRECISION array
05404 *          On entry, B is an array of  dimension  (DESCB( M_ ),*).  This
05405 *          array contains a local copy of the initial entire matrix PB.
05406 *
05407 *  IB      (global input) INTEGER
05408 *          On entry, IB  specifies B's global row index, which points to
05409 *          the beginning of the submatrix sub( B ).
05410 *
05411 *  JB      (global input) INTEGER
05412 *          On entry, JB  specifies B's global column index, which points
05413 *          to the beginning of the submatrix sub( B ).
05414 *
05415 *  DESCB   (global and local input) INTEGER array
05416 *          On entry, DESCB  is an integer array of dimension DLEN_. This
05417 *          is the array descriptor for the matrix B.
05418 *
05419 *  BETA    (global input) DOUBLE PRECISION
05420 *          On entry, BETA specifies the scalar beta.
05421 *
05422 *  C       (local input/local output) DOUBLE PRECISION array
05423 *          On entry, C is an array of  dimension  (DESCC( M_ ),*).  This
05424 *          array contains a local copy of the initial entire matrix PC.
05425 *
05426 *  PC      (local input) DOUBLE PRECISION array
05427 *          On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
05428 *          array contains the local pieces of the matrix PC.
05429 *
05430 *  IC      (global input) INTEGER
05431 *          On entry, IC  specifies C's global row index, which points to
05432 *          the beginning of the submatrix sub( C ).
05433 *
05434 *  JC      (global input) INTEGER
05435 *          On entry, JC  specifies C's global column index, which points
05436 *          to the beginning of the submatrix sub( C ).
05437 *
05438 *  DESCC   (global and local input) INTEGER array
05439 *          On entry, DESCC  is an integer array of dimension DLEN_. This
05440 *          is the array descriptor for the matrix C.
05441 *
05442 *  CT      (workspace) DOUBLE PRECISION array
05443 *          On entry, CT is an array of dimension at least MAX(M,N,K). CT
05444 *          holds a copy of the current column of C.
05445 *
05446 *  G       (workspace) DOUBLE PRECISION array
05447 *          On entry, G  is  an array of dimension at least MAX(M,N,K). G
05448 *          is used to compute the gauges.
05449 *
05450 *  ERR     (global output) DOUBLE PRECISION
05451 *          On exit, ERR specifies the largest error in absolute value.
05452 *
05453 *  INFO    (global output) INTEGER
05454 *          On exit, if INFO <> 0, the result is less than half accurate.
05455 *
05456 *  -- Written on April 1, 1998 by
05457 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
05458 *
05459 *  =====================================================================
05460 *
05461 *     .. Parameters ..
05462       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
05463      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
05464      $                   RSRC_
05465       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
05466      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
05467      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
05468      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
05469       DOUBLE PRECISION   ZERO, ONE
05470       PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
05471 *     ..
05472 *     .. Local Scalars ..
05473       LOGICAL            COLREP, ROWREP, TRANA, TRANB
05474       INTEGER            I, IBB, ICCOL, ICROW, ICURROW, IIC, IN, IOFFA,
05475      $                   IOFFB, IOFFC, J, JJC, KK, LDA, LDB, LDC, LDPC,
05476      $                   MYCOL, MYROW, NPCOL, NPROW
05477       DOUBLE PRECISION   EPS, ERRI
05478 *     ..
05479 *     .. External Subroutines ..
05480       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L
05481 *     ..
05482 *     .. External Functions ..
05483       LOGICAL            LSAME
05484       DOUBLE PRECISION   PDLAMCH
05485       EXTERNAL           LSAME, PDLAMCH
05486 *     ..
05487 *     .. Intrinsic Functions ..
05488       INTRINSIC          ABS, MAX, MIN, MOD, SQRT
05489 *     ..
05490 *     .. Executable Statements ..
05491 *
05492       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
05493 *
05494       EPS = PDLAMCH( ICTXT, 'eps' )
05495 *
05496       TRANA = LSAME( TRANSA, 'T' ).OR.LSAME( TRANSA, 'C' )
05497       TRANB = LSAME( TRANSB, 'T' ).OR.LSAME( TRANSB, 'C' )
05498 *
05499       LDA = MAX( 1, DESCA( M_ ) )
05500       LDB = MAX( 1, DESCB( M_ ) )
05501       LDC = MAX( 1, DESCC( M_ ) )
05502 *
05503 *     Compute expected result in C using data in A, B and C.
05504 *     Compute gauges in G. This part of the computation is performed
05505 *     by every process in the grid.
05506 *
05507       DO 240 J = 1, N
05508 *
05509          IOFFC = IC + ( JC + J - 2 ) * LDC
05510          DO 10 I = 1, M
05511             CT( I ) = ZERO
05512             G( I )  = ZERO
05513    10    CONTINUE
05514 *
05515          IF( .NOT.TRANA .AND. .NOT.TRANB ) THEN
05516             DO 30 KK = 1, K
05517                IOFFB = IB + KK - 1 + ( JB + J - 2 ) * LDB
05518                DO 20 I = 1, M
05519                   IOFFA = IA + I - 1 + ( JA + KK - 2 ) * LDA
05520                   CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB )
05521                   G( I ) = G( I ) + ABS( A( IOFFA ) ) *
05522      $                     ABS( B( IOFFB ) )
05523    20          CONTINUE
05524    30       CONTINUE
05525          ELSE IF( TRANA .AND. .NOT.TRANB ) THEN
05526             DO 50 KK = 1, K
05527                IOFFB = IB + KK - 1 + ( JB + J - 2 ) * LDB
05528                DO 40 I = 1, M
05529                   IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA
05530                   CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB )
05531                   G( I ) = G( I ) + ABS( A( IOFFA ) ) *
05532      $                     ABS( B( IOFFB ) )
05533    40          CONTINUE
05534    50       CONTINUE
05535          ELSE IF( .NOT.TRANA .AND. TRANB ) THEN
05536             DO 70 KK = 1, K
05537                IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB
05538                DO 60 I = 1, M
05539                   IOFFA = IA + I - 1 + ( JA + KK - 2 ) * LDA
05540                   CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB )
05541                   G( I ) = G( I ) + ABS( A( IOFFA ) ) *
05542      $                     ABS( B( IOFFB ) )
05543    60          CONTINUE
05544    70       CONTINUE
05545          ELSE IF( TRANA .AND. TRANB ) THEN
05546             DO 90 KK = 1, K
05547                IOFFB = IB + J - 1 + ( JB + KK - 2 ) * LDB
05548                DO 80 I = 1, M
05549                   IOFFA = IA + KK - 1 + ( JA + I - 2 ) * LDA
05550                   CT( I ) = CT( I ) + A( IOFFA ) * B( IOFFB )
05551                   G( I ) = G( I ) + ABS( A( IOFFA ) ) *
05552      $                     ABS( B( IOFFB ) )
05553    80          CONTINUE
05554    90       CONTINUE
05555          END IF
05556 *
05557          DO 200 I = 1, M
05558             CT( I ) = ALPHA*CT( I ) + BETA * C( IOFFC )
05559             G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( IOFFC ) )
05560             C( IOFFC ) = CT( I )
05561             IOFFC      = IOFFC + 1
05562   200    CONTINUE
05563 *
05564 *        Compute the error ratio for this result.
05565 *
05566          ERR  = ZERO
05567          INFO = 0
05568          LDPC = DESCC( LLD_ )
05569          IOFFC = IC + ( JC + J - 2 ) * LDC
05570          CALL PB_INFOG2L( IC, JC+J-1, DESCC, NPROW, NPCOL, MYROW, MYCOL,
05571      $                    IIC, JJC, ICROW, ICCOL )
05572          ICURROW = ICROW
05573          ROWREP  = ( ICROW.EQ.-1 )
05574          COLREP  = ( ICCOL.EQ.-1 )
05575 *
05576          IF( MYCOL.EQ.ICCOL .OR. COLREP ) THEN
05577 *
05578             IBB = DESCC( IMB_ ) - IC + 1
05579             IF( IBB.LE.0 )
05580      $         IBB = ( ( -IBB ) / DESCC( MB_ ) + 1 )*DESCC( MB_ ) + IBB
05581             IBB = MIN( IBB, M )
05582             IN = IC + IBB - 1
05583 *
05584             DO 210 I = IC, IN
05585 *
05586                IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
05587                   ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
05588      $                        C( IOFFC ) ) / EPS
05589                   IF( G( I-IC+1 ).NE.ZERO )
05590      $               ERRI = ERRI / G( I-IC+1 )
05591                   ERR = MAX( ERR, ERRI )
05592                   IF( ERR*SQRT( EPS ).GE.ONE )
05593      $               INFO = 1
05594                   IIC = IIC + 1
05595                END IF
05596 *
05597                IOFFC = IOFFC + 1
05598 *
05599   210       CONTINUE
05600 *
05601             ICURROW = MOD( ICURROW+1, NPROW )
05602 *
05603             DO 230 I = IN+1, IC+M-1, DESCC( MB_ )
05604                IBB = MIN( IC+M-I, DESCC( MB_ ) )
05605 *
05606                DO 220 KK = 0, IBB-1
05607 *
05608                   IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
05609                      ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
05610      $                           C( IOFFC ) )/EPS
05611                      IF( G( I+KK-IC+1 ).NE.ZERO )
05612      $                  ERRI = ERRI / G( I+KK-IC+1 )
05613                      ERR = MAX( ERR, ERRI )
05614                      IF( ERR*SQRT( EPS ).GE.ONE )
05615      $                  INFO = 1
05616                      IIC = IIC + 1
05617                   END IF
05618 *
05619                   IOFFC = IOFFC + 1
05620 *
05621   220          CONTINUE
05622 *
05623                ICURROW = MOD( ICURROW+1, NPROW )
05624 *
05625   230       CONTINUE
05626 *
05627          END IF
05628 *
05629 *        If INFO = 0, all results are at least half accurate.
05630 *
05631          CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL )
05632          CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
05633      $                 MYCOL )
05634          IF( INFO.NE.0 )
05635      $      GO TO 250
05636 *
05637   240 CONTINUE
05638 *
05639   250 CONTINUE
05640 *
05641       RETURN
05642 *
05643 *     End of PDMMCH
05644 *
05645       END
05646       SUBROUTINE PDMMCH1( ICTXT, UPLO, TRANS, N, K, ALPHA, A, IA, JA,
05647      $                    DESCA, BETA, C, PC, IC, JC, DESCC, CT, G,
05648      $                    ERR, INFO )
05649 *
05650 *  -- PBLAS test routine (version 2.0) --
05651 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
05652 *     and University of California, Berkeley.
05653 *     April 1, 1998
05654 *
05655 *     .. Scalar Arguments ..
05656       CHARACTER*1        TRANS, UPLO
05657       INTEGER            IA, IC, ICTXT, INFO, JA, JC, K, N
05658       DOUBLE PRECISION   ALPHA, BETA, ERR
05659 *     ..
05660 *     .. Array Arguments ..
05661       INTEGER            DESCA( * ), DESCC( * )
05662       DOUBLE PRECISION   A( * ), C( * ), CT( * ), G( * ), PC( * )
05663 *     ..
05664 *
05665 *  Purpose
05666 *  =======
05667 *
05668 *  PDMMCH1 checks the results of the computational tests.
05669 *
05670 *  Notes
05671 *  =====
05672 *
05673 *  A description  vector  is associated with each 2D block-cyclicly dis-
05674 *  tributed matrix.  This  vector  stores  the  information  required to
05675 *  establish the  mapping  between a  matrix entry and its corresponding
05676 *  process and memory location.
05677 *
05678 *  In  the  following  comments,   the character _  should  be  read  as
05679 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
05680 *  block cyclicly distributed matrix.  Its description vector is DESCA:
05681 *
05682 *  NOTATION         STORED IN       EXPLANATION
05683 *  ---------------- --------------- ------------------------------------
05684 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
05685 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
05686 *                                   the NPROW x NPCOL BLACS process grid
05687 *                                   A  is distributed over.  The context
05688 *                                   itself  is  global,  but  the handle
05689 *                                   (the integer value) may vary.
05690 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
05691 *                                   ted matrix A, M_A >= 0.
05692 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
05693 *                                   buted matrix A, N_A >= 0.
05694 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
05695 *                                   block of the matrix A, IMB_A > 0.
05696 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
05697 *                                   left   block   of   the   matrix  A,
05698 *                                   INB_A > 0.
05699 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
05700 *                                   bute the last  M_A-IMB_A rows of  A,
05701 *                                   MB_A > 0.
05702 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
05703 *                                   bute the last  N_A-INB_A  columns of
05704 *                                   A, NB_A > 0.
05705 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
05706 *                                   row of the matrix  A is distributed,
05707 *                                   NPROW > RSRC_A >= 0.
05708 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
05709 *                                   first  column of  A  is distributed.
05710 *                                   NPCOL > CSRC_A >= 0.
05711 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
05712 *                                   array  storing  the  local blocks of
05713 *                                   the distributed matrix A,
05714 *                                   IF( Lc( 1, N_A ) > 0 )
05715 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
05716 *                                   ELSE
05717 *                                      LLD_A >= 1.
05718 *
05719 *  Let K be the number of  rows of a matrix A starting at the global in-
05720 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
05721 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
05722 *  receive if these K rows were distributed over NPROW processes.  If  K
05723 *  is the number of columns of a matrix  A  starting at the global index
05724 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
05725 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
05726 *  these K columns were distributed over NPCOL processes.
05727 *
05728 *  The values of Lr() and Lc() may be determined via a call to the func-
05729 *  tion PB_NUMROC:
05730 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
05731 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
05732 *
05733 *  Arguments
05734 *  =========
05735 *
05736 *  ICTXT   (local input) INTEGER
05737 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
05738 *          ting the global  context of the operation. The context itself
05739 *          is global, but the value of ICTXT is local.
05740 *
05741 *  UPLO    (global input) CHARACTER*1
05742 *          On entry,  UPLO  specifies which part of C should contain the
05743 *          result.
05744 *
05745 *  TRANS   (global input) CHARACTER*1
05746 *          On entry,  TRANS  specifies  whether  the  matrix A has to be
05747 *          transposed or not before computing the matrix-matrix product.
05748 *
05749 *  N       (global input) INTEGER
05750 *          On entry, N  specifies  the order  the submatrix operand C. N
05751 *          must be at least zero.
05752 *
05753 *  K       (global input) INTEGER
05754 *          On entry, K specifies the number of columns (resp. rows) of A
05755 *          when  TRANS = 'N'  (resp. TRANS <> 'N').  K  must be at least
05756 *          zero.
05757 *
05758 *  ALPHA   (global input) DOUBLE PRECISION
05759 *          On entry, ALPHA specifies the scalar alpha.
05760 *
05761 *  A       (local input) DOUBLE PRECISION array
05762 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
05763 *          array contains a local copy of the initial entire matrix PA.
05764 *
05765 *  IA      (global input) INTEGER
05766 *          On entry, IA  specifies A's global row index, which points to
05767 *          the beginning of the submatrix sub( A ).
05768 *
05769 *  JA      (global input) INTEGER
05770 *          On entry, JA  specifies A's global column index, which points
05771 *          to the beginning of the submatrix sub( A ).
05772 *
05773 *  DESCA   (global and local input) INTEGER array
05774 *          On entry, DESCA  is an integer array of dimension DLEN_. This
05775 *          is the array descriptor for the matrix A.
05776 *
05777 *  BETA    (global input) DOUBLE PRECISION
05778 *          On entry, BETA specifies the scalar beta.
05779 *
05780 *  C       (local input/local output) DOUBLE PRECISION array
05781 *          On entry, C is an array of  dimension  (DESCC( M_ ),*).  This
05782 *          array contains a local copy of the initial entire matrix PC.
05783 *
05784 *  PC      (local input) DOUBLE PRECISION array
05785 *          On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
05786 *          array contains the local pieces of the matrix PC.
05787 *
05788 *  IC      (global input) INTEGER
05789 *          On entry, IC  specifies C's global row index, which points to
05790 *          the beginning of the submatrix sub( C ).
05791 *
05792 *  JC      (global input) INTEGER
05793 *          On entry, JC  specifies C's global column index, which points
05794 *          to the beginning of the submatrix sub( C ).
05795 *
05796 *  DESCC   (global and local input) INTEGER array
05797 *          On entry, DESCC  is an integer array of dimension DLEN_. This
05798 *          is the array descriptor for the matrix C.
05799 *
05800 *  CT      (workspace) DOUBLE PRECISION array
05801 *          On entry, CT is an array of dimension at least MAX(M,N,K). CT
05802 *          holds a copy of the current column of C.
05803 *
05804 *  G       (workspace) DOUBLE PRECISION array
05805 *          On entry, G  is  an array of dimension at least MAX(M,N,K). G
05806 *          is used to compute the gauges.
05807 *
05808 *  ERR     (global output) DOUBLE PRECISION
05809 *          On exit, ERR specifies the largest error in absolute value.
05810 *
05811 *  INFO    (global output) INTEGER
05812 *          On exit, if INFO <> 0, the result is less than half accurate.
05813 *
05814 *  -- Written on April 1, 1998 by
05815 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
05816 *
05817 *  =====================================================================
05818 *
05819 *     .. Parameters ..
05820       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
05821      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
05822      $                   RSRC_
05823       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
05824      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
05825      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
05826      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
05827       DOUBLE PRECISION   ZERO, ONE
05828       PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
05829 *     ..
05830 *     .. Local Scalars ..
05831       LOGICAL            COLREP, NOTRAN, ROWREP, TRAN, UPPER
05832       INTEGER            I, IBB, IBEG, ICCOL, ICROW, ICURROW, IEND, IIC,
05833      $                   IN, IOFFAK, IOFFAN, IOFFC, J, JJC, KK, LDA,
05834      $                   LDC, LDPC, MYCOL, MYROW, NPCOL, NPROW
05835       DOUBLE PRECISION   EPS, ERRI
05836 *     ..
05837 *     .. External Subroutines ..
05838       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L
05839 *     ..
05840 *     .. External Functions ..
05841       LOGICAL            LSAME
05842       DOUBLE PRECISION   PDLAMCH
05843       EXTERNAL           LSAME, PDLAMCH
05844 *     ..
05845 *     .. Intrinsic Functions ..
05846       INTRINSIC          ABS, MAX, MIN, MOD, SQRT
05847 *     ..
05848 *     .. Executable Statements ..
05849 *
05850       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
05851 *
05852       EPS = PDLAMCH( ICTXT, 'eps' )
05853 *
05854       UPPER  = LSAME( UPLO,  'U' )
05855       NOTRAN = LSAME( TRANS, 'N' )
05856       TRAN   = LSAME( TRANS, 'T' )
05857 *
05858       LDA = MAX( 1, DESCA( M_ ) )
05859       LDC = MAX( 1, DESCC( M_ ) )
05860 *
05861 *     Compute expected result in C using data in A, B and C.
05862 *     Compute gauges in G. This part of the computation is performed
05863 *     by every process in the grid.
05864 *
05865       DO 140 J = 1, N
05866 *
05867          IF( UPPER ) THEN
05868             IBEG = 1
05869             IEND = J
05870          ELSE
05871             IBEG = J
05872             IEND = N
05873          END IF
05874 *
05875          DO 10 I = 1, N
05876             CT( I ) = ZERO
05877             G( I )  = ZERO
05878    10    CONTINUE
05879 *
05880          IF( NOTRAN ) THEN
05881             DO 30 KK = 1, K
05882                IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA
05883                DO 20 I = IBEG, IEND
05884                   IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA
05885                   CT( I ) = CT( I ) + A( IOFFAK ) * A( IOFFAN )
05886                   G( I ) = G( I ) + ABS( A( IOFFAK ) ) *
05887      $                     ABS( A( IOFFAN ) )
05888    20          CONTINUE
05889    30       CONTINUE
05890          ELSE IF( TRAN ) THEN
05891             DO 50 KK = 1, K
05892                IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA
05893                DO 40 I = IBEG, IEND
05894                   IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA
05895                   CT( I ) = CT( I ) + A( IOFFAK ) * A( IOFFAN )
05896                   G( I ) = G( I ) + ABS( A( IOFFAK ) ) *
05897      $                     ABS( A( IOFFAN ) )
05898    40          CONTINUE
05899    50       CONTINUE
05900          END IF
05901 *
05902          IOFFC = IC + IBEG - 1 + ( JC + J - 2 ) * LDC
05903 *
05904          DO 100 I = IBEG, IEND
05905             CT( I ) = ALPHA*CT( I ) + BETA * C( IOFFC )
05906             G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( IOFFC ) )
05907             C( IOFFC ) = CT( I )
05908             IOFFC = IOFFC + 1
05909   100    CONTINUE
05910 *
05911 *        Compute the error ratio for this result.
05912 *
05913          ERR  = ZERO
05914          INFO = 0
05915          LDPC = DESCC( LLD_ )
05916          IOFFC = IC + ( JC + J - 2 ) * LDC
05917          CALL PB_INFOG2L( IC, JC+J-1, DESCC, NPROW, NPCOL, MYROW, MYCOL,
05918      $                    IIC, JJC, ICROW, ICCOL )
05919          ICURROW = ICROW
05920          ROWREP  = ( ICROW.EQ.-1 )
05921          COLREP  = ( ICCOL.EQ.-1 )
05922 *
05923          IF( MYCOL.EQ.ICCOL .OR. COLREP ) THEN
05924 *
05925             IBB = DESCC( IMB_ ) - IC + 1
05926             IF( IBB.LE.0 )
05927      $         IBB = ( ( -IBB ) / DESCC( MB_ ) + 1 )*DESCC( MB_ ) + IBB
05928             IBB = MIN( IBB, N )
05929             IN = IC + IBB - 1
05930 *
05931             DO 110 I = IC, IN
05932 *
05933                IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
05934                   ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
05935      $                        C( IOFFC ) ) / EPS
05936                   IF( G( I-IC+1 ).NE.ZERO )
05937      $               ERRI = ERRI / G( I-IC+1 )
05938                   ERR = MAX( ERR, ERRI )
05939                   IF( ERR*SQRT( EPS ).GE.ONE )
05940      $               INFO = 1
05941                   IIC = IIC + 1
05942                END IF
05943 *
05944                IOFFC = IOFFC + 1
05945 *
05946   110       CONTINUE
05947 *
05948             ICURROW = MOD( ICURROW+1, NPROW )
05949 *
05950             DO 130 I = IN+1, IC+N-1, DESCC( MB_ )
05951                IBB = MIN( IC+N-I, DESCC( MB_ ) )
05952 *
05953                DO 120 KK = 0, IBB-1
05954 *
05955                   IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
05956                      ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
05957      $                           C( IOFFC ) )/EPS
05958                      IF( G( I+KK-IC+1 ).NE.ZERO )
05959      $                  ERRI = ERRI / G( I+KK-IC+1 )
05960                      ERR = MAX( ERR, ERRI )
05961                      IF( ERR*SQRT( EPS ).GE.ONE )
05962      $                  INFO = 1
05963                      IIC = IIC + 1
05964                   END IF
05965 *
05966                   IOFFC = IOFFC + 1
05967 *
05968   120          CONTINUE
05969 *
05970                ICURROW = MOD( ICURROW+1, NPROW )
05971 *
05972   130       CONTINUE
05973 *
05974          END IF
05975 *
05976 *        If INFO = 0, all results are at least half accurate.
05977 *
05978          CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL )
05979          CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
05980      $                 MYCOL )
05981          IF( INFO.NE.0 )
05982      $      GO TO 150
05983 *
05984   140 CONTINUE
05985 *
05986   150 CONTINUE
05987 *
05988       RETURN
05989 *
05990 *     End of PDMMCH1
05991 *
05992       END
05993       SUBROUTINE PDMMCH2( ICTXT, UPLO, TRANS, N, K, ALPHA, A, IA, JA,
05994      $                    DESCA, B, IB, JB, DESCB, BETA, C, PC, IC,
05995      $                    JC, DESCC, CT, G, ERR, INFO )
05996 *
05997 *  -- PBLAS test routine (version 2.0) --
05998 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
05999 *     and University of California, Berkeley.
06000 *     April 1, 1998
06001 *
06002 *     .. Scalar Arguments ..
06003       CHARACTER*1        TRANS, UPLO
06004       INTEGER            IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, N
06005       DOUBLE PRECISION   ALPHA, BETA, ERR
06006 *     ..
06007 *     .. Array Arguments ..
06008       INTEGER            DESCA( * ), DESCB( * ), DESCC( * )
06009       DOUBLE PRECISION   A( * ), B( * ), C( * ), CT( * ), G( * ),
06010      $                   PC( * )
06011 *     ..
06012 *
06013 *  Purpose
06014 *  =======
06015 *
06016 *  PDMMCH2 checks the results of the computational tests.
06017 *
06018 *  Notes
06019 *  =====
06020 *
06021 *  A description  vector  is associated with each 2D block-cyclicly dis-
06022 *  tributed matrix.  This  vector  stores  the  information  required to
06023 *  establish the  mapping  between a  matrix entry and its corresponding
06024 *  process and memory location.
06025 *
06026 *  In  the  following  comments,   the character _  should  be  read  as
06027 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
06028 *  block cyclicly distributed matrix.  Its description vector is DESCA:
06029 *
06030 *  NOTATION         STORED IN       EXPLANATION
06031 *  ---------------- --------------- ------------------------------------
06032 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
06033 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
06034 *                                   the NPROW x NPCOL BLACS process grid
06035 *                                   A  is distributed over.  The context
06036 *                                   itself  is  global,  but  the handle
06037 *                                   (the integer value) may vary.
06038 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
06039 *                                   ted matrix A, M_A >= 0.
06040 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
06041 *                                   buted matrix A, N_A >= 0.
06042 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
06043 *                                   block of the matrix A, IMB_A > 0.
06044 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
06045 *                                   left   block   of   the   matrix  A,
06046 *                                   INB_A > 0.
06047 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
06048 *                                   bute the last  M_A-IMB_A rows of  A,
06049 *                                   MB_A > 0.
06050 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
06051 *                                   bute the last  N_A-INB_A  columns of
06052 *                                   A, NB_A > 0.
06053 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
06054 *                                   row of the matrix  A is distributed,
06055 *                                   NPROW > RSRC_A >= 0.
06056 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
06057 *                                   first  column of  A  is distributed.
06058 *                                   NPCOL > CSRC_A >= 0.
06059 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
06060 *                                   array  storing  the  local blocks of
06061 *                                   the distributed matrix A,
06062 *                                   IF( Lc( 1, N_A ) > 0 )
06063 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
06064 *                                   ELSE
06065 *                                      LLD_A >= 1.
06066 *
06067 *  Let K be the number of  rows of a matrix A starting at the global in-
06068 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
06069 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
06070 *  receive if these K rows were distributed over NPROW processes.  If  K
06071 *  is the number of columns of a matrix  A  starting at the global index
06072 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
06073 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
06074 *  these K columns were distributed over NPCOL processes.
06075 *
06076 *  The values of Lr() and Lc() may be determined via a call to the func-
06077 *  tion PB_NUMROC:
06078 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
06079 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
06080 *
06081 *  Arguments
06082 *  =========
06083 *
06084 *  ICTXT   (local input) INTEGER
06085 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
06086 *          ting the global  context of the operation. The context itself
06087 *          is global, but the value of ICTXT is local.
06088 *
06089 *  UPLO    (global input) CHARACTER*1
06090 *          On entry,  UPLO  specifies which part of C should contain the
06091 *          result.
06092 *
06093 *  TRANS   (global input) CHARACTER*1
06094 *          On entry,  TRANS  specifies whether the matrices A and B have
06095 *          to  be  transposed  or not before computing the matrix-matrix
06096 *          product.
06097 *
06098 *  N       (global input) INTEGER
06099 *          On entry, N  specifies  the order  the submatrix operand C. N
06100 *          must be at least zero.
06101 *
06102 *  K       (global input) INTEGER
06103 *          On entry, K specifies the number of columns (resp. rows) of A
06104 *          and B when  TRANS = 'N' (resp. TRANS <> 'N').  K  must  be at
06105 *          least zero.
06106 *
06107 *  ALPHA   (global input) DOUBLE PRECISION
06108 *          On entry, ALPHA specifies the scalar alpha.
06109 *
06110 *  A       (local input) DOUBLE PRECISION array
06111 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
06112 *          array contains a local copy of the initial entire matrix PA.
06113 *
06114 *  IA      (global input) INTEGER
06115 *          On entry, IA  specifies A's global row index, which points to
06116 *          the beginning of the submatrix sub( A ).
06117 *
06118 *  JA      (global input) INTEGER
06119 *          On entry, JA  specifies A's global column index, which points
06120 *          to the beginning of the submatrix sub( A ).
06121 *
06122 *  DESCA   (global and local input) INTEGER array
06123 *          On entry, DESCA  is an integer array of dimension DLEN_. This
06124 *          is the array descriptor for the matrix A.
06125 *
06126 *  B       (local input) DOUBLE PRECISION array
06127 *          On entry, B is an array of  dimension  (DESCB( M_ ),*).  This
06128 *          array contains a local copy of the initial entire matrix PB.
06129 *
06130 *  IB      (global input) INTEGER
06131 *          On entry, IB  specifies B's global row index, which points to
06132 *          the beginning of the submatrix sub( B ).
06133 *
06134 *  JB      (global input) INTEGER
06135 *          On entry, JB  specifies B's global column index, which points
06136 *          to the beginning of the submatrix sub( B ).
06137 *
06138 *  DESCB   (global and local input) INTEGER array
06139 *          On entry, DESCB  is an integer array of dimension DLEN_. This
06140 *          is the array descriptor for the matrix B.
06141 *
06142 *  BETA    (global input) DOUBLE PRECISION
06143 *          On entry, BETA specifies the scalar beta.
06144 *
06145 *  C       (local input/local output) DOUBLE PRECISION array
06146 *          On entry, C is an array of  dimension  (DESCC( M_ ),*).  This
06147 *          array contains a local copy of the initial entire matrix PC.
06148 *
06149 *  PC      (local input) DOUBLE PRECISION array
06150 *          On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
06151 *          array contains the local pieces of the matrix PC.
06152 *
06153 *  IC      (global input) INTEGER
06154 *          On entry, IC  specifies C's global row index, which points to
06155 *          the beginning of the submatrix sub( C ).
06156 *
06157 *  JC      (global input) INTEGER
06158 *          On entry, JC  specifies C's global column index, which points
06159 *          to the beginning of the submatrix sub( C ).
06160 *
06161 *  DESCC   (global and local input) INTEGER array
06162 *          On entry, DESCC  is an integer array of dimension DLEN_. This
06163 *          is the array descriptor for the matrix C.
06164 *
06165 *  CT      (workspace) DOUBLE PRECISION array
06166 *          On entry, CT is an array of dimension at least MAX(M,N,K). CT
06167 *          holds a copy of the current column of C.
06168 *
06169 *  G       (workspace) DOUBLE PRECISION array
06170 *          On entry, G  is  an array of dimension at least MAX(M,N,K). G
06171 *          is used to compute the gauges.
06172 *
06173 *  ERR     (global output) DOUBLE PRECISION
06174 *          On exit, ERR specifies the largest error in absolute value.
06175 *
06176 *  INFO    (global output) INTEGER
06177 *          On exit, if INFO <> 0, the result is less than half accurate.
06178 *
06179 *  -- Written on April 1, 1998 by
06180 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
06181 *
06182 *  =====================================================================
06183 *
06184 *     .. Parameters ..
06185       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
06186      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
06187      $                   RSRC_
06188       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
06189      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
06190      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
06191      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
06192       DOUBLE PRECISION   ZERO, ONE
06193       PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
06194 *     ..
06195 *     .. Local Scalars ..
06196       LOGICAL            COLREP, NOTRAN, ROWREP, TRAN, UPPER
06197       INTEGER            I, IBB, IBEG, ICCOL, ICROW, ICURROW, IEND, IIC,
06198      $                   IN, IOFFAK, IOFFAN, IOFFBK, IOFFBN, IOFFC, J,
06199      $                   JJC, KK, LDA, LDB, LDC, LDPC, MYCOL, MYROW,
06200      $                   NPCOL, NPROW
06201       DOUBLE PRECISION   EPS, ERRI
06202 *     ..
06203 *     .. External Subroutines ..
06204       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L
06205 *     ..
06206 *     .. External Functions ..
06207       LOGICAL            LSAME
06208       DOUBLE PRECISION   PDLAMCH
06209       EXTERNAL           LSAME, PDLAMCH
06210 *     ..
06211 *     .. Intrinsic Functions ..
06212       INTRINSIC          ABS, MAX, MIN, MOD, SQRT
06213 *     ..
06214 *     .. Executable Statements ..
06215 *
06216       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
06217 *
06218       EPS = PDLAMCH( ICTXT, 'eps' )
06219 *
06220       UPPER = LSAME( UPLO, 'U' )
06221       NOTRAN = LSAME( TRANS, 'N' )
06222       TRAN = LSAME( TRANS, 'T' )
06223 *
06224       LDA = MAX( 1, DESCA( M_ ) )
06225       LDB = MAX( 1, DESCB( M_ ) )
06226       LDC = MAX( 1, DESCC( M_ ) )
06227 *
06228 *     Compute expected result in C using data in A, B and C.
06229 *     Compute gauges in G. This part of the computation is performed
06230 *     by every process in the grid.
06231 *
06232       DO 140 J = 1, N
06233 *
06234          IF( UPPER ) THEN
06235             IBEG = 1
06236             IEND = J
06237          ELSE
06238             IBEG = J
06239             IEND = N
06240          END IF
06241 *
06242          DO 10 I = 1, N
06243             CT( I ) = ZERO
06244             G( I )  = ZERO
06245    10    CONTINUE
06246 *
06247          IF( NOTRAN ) THEN
06248             DO 30 KK = 1, K
06249                IOFFAK = IA + J - 1 + ( JA + KK - 2 ) * LDA
06250                IOFFBK = IB + J - 1 + ( JB + KK - 2 ) * LDB
06251                DO 20 I = IBEG, IEND
06252                   IOFFAN = IA + I - 1 + ( JA + KK - 2 ) * LDA
06253                   IOFFBN = IB + I - 1 + ( JB + KK - 2 ) * LDB
06254                   CT( I ) = CT( I ) + ALPHA * (
06255      $                      A( IOFFAN ) * B( IOFFBK ) +
06256      $                      B( IOFFBN ) * A( IOFFAK ) )
06257                   G( I ) = G( I ) + ABS( ALPHA ) * (
06258      $                     ABS( A( IOFFAN ) ) * ABS( B( IOFFBK ) ) +
06259      $                     ABS( B( IOFFBN ) ) * ABS( A( IOFFAK ) ) )
06260    20          CONTINUE
06261    30       CONTINUE
06262          ELSE IF( TRAN ) THEN
06263             DO 50 KK = 1, K
06264                IOFFAK = IA + KK - 1 + ( JA + J - 2 ) * LDA
06265                IOFFBK = IB + KK - 1 + ( JB + J - 2 ) * LDB
06266                DO 40 I = IBEG, IEND
06267                   IOFFAN = IA + KK - 1 + ( JA + I - 2 ) * LDA
06268                   IOFFBN = IB + KK - 1 + ( JB + I - 2 ) * LDB
06269                   CT( I ) = CT( I ) + ALPHA * (
06270      $                      A( IOFFAN ) * B( IOFFBK ) +
06271      $                      B( IOFFBN ) * A( IOFFAK ) )
06272                   G( I ) = G( I ) + ABS( ALPHA ) * (
06273      $                     ABS( A( IOFFAN ) ) * ABS( B( IOFFBK ) ) +
06274      $                     ABS( B( IOFFBN ) ) * ABS( A( IOFFAK ) ) )
06275    40          CONTINUE
06276    50       CONTINUE
06277          END IF
06278 *
06279          IOFFC = IC + IBEG - 1 + ( JC + J - 2 ) * LDC
06280 *
06281          DO 100 I = IBEG, IEND
06282             CT( I ) = CT( I ) + BETA * C( IOFFC )
06283             G( I ) = G( I ) + ABS( BETA )*ABS( C( IOFFC ) )
06284             C( IOFFC ) = CT( I )
06285             IOFFC = IOFFC + 1
06286   100    CONTINUE
06287 *
06288 *        Compute the error ratio for this result.
06289 *
06290          ERR  = ZERO
06291          INFO = 0
06292          LDPC = DESCC( LLD_ )
06293          IOFFC = IC + ( JC + J - 2 ) * LDC
06294          CALL PB_INFOG2L( IC, JC+J-1, DESCC, NPROW, NPCOL, MYROW, MYCOL,
06295      $                    IIC, JJC, ICROW, ICCOL )
06296          ICURROW = ICROW
06297          ROWREP  = ( ICROW.EQ.-1 )
06298          COLREP  = ( ICCOL.EQ.-1 )
06299 *
06300          IF( MYCOL.EQ.ICCOL .OR. COLREP ) THEN
06301 *
06302             IBB = DESCC( IMB_ ) - IC + 1
06303             IF( IBB.LE.0 )
06304      $         IBB = ( ( -IBB ) / DESCC( MB_ ) + 1 )*DESCC( MB_ ) + IBB
06305             IBB = MIN( IBB, N )
06306             IN = IC + IBB - 1
06307 *
06308             DO 110 I = IC, IN
06309 *
06310                IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
06311                   ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
06312      $                        C( IOFFC ) ) / EPS
06313                   IF( G( I-IC+1 ).NE.ZERO )
06314      $               ERRI = ERRI / G( I-IC+1 )
06315                   ERR = MAX( ERR, ERRI )
06316                   IF( ERR*SQRT( EPS ).GE.ONE )
06317      $               INFO = 1
06318                   IIC = IIC + 1
06319                END IF
06320 *
06321                IOFFC = IOFFC + 1
06322 *
06323   110       CONTINUE
06324 *
06325             ICURROW = MOD( ICURROW+1, NPROW )
06326 *
06327             DO 130 I = IN+1, IC+N-1, DESCC( MB_ )
06328                IBB = MIN( IC+N-I, DESCC( MB_ ) )
06329 *
06330                DO 120 KK = 0, IBB-1
06331 *
06332                   IF( MYROW.EQ.ICURROW .OR. ROWREP ) THEN
06333                      ERRI = ABS( PC( IIC+(JJC-1)*LDPC ) -
06334      $                           C( IOFFC ) )/EPS
06335                      IF( G( I+KK-IC+1 ).NE.ZERO )
06336      $                  ERRI = ERRI / G( I+KK-IC+1 )
06337                      ERR = MAX( ERR, ERRI )
06338                      IF( ERR*SQRT( EPS ).GE.ONE )
06339      $                  INFO = 1
06340                      IIC = IIC + 1
06341                   END IF
06342 *
06343                   IOFFC = IOFFC + 1
06344 *
06345   120          CONTINUE
06346 *
06347                ICURROW = MOD( ICURROW+1, NPROW )
06348 *
06349   130       CONTINUE
06350 *
06351          END IF
06352 *
06353 *        If INFO = 0, all results are at least half accurate.
06354 *
06355          CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL )
06356          CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
06357      $                 MYCOL )
06358          IF( INFO.NE.0 )
06359      $      GO TO 150
06360 *
06361   140 CONTINUE
06362 *
06363   150 CONTINUE
06364 *
06365       RETURN
06366 *
06367 *     End of PDMMCH2
06368 *
06369       END
06370       SUBROUTINE PDMMCH3( UPLO, TRANS, M, N, ALPHA, A, IA, JA, DESCA,
06371      $                    BETA, C, PC, IC, JC, DESCC, ERR, INFO )
06372 *
06373 *  -- PBLAS test routine (version 2.0) --
06374 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
06375 *     and University of California, Berkeley.
06376 *     April 1, 1998
06377 *
06378 *     .. Scalar Arguments ..
06379       CHARACTER*1        TRANS, UPLO
06380       INTEGER            IA, IC, INFO, JA, JC, M, N
06381       DOUBLE PRECISION   ALPHA, BETA, ERR
06382 *     ..
06383 *     .. Array Arguments ..
06384       INTEGER            DESCA( * ), DESCC( * )
06385       DOUBLE PRECISION   A( * ), C( * ), PC( * )
06386 *     ..
06387 *
06388 *  Purpose
06389 *  =======
06390 *
06391 *  PDMMCH3 checks the results of the computational tests.
06392 *
06393 *  Notes
06394 *  =====
06395 *
06396 *  A description  vector  is associated with each 2D block-cyclicly dis-
06397 *  tributed matrix.  This  vector  stores  the  information  required to
06398 *  establish the  mapping  between a  matrix entry and its corresponding
06399 *  process and memory location.
06400 *
06401 *  In  the  following  comments,   the character _  should  be  read  as
06402 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
06403 *  block cyclicly distributed matrix.  Its description vector is DESCA:
06404 *
06405 *  NOTATION         STORED IN       EXPLANATION
06406 *  ---------------- --------------- ------------------------------------
06407 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
06408 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
06409 *                                   the NPROW x NPCOL BLACS process grid
06410 *                                   A  is distributed over.  The context
06411 *                                   itself  is  global,  but  the handle
06412 *                                   (the integer value) may vary.
06413 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
06414 *                                   ted matrix A, M_A >= 0.
06415 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
06416 *                                   buted matrix A, N_A >= 0.
06417 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
06418 *                                   block of the matrix A, IMB_A > 0.
06419 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
06420 *                                   left   block   of   the   matrix  A,
06421 *                                   INB_A > 0.
06422 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
06423 *                                   bute the last  M_A-IMB_A rows of  A,
06424 *                                   MB_A > 0.
06425 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
06426 *                                   bute the last  N_A-INB_A  columns of
06427 *                                   A, NB_A > 0.
06428 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
06429 *                                   row of the matrix  A is distributed,
06430 *                                   NPROW > RSRC_A >= 0.
06431 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
06432 *                                   first  column of  A  is distributed.
06433 *                                   NPCOL > CSRC_A >= 0.
06434 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
06435 *                                   array  storing  the  local blocks of
06436 *                                   the distributed matrix A,
06437 *                                   IF( Lc( 1, N_A ) > 0 )
06438 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
06439 *                                   ELSE
06440 *                                      LLD_A >= 1.
06441 *
06442 *  Let K be the number of  rows of a matrix A starting at the global in-
06443 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
06444 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
06445 *  receive if these K rows were distributed over NPROW processes.  If  K
06446 *  is the number of columns of a matrix  A  starting at the global index
06447 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
06448 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
06449 *  these K columns were distributed over NPCOL processes.
06450 *
06451 *  The values of Lr() and Lc() may be determined via a call to the func-
06452 *  tion PB_NUMROC:
06453 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
06454 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
06455 *
06456 *  Arguments
06457 *  =========
06458 *
06459 *  UPLO    (global input) CHARACTER*1
06460 *          On entry,  UPLO  specifies which part of C should contain the
06461 *          result.
06462 *
06463 *  TRANS   (global input) CHARACTER*1
06464 *          On entry,  TRANS  specifies  whether  the  matrix A has to be
06465 *          transposed  or not  before computing the  matrix-matrix addi-
06466 *          tion.
06467 *
06468 *  M       (global input) INTEGER
06469 *          On entry, M specifies the number of rows of C.
06470 *
06471 *  N       (global input) INTEGER
06472 *          On entry, N specifies the number of columns of C.
06473 *
06474 *  ALPHA   (global input) DOUBLE PRECISION
06475 *          On entry, ALPHA specifies the scalar alpha.
06476 *
06477 *  A       (local input) DOUBLE PRECISION array
06478 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
06479 *          array contains a local copy of the initial entire matrix PA.
06480 *
06481 *  IA      (global input) INTEGER
06482 *          On entry, IA  specifies A's global row index, which points to
06483 *          the beginning of the submatrix sub( A ).
06484 *
06485 *  JA      (global input) INTEGER
06486 *          On entry, JA  specifies A's global column index, which points
06487 *          to the beginning of the submatrix sub( A ).
06488 *
06489 *  DESCA   (global and local input) INTEGER array
06490 *          On entry, DESCA  is an integer array of dimension DLEN_. This
06491 *          is the array descriptor for the matrix A.
06492 *
06493 *  BETA    (global input) DOUBLE PRECISION
06494 *          On entry, BETA specifies the scalar beta.
06495 *
06496 *  C       (local input/local output) DOUBLE PRECISION array
06497 *          On entry, C is an array of  dimension  (DESCC( M_ ),*).  This
06498 *          array contains a local copy of the initial entire matrix PC.
06499 *
06500 *  PC      (local input) DOUBLE PRECISION array
06501 *          On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
06502 *          array contains the local pieces of the matrix PC.
06503 *
06504 *  IC      (global input) INTEGER
06505 *          On entry, IC  specifies C's global row index, which points to
06506 *          the beginning of the submatrix sub( C ).
06507 *
06508 *  JC      (global input) INTEGER
06509 *          On entry, JC  specifies C's global column index, which points
06510 *          to the beginning of the submatrix sub( C ).
06511 *
06512 *  DESCC   (global and local input) INTEGER array
06513 *          On entry, DESCC  is an integer array of dimension DLEN_. This
06514 *          is the array descriptor for the matrix C.
06515 *
06516 *  ERR     (global output) DOUBLE PRECISION
06517 *          On exit, ERR specifies the largest error in absolute value.
06518 *
06519 *  INFO    (global output) INTEGER
06520 *          On exit, if INFO <> 0, the result is less than half accurate.
06521 *
06522 *  -- Written on April 1, 1998 by
06523 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
06524 *
06525 *  =====================================================================
06526 *
06527 *     .. Parameters ..
06528       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
06529      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
06530      $                   RSRC_
06531       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
06532      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
06533      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
06534      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
06535       DOUBLE PRECISION   ZERO
06536       PARAMETER          ( ZERO = 0.0D+0 )
06537 *     ..
06538 *     .. Local Scalars ..
06539       LOGICAL            COLREP, LOWER, NOTRAN, ROWREP, UPPER
06540       INTEGER            I, ICCOL, ICROW, ICTXT, IIC, IOFFA, IOFFC, J,
06541      $                   JJC, LDA, LDC, LDPC, MYCOL, MYROW, NPCOL,
06542      $                   NPROW
06543       DOUBLE PRECISION   ERR0, ERRI, PREC
06544 *     ..
06545 *     .. External Subroutines ..
06546       EXTERNAL           BLACS_GRIDINFO, DGAMX2D, IGSUM2D, PB_INFOG2L,
06547      $                   PDERRAXPBY
06548 *     ..
06549 *     .. External Functions ..
06550       LOGICAL            LSAME
06551       DOUBLE PRECISION   PDLAMCH
06552       EXTERNAL           LSAME, PDLAMCH
06553 *     ..
06554 *     .. Intrinsic Functions ..
06555       INTRINSIC          ABS, MAX
06556 *     ..
06557 *     .. Executable Statements ..
06558 *
06559       ICTXT = DESCC( CTXT_ )
06560       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
06561 *
06562       PREC   = PDLAMCH( ICTXT, 'eps' )
06563 *
06564       UPPER  = LSAME( UPLO,  'U' )
06565       LOWER  = LSAME( UPLO,  'L' )
06566       NOTRAN = LSAME( TRANS, 'N' )
06567 *
06568 *     Compute expected result in C using data in A and C. This part of
06569 *     the computation is performed by every process in the grid.
06570 *
06571       INFO   = 0
06572       ERR    = ZERO
06573 *
06574       LDA    = MAX( 1, DESCA( M_   ) )
06575       LDC    = MAX( 1, DESCC( M_   ) )
06576       LDPC   = MAX( 1, DESCC( LLD_ ) )
06577       ROWREP = ( DESCC( RSRC_ ).EQ.-1 )
06578       COLREP = ( DESCC( CSRC_ ).EQ.-1 )
06579 *
06580       IF( NOTRAN ) THEN
06581 *
06582          DO 20 J = JC, JC + N - 1
06583 *
06584             IOFFC = IC + ( J  - 1          ) * LDC
06585             IOFFA = IA + ( JA - 1 + J - JC ) * LDA
06586 *
06587             DO 10 I = IC, IC + M - 1
06588 *
06589                IF( UPPER ) THEN
06590                   IF( ( J - JC ).GE.( I - IC ) ) THEN
06591                      CALL PDERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06592      $                                C( IOFFC ), PREC )
06593                   ELSE
06594                      ERRI = ZERO
06595                   END IF
06596                ELSE IF( LOWER ) THEN
06597                   IF( ( J - JC ).LE.( I - IC ) ) THEN
06598                      CALL PDERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06599      $                                C( IOFFC ), PREC )
06600                   ELSE
06601                      ERRI = ZERO
06602                   END IF
06603                ELSE
06604                   CALL PDERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06605      $                             C( IOFFC ), PREC )
06606                END IF
06607 *
06608                CALL PB_INFOG2L( I, J, DESCC, NPROW, NPCOL, MYROW, MYCOL,
06609      $                          IIC, JJC, ICROW, ICCOL )
06610                IF( ( MYROW.EQ.ICROW .OR. ROWREP ) .AND.
06611      $             ( MYCOL.EQ.ICCOL .OR. COLREP ) ) THEN
06612                   ERR0 = ABS( PC( IIC+(JJC-1)*LDPC )-C( IOFFC ) )
06613                   IF( ERR0.GT.ERRI )
06614      $               INFO = 1
06615                   ERR = MAX( ERR, ERR0 )
06616                END IF
06617 *
06618                IOFFA = IOFFA + 1
06619                IOFFC = IOFFC + 1
06620 *
06621    10       CONTINUE
06622 *
06623    20    CONTINUE
06624 *
06625       ELSE
06626 *
06627          DO 40 J = JC, JC + N - 1
06628 *
06629             IOFFC = IC +              ( J  - 1 ) * LDC
06630             IOFFA = IA + ( J - JC ) + ( JA - 1 ) * LDA
06631 *
06632             DO 30 I = IC, IC + M - 1
06633 *
06634                IF( UPPER ) THEN
06635                   IF( ( J - JC ).GE.( I - IC ) ) THEN
06636                      CALL PDERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06637      $                               C( IOFFC ), PREC )
06638                   ELSE
06639                      ERRI = ZERO
06640                   END IF
06641                ELSE IF( LOWER ) THEN
06642                   IF( ( J - JC ).LE.( I - IC ) ) THEN
06643                      CALL PDERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06644      $                               C( IOFFC ), PREC )
06645                   ELSE
06646                      ERRI = ZERO
06647                   END IF
06648                ELSE
06649                   CALL PDERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06650      $                            C( IOFFC ), PREC )
06651                END IF
06652 *
06653                CALL PB_INFOG2L( I, J, DESCC, NPROW, NPCOL, MYROW, MYCOL,
06654      $                          IIC, JJC, ICROW, ICCOL )
06655                IF( ( MYROW.EQ.ICROW .OR. ROWREP ) .AND.
06656      $             ( MYCOL.EQ.ICCOL .OR. COLREP ) ) THEN
06657                   ERR0 = ABS( PC( IIC+(JJC-1)*LDPC )-C( IOFFC ) )
06658                   IF( ERR0.GT.ERRI )
06659      $               INFO = 1
06660                   ERR = MAX( ERR, ERR0 )
06661                END IF
06662 *
06663                IOFFC = IOFFC + 1
06664                IOFFA = IOFFA + LDA
06665 *
06666    30       CONTINUE
06667 *
06668    40    CONTINUE
06669 *
06670       END IF
06671 *
06672 *     If INFO = 0, all results are at least half accurate.
06673 *
06674       CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, MYCOL )
06675       CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
06676      $              MYCOL )
06677 *
06678       RETURN
06679 *
06680 *     End of PDMMCH3
06681 *
06682       END
06683       SUBROUTINE PDERRAXPBY( ERRBND, ALPHA, X, BETA, Y, PREC )
06684 *
06685 *  -- PBLAS test routine (version 2.0) --
06686 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
06687 *     and University of California, Berkeley.
06688 *     April 1, 1998
06689 *
06690 *     .. Scalar Arguments ..
06691       DOUBLE PRECISION   ALPHA, BETA, ERRBND, PREC, X, Y
06692 *     ..
06693 *
06694 *  Purpose
06695 *  =======
06696 *
06697 *  PDERRAXPBY  serially  computes  y := beta*y + alpha * x and returns a
06698 *  scaled relative acceptable error bound on the result.
06699 *
06700 *  Arguments
06701 *  =========
06702 *
06703 *  ERRBND  (global output) DOUBLE PRECISION
06704 *          On exit, ERRBND  specifies the scaled relative acceptable er-
06705 *          ror bound.
06706 *
06707 *  ALPHA   (global input) DOUBLE PRECISION
06708 *          On entry, ALPHA specifies the scalar alpha.
06709 *
06710 *  X       (global input) DOUBLE PRECISION
06711 *          On entry, X  specifies the scalar x to be scaled.
06712 *
06713 *  BETA    (global input) DOUBLE PRECISION
06714 *          On entry, BETA specifies the scalar beta.
06715 *
06716 *  Y       (global input/global output) DOUBLE PRECISION
06717 *          On entry,  Y  specifies  the scalar y to be added. On exit, Y
06718 *          contains the resulting scalar y.
06719 *
06720 *  PREC    (global input) DOUBLE PRECISION
06721 *          On entry, PREC specifies the machine precision.
06722 *
06723 *  -- Written on April 1, 1998 by
06724 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
06725 *
06726 *  =====================================================================
06727 *
06728 *     .. Parameters ..
06729       DOUBLE PRECISION   ONE, TWO, ZERO
06730       PARAMETER          ( ONE = 1.0D+0, TWO = 2.0D+0,
06731      $                   ZERO = 0.0D+0 )
06732 *     ..
06733 *     .. Local Scalars ..
06734       DOUBLE PRECISION   ADDBND, FACT, SUMPOS, SUMNEG, TMP
06735 *     ..
06736 *     .. Intrinsic Functions ..
06737 *     ..
06738 *     .. Executable Statements ..
06739 *
06740       SUMPOS = ZERO
06741       SUMNEG = ZERO
06742       FACT = ONE + TWO * PREC
06743       ADDBND = TWO * TWO * TWO * PREC
06744 *
06745       TMP = ALPHA * X
06746       IF( TMP.GE.ZERO ) THEN
06747          SUMPOS = SUMPOS + TMP * FACT
06748       ELSE
06749          SUMNEG = SUMNEG - TMP * FACT
06750       END IF
06751 *
06752       TMP = BETA * Y
06753       IF( TMP.GE.ZERO ) THEN
06754          SUMPOS = SUMPOS + TMP * FACT
06755       ELSE
06756          SUMNEG = SUMNEG - TMP * FACT
06757       END IF
06758 *
06759       Y = ( BETA * Y ) + ( ALPHA * X )
06760 *
06761       ERRBND = ADDBND * MAX( SUMPOS, SUMNEG )
06762 *
06763       RETURN
06764 *
06765 *     End of PDERRAXPBY
06766 *
06767       END
06768       DOUBLE PRECISION   FUNCTION PDLAMCH( ICTXT, CMACH )
06769 *
06770 *  -- PBLAS test routine (version 2.0) --
06771 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
06772 *     and University of California, Berkeley.
06773 *     April 1, 1998
06774 *
06775 *     .. Scalar Arguments ..
06776       CHARACTER*1        CMACH
06777       INTEGER            ICTXT
06778 *     ..
06779 *
06780 *  Purpose
06781 *  =======
06782 *
06783 *  PDLAMCH determines double precision machine parameters.
06784 *
06785 *  Arguments
06786 *  =========
06787 *
06788 *  ICTXT   (local input) INTEGER
06789 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
06790 *          ting the global  context of the operation. The context itself
06791 *          is global, but the value of ICTXT is local.
06792 *
06793 *  CMACH   (global input) CHARACTER*1
06794 *          On entry, CMACH specifies the value to be returned by PDLAMCH
06795 *          as follows:
06796 *             = 'E' or 'e',   PDLAMCH := eps,
06797 *             = 'S' or 's ,   PDLAMCH := sfmin,
06798 *             = 'B' or 'b',   PDLAMCH := base,
06799 *             = 'P' or 'p',   PDLAMCH := eps*base,
06800 *             = 'N' or 'n',   PDLAMCH := t,
06801 *             = 'R' or 'r',   PDLAMCH := rnd,
06802 *             = 'M' or 'm',   PDLAMCH := emin,
06803 *             = 'U' or 'u',   PDLAMCH := rmin,
06804 *             = 'L' or 'l',   PDLAMCH := emax,
06805 *             = 'O' or 'o',   PDLAMCH := rmax,
06806 *
06807 *          where
06808 *
06809 *          eps   = relative machine precision,
06810 *          sfmin = safe minimum, such that 1/sfmin does not overflow,
06811 *          base  = base of the machine,
06812 *          prec  = eps*base,
06813 *          t     = number of (base) digits in the mantissa,
06814 *          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise,
06815 *          emin  = minimum exponent before (gradual) underflow,
06816 *          rmin  = underflow threshold - base**(emin-1),
06817 *          emax  = largest exponent before overflow,
06818 *          rmax  = overflow threshold  - (base**emax)*(1-eps).
06819 *
06820 *  -- Written on April 1, 1998 by
06821 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
06822 *
06823 *  =====================================================================
06824 *
06825 *     .. Local Scalars ..
06826       CHARACTER*1        TOP
06827       INTEGER            IDUMM
06828       DOUBLE PRECISION   TEMP
06829 *     ..
06830 *     .. External Subroutines ..
06831       EXTERNAL           DGAMN2D, DGAMX2D, PB_TOPGET
06832 *     ..
06833 *     .. External Functions ..
06834       LOGICAL            LSAME
06835       DOUBLE PRECISION   DLAMCH
06836       EXTERNAL           DLAMCH, LSAME
06837 *     ..
06838 *     .. Executable Statements ..
06839 *
06840       TEMP = DLAMCH( CMACH )
06841       IDUMM = 0
06842 *
06843       IF( LSAME( CMACH, 'E' ).OR.LSAME( CMACH, 'S' ).OR.
06844      $    LSAME( CMACH, 'M' ).OR.LSAME( CMACH, 'U' ) ) THEN
06845          CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP )
06846          CALL DGAMX2D( ICTXT, 'All', TOP, 1, 1, TEMP, 1, IDUMM,
06847      $                 IDUMM, -1, -1, IDUMM )
06848       ELSE IF( LSAME( CMACH, 'L' ).OR.LSAME( CMACH, 'O' ) ) THEN
06849          CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP )
06850          CALL DGAMN2D( ICTXT, 'All', TOP, 1, 1, TEMP, 1, IDUMM,
06851      $                 IDUMM, -1, -1, IDUMM )
06852       END IF
06853 *
06854       PDLAMCH = TEMP
06855 *
06856       RETURN
06857 *
06858 *     End of PDLAMCH
06859 *
06860       END
06861       SUBROUTINE PDLASET( UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA )
06862 *
06863 *  -- PBLAS test routine (version 2.0) --
06864 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
06865 *     and University of California, Berkeley.
06866 *     April 1, 1998
06867 *
06868 *     .. Scalar Arguments ..
06869       CHARACTER*1        UPLO
06870       INTEGER            IA, JA, M, N
06871       DOUBLE PRECISION   ALPHA, BETA
06872 *     ..
06873 *     .. Array Arguments ..
06874       INTEGER            DESCA( * )
06875       DOUBLE PRECISION   A( * )
06876 *     ..
06877 *
06878 *  Purpose
06879 *  =======
06880 *
06881 *  PDLASET  initializes an m by n submatrix A(IA:IA+M-1,JA:JA+N-1) deno-
06882 *  ted  by  sub( A )  to beta on the diagonal and alpha on the offdiago-
06883 *  nals.
06884 *
06885 *  Notes
06886 *  =====
06887 *
06888 *  A description  vector  is associated with each 2D block-cyclicly dis-
06889 *  tributed matrix.  This  vector  stores  the  information  required to
06890 *  establish the  mapping  between a  matrix entry and its corresponding
06891 *  process and memory location.
06892 *
06893 *  In  the  following  comments,   the character _  should  be  read  as
06894 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
06895 *  block cyclicly distributed matrix.  Its description vector is DESCA:
06896 *
06897 *  NOTATION         STORED IN       EXPLANATION
06898 *  ---------------- --------------- ------------------------------------
06899 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
06900 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
06901 *                                   the NPROW x NPCOL BLACS process grid
06902 *                                   A  is distributed over.  The context
06903 *                                   itself  is  global,  but  the handle
06904 *                                   (the integer value) may vary.
06905 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
06906 *                                   ted matrix A, M_A >= 0.
06907 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
06908 *                                   buted matrix A, N_A >= 0.
06909 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
06910 *                                   block of the matrix A, IMB_A > 0.
06911 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
06912 *                                   left   block   of   the   matrix  A,
06913 *                                   INB_A > 0.
06914 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
06915 *                                   bute the last  M_A-IMB_A rows of  A,
06916 *                                   MB_A > 0.
06917 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
06918 *                                   bute the last  N_A-INB_A  columns of
06919 *                                   A, NB_A > 0.
06920 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
06921 *                                   row of the matrix  A is distributed,
06922 *                                   NPROW > RSRC_A >= 0.
06923 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
06924 *                                   first  column of  A  is distributed.
06925 *                                   NPCOL > CSRC_A >= 0.
06926 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
06927 *                                   array  storing  the  local blocks of
06928 *                                   the distributed matrix A,
06929 *                                   IF( Lc( 1, N_A ) > 0 )
06930 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
06931 *                                   ELSE
06932 *                                      LLD_A >= 1.
06933 *
06934 *  Let K be the number of  rows of a matrix A starting at the global in-
06935 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
06936 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
06937 *  receive if these K rows were distributed over NPROW processes.  If  K
06938 *  is the number of columns of a matrix  A  starting at the global index
06939 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
06940 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
06941 *  these K columns were distributed over NPCOL processes.
06942 *
06943 *  The values of Lr() and Lc() may be determined via a call to the func-
06944 *  tion PB_NUMROC:
06945 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
06946 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
06947 *
06948 *  Arguments
06949 *  =========
06950 *
06951 *  UPLO    (global input) CHARACTER*1
06952 *          On entry, UPLO specifies the part  of  the submatrix sub( A )
06953 *          to be set:
06954 *             = 'L' or 'l':   Lower triangular part is set; the strictly
06955 *                      upper triangular part of sub( A ) is not changed;
06956 *             = 'U' or 'u':   Upper triangular part is set; the strictly
06957 *                      lower triangular part of sub( A ) is not changed;
06958 *             Otherwise:  All of the matrix sub( A ) is set.
06959 *
06960 *  M       (global input) INTEGER
06961 *          On entry,  M  specifies the number of rows of  the  submatrix
06962 *          sub( A ). M  must be at least zero.
06963 *
06964 *  N       (global input) INTEGER
06965 *          On entry, N  specifies the number of columns of the submatrix
06966 *          sub( A ). N must be at least zero.
06967 *
06968 *  ALPHA   (global input) DOUBLE PRECISION
06969 *          On entry,  ALPHA  specifies the scalar alpha, i.e., the cons-
06970 *          tant to which the offdiagonal elements are to be set.
06971 *
06972 *  BETA    (global input) DOUBLE PRECISION
06973 *          On entry, BETA  specifies the scalar beta, i.e., the constant
06974 *          to which the diagonal elements are to be set.
06975 *
06976 *  A       (local input/local output) DOUBLE PRECISION array
06977 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
06978 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
06979 *          the local entries of the matrix  A  to be  set.  On exit, the
06980 *          leading m by n submatrix sub( A ) is set as follows:
06981 *
06982 *          if UPLO = 'U',  A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=j-1, 1<=j<=N,
06983 *          if UPLO = 'L',  A(IA+i-1,JA+j-1) = ALPHA, j+1<=i<=M, 1<=j<=N,
06984 *          otherwise,      A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=M,   1<=j<=N,
06985 *                                                      and IA+i.NE.JA+j,
06986 *          and, for all UPLO,  A(IA+i-1,JA+i-1) = BETA,  1<=i<=min(M,N).
06987 *
06988 *  IA      (global input) INTEGER
06989 *          On entry, IA  specifies A's global row index, which points to
06990 *          the beginning of the submatrix sub( A ).
06991 *
06992 *  JA      (global input) INTEGER
06993 *          On entry, JA  specifies A's global column index, which points
06994 *          to the beginning of the submatrix sub( A ).
06995 *
06996 *  DESCA   (global and local input) INTEGER array
06997 *          On entry, DESCA  is an integer array of dimension DLEN_. This
06998 *          is the array descriptor for the matrix A.
06999 *
07000 *  -- Written on April 1, 1998 by
07001 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
07002 *
07003 *  =====================================================================
07004 *
07005 *     .. Parameters ..
07006       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
07007      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
07008      $                   RSRC_
07009       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
07010      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
07011      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
07012      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
07013 *     ..
07014 *     .. Local Scalars ..
07015       LOGICAL            GODOWN, GOLEFT, ISCOLREP, ISROWREP, LOWER,
07016      $                   UPPER
07017       INTEGER            IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1,
07018      $                   IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP, JJA,
07019      $                   JJMAX, JOFFA, JOFFD, LCMT, LCMT00, LDA, LMBLOC,
07020      $                   LNBLOC, LOW, M1, MB, MBLKD, MBLKS, MBLOC, MP,
07021      $                   MRCOL, MRROW, MYCOL, MYROW, N1, NB, NBLKD,
07022      $                   NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB, QNB, TMP1,
07023      $                   UPP
07024 *     ..
07025 *     .. Local Arrays ..
07026       INTEGER            DESCA2( DLEN_ )
07027 *     ..
07028 *     .. External Subroutines ..
07029       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
07030      $                   PB_DESCTRANS, PB_DLASET
07031 *     ..
07032 *     .. External Functions ..
07033       LOGICAL            LSAME
07034       EXTERNAL           LSAME
07035 *     ..
07036 *     .. Intrinsic Functions ..
07037       INTRINSIC          MIN
07038 *     ..
07039 *     .. Executable Statements ..
07040 *
07041       IF( M.EQ.0 .OR. N.EQ.0 )
07042      $   RETURN
07043 *
07044 *     Convert descriptor
07045 *
07046       CALL PB_DESCTRANS( DESCA, DESCA2 )
07047 *
07048 *     Get grid parameters
07049 *
07050       ICTXT = DESCA2( CTXT_ )
07051       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
07052 *
07053       CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
07054      $                  MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
07055      $                  IACOL, MRROW, MRCOL )
07056 *
07057       IF( MP.LE.0 .OR. NQ.LE.0 )
07058      $   RETURN
07059 *
07060       ISROWREP = ( DESCA2( RSRC_ ).LT.0 )
07061       ISCOLREP = ( DESCA2( CSRC_ ).LT.0 )
07062       LDA      = DESCA2( LLD_ )
07063 *
07064       UPPER = .NOT.( LSAME( UPLO, 'L' ) )
07065       LOWER = .NOT.( LSAME( UPLO, 'U' ) )
07066 *
07067       IF( ( ( LOWER.AND.UPPER ).AND.( ALPHA.EQ.BETA ) ).OR.
07068      $    (   ISROWREP        .AND.  ISCOLREP        ) ) THEN
07069          IF( ( MP.GT.0 ).AND.( NQ.GT.0 ) )
07070      $      CALL PB_DLASET( UPLO, MP, NQ, 0, ALPHA, BETA,
07071      $                      A( IIA + ( JJA - 1 ) * LDA ), LDA )
07072          RETURN
07073       END IF
07074 *
07075 *     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
07076 *     ILOW, LOW, IUPP, and UPP.
07077 *
07078       MB = DESCA2( MB_ )
07079       NB = DESCA2( NB_ )
07080       CALL PB_BINFO( 0, MP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL,
07081      $               LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
07082      $               LNBLOC, ILOW, LOW, IUPP, UPP )
07083 *
07084       IOFFA = IIA - 1
07085       JOFFA = JJA - 1
07086       IIMAX = IOFFA + MP
07087       JJMAX = JOFFA + NQ
07088 *
07089       IF( ISROWREP ) THEN
07090          PMB = MB
07091       ELSE
07092          PMB = NPROW * MB
07093       END IF
07094       IF( ISCOLREP ) THEN
07095          QNB = NB
07096       ELSE
07097          QNB = NPCOL * NB
07098       END IF
07099 *
07100       M1 = MP
07101       N1 = NQ
07102 *
07103 *     Handle the first block of rows or columns separately, and update
07104 *     LCMT00, MBLKS and NBLKS.
07105 *
07106       GODOWN = ( LCMT00.GT.IUPP )
07107       GOLEFT = ( LCMT00.LT.ILOW )
07108 *
07109       IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN
07110 *
07111 *        LCMT00 >= ILOW && LCMT00 <= IUPP
07112 *
07113          GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW )
07114          GODOWN = .NOT.GOLEFT
07115 *
07116          CALL PB_DLASET( UPLO, IMBLOC, INBLOC, LCMT00, ALPHA, BETA,
07117      $                   A( IIA+JOFFA*LDA ), LDA )
07118          IF( GODOWN ) THEN
07119             IF( UPPER .AND. NQ.GT.INBLOC )
07120      $         CALL PB_DLASET( 'All', IMBLOC, NQ-INBLOC, 0, ALPHA,
07121      $                         ALPHA, A( IIA+(JOFFA+INBLOC)*LDA ), LDA )
07122             IIA = IIA + IMBLOC
07123             M1  = M1 - IMBLOC
07124          ELSE
07125             IF( LOWER .AND. MP.GT.IMBLOC )
07126      $         CALL PB_DLASET( 'All', MP-IMBLOC, INBLOC, 0, ALPHA,
07127      $                         ALPHA, A( IIA+IMBLOC+JOFFA*LDA ), LDA )
07128             JJA = JJA + INBLOC
07129             N1  = N1 - INBLOC
07130          END IF
07131 *
07132       END IF
07133 *
07134       IF( GODOWN ) THEN
07135 *
07136          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
07137          MBLKS  = MBLKS - 1
07138          IOFFA  = IOFFA + IMBLOC
07139 *
07140    10    CONTINUE
07141          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
07142             LCMT00 = LCMT00 - PMB
07143             MBLKS  = MBLKS - 1
07144             IOFFA  = IOFFA + MB
07145             GO TO 10
07146          END IF
07147 *
07148          TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
07149          IF( UPPER .AND. TMP1.GT.0 ) THEN
07150             CALL PB_DLASET( 'All', TMP1, N1, 0, ALPHA, ALPHA,
07151      $                      A( IIA+JOFFA*LDA ), LDA )
07152             IIA = IIA + TMP1
07153             M1  = M1 - TMP1
07154          END IF
07155 *
07156          IF( MBLKS.LE.0 )
07157      $      RETURN
07158 *
07159          LCMT  = LCMT00
07160          MBLKD = MBLKS
07161          IOFFD = IOFFA
07162 *
07163          MBLOC = MB
07164    20    CONTINUE
07165          IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN
07166             IF( MBLKD.EQ.1 )
07167      $         MBLOC = LMBLOC
07168             CALL PB_DLASET( UPLO, MBLOC, INBLOC, LCMT, ALPHA, BETA,
07169      $                      A( IOFFD+1+JOFFA*LDA ), LDA )
07170             LCMT00 = LCMT
07171             LCMT   = LCMT - PMB
07172             MBLKS  = MBLKD
07173             MBLKD  = MBLKD - 1
07174             IOFFA  = IOFFD
07175             IOFFD  = IOFFD + MBLOC
07176             GO TO 20
07177          END IF
07178 *
07179          TMP1 = M1 - IOFFD + IIA - 1
07180          IF( LOWER .AND. TMP1.GT.0 )
07181      $      CALL PB_DLASET( 'ALL', TMP1, INBLOC, 0, ALPHA, ALPHA,
07182      $                      A( IOFFD+1+JOFFA*LDA ), LDA )
07183 *
07184          TMP1   = IOFFA - IIA + 1
07185          M1     = M1 - TMP1
07186          N1     = N1 - INBLOC
07187          LCMT00 = LCMT00 + LOW - ILOW + QNB
07188          NBLKS  = NBLKS - 1
07189          JOFFA  = JOFFA + INBLOC
07190 *
07191          IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 )
07192      $      CALL PB_DLASET( 'ALL', TMP1, N1, 0, ALPHA, ALPHA,
07193      $                      A( IIA+JOFFA*LDA ), LDA )
07194 *
07195          IIA = IOFFA + 1
07196          JJA = JOFFA + 1
07197 *
07198       ELSE IF( GOLEFT ) THEN
07199 *
07200          LCMT00 = LCMT00 + LOW - ILOW + QNB
07201          NBLKS  = NBLKS - 1
07202          JOFFA  = JOFFA + INBLOC
07203 *
07204    30    CONTINUE
07205          IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN
07206             LCMT00 = LCMT00 + QNB
07207             NBLKS  = NBLKS - 1
07208             JOFFA  = JOFFA + NB
07209             GO TO 30
07210          END IF
07211 *
07212          TMP1 = MIN( JOFFA, JJMAX ) - JJA + 1
07213          IF( LOWER .AND. TMP1.GT.0 ) THEN
07214             CALL PB_DLASET( 'All', M1, TMP1, 0, ALPHA, ALPHA,
07215      $                      A( IIA+(JJA-1)*LDA ), LDA )
07216             JJA = JJA + TMP1
07217             N1  = N1 - TMP1
07218          END IF
07219 *
07220          IF( NBLKS.LE.0 )
07221      $      RETURN
07222 *
07223          LCMT  = LCMT00
07224          NBLKD = NBLKS
07225          JOFFD = JOFFA
07226 *
07227          NBLOC = NB
07228    40    CONTINUE
07229          IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN
07230             IF( NBLKD.EQ.1 )
07231      $         NBLOC = LNBLOC
07232             CALL PB_DLASET( UPLO, IMBLOC, NBLOC, LCMT, ALPHA, BETA,
07233      $                      A( IIA+JOFFD*LDA ), LDA )
07234             LCMT00 = LCMT
07235             LCMT   = LCMT + QNB
07236             NBLKS  = NBLKD
07237             NBLKD  = NBLKD - 1
07238             JOFFA  = JOFFD
07239             JOFFD  = JOFFD + NBLOC
07240             GO TO 40
07241          END IF
07242 *
07243          TMP1 = N1 - JOFFD + JJA - 1
07244          IF( UPPER .AND. TMP1.GT.0 )
07245      $      CALL PB_DLASET( 'All', IMBLOC, TMP1, 0, ALPHA, ALPHA,
07246      $                      A( IIA+JOFFD*LDA ), LDA )
07247 *
07248          TMP1   = JOFFA - JJA + 1
07249          M1     = M1 - IMBLOC
07250          N1     = N1 - TMP1
07251          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
07252          MBLKS  = MBLKS - 1
07253          IOFFA  = IOFFA + IMBLOC
07254 *
07255          IF( LOWER .AND. M1.GT.0 .AND. TMP1.GT.0 )
07256      $      CALL PB_DLASET( 'All', M1, TMP1, 0, ALPHA, ALPHA,
07257      $                      A( IOFFA+1+(JJA-1)*LDA ), LDA )
07258 *
07259          IIA = IOFFA + 1
07260          JJA = JOFFA + 1
07261 *
07262       END IF
07263 *
07264       NBLOC = NB
07265    50 CONTINUE
07266       IF( NBLKS.GT.0 ) THEN
07267          IF( NBLKS.EQ.1 )
07268      $      NBLOC = LNBLOC
07269    60    CONTINUE
07270          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
07271             LCMT00 = LCMT00 - PMB
07272             MBLKS  = MBLKS - 1
07273             IOFFA  = IOFFA + MB
07274             GO TO 60
07275          END IF
07276 *
07277          TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
07278          IF( UPPER .AND. TMP1.GT.0 ) THEN
07279             CALL PB_DLASET( 'All', TMP1, N1, 0, ALPHA, ALPHA,
07280      $                      A( IIA+JOFFA*LDA ), LDA )
07281             IIA = IIA + TMP1
07282             M1  = M1 - TMP1
07283          END IF
07284 *
07285          IF( MBLKS.LE.0 )
07286      $      RETURN
07287 *
07288          LCMT  = LCMT00
07289          MBLKD = MBLKS
07290          IOFFD = IOFFA
07291 *
07292          MBLOC = MB
07293    70    CONTINUE
07294          IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN
07295             IF( MBLKD.EQ.1 )
07296      $         MBLOC = LMBLOC
07297             CALL PB_DLASET( UPLO, MBLOC, NBLOC, LCMT, ALPHA, BETA,
07298      $                      A( IOFFD+1+JOFFA*LDA ), LDA )
07299             LCMT00 = LCMT
07300             LCMT   = LCMT - PMB
07301             MBLKS  = MBLKD
07302             MBLKD  = MBLKD - 1
07303             IOFFA  = IOFFD
07304             IOFFD  = IOFFD + MBLOC
07305             GO TO 70
07306          END IF
07307 *
07308          TMP1 = M1 - IOFFD + IIA - 1
07309          IF( LOWER .AND. TMP1.GT.0 )
07310      $      CALL PB_DLASET( 'All', TMP1, NBLOC, 0, ALPHA, ALPHA,
07311      $                      A( IOFFD+1+JOFFA*LDA ), LDA )
07312 *
07313          TMP1   = MIN( IOFFA, IIMAX )  - IIA + 1
07314          M1     = M1 - TMP1
07315          N1     = N1 - NBLOC
07316          LCMT00 = LCMT00 + QNB
07317          NBLKS  = NBLKS - 1
07318          JOFFA  = JOFFA + NBLOC
07319 *
07320          IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 )
07321      $      CALL PB_DLASET( 'All', TMP1, N1, 0, ALPHA, ALPHA,
07322      $                      A( IIA+JOFFA*LDA ), LDA )
07323 *
07324          IIA = IOFFA + 1
07325          JJA = JOFFA + 1
07326 *
07327          GO TO 50
07328 *
07329       END IF
07330 *
07331       RETURN
07332 *
07333 *     End of PDLASET
07334 *
07335       END
07336       SUBROUTINE PDLASCAL( TYPE, M, N, ALPHA, A, IA, JA, DESCA )
07337 *
07338 *  -- PBLAS test routine (version 2.0) --
07339 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
07340 *     and University of California, Berkeley.
07341 *     April 1, 1998
07342 *
07343 *     .. Scalar Arguments ..
07344       CHARACTER*1        TYPE
07345       INTEGER            IA, JA, M, N
07346       DOUBLE PRECISION   ALPHA
07347 *     ..
07348 *     .. Array Arguments ..
07349       INTEGER            DESCA( * )
07350       DOUBLE PRECISION   A( * )
07351 *     ..
07352 *
07353 *  Purpose
07354 *  =======
07355 *
07356 *  PDLASCAL  scales the  m by n submatrix A(IA:IA+M-1,JA:JA+N-1) denoted
07357 *  by sub( A ) by the scalar alpha. TYPE  specifies if sub( A ) is full,
07358 *  upper triangular, lower triangular or upper Hessenberg.
07359 *
07360 *  Notes
07361 *  =====
07362 *
07363 *  A description  vector  is associated with each 2D block-cyclicly dis-
07364 *  tributed matrix.  This  vector  stores  the  information  required to
07365 *  establish the  mapping  between a  matrix entry and its corresponding
07366 *  process and memory location.
07367 *
07368 *  In  the  following  comments,   the character _  should  be  read  as
07369 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
07370 *  block cyclicly distributed matrix.  Its description vector is DESCA:
07371 *
07372 *  NOTATION         STORED IN       EXPLANATION
07373 *  ---------------- --------------- ------------------------------------
07374 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
07375 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
07376 *                                   the NPROW x NPCOL BLACS process grid
07377 *                                   A  is distributed over.  The context
07378 *                                   itself  is  global,  but  the handle
07379 *                                   (the integer value) may vary.
07380 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
07381 *                                   ted matrix A, M_A >= 0.
07382 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
07383 *                                   buted matrix A, N_A >= 0.
07384 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
07385 *                                   block of the matrix A, IMB_A > 0.
07386 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
07387 *                                   left   block   of   the   matrix  A,
07388 *                                   INB_A > 0.
07389 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
07390 *                                   bute the last  M_A-IMB_A rows of  A,
07391 *                                   MB_A > 0.
07392 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
07393 *                                   bute the last  N_A-INB_A  columns of
07394 *                                   A, NB_A > 0.
07395 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
07396 *                                   row of the matrix  A is distributed,
07397 *                                   NPROW > RSRC_A >= 0.
07398 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
07399 *                                   first  column of  A  is distributed.
07400 *                                   NPCOL > CSRC_A >= 0.
07401 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
07402 *                                   array  storing  the  local blocks of
07403 *                                   the distributed matrix A,
07404 *                                   IF( Lc( 1, N_A ) > 0 )
07405 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
07406 *                                   ELSE
07407 *                                      LLD_A >= 1.
07408 *
07409 *  Let K be the number of  rows of a matrix A starting at the global in-
07410 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
07411 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
07412 *  receive if these K rows were distributed over NPROW processes.  If  K
07413 *  is the number of columns of a matrix  A  starting at the global index
07414 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
07415 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
07416 *  these K columns were distributed over NPCOL processes.
07417 *
07418 *  The values of Lr() and Lc() may be determined via a call to the func-
07419 *  tion PB_NUMROC:
07420 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
07421 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
07422 *
07423 *  Arguments
07424 *  =========
07425 *
07426 *  TYPE    (global input) CHARACTER*1
07427 *          On entry,  TYPE  specifies the type of the input submatrix as
07428 *          follows:
07429 *             = 'L' or 'l':  sub( A ) is a lower triangular matrix,
07430 *             = 'U' or 'u':  sub( A ) is an upper triangular matrix,
07431 *             = 'H' or 'h':  sub( A ) is an upper Hessenberg matrix,
07432 *             otherwise sub( A ) is a  full matrix.
07433 *
07434 *  M       (global input) INTEGER
07435 *          On entry,  M  specifies the number of rows of  the  submatrix
07436 *          sub( A ). M  must be at least zero.
07437 *
07438 *  N       (global input) INTEGER
07439 *          On entry, N  specifies the number of columns of the submatrix
07440 *          sub( A ). N  must be at least zero.
07441 *
07442 *  ALPHA   (global input) DOUBLE PRECISION
07443 *          On entry, ALPHA specifies the scalar alpha.
07444 *
07445 *  A       (local input/local output) DOUBLE PRECISION array
07446 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
07447 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
07448 *          the local entries of the matrix  A.
07449 *          On exit, the local entries of this array corresponding to the
07450 *          to  the entries of the submatrix sub( A ) are  overwritten by
07451 *          the local entries of the m by n scaled submatrix.
07452 *
07453 *  IA      (global input) INTEGER
07454 *          On entry, IA  specifies A's global row index, which points to
07455 *          the beginning of the submatrix sub( A ).
07456 *
07457 *  JA      (global input) INTEGER
07458 *          On entry, JA  specifies A's global column index, which points
07459 *          to the beginning of the submatrix sub( A ).
07460 *
07461 *  DESCA   (global and local input) INTEGER array
07462 *          On entry, DESCA  is an integer array of dimension DLEN_. This
07463 *          is the array descriptor for the matrix A.
07464 *
07465 *  -- Written on April 1, 1998 by
07466 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
07467 *
07468 *  =====================================================================
07469 *
07470 *     .. Parameters ..
07471       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
07472      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
07473      $                   RSRC_
07474       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
07475      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
07476      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
07477      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
07478 *     ..
07479 *     .. Local Scalars ..
07480       CHARACTER*1        UPLO
07481       LOGICAL            GODOWN, GOLEFT, LOWER, UPPER
07482       INTEGER            IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1,
07483      $                   IMBLOC, INB1, INBLOC, IOFFA, IOFFD, ITYPE,
07484      $                   IUPP, JJA, JJMAX, JOFFA, JOFFD, LCMT, LCMT00,
07485      $                   LDA, LMBLOC, LNBLOC, LOW, M1, MB, MBLKD, MBLKS,
07486      $                   MBLOC, MP, MRCOL, MRROW, MYCOL, MYROW, N1, NB,
07487      $                   NBLKD, NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB,
07488      $                   QNB, TMP1, UPP
07489 *     ..
07490 *     .. Local Arrays ..
07491       INTEGER            DESCA2( DLEN_ )
07492 *     ..
07493 *     .. External Subroutines ..
07494       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
07495      $                   PB_DESCTRANS, PB_DLASCAL, PB_INFOG2L
07496 *     ..
07497 *     .. External Functions ..
07498       LOGICAL            LSAME
07499       INTEGER            PB_NUMROC
07500       EXTERNAL           LSAME, PB_NUMROC
07501 *     ..
07502 *     .. Intrinsic Functions ..
07503       INTRINSIC          MIN
07504 *     ..
07505 *     .. Executable Statements ..
07506 *
07507 *     Convert descriptor
07508 *
07509       CALL PB_DESCTRANS( DESCA, DESCA2 )
07510 *
07511 *     Get grid parameters
07512 *
07513       ICTXT = DESCA2( CTXT_ )
07514       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
07515 *
07516 *     Quick return if possible
07517 *
07518       IF( M.EQ.0 .OR. N.EQ.0 )
07519      $   RETURN
07520 *
07521       IF( LSAME( TYPE, 'L' ) ) THEN
07522          ITYPE = 1
07523          UPLO  = TYPE
07524          UPPER = .FALSE.
07525          LOWER = .TRUE.
07526          IOFFD = 0
07527       ELSE IF( LSAME( TYPE, 'U' ) ) THEN
07528          ITYPE = 2
07529          UPLO  = TYPE
07530          UPPER = .TRUE.
07531          LOWER = .FALSE.
07532          IOFFD = 0
07533       ELSE IF( LSAME( TYPE, 'H' ) ) THEN
07534          ITYPE = 3
07535          UPLO  = 'U'
07536          UPPER = .TRUE.
07537          LOWER = .FALSE.
07538          IOFFD = 1
07539       ELSE
07540          ITYPE = 0
07541          UPLO  = 'A'
07542          UPPER = .TRUE.
07543          LOWER = .TRUE.
07544          IOFFD = 0
07545       END IF
07546 *
07547 *     Compute local indexes
07548 *
07549       IF( ITYPE.EQ.0 ) THEN
07550 *
07551 *        Full matrix
07552 *
07553          CALL PB_INFOG2L( IA, JA, DESCA2, NPROW, NPCOL, MYROW, MYCOL,
07554      $                    IIA, JJA, IAROW, IACOL )
07555          MP = PB_NUMROC( M, IA, DESCA2( IMB_ ), DESCA2( MB_ ), MYROW,
07556      $                   DESCA2( RSRC_ ), NPROW )
07557          NQ = PB_NUMROC( N, JA, DESCA2( INB_ ), DESCA2( NB_ ), MYCOL,
07558      $                   DESCA2( CSRC_ ), NPCOL )
07559 *
07560          IF( MP.LE.0 .OR. NQ.LE.0 )
07561      $      RETURN
07562 *
07563          LDA   = DESCA2( LLD_ )
07564          IOFFA = IIA + ( JJA - 1 ) * LDA
07565 *
07566          CALL PB_DLASCAL( 'All', MP, NQ, 0, ALPHA, A( IOFFA ), LDA )
07567 *
07568       ELSE
07569 *
07570 *        Trapezoidal matrix
07571 *
07572          CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
07573      $                     MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
07574      $                     IACOL, MRROW, MRCOL )
07575 *
07576          IF( MP.LE.0 .OR. NQ.LE.0 )
07577      $      RETURN
07578 *
07579 *        Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
07580 *        LNBLOC, ILOW, LOW, IUPP, and UPP.
07581 *
07582          MB  = DESCA2( MB_ )
07583          NB  = DESCA2( NB_ )
07584          LDA = DESCA2( LLD_ )
07585 *
07586          CALL PB_BINFO( IOFFD, MP, NQ, IMB1, INB1, MB, NB, MRROW,
07587      $                  MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC,
07588      $                  LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP )
07589 *
07590          M1    = MP
07591          N1    = NQ
07592          IOFFA = IIA - 1
07593          JOFFA = JJA - 1
07594          IIMAX = IOFFA + MP
07595          JJMAX = JOFFA + NQ
07596 *
07597          IF( DESCA2( RSRC_ ).LT.0 ) THEN
07598             PMB = MB
07599          ELSE
07600             PMB = NPROW * MB
07601          END IF
07602          IF( DESCA2( CSRC_ ).LT.0 ) THEN
07603             QNB = NB
07604          ELSE
07605             QNB = NPCOL * NB
07606          END IF
07607 *
07608 *        Handle the first block of rows or columns separately, and
07609 *        update LCMT00, MBLKS and NBLKS.
07610 *
07611          GODOWN = ( LCMT00.GT.IUPP )
07612          GOLEFT = ( LCMT00.LT.ILOW )
07613 *
07614          IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN
07615 *
07616 *           LCMT00 >= ILOW && LCMT00 <= IUPP
07617 *
07618             GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW )
07619             GODOWN = .NOT.GOLEFT
07620 *
07621             CALL PB_DLASCAL( UPLO, IMBLOC, INBLOC, LCMT00, ALPHA,
07622      $                       A( IIA+JOFFA*LDA ), LDA )
07623             IF( GODOWN ) THEN
07624                IF( UPPER .AND. NQ.GT.INBLOC )
07625      $            CALL PB_DLASCAL( 'All', IMBLOC, NQ-INBLOC, 0, ALPHA,
07626      $                             A( IIA+(JOFFA+INBLOC)*LDA ), LDA )
07627                IIA = IIA + IMBLOC
07628                M1  = M1 - IMBLOC
07629             ELSE
07630                IF( LOWER .AND. MP.GT.IMBLOC )
07631      $            CALL PB_DLASCAL( 'All', MP-IMBLOC, INBLOC, 0, ALPHA,
07632      $                             A( IIA+IMBLOC+JOFFA*LDA ), LDA )
07633                JJA = JJA + INBLOC
07634                N1  = N1 - INBLOC
07635             END IF
07636 *
07637          END IF
07638 *
07639          IF( GODOWN ) THEN
07640 *
07641             LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
07642             MBLKS  = MBLKS - 1
07643             IOFFA  = IOFFA + IMBLOC
07644 *
07645    10       CONTINUE
07646             IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
07647                LCMT00 = LCMT00 - PMB
07648                MBLKS  = MBLKS - 1
07649                IOFFA  = IOFFA + MB
07650                GO TO 10
07651             END IF
07652 *
07653             TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
07654             IF( UPPER .AND. TMP1.GT.0 ) THEN
07655                CALL PB_DLASCAL( 'All', TMP1, N1, 0, ALPHA,
07656      $                          A( IIA+JOFFA*LDA ), LDA )
07657                IIA = IIA + TMP1
07658                M1  = M1 - TMP1
07659             END IF
07660 *
07661             IF( MBLKS.LE.0 )
07662      $         RETURN
07663 *
07664             LCMT  = LCMT00
07665             MBLKD = MBLKS
07666             IOFFD = IOFFA
07667 *
07668             MBLOC = MB
07669    20       CONTINUE
07670             IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN
07671                IF( MBLKD.EQ.1 )
07672      $            MBLOC = LMBLOC
07673                CALL PB_DLASCAL( UPLO, MBLOC, INBLOC, LCMT, ALPHA,
07674      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
07675                LCMT00 = LCMT
07676                LCMT   = LCMT - PMB
07677                MBLKS  = MBLKD
07678                MBLKD  = MBLKD - 1
07679                IOFFA  = IOFFD
07680                IOFFD  = IOFFD + MBLOC
07681                GO TO 20
07682             END IF
07683 *
07684             TMP1 = M1 - IOFFD + IIA - 1
07685             IF( LOWER .AND. TMP1.GT.0 )
07686      $         CALL PB_DLASCAL( 'All', TMP1, INBLOC, 0, ALPHA,
07687      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
07688 *
07689             TMP1   = IOFFA - IIA + 1
07690             M1     = M1 - TMP1
07691             N1     = N1 - INBLOC
07692             LCMT00 = LCMT00 + LOW - ILOW + QNB
07693             NBLKS  = NBLKS - 1
07694             JOFFA  = JOFFA + INBLOC
07695 *
07696             IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 )
07697      $         CALL PB_DLASCAL( 'All', TMP1, N1, 0, ALPHA,
07698      $                          A( IIA+JOFFA*LDA ), LDA )
07699 *
07700             IIA = IOFFA + 1
07701             JJA = JOFFA + 1
07702 *
07703          ELSE IF( GOLEFT ) THEN
07704 *
07705             LCMT00 = LCMT00 + LOW - ILOW + QNB
07706             NBLKS  = NBLKS - 1
07707             JOFFA  = JOFFA + INBLOC
07708 *
07709    30       CONTINUE
07710             IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN
07711                LCMT00 = LCMT00 + QNB
07712                NBLKS  = NBLKS - 1
07713                JOFFA  = JOFFA + NB
07714                GO TO 30
07715             END IF
07716 *
07717             TMP1 = MIN( JOFFA, JJMAX ) - JJA + 1
07718             IF( LOWER .AND. TMP1.GT.0 ) THEN
07719                CALL PB_DLASCAL( 'All', M1, TMP1, 0, ALPHA,
07720      $                          A( IIA+(JJA-1)*LDA ), LDA )
07721                JJA = JJA + TMP1
07722                N1  = N1 - TMP1
07723             END IF
07724 *
07725             IF( NBLKS.LE.0 )
07726      $         RETURN
07727 *
07728             LCMT  = LCMT00
07729             NBLKD = NBLKS
07730             JOFFD = JOFFA
07731 *
07732             NBLOC = NB
07733    40       CONTINUE
07734             IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN
07735                IF( NBLKD.EQ.1 )
07736      $            NBLOC = LNBLOC
07737                CALL PB_DLASCAL( UPLO, IMBLOC, NBLOC, LCMT, ALPHA,
07738      $                          A( IIA+JOFFD*LDA ), LDA )
07739                LCMT00 = LCMT
07740                LCMT   = LCMT + QNB
07741                NBLKS  = NBLKD
07742                NBLKD  = NBLKD - 1
07743                JOFFA  = JOFFD
07744                JOFFD  = JOFFD + NBLOC
07745                GO TO 40
07746             END IF
07747 *
07748             TMP1 = N1 - JOFFD + JJA - 1
07749             IF( UPPER .AND. TMP1.GT.0 )
07750      $         CALL PB_DLASCAL( 'All', IMBLOC, TMP1, 0, ALPHA,
07751      $                          A( IIA+JOFFD*LDA ), LDA )
07752 *
07753             TMP1   = JOFFA - JJA + 1
07754             M1     = M1 - IMBLOC
07755             N1     = N1 - TMP1
07756             LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
07757             MBLKS  = MBLKS - 1
07758             IOFFA  = IOFFA + IMBLOC
07759 *
07760             IF( LOWER .AND. M1.GT.0 .AND. TMP1.GT.0 )
07761      $         CALL PB_DLASCAL( 'All', M1, TMP1, 0, ALPHA,
07762      $                          A( IOFFA+1+(JJA-1)*LDA ), LDA )
07763 *
07764             IIA = IOFFA + 1
07765             JJA = JOFFA + 1
07766 *
07767          END IF
07768 *
07769          NBLOC = NB
07770    50    CONTINUE
07771          IF( NBLKS.GT.0 ) THEN
07772             IF( NBLKS.EQ.1 )
07773      $         NBLOC = LNBLOC
07774    60       CONTINUE
07775             IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
07776                LCMT00 = LCMT00 - PMB
07777                MBLKS  = MBLKS - 1
07778                IOFFA  = IOFFA + MB
07779                GO TO 60
07780             END IF
07781 *
07782             TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
07783             IF( UPPER .AND. TMP1.GT.0 ) THEN
07784                CALL PB_DLASCAL( 'All', TMP1, N1, 0, ALPHA,
07785      $                          A( IIA+JOFFA*LDA ), LDA )
07786                IIA = IIA + TMP1
07787                M1  = M1 - TMP1
07788             END IF
07789 *
07790             IF( MBLKS.LE.0 )
07791      $         RETURN
07792 *
07793             LCMT  = LCMT00
07794             MBLKD = MBLKS
07795             IOFFD = IOFFA
07796 *
07797             MBLOC = MB
07798    70       CONTINUE
07799             IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN
07800                IF( MBLKD.EQ.1 )
07801      $            MBLOC = LMBLOC
07802                CALL PB_DLASCAL( UPLO, MBLOC, NBLOC, LCMT, ALPHA,
07803      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
07804                LCMT00 = LCMT
07805                LCMT   = LCMT - PMB
07806                MBLKS  = MBLKD
07807                MBLKD  = MBLKD - 1
07808                IOFFA  = IOFFD
07809                IOFFD  = IOFFD + MBLOC
07810                GO TO 70
07811             END IF
07812 *
07813             TMP1 = M1 - IOFFD + IIA - 1
07814             IF( LOWER .AND. TMP1.GT.0 )
07815      $         CALL PB_DLASCAL( 'All', TMP1, NBLOC, 0, ALPHA,
07816      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
07817 *
07818             TMP1   = MIN( IOFFA, IIMAX )  - IIA + 1
07819             M1     = M1 - TMP1
07820             N1     = N1 - NBLOC
07821             LCMT00 = LCMT00 + QNB
07822             NBLKS  = NBLKS - 1
07823             JOFFA  = JOFFA + NBLOC
07824 *
07825             IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 )
07826      $         CALL PB_DLASCAL( 'All', TMP1, N1, 0, ALPHA,
07827      $                          A( IIA+JOFFA*LDA ), LDA )
07828 *
07829             IIA = IOFFA + 1
07830             JJA = JOFFA + 1
07831 *
07832             GO TO 50
07833 *
07834          END IF
07835 *
07836       END IF
07837 *
07838       RETURN
07839 *
07840 *     End of PDLASCAL
07841 *
07842       END
07843       SUBROUTINE PDLAGEN( INPLACE, AFORM, DIAG, OFFA, M, N, IA, JA,
07844      $                    DESCA, IASEED, A, LDA )
07845 *
07846 *  -- PBLAS test routine (version 2.0) --
07847 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
07848 *     and University of California, Berkeley.
07849 *     April 1, 1998
07850 *
07851 *     .. Scalar Arguments ..
07852       LOGICAL            INPLACE
07853       CHARACTER*1        AFORM, DIAG
07854       INTEGER            IA, IASEED, JA, LDA, M, N, OFFA
07855 *     ..
07856 *     .. Array Arguments ..
07857       INTEGER            DESCA( * )
07858       DOUBLE PRECISION   A( LDA, * )
07859 *     ..
07860 *
07861 *  Purpose
07862 *  =======
07863 *
07864 *  PDLAGEN  generates  (or regenerates)  a  submatrix  sub( A ) denoting
07865 *  A(IA:IA+M-1,JA:JA+N-1).
07866 *
07867 *  Notes
07868 *  =====
07869 *
07870 *  A description  vector  is associated with each 2D block-cyclicly dis-
07871 *  tributed matrix.  This  vector  stores  the  information  required to
07872 *  establish the  mapping  between a  matrix entry and its corresponding
07873 *  process and memory location.
07874 *
07875 *  In  the  following  comments,   the character _  should  be  read  as
07876 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
07877 *  block cyclicly distributed matrix.  Its description vector is DESCA:
07878 *
07879 *  NOTATION         STORED IN       EXPLANATION
07880 *  ---------------- --------------- ------------------------------------
07881 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
07882 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
07883 *                                   the NPROW x NPCOL BLACS process grid
07884 *                                   A  is distributed over.  The context
07885 *                                   itself  is  global,  but  the handle
07886 *                                   (the integer value) may vary.
07887 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
07888 *                                   ted matrix A, M_A >= 0.
07889 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
07890 *                                   buted matrix A, N_A >= 0.
07891 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
07892 *                                   block of the matrix A, IMB_A > 0.
07893 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
07894 *                                   left   block   of   the   matrix  A,
07895 *                                   INB_A > 0.
07896 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
07897 *                                   bute the last  M_A-IMB_A rows of  A,
07898 *                                   MB_A > 0.
07899 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
07900 *                                   bute the last  N_A-INB_A  columns of
07901 *                                   A, NB_A > 0.
07902 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
07903 *                                   row of the matrix  A is distributed,
07904 *                                   NPROW > RSRC_A >= 0.
07905 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
07906 *                                   first  column of  A  is distributed.
07907 *                                   NPCOL > CSRC_A >= 0.
07908 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
07909 *                                   array  storing  the  local blocks of
07910 *                                   the distributed matrix A,
07911 *                                   IF( Lc( 1, N_A ) > 0 )
07912 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
07913 *                                   ELSE
07914 *                                      LLD_A >= 1.
07915 *
07916 *  Let K be the number of  rows of a matrix A starting at the global in-
07917 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
07918 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
07919 *  receive if these K rows were distributed over NPROW processes.  If  K
07920 *  is the number of columns of a matrix  A  starting at the global index
07921 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
07922 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
07923 *  these K columns were distributed over NPCOL processes.
07924 *
07925 *  The values of Lr() and Lc() may be determined via a call to the func-
07926 *  tion PB_NUMROC:
07927 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
07928 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
07929 *
07930 *  Arguments
07931 *  =========
07932 *
07933 *  INPLACE (global input) LOGICAL
07934 *          On entry, INPLACE specifies if the matrix should be generated
07935 *          in place or not. If INPLACE is .TRUE., the local random array
07936 *          to be generated  will start in memory at the local memory lo-
07937 *          cation A( 1, 1 ),  otherwise it will start at the local posi-
07938 *          tion induced by IA and JA.
07939 *
07940 *  AFORM   (global input) CHARACTER*1
07941 *          On entry, AFORM specifies the type of submatrix to be genera-
07942 *          ted as follows:
07943 *             AFORM = 'S', sub( A ) is a symmetric matrix,
07944 *             AFORM = 'H', sub( A ) is a Hermitian matrix,
07945 *             AFORM = 'T', sub( A ) is overrwritten  with  the transpose
07946 *                          of what would normally be generated,
07947 *             AFORM = 'C', sub( A ) is overwritten  with  the  conjugate
07948 *                          transpose  of  what would normally be genera-
07949 *                          ted.
07950 *             AFORM = 'N', a random submatrix is generated.
07951 *
07952 *  DIAG    (global input) CHARACTER*1
07953 *          On entry, DIAG specifies if the generated submatrix is diago-
07954 *          nally dominant or not as follows:
07955 *             DIAG = 'D' : sub( A ) is diagonally dominant,
07956 *             DIAG = 'N' : sub( A ) is not diagonally dominant.
07957 *
07958 *  OFFA    (global input) INTEGER
07959 *          On entry, OFFA  specifies  the  offdiagonal of the underlying
07960 *          matrix A(1:DESCA(M_),1:DESCA(N_)) of interest when the subma-
07961 *          trix is symmetric, Hermitian or diagonally dominant. OFFA = 0
07962 *          specifies the main diagonal,  OFFA > 0  specifies a subdiago-
07963 *          nal,  and OFFA < 0 specifies a superdiagonal (see further de-
07964 *          tails).
07965 *
07966 *  M       (global input) INTEGER
07967 *          On entry, M specifies the global number of matrix rows of the
07968 *          submatrix sub( A ) to be generated. M must be at least zero.
07969 *
07970 *  N       (global input) INTEGER
07971 *          On entry,  N specifies the global number of matrix columns of
07972 *          the  submatrix  sub( A )  to be generated. N must be at least
07973 *          zero.
07974 *
07975 *  IA      (global input) INTEGER
07976 *          On entry, IA  specifies A's global row index, which points to
07977 *          the beginning of the submatrix sub( A ).
07978 *
07979 *  JA      (global input) INTEGER
07980 *          On entry, JA  specifies A's global column index, which points
07981 *          to the beginning of the submatrix sub( A ).
07982 *
07983 *  DESCA   (global and local input) INTEGER array
07984 *          On entry, DESCA  is an integer array of dimension DLEN_. This
07985 *          is the array descriptor for the matrix A.
07986 *
07987 *  IASEED  (global input) INTEGER
07988 *          On entry, IASEED  specifies  the  seed number to generate the
07989 *          matrix A. IASEED must be at least zero.
07990 *
07991 *  A       (local output) DOUBLE PRECISION array
07992 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
07993 *          at least Lc( 1, JA+N-1 ).  On  exit, this array  contains the
07994 *          local entries of the randomly generated submatrix sub( A ).
07995 *
07996 *  LDA     (local input) INTEGER
07997 *          On entry,  LDA  specifies  the local leading dimension of the
07998 *          array A. When INPLACE is .FALSE., LDA is usually DESCA(LLD_).
07999 *          This restriction is however not enforced, and this subroutine
08000 *          requires only that LDA >= MAX( 1, Mp ) where
08001 *
08002 *          Mp = PB_NUMROC( M, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ).
08003 *
08004 *          PB_NUMROC  is  a ScaLAPACK tool function; MYROW, MYCOL, NPROW
08005 *          and NPCOL  can  be determined by calling the BLACS subroutine
08006 *          BLACS_GRIDINFO.
08007 *
08008 *  Further Details
08009 *  ===============
08010 *
08011 *  OFFD  is  tied  to  the matrix described by  DESCA, as opposed to the
08012 *  piece that is currently  (re)generated.  This is a global information
08013 *  independent from the distribution  parameters.  Below are examples of
08014 *  the meaning of OFFD for a global 7 by 5 matrix:
08015 *
08016 *  ---------------------------------------------------------------------
08017 *  OFFD   |  0 -1 -2 -3 -4         0 -1 -2 -3 -4          0 -1 -2 -3 -4
08018 *  -------|-------------------------------------------------------------
08019 *         |     | OFFD=-1          |   OFFD=0                 OFFD=2
08020 *         |     V                  V
08021 *  0      |  .  d  .  .  .      -> d  .  .  .  .          .  .  .  .  .
08022 *  1      |  .  .  d  .  .         .  d  .  .  .          .  .  .  .  .
08023 *  2      |  .  .  .  d  .         .  .  d  .  .       -> d  .  .  .  .
08024 *  3      |  .  .  .  .  d         .  .  .  d  .          .  d  .  .  .
08025 *  4      |  .  .  .  .  .         .  .  .  .  d          .  .  d  .  .
08026 *  5      |  .  .  .  .  .         .  .  .  .  .          .  .  .  d  .
08027 *  6      |  .  .  .  .  .         .  .  .  .  .          .  .  .  .  d
08028 *  ---------------------------------------------------------------------
08029 *
08030 *  -- Written on April 1, 1998 by
08031 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
08032 *
08033 *  =====================================================================
08034 *
08035 *     .. Parameters ..
08036       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
08037      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
08038      $                   RSRC_
08039       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
08040      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
08041      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
08042      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
08043       INTEGER            JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
08044      $                   JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
08045      $                   JMP_NQINBLOC, JMP_NQNB, JMP_ROW
08046       PARAMETER          ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3,
08047      $                   JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6,
08048      $                   JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9,
08049      $                   JMP_NQNB = 10, JMP_NQINBLOC = 11,
08050      $                   JMP_LEN = 11 )
08051 *     ..
08052 *     .. Local Scalars ..
08053       LOGICAL            DIAGDO, SYMM, HERM, NOTRAN
08054       INTEGER            CSRC, I, IACOL, IAROW, ICTXT, IIA, ILOCBLK,
08055      $                   ILOCOFF, ILOW, IMB, IMB1, IMBLOC, IMBVIR, INB,
08056      $                   INB1, INBLOC, INBVIR, INFO, IOFFDA, ITMP, IUPP,
08057      $                   IVIR, JJA, JLOCBLK, JLOCOFF, JVIR, LCMT00,
08058      $                   LMBLOC, LNBLOC, LOW, MAXMN, MB, MBLKS, MP,
08059      $                   MRCOL, MRROW, MYCDIST, MYCOL, MYRDIST, MYROW,
08060      $                   NB, NBLKS, NPCOL, NPROW, NQ, NVIR, RSRC, UPP
08061       DOUBLE PRECISION   ALPHA
08062 *     ..
08063 *     .. Local Arrays ..
08064       INTEGER            DESCA2( DLEN_ ), IMULADD( 4, JMP_LEN ),
08065      $                   IRAN( 2 ), JMP( JMP_LEN ), MULADD0( 4 )
08066 *     ..
08067 *     .. External Subroutines ..
08068       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
08069      $                   PB_CHKMAT, PB_DESCTRANS, PB_DLAGEN, PB_INITJMP,
08070      $                   PB_INITMULADD, PB_JUMP, PB_JUMPIT, PB_LOCINFO,
08071      $                   PB_SETLOCRAN, PB_SETRAN, PDLADOM, PXERBLA
08072 *     ..
08073 *     .. External Functions ..
08074       LOGICAL            LSAME
08075       EXTERNAL           LSAME
08076 *     ..
08077 *     .. Intrinsic Functions ..
08078       INTRINSIC          DBLE, MAX, MIN
08079 *     ..
08080 *     .. Data Statements ..
08081       DATA               ( MULADD0( I ), I = 1, 4 ) / 20077, 16838,
08082      $                   12345, 0 /
08083 *     ..
08084 *     .. Executable Statements ..
08085 *
08086 *     Convert descriptor
08087 *
08088       CALL PB_DESCTRANS( DESCA, DESCA2 )
08089 *
08090 *     Test the input arguments
08091 *
08092       ICTXT = DESCA2( CTXT_ )
08093       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
08094 *
08095 *     Test the input parameters
08096 *
08097       INFO = 0
08098       IF( NPROW.EQ.-1 ) THEN
08099          INFO = -( 1000 + CTXT_ )
08100       ELSE
08101          SYMM   = LSAME( AFORM, 'S' )
08102          HERM   = LSAME( AFORM, 'H' )
08103          NOTRAN = LSAME( AFORM, 'N' )
08104          DIAGDO = LSAME( DIAG, 'D' )
08105          IF( .NOT.( SYMM.OR.HERM.OR.NOTRAN ) .AND.
08106      $       .NOT.( LSAME( AFORM, 'T' )    ) .AND.
08107      $       .NOT.( LSAME( AFORM, 'C' )    ) ) THEN
08108             INFO = -2
08109          ELSE IF( ( .NOT.DIAGDO ) .AND.
08110      $            ( .NOT.LSAME( DIAG, 'N' ) ) ) THEN
08111             INFO = -3
08112          END IF
08113          CALL PB_CHKMAT( ICTXT, M, 5, N, 6, IA, JA, DESCA2, 10, INFO )
08114       END IF
08115 *
08116       IF( INFO.NE.0 ) THEN
08117          CALL PXERBLA( ICTXT, 'PDLAGEN', -INFO )
08118          RETURN
08119       END IF
08120 *
08121 *     Quick return if possible
08122 *
08123       IF( ( M.LE.0 ).OR.( N.LE.0 ) )
08124      $   RETURN
08125 *
08126 *     Start the operations
08127 *
08128       MB   = DESCA2( MB_   )
08129       NB   = DESCA2( NB_   )
08130       IMB  = DESCA2( IMB_  )
08131       INB  = DESCA2( INB_  )
08132       RSRC = DESCA2( RSRC_ )
08133       CSRC = DESCA2( CSRC_ )
08134 *
08135 *     Figure out local information about the distributed matrix operand
08136 *
08137       CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
08138      $                  MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
08139      $                  IACOL, MRROW, MRCOL )
08140 *
08141 *     Decide where the entries shall be stored in memory
08142 *
08143       IF( INPLACE ) THEN
08144          IIA = 1
08145          JJA = 1
08146       END IF
08147 *
08148 *     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
08149 *     ILOW, LOW, IUPP, and UPP.
08150 *
08151       IOFFDA = JA + OFFA - IA
08152       CALL PB_BINFO( IOFFDA, MP, NQ, IMB1, INB1, MB, NB, MRROW,
08153      $               MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC,
08154      $               LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP )
08155 *
08156 *     Initialize ILOCBLK, ILOCOFF, MYRDIST, JLOCBLK, JLOCOFF, MYCDIST
08157 *     This values correspond to the square virtual underlying matrix
08158 *     of size MAX( M_ + MAX( 0, -OFFA ), N_ + MAX( 0, OFFA ) ) used
08159 *     to set up the random sequence. For practical purposes, the size
08160 *     of this virtual matrix is upper bounded by M_ + N_ - 1.
08161 *
08162       ITMP   = MAX( 0, -OFFA )
08163       IVIR   = IA  + ITMP
08164       IMBVIR = IMB + ITMP
08165       NVIR   = DESCA2( M_ ) + ITMP
08166 *
08167       CALL PB_LOCINFO( IVIR, IMBVIR, MB, MYROW, RSRC, NPROW, ILOCBLK,
08168      $                 ILOCOFF, MYRDIST )
08169 *
08170       ITMP   = MAX( 0, OFFA )
08171       JVIR   = JA  + ITMP
08172       INBVIR = INB + ITMP
08173       NVIR   = MAX( MAX( NVIR, DESCA2( N_ ) + ITMP ),
08174      $              DESCA2( M_ ) + DESCA2( N_ ) - 1 )
08175 *
08176       CALL PB_LOCINFO( JVIR, INBVIR, NB, MYCOL, CSRC, NPCOL, JLOCBLK,
08177      $                 JLOCOFF, MYCDIST )
08178 *
08179       IF( SYMM .OR. HERM .OR. NOTRAN ) THEN
08180 *
08181          CALL PB_INITJMP( .TRUE., NVIR, IMBVIR, INBVIR, IMBLOC, INBLOC,
08182      $                    MB, NB, RSRC, CSRC, NPROW, NPCOL, 1, JMP )
08183 *
08184 *        Compute constants to jump JMP( * ) numbers in the sequence
08185 *
08186          CALL PB_INITMULADD( MULADD0, JMP, IMULADD )
08187 *
08188 *        Compute and set the random value corresponding to A( IA, JA )
08189 *
08190          CALL PB_SETLOCRAN( IASEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF,
08191      $                      MYRDIST, MYCDIST, NPROW, NPCOL, JMP,
08192      $                      IMULADD, IRAN )
08193 *
08194          CALL PB_DLAGEN( 'Lower', AFORM, A( IIA, JJA ), LDA, LCMT00,
08195      $                   IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC,
08196      $                   NB, LNBLOC, JMP, IMULADD )
08197 *
08198       END IF
08199 *
08200       IF( SYMM .OR. HERM .OR. ( .NOT. NOTRAN ) ) THEN
08201 *
08202          CALL PB_INITJMP( .FALSE., NVIR, IMBVIR, INBVIR, IMBLOC, INBLOC,
08203      $                    MB, NB, RSRC, CSRC, NPROW, NPCOL, 1, JMP )
08204 *
08205 *        Compute constants to jump JMP( * ) numbers in the sequence
08206 *
08207          CALL PB_INITMULADD( MULADD0, JMP, IMULADD )
08208 *
08209 *        Compute and set the random value corresponding to A( IA, JA )
08210 *
08211          CALL PB_SETLOCRAN( IASEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF,
08212      $                      MYRDIST, MYCDIST, NPROW, NPCOL, JMP,
08213      $                      IMULADD, IRAN )
08214 *
08215          CALL PB_DLAGEN( 'Upper', AFORM, A( IIA, JJA ), LDA, LCMT00,
08216      $                   IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC,
08217      $                   NB, LNBLOC, JMP, IMULADD )
08218 *
08219       END IF
08220 *
08221       IF( DIAGDO ) THEN
08222 *
08223          MAXMN = MAX( DESCA2( M_ ), DESCA2( N_ ) )
08224          ALPHA = DBLE( MAXMN )
08225 *
08226          IF( IOFFDA.GE.0 ) THEN
08227             CALL PDLADOM( INPLACE, MIN( MAX( 0, M-IOFFDA ), N ), ALPHA,
08228      $                    A, MIN( IA+IOFFDA, IA+M-1 ), JA, DESCA )
08229          ELSE
08230             CALL PDLADOM( INPLACE, MIN( M, MAX( 0, N+IOFFDA ) ), ALPHA,
08231      $                    A, IA, MIN( JA-IOFFDA, JA+N-1 ), DESCA )
08232          END IF
08233 *
08234       END IF
08235 *
08236       RETURN
08237 *
08238 *     End of PDLAGEN
08239 *
08240       END
08241       SUBROUTINE PDLADOM( INPLACE, N, ALPHA, A, IA, JA, DESCA )
08242 *
08243 *  -- PBLAS test routine (version 2.0) --
08244 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
08245 *     and University of California, Berkeley.
08246 *     April 1, 1998
08247 *
08248 *     .. Scalar Arguments ..
08249       LOGICAL            INPLACE
08250       INTEGER            IA, JA, N
08251       DOUBLE PRECISION   ALPHA
08252 *     ..
08253 *     .. Array Arguments ..
08254       INTEGER            DESCA( * )
08255       DOUBLE PRECISION   A( * )
08256 *     ..
08257 *
08258 *  Purpose
08259 *  =======
08260 *
08261 *  PDLADOM  adds alpha to the diagonal entries  of  an  n by n submatrix
08262 *  sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ).
08263 *
08264 *  Notes
08265 *  =====
08266 *
08267 *  A description  vector  is associated with each 2D block-cyclicly dis-
08268 *  tributed matrix.  This  vector  stores  the  information  required to
08269 *  establish the  mapping  between a  matrix entry and its corresponding
08270 *  process and memory location.
08271 *
08272 *  In  the  following  comments,   the character _  should  be  read  as
08273 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
08274 *  block cyclicly distributed matrix.  Its description vector is DESCA:
08275 *
08276 *  NOTATION         STORED IN       EXPLANATION
08277 *  ---------------- --------------- ------------------------------------
08278 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
08279 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
08280 *                                   the NPROW x NPCOL BLACS process grid
08281 *                                   A  is distributed over.  The context
08282 *                                   itself  is  global,  but  the handle
08283 *                                   (the integer value) may vary.
08284 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
08285 *                                   ted matrix A, M_A >= 0.
08286 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
08287 *                                   buted matrix A, N_A >= 0.
08288 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
08289 *                                   block of the matrix A, IMB_A > 0.
08290 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
08291 *                                   left   block   of   the   matrix  A,
08292 *                                   INB_A > 0.
08293 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
08294 *                                   bute the last  M_A-IMB_A rows of  A,
08295 *                                   MB_A > 0.
08296 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
08297 *                                   bute the last  N_A-INB_A  columns of
08298 *                                   A, NB_A > 0.
08299 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
08300 *                                   row of the matrix  A is distributed,
08301 *                                   NPROW > RSRC_A >= 0.
08302 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
08303 *                                   first  column of  A  is distributed.
08304 *                                   NPCOL > CSRC_A >= 0.
08305 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
08306 *                                   array  storing  the  local blocks of
08307 *                                   the distributed matrix A,
08308 *                                   IF( Lc( 1, N_A ) > 0 )
08309 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
08310 *                                   ELSE
08311 *                                      LLD_A >= 1.
08312 *
08313 *  Let K be the number of  rows of a matrix A starting at the global in-
08314 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
08315 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
08316 *  receive if these K rows were distributed over NPROW processes.  If  K
08317 *  is the number of columns of a matrix  A  starting at the global index
08318 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
08319 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
08320 *  these K columns were distributed over NPCOL processes.
08321 *
08322 *  The values of Lr() and Lc() may be determined via a call to the func-
08323 *  tion PB_NUMROC:
08324 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
08325 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
08326 *
08327 *  Arguments
08328 *  =========
08329 *
08330 *  INPLACE (global input) LOGICAL
08331 *          On entry, INPLACE specifies if the matrix should be generated
08332 *          in place or not. If INPLACE is .TRUE., the local random array
08333 *          to be generated  will start in memory at the local memory lo-
08334 *          cation A( 1, 1 ),  otherwise it will start at the local posi-
08335 *          tion induced by IA and JA.
08336 *
08337 *  N       (global input) INTEGER
08338 *          On entry,  N  specifies  the  global  order  of the submatrix
08339 *          sub( A ) to be modified. N must be at least zero.
08340 *
08341 *  ALPHA   (global input) DOUBLE PRECISION
08342 *          On entry, ALPHA specifies the scalar alpha.
08343 *
08344 *  A       (local input/local output) DOUBLE PRECISION array
08345 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
08346 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
08347 *          the local entries of the matrix A. On exit, the local entries
08348 *          of this array corresponding to the main diagonal of  sub( A )
08349 *          have been updated.
08350 *
08351 *  IA      (global input) INTEGER
08352 *          On entry, IA  specifies A's global row index, which points to
08353 *          the beginning of the submatrix sub( A ).
08354 *
08355 *  JA      (global input) INTEGER
08356 *          On entry, JA  specifies A's global column index, which points
08357 *          to the beginning of the submatrix sub( A ).
08358 *
08359 *  DESCA   (global and local input) INTEGER array
08360 *          On entry, DESCA  is an integer array of dimension DLEN_. This
08361 *          is the array descriptor for the matrix A.
08362 *
08363 *  -- Written on April 1, 1998 by
08364 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
08365 *
08366 *  =====================================================================
08367 *
08368 *     .. Parameters ..
08369       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
08370      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
08371      $                   RSRC_
08372       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
08373      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
08374      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
08375      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
08376 *     ..
08377 *     .. Local Scalars ..
08378       LOGICAL            GODOWN, GOLEFT
08379       INTEGER            I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW,
08380      $                   IMB1, IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP,
08381      $                   JJA, JOFFA, JOFFD, LCMT, LCMT00, LDA, LDAP1,
08382      $                   LMBLOC, LNBLOC, LOW, MB, MBLKD, MBLKS, MBLOC,
08383      $                   MRCOL, MRROW, MYCOL, MYROW, NB, NBLKD, NBLKS,
08384      $                   NBLOC, NP, NPCOL, NPROW, NQ, PMB, QNB, UPP
08385       DOUBLE PRECISION   ATMP
08386 *     ..
08387 *     .. Local Scalars ..
08388       INTEGER            DESCA2( DLEN_ )
08389 *     ..
08390 *     .. External Subroutines ..
08391       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
08392      $                   PB_DESCTRANS
08393 *     ..
08394 *     .. Intrinsic Functions ..
08395       INTRINSIC          ABS, MAX, MIN
08396 *     ..
08397 *     .. Executable Statements ..
08398 *
08399 *     Convert descriptor
08400 *
08401       CALL PB_DESCTRANS( DESCA, DESCA2 )
08402 *
08403 *     Get grid parameters
08404 *
08405       ICTXT = DESCA2( CTXT_ )
08406       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
08407 *
08408       IF( N.EQ.0 )
08409      $   RETURN
08410 *
08411       CALL PB_AINFOG2L( N, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
08412      $                  MYCOL, IMB1, INB1, NP, NQ, IIA, JJA, IAROW,
08413      $                  IACOL, MRROW, MRCOL )
08414 *
08415 *     Decide where the entries shall be stored in memory
08416 *
08417       IF( INPLACE ) THEN
08418          IIA = 1
08419          JJA = 1
08420       END IF
08421 *
08422 *     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
08423 *     ILOW, LOW, IUPP, and UPP.
08424 *
08425       MB = DESCA2( MB_ )
08426       NB = DESCA2( NB_ )
08427 *
08428       CALL PB_BINFO( 0, NP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL,
08429      $               LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
08430      $               LNBLOC, ILOW, LOW, IUPP, UPP )
08431 *
08432       IOFFA  = IIA - 1
08433       JOFFA  = JJA - 1
08434       LDA    = DESCA2( LLD_ )
08435       LDAP1  = LDA + 1
08436 *
08437       IF( DESCA2( RSRC_ ).LT.0 ) THEN
08438          PMB = MB
08439       ELSE
08440          PMB = NPROW * MB
08441       END IF
08442       IF( DESCA2( CSRC_ ).LT.0 ) THEN
08443          QNB = NB
08444       ELSE
08445          QNB = NPCOL * NB
08446       END IF
08447 *
08448 *     Handle the first block of rows or columns separately, and update
08449 *     LCMT00, MBLKS and NBLKS.
08450 *
08451       GODOWN = ( LCMT00.GT.IUPP )
08452       GOLEFT = ( LCMT00.LT.ILOW )
08453 *
08454       IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN
08455 *
08456 *        LCMT00 >= ILOW && LCMT00 <= IUPP
08457 *
08458          IF( LCMT00.GE.0 ) THEN
08459             IJOFFA = IOFFA+LCMT00 + ( JOFFA - 1 ) * LDA
08460             DO 10 I = 1, MIN( INBLOC, MAX( 0, IMBLOC - LCMT00 ) )
08461                ATMP = A( IJOFFA + I*LDAP1 )
08462                A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
08463    10       CONTINUE
08464          ELSE
08465             IJOFFA = IOFFA + ( JOFFA - LCMT00 - 1 ) * LDA
08466             DO 20 I = 1, MIN( IMBLOC, MAX( 0, INBLOC + LCMT00 ) )
08467                ATMP = A( IJOFFA + I*LDAP1 )
08468                A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
08469    20       CONTINUE
08470          END IF
08471          GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW )
08472          GODOWN = .NOT.GOLEFT
08473 *
08474       END IF
08475 *
08476       IF( GODOWN ) THEN
08477 *
08478          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
08479          MBLKS  = MBLKS - 1
08480          IOFFA  = IOFFA + IMBLOC
08481 *
08482    30    CONTINUE
08483          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
08484             LCMT00 = LCMT00 - PMB
08485             MBLKS  = MBLKS - 1
08486             IOFFA  = IOFFA + MB
08487             GO TO 30
08488          END IF
08489 *
08490          LCMT  = LCMT00
08491          MBLKD = MBLKS
08492          IOFFD = IOFFA
08493 *
08494          MBLOC = MB
08495    40    CONTINUE
08496          IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN
08497             IF( MBLKD.EQ.1 )
08498      $         MBLOC = LMBLOC
08499             IF( LCMT.GE.0 ) THEN
08500                IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
08501                DO 50 I = 1, MIN( INBLOC, MAX( 0, MBLOC - LCMT ) )
08502                   ATMP = A( IJOFFA + I*LDAP1 )
08503                   A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
08504    50          CONTINUE
08505             ELSE
08506                IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
08507                DO 60 I = 1, MIN( MBLOC, MAX( 0, INBLOC + LCMT ) )
08508                   ATMP = A( IJOFFA + I*LDAP1 )
08509                   A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
08510    60          CONTINUE
08511             END IF
08512             LCMT00 = LCMT
08513             LCMT   = LCMT - PMB
08514             MBLKS  = MBLKD
08515             MBLKD  = MBLKD - 1
08516             IOFFA  = IOFFD
08517             IOFFD  = IOFFD + MBLOC
08518             GO TO 40
08519          END IF
08520 *
08521          LCMT00 = LCMT00 + LOW - ILOW + QNB
08522          NBLKS  = NBLKS - 1
08523          JOFFA  = JOFFA + INBLOC
08524 *
08525       ELSE IF( GOLEFT ) THEN
08526 *
08527          LCMT00 = LCMT00 + LOW - ILOW + QNB
08528          NBLKS  = NBLKS - 1
08529          JOFFA  = JOFFA + INBLOC
08530 *
08531    70    CONTINUE
08532          IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN
08533             LCMT00 = LCMT00 + QNB
08534             NBLKS  = NBLKS - 1
08535             JOFFA  = JOFFA + NB
08536             GO TO 70
08537          END IF
08538 *
08539          LCMT  = LCMT00
08540          NBLKD = NBLKS
08541          JOFFD = JOFFA
08542 *
08543          NBLOC = NB
08544    80    CONTINUE
08545          IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN
08546             IF( NBLKD.EQ.1 )
08547      $         NBLOC = LNBLOC
08548             IF( LCMT.GE.0 ) THEN
08549                IJOFFA = IOFFA + LCMT + ( JOFFD - 1 ) * LDA
08550                DO 90 I = 1, MIN( NBLOC, MAX( 0, IMBLOC - LCMT ) )
08551                   ATMP = A( IJOFFA + I*LDAP1 )
08552                   A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
08553    90          CONTINUE
08554             ELSE
08555                IJOFFA = IOFFA + ( JOFFD - LCMT - 1 ) * LDA
08556                DO 100 I = 1, MIN( IMBLOC, MAX( 0, NBLOC + LCMT ) )
08557                   ATMP = A( IJOFFA + I*LDAP1 )
08558                   A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
08559   100          CONTINUE
08560             END IF
08561             LCMT00 = LCMT
08562             LCMT   = LCMT + QNB
08563             NBLKS  = NBLKD
08564             NBLKD  = NBLKD - 1
08565             JOFFA  = JOFFD
08566             JOFFD  = JOFFD + NBLOC
08567             GO TO 80
08568          END IF
08569 *
08570          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
08571          MBLKS  = MBLKS - 1
08572          IOFFA  = IOFFA + IMBLOC
08573 *
08574       END IF
08575 *
08576       NBLOC = NB
08577   110 CONTINUE
08578       IF( NBLKS.GT.0 ) THEN
08579          IF( NBLKS.EQ.1 )
08580      $      NBLOC = LNBLOC
08581   120    CONTINUE
08582          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
08583             LCMT00 = LCMT00 - PMB
08584             MBLKS  = MBLKS - 1
08585             IOFFA  = IOFFA + MB
08586             GO TO 120
08587          END IF
08588 *
08589          LCMT  = LCMT00
08590          MBLKD = MBLKS
08591          IOFFD = IOFFA
08592 *
08593          MBLOC = MB
08594   130    CONTINUE
08595          IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN
08596             IF( MBLKD.EQ.1 )
08597      $         MBLOC = LMBLOC
08598             IF( LCMT.GE.0 ) THEN
08599                IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
08600                DO 140 I = 1, MIN( NBLOC, MAX( 0, MBLOC - LCMT ) )
08601                   ATMP = A( IJOFFA + I*LDAP1 )
08602                   A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
08603   140          CONTINUE
08604             ELSE
08605                IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
08606                DO 150 I = 1, MIN( MBLOC, MAX( 0, NBLOC + LCMT ) )
08607                   ATMP = A( IJOFFA + I*LDAP1 )
08608                   A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
08609   150          CONTINUE
08610             END IF
08611             LCMT00 = LCMT
08612             LCMT   = LCMT - PMB
08613             MBLKS  = MBLKD
08614             MBLKD  = MBLKD - 1
08615             IOFFA  = IOFFD
08616             IOFFD  = IOFFD + MBLOC
08617             GO TO 130
08618          END IF
08619 *
08620          LCMT00 = LCMT00 + QNB
08621          NBLKS  = NBLKS - 1
08622          JOFFA  = JOFFA + NBLOC
08623          GO TO 110
08624 *
08625       END IF
08626 *
08627       RETURN
08628 *
08629 *     End of PDLADOM
08630 *
08631       END
08632       SUBROUTINE PB_PDLAPRNT( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT,
08633      $                        CMATNM, NOUT, WORK )
08634 *
08635 *  -- PBLAS test routine (version 2.0) --
08636 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
08637 *     and University of California, Berkeley.
08638 *     April 1, 1998
08639 *
08640 *     .. Scalar Arguments ..
08641       INTEGER            IA, ICPRNT, IRPRNT, JA, M, N, NOUT
08642 *     ..
08643 *     .. Array Arguments ..
08644       CHARACTER*(*)      CMATNM
08645       INTEGER            DESCA( * )
08646       DOUBLE PRECISION   A( * ), WORK( * )
08647 *     ..
08648 *
08649 *  Purpose
08650 *  =======
08651 *
08652 *  PB_PDLAPRNT  prints to the standard output a submatrix sub( A ) deno-
08653 *  ting A(IA:IA+M-1,JA:JA+N-1). The local pieces are sent and printed by
08654 *  the process of coordinates (IRPRNT, ICPRNT).
08655 *
08656 *  Notes
08657 *  =====
08658 *
08659 *  A description  vector  is associated with each 2D block-cyclicly dis-
08660 *  tributed matrix.  This  vector  stores  the  information  required to
08661 *  establish the  mapping  between a  matrix entry and its corresponding
08662 *  process and memory location.
08663 *
08664 *  In  the  following  comments,   the character _  should  be  read  as
08665 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
08666 *  block cyclicly distributed matrix.  Its description vector is DESCA:
08667 *
08668 *  NOTATION         STORED IN       EXPLANATION
08669 *  ---------------- --------------- ------------------------------------
08670 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
08671 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
08672 *                                   the NPROW x NPCOL BLACS process grid
08673 *                                   A  is distributed over.  The context
08674 *                                   itself  is  global,  but  the handle
08675 *                                   (the integer value) may vary.
08676 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
08677 *                                   ted matrix A, M_A >= 0.
08678 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
08679 *                                   buted matrix A, N_A >= 0.
08680 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
08681 *                                   block of the matrix A, IMB_A > 0.
08682 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
08683 *                                   left   block   of   the   matrix  A,
08684 *                                   INB_A > 0.
08685 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
08686 *                                   bute the last  M_A-IMB_A rows of  A,
08687 *                                   MB_A > 0.
08688 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
08689 *                                   bute the last  N_A-INB_A  columns of
08690 *                                   A, NB_A > 0.
08691 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
08692 *                                   row of the matrix  A is distributed,
08693 *                                   NPROW > RSRC_A >= 0.
08694 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
08695 *                                   first  column of  A  is distributed.
08696 *                                   NPCOL > CSRC_A >= 0.
08697 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
08698 *                                   array  storing  the  local blocks of
08699 *                                   the distributed matrix A,
08700 *                                   IF( Lc( 1, N_A ) > 0 )
08701 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
08702 *                                   ELSE
08703 *                                      LLD_A >= 1.
08704 *
08705 *  Let K be the number of  rows of a matrix A starting at the global in-
08706 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
08707 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
08708 *  receive if these K rows were distributed over NPROW processes.  If  K
08709 *  is the number of columns of a matrix  A  starting at the global index
08710 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
08711 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
08712 *  these K columns were distributed over NPCOL processes.
08713 *
08714 *  The values of Lr() and Lc() may be determined via a call to the func-
08715 *  tion PB_NUMROC:
08716 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
08717 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
08718 *
08719 *  Arguments
08720 *  =========
08721 *
08722 *  M       (global input) INTEGER
08723 *          On entry,  M  specifies the number of rows of  the  submatrix
08724 *          sub( A ). M  must be at least zero.
08725 *
08726 *  N       (global input) INTEGER
08727 *          On entry, N  specifies the number of columns of the submatrix
08728 *          sub( A ). N must be at least zero.
08729 *
08730 *  A       (local input) DOUBLE PRECISION array
08731 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
08732 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
08733 *          the local entries of the matrix A.
08734 *
08735 *  IA      (global input) INTEGER
08736 *          On entry, IA  specifies A's global row index, which points to
08737 *          the beginning of the submatrix sub( A ).
08738 *
08739 *  JA      (global input) INTEGER
08740 *          On entry, JA  specifies A's global column index, which points
08741 *          to the beginning of the submatrix sub( A ).
08742 *
08743 *  DESCA   (global and local input) INTEGER array
08744 *          On entry, DESCA  is an integer array of dimension DLEN_. This
08745 *          is the array descriptor for the matrix A.
08746 *
08747 *  IRPRNT  (global input) INTEGER
08748 *          On entry, IRPRNT specifies the row index of the printing pro-
08749 *          cess.
08750 *
08751 *  ICPRNT  (global input) INTEGER
08752 *          On entry, ICPRNT specifies the  column  index of the printing
08753 *          process.
08754 *
08755 *  CMATNM  (global input) CHARACTER*(*)
08756 *          On entry, CMATNM is the name of the matrix to be printed.
08757 *
08758 *  NOUT    (global input) INTEGER
08759 *          On entry, NOUT specifies the output unit number. When NOUT is
08760 *          equal to 6, the submatrix is printed on the screen.
08761 *
08762 *  WORK    (local workspace) DOUBLE PRECISION array
08763 *          On entry, WORK is a work array of dimension at least equal to
08764 *          MAX( IMB_A, MB_A ).
08765 *
08766 *  -- Written on April 1, 1998 by
08767 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
08768 *
08769 *  =====================================================================
08770 *
08771 *     .. Parameters ..
08772       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
08773      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
08774      $                   RSRC_
08775       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
08776      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
08777      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
08778      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
08779 *     ..
08780 *     .. Local Scalars ..
08781       INTEGER            MYCOL, MYROW, NPCOL, NPROW, PCOL, PROW
08782 *     ..
08783 *     .. Local Arrays ..
08784       INTEGER            DESCA2( DLEN_ )
08785 *     ..
08786 *     .. External Subroutines ..
08787       EXTERNAL           BLACS_GRIDINFO, PB_DESCTRANS, PB_PDLAPRN2
08788 *     ..
08789 *     .. Executable Statements ..
08790 *
08791 *     Quick return if possible
08792 *
08793       IF( ( M.LE.0 ).OR.( N.LE.0 ) )
08794      $   RETURN
08795 *
08796 *     Convert descriptor
08797 *
08798       CALL PB_DESCTRANS( DESCA, DESCA2 )
08799 *
08800       CALL BLACS_GRIDINFO( DESCA2( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
08801 *
08802       IF( DESCA2( RSRC_ ).GE.0 ) THEN
08803          IF( DESCA2( CSRC_ ).GE.0 ) THEN
08804             CALL PB_PDLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT, ICPRNT,
08805      $                        CMATNM, NOUT, DESCA2( RSRC_ ),
08806      $                        DESCA2( CSRC_ ), WORK )
08807          ELSE
08808             DO 10 PCOL = 0, NPCOL - 1
08809                IF( ( MYROW.EQ.IRPRNT ).AND.( MYCOL.EQ.ICPRNT ) )
08810      $            WRITE( NOUT, * ) 'Colum-replicated array -- ' ,
08811      $                             'copy in process column: ', PCOL
08812                CALL PB_PDLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT,
08813      $                           ICPRNT, CMATNM, NOUT, DESCA2( RSRC_ ),
08814      $                           PCOL, WORK )
08815    10       CONTINUE
08816          END IF
08817       ELSE
08818          IF( DESCA2( CSRC_ ).GE.0 ) THEN
08819             DO 20 PROW = 0, NPROW - 1
08820                IF( ( MYROW.EQ.IRPRNT ).AND.( MYCOL.EQ.ICPRNT ) )
08821      $            WRITE( NOUT, * ) 'Row-replicated array -- ' ,
08822      $                             'copy in process row: ', PROW
08823                CALL PB_PDLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT,
08824      $                           ICPRNT, CMATNM, NOUT, PROW,
08825      $                           DESCA2( CSRC_ ), WORK )
08826    20       CONTINUE
08827          ELSE
08828             DO 40 PROW = 0, NPROW - 1
08829                DO 30 PCOL = 0, NPCOL - 1
08830                   IF( ( MYROW.EQ.IRPRNT ).AND.( MYCOL.EQ.ICPRNT ) )
08831      $               WRITE( NOUT, * ) 'Replicated array -- ' ,
08832      $                      'copy in process (', PROW, ',', PCOL, ')'
08833                   CALL PB_PDLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT,
08834      $                              ICPRNT, CMATNM, NOUT, PROW, PCOL,
08835      $                              WORK )
08836    30          CONTINUE
08837    40       CONTINUE
08838          END IF
08839       END IF
08840 *
08841       RETURN
08842 *
08843 *     End of PB_PDLAPRNT
08844 *
08845       END
08846       SUBROUTINE PB_PDLAPRN2( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT,
08847      $                        CMATNM, NOUT, PROW, PCOL, WORK )
08848 *
08849 *  -- PBLAS test routine (version 2.0) --
08850 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
08851 *     and University of California, Berkeley.
08852 *     April 1, 1998
08853 *
08854 *     .. Scalar Arguments ..
08855       INTEGER            IA, ICPRNT, IRPRNT, JA, M, N, NOUT, PCOL, PROW
08856 *     ..
08857 *     .. Array Arguments ..
08858       CHARACTER*(*)      CMATNM
08859       INTEGER            DESCA( * )
08860       DOUBLE PRECISION   A( * ), WORK( * )
08861 *     ..
08862 *
08863 *     .. Parameters ..
08864       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
08865      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
08866      $                   RSRC_
08867       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
08868      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
08869      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
08870      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
08871 *     ..
08872 *     .. Local Scalars ..
08873       LOGICAL            AISCOLREP, AISROWREP
08874       INTEGER            H, I, IACOL, IAROW, IB, ICTXT, ICURCOL,
08875      $                   ICURROW, II, IIA, IN, J, JB, JJ, JJA, JN, K,
08876      $                   LDA, LDW, MYCOL, MYROW, NPCOL, NPROW
08877 *     ..
08878 *     .. External Subroutines ..
08879       EXTERNAL           BLACS_BARRIER, BLACS_GRIDINFO, DGERV2D,
08880      $                   DGESD2D, PB_INFOG2L
08881 *     ..
08882 *     .. Intrinsic Functions ..
08883       INTRINSIC          MIN
08884 *     ..
08885 *     .. Executable Statements ..
08886 *
08887 *     Get grid parameters
08888 *
08889       ICTXT = DESCA( CTXT_ )
08890       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
08891       CALL PB_INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL,
08892      $                 IIA, JJA, IAROW, IACOL )
08893       II = IIA
08894       JJ = JJA
08895       IF( DESCA( RSRC_ ).LT.0 ) THEN
08896          AISROWREP = .TRUE.
08897          IAROW     = PROW
08898          ICURROW   = PROW
08899       ELSE
08900          AISROWREP = .FALSE.
08901          ICURROW   = IAROW
08902       END IF
08903       IF( DESCA( CSRC_ ).LT.0 ) THEN
08904          AISCOLREP = .TRUE.
08905          IACOL     = PCOL
08906          ICURCOL   = PCOL
08907       ELSE
08908          AISCOLREP = .FALSE.
08909          ICURCOL   = IACOL
08910       END IF
08911       LDA = DESCA( LLD_ )
08912       LDW = MAX( DESCA( IMB_ ), DESCA( MB_ ) )
08913 *
08914 *     Handle the first block of column separately
08915 *
08916       JB = DESCA( INB_ ) - JA + 1
08917       IF( JB.LE.0 )
08918      $   JB = ( (-JB) / DESCA( NB_ ) + 1 ) * DESCA( NB_ ) + JB
08919       JB = MIN( JB, N )
08920       JN = JA+JB-1
08921       DO 60 H = 0, JB-1
08922          IB = DESCA( IMB_ ) - IA + 1
08923          IF( IB.LE.0 )
08924      $      IB = ( (-IB) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
08925          IB = MIN( IB, M )
08926          IN = IA+IB-1
08927          IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN
08928             IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
08929                DO 10 K = 0, IB-1
08930                   WRITE( NOUT, FMT = 9999 )
08931      $                   CMATNM, IA+K, JA+H, A( II+K+(JJ+H-1)*LDA )
08932    10          CONTINUE
08933             END IF
08934          ELSE
08935             IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN
08936                CALL DGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ), LDA,
08937      $                       IRPRNT, ICPRNT )
08938             ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
08939                CALL DGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW, ICURCOL )
08940                DO 20 K = 1, IB
08941                   WRITE( NOUT, FMT = 9999 )
08942      $                   CMATNM, IA+K-1, JA+H, WORK( K )
08943    20          CONTINUE
08944             END IF
08945          END IF
08946          IF( MYROW.EQ.ICURROW )
08947      $      II = II + IB
08948          IF( .NOT.AISROWREP )
08949      $      ICURROW = MOD( ICURROW+1, NPROW )
08950          CALL BLACS_BARRIER( ICTXT, 'All' )
08951 *
08952 *        Loop over remaining block of rows
08953 *
08954          DO 50 I = IN+1, IA+M-1, DESCA( MB_ )
08955             IB = MIN( DESCA( MB_ ), IA+M-I )
08956             IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN
08957                IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
08958                   DO 30 K = 0, IB-1
08959                      WRITE( NOUT, FMT = 9999 )
08960      $                      CMATNM, I+K, JA+H, A( II+K+(JJ+H-1)*LDA )
08961    30             CONTINUE
08962                END IF
08963             ELSE
08964                IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN
08965                   CALL DGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ),
08966      $                          LDA, IRPRNT, ICPRNT )
08967                ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
08968                   CALL DGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW,
08969      $                          ICURCOL )
08970                   DO 40 K = 1, IB
08971                      WRITE( NOUT, FMT = 9999 )
08972      $                      CMATNM, I+K-1, JA+H, WORK( K )
08973    40             CONTINUE
08974                END IF
08975             END IF
08976             IF( MYROW.EQ.ICURROW )
08977      $         II = II + IB
08978             IF( .NOT.AISROWREP )
08979      $         ICURROW = MOD( ICURROW+1, NPROW )
08980             CALL BLACS_BARRIER( ICTXT, 'All' )
08981    50    CONTINUE
08982 *
08983          II = IIA
08984          ICURROW = IAROW
08985    60 CONTINUE
08986 *
08987       IF( MYCOL.EQ.ICURCOL )
08988      $   JJ = JJ + JB
08989       IF( .NOT.AISCOLREP )
08990      $   ICURCOL = MOD( ICURCOL+1, NPCOL )
08991       CALL BLACS_BARRIER( ICTXT, 'All' )
08992 *
08993 *     Loop over remaining column blocks
08994 *
08995       DO 130 J = JN+1, JA+N-1, DESCA( NB_ )
08996          JB = MIN(  DESCA( NB_ ), JA+N-J )
08997          DO 120 H = 0, JB-1
08998             IB = DESCA( IMB_ )-IA+1
08999             IF( IB.LE.0 )
09000      $         IB = ( (-IB) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
09001             IB = MIN( IB, M )
09002             IN = IA+IB-1
09003             IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN
09004                IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09005                   DO 70 K = 0, IB-1
09006                      WRITE( NOUT, FMT = 9999 )
09007      $                      CMATNM, IA+K, J+H, A( II+K+(JJ+H-1)*LDA )
09008    70             CONTINUE
09009                END IF
09010             ELSE
09011                IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN
09012                   CALL DGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ),
09013      $                          LDA, IRPRNT, ICPRNT )
09014                ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09015                   CALL DGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW,
09016      $                          ICURCOL )
09017                   DO 80 K = 1, IB
09018                      WRITE( NOUT, FMT = 9999 )
09019      $                      CMATNM, IA+K-1, J+H, WORK( K )
09020    80             CONTINUE
09021                END IF
09022             END IF
09023             IF( MYROW.EQ.ICURROW )
09024      $         II = II + IB
09025             ICURROW = MOD( ICURROW+1, NPROW )
09026             CALL BLACS_BARRIER( ICTXT, 'All' )
09027 *
09028 *           Loop over remaining block of rows
09029 *
09030             DO 110 I = IN+1, IA+M-1, DESCA( MB_ )
09031                IB = MIN( DESCA( MB_ ), IA+M-I )
09032                IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN
09033                   IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09034                      DO 90 K = 0, IB-1
09035                         WRITE( NOUT, FMT = 9999 )
09036      $                         CMATNM, I+K, J+H, A( II+K+(JJ+H-1)*LDA )
09037    90                CONTINUE
09038                   END IF
09039                ELSE
09040                   IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN
09041                      CALL DGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ),
09042      $                             LDA, IRPRNT, ICPRNT )
09043                    ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09044                      CALL DGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW,
09045      $                             ICURCOL )
09046                      DO 100 K = 1, IB
09047                         WRITE( NOUT, FMT = 9999 )
09048      $                         CMATNM, I+K-1, J+H, WORK( K )
09049   100                CONTINUE
09050                   END IF
09051                END IF
09052                IF( MYROW.EQ.ICURROW )
09053      $            II = II + IB
09054                IF( .NOT.AISROWREP )
09055      $            ICURROW = MOD( ICURROW+1, NPROW )
09056                CALL BLACS_BARRIER( ICTXT, 'All' )
09057   110       CONTINUE
09058 *
09059             II = IIA
09060             ICURROW = IAROW
09061   120    CONTINUE
09062 *
09063          IF( MYCOL.EQ.ICURCOL )
09064      $      JJ = JJ + JB
09065          IF( .NOT.AISCOLREP )
09066      $      ICURCOL = MOD( ICURCOL+1, NPCOL )
09067          CALL BLACS_BARRIER( ICTXT, 'All' )
09068 *
09069   130 CONTINUE
09070 *
09071  9999 FORMAT( 1X, A, '(', I6, ',', I6, ')=', D30.18 )
09072 *
09073       RETURN
09074 *
09075 *     End of PB_PDLAPRN2
09076 *
09077       END
09078       SUBROUTINE PB_DFILLPAD( ICTXT, M, N, A, LDA, IPRE, IPOST, CHKVAL )
09079 *
09080 *  -- PBLAS test routine (version 2.0) --
09081 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
09082 *     and University of California, Berkeley.
09083 *     April 1, 1998
09084 *
09085 *     .. Scalar Arguments ..
09086       INTEGER            ICTXT, IPOST, IPRE, LDA, M, N
09087       DOUBLE PRECISION   CHKVAL
09088 *     ..
09089 *     .. Array Arguments ..
09090       DOUBLE PRECISION   A( * )
09091 *     ..
09092 *
09093 *  Purpose
09094 *  =======
09095 *
09096 *  PB_DFILLPAD surrounds a two dimensional local array with a guard-zone
09097 *  initialized to the value CHKVAL. The user may later call the  routine
09098 *  PB_DCHEKPAD to discover if the guardzone has been violated. There are
09099 *  three guardzones. The first is a buffer of size  IPRE  that is before
09100 *  the start of the array. The second is the buffer of size IPOST  which
09101 *  is after the end of the array to be padded. Finally, there is a guard
09102 *  zone inside every column of the array to be padded, in  the  elements
09103 *  of A(M+1:LDA, J).
09104 *
09105 *  Arguments
09106 *  =========
09107 *
09108 *  ICTXT   (local input) INTEGER
09109 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
09110 *          ting the global  context of the operation. The context itself
09111 *          is global, but the value of ICTXT is local.
09112 *
09113 *  M       (local input) INTEGER
09114 *          On entry, M  specifies the number of rows in the local  array
09115 *          A.  M must be at least zero.
09116 *
09117 *  N       (local input) INTEGER
09118 *          On entry, N  specifies the number of columns in the local ar-
09119 *          ray A. N must be at least zero.
09120 *
09121 *  A       (local input/local output) DOUBLE PRECISION array
09122 *          On entry,  A  is an array of dimension (LDA,N). On exit, this
09123 *          array is the padded array.
09124 *
09125 *  LDA     (local input) INTEGER
09126 *          On entry,  LDA  specifies  the leading dimension of the local
09127 *          array to be padded. LDA must be at least MAX( 1, M ).
09128 *
09129 *  IPRE    (local input) INTEGER
09130 *          On entry, IPRE specifies the size of  the  guard zone  to put
09131 *          before the start of the padded array.
09132 *
09133 *  IPOST   (local input) INTEGER
09134 *          On entry, IPOST specifies the size of the  guard zone  to put
09135 *          after the end of the padded array.
09136 *
09137 *  CHKVAL  (local input) DOUBLE PRECISION
09138 *          On entry, CHKVAL specifies the value to pad the array with.
09139 *
09140 *  -- Written on April 1, 1998 by
09141 *     R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
09142 *
09143 *  =====================================================================
09144 *
09145 *     .. Local Scalars ..
09146       INTEGER            I, J, K
09147 *     ..
09148 *     .. Executable Statements ..
09149 *
09150 *     Put check buffer in front of A
09151 *
09152       IF( IPRE.GT.0 ) THEN
09153          DO 10 I = 1, IPRE
09154             A( I ) = CHKVAL
09155    10    CONTINUE
09156       ELSE
09157          WRITE( *, FMT = '(A)' )
09158      $          'WARNING no pre-guardzone in PB_DFILLPAD'
09159       END IF
09160 *
09161 *     Put check buffer in back of A
09162 *
09163       IF( IPOST.GT.0 ) THEN
09164          J = IPRE+LDA*N+1
09165          DO 20 I = J, J+IPOST-1
09166             A( I ) = CHKVAL
09167    20    CONTINUE
09168       ELSE
09169          WRITE( *, FMT = '(A)' )
09170      $          'WARNING no post-guardzone in PB_DFILLPAD'
09171       END IF
09172 *
09173 *     Put check buffer in all (LDA-M) gaps
09174 *
09175       IF( LDA.GT.M ) THEN
09176          K = IPRE + M + 1
09177          DO 40 J = 1, N
09178             DO 30 I = K, K + ( LDA - M ) - 1
09179                A( I ) = CHKVAL
09180    30       CONTINUE
09181             K = K + LDA
09182    40    CONTINUE
09183       END IF
09184 *
09185       RETURN
09186 *
09187 *     End of PB_DFILLPAD
09188 *
09189       END
09190       SUBROUTINE PB_DCHEKPAD( ICTXT, MESS, M, N, A, LDA, IPRE, IPOST,
09191      $                        CHKVAL )
09192 *
09193 *  -- PBLAS test routine (version 2.0) --
09194 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
09195 *     and University of California, Berkeley.
09196 *     April 1, 1998
09197 *
09198 *     .. Scalar Arguments ..
09199       INTEGER            ICTXT, IPOST, IPRE, LDA, M, N
09200       DOUBLE PRECISION   CHKVAL
09201 *     ..
09202 *     .. Array Arguments ..
09203       CHARACTER*(*)      MESS
09204       DOUBLE PRECISION   A( * )
09205 *     ..
09206 *
09207 *  Purpose
09208 *  =======
09209 *
09210 *  PB_DCHEKPAD checks that the padding around a local array has not been
09211 *  overwritten since the call to PB_DFILLPAD.  Three types of errors are
09212 *  reported:
09213 *
09214 *  1) Overwrite in pre-guardzone.  This indicates a memory overwrite has
09215 *  occurred in the  first  IPRE  elements which form a buffer before the
09216 *  beginning of A. Therefore, the error message:
09217 *     'Overwrite in  pre-guardzone: loc(  5) =         18.00000'
09218 *  tells that the 5th element of the IPRE long buffer has been overwrit-
09219 *  ten with the value 18, where it should still have the value CHKVAL.
09220 *
09221 *  2) Overwrite in post-guardzone. This indicates a memory overwrite has
09222 *  occurred in the last IPOST elements which form a buffer after the end
09223 *  of A. Error reports are refered from the end of A.  Therefore,
09224 *     'Overwrite in post-guardzone: loc( 19) =         24.00000'
09225 *  tells  that the  19th element after the end of A was overwritten with
09226 *  the value 24, where it should still have the value of CHKVAL.
09227 *
09228 *  3) Overwrite in lda-m gap.  Tells you elements between M and LDA were
09229 *  overwritten.  So,
09230 *     'Overwrite in lda-m gap: A( 12,  3) =         22.00000'
09231 *  tells  that the element at the 12th row and 3rd column of A was over-
09232 *  written with the value of 22, where it should still have the value of
09233 *  CHKVAL.
09234 *
09235 *  Arguments
09236 *  =========
09237 *
09238 *  ICTXT   (local input) INTEGER
09239 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
09240 *          ting the global  context of the operation. The context itself
09241 *          is global, but the value of ICTXT is local.
09242 *
09243 *  MESS    (local input) CHARACTER*(*)
09244 *          On entry, MESS is a ttring containing a user-defined message.
09245 *
09246 *  M       (local input) INTEGER
09247 *          On entry, M  specifies the number of rows in the local  array
09248 *          A.  M must be at least zero.
09249 *
09250 *  N       (local input) INTEGER
09251 *          On entry, N  specifies the number of columns in the local ar-
09252 *          ray A. N must be at least zero.
09253 *
09254 *  A       (local input) DOUBLE PRECISION array
09255 *          On entry,  A  is an array of dimension (LDA,N).
09256 *
09257 *  LDA     (local input) INTEGER
09258 *          On entry,  LDA  specifies  the leading dimension of the local
09259 *          array to be padded. LDA must be at least MAX( 1, M ).
09260 *
09261 *  IPRE    (local input) INTEGER
09262 *          On entry, IPRE specifies the size of  the  guard zone  to put
09263 *          before the start of the padded array.
09264 *
09265 *  IPOST   (local input) INTEGER
09266 *          On entry, IPOST specifies the size of the  guard zone  to put
09267 *          after the end of the padded array.
09268 *
09269 *  CHKVAL  (local input) DOUBLE PRECISION
09270 *          On entry, CHKVAL specifies the value to pad the array with.
09271 *
09272 *
09273 *  -- Written on April 1, 1998 by
09274 *     R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
09275 *
09276 *  =====================================================================
09277 *
09278 *     .. Local Scalars ..
09279       CHARACTER*1        TOP
09280       INTEGER            I, IAM, IDUMM, INFO, J, K, MYCOL, MYROW, NPCOL,
09281      $                   NPROW
09282 *     ..
09283 *     .. External Subroutines ..
09284       EXTERNAL           BLACS_GRIDINFO, IGAMX2D, PB_TOPGET
09285 *     ..
09286 *     .. Executable Statements ..
09287 *
09288 *     Get grid parameters
09289 *
09290       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
09291       IAM  = MYROW*NPCOL + MYCOL
09292       INFO = -1
09293 *
09294 *     Check buffer in front of A
09295 *
09296       IF( IPRE.GT.0 ) THEN
09297          DO 10 I = 1, IPRE
09298             IF( A( I ).NE.CHKVAL ) THEN
09299                WRITE( *, FMT = 9998 ) MYROW, MYCOL, MESS, ' pre', I,
09300      $                                A( I )
09301                INFO = IAM
09302             END IF
09303    10    CONTINUE
09304       ELSE
09305          WRITE( *, FMT = * ) 'WARNING no pre-guardzone in PB_DCHEKPAD'
09306       END IF
09307 *
09308 *     Check buffer after A
09309 *
09310       IF( IPOST.GT.0 ) THEN
09311          J = IPRE+LDA*N+1
09312          DO 20 I = J, J+IPOST-1
09313             IF( A( I ).NE.CHKVAL ) THEN
09314                WRITE( *, FMT = 9998 ) MYROW, MYCOL, MESS, 'post',
09315      $                                I-J+1, A( I )
09316                INFO = IAM
09317             END IF
09318    20    CONTINUE
09319       ELSE
09320          WRITE( *, FMT = * )
09321      $          'WARNING no post-guardzone buffer in PB_DCHEKPAD'
09322       END IF
09323 *
09324 *     Check all (LDA-M) gaps
09325 *
09326       IF( LDA.GT.M ) THEN
09327          K = IPRE + M + 1
09328          DO 40 J = 1, N
09329             DO 30 I = K, K + (LDA-M) - 1
09330                IF( A( I ).NE.CHKVAL ) THEN
09331                   WRITE( *, FMT = 9997 ) MYROW, MYCOL, MESS,
09332      $               I-IPRE-LDA*(J-1), J, A( I )
09333                   INFO = IAM
09334                END IF
09335    30       CONTINUE
09336             K = K + LDA
09337    40    CONTINUE
09338       END IF
09339 *
09340       CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP )
09341       CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, IDUMM, IDUMM, -1,
09342      $              0, 0 )
09343       IF( IAM.EQ.0 .AND. INFO.GE.0 ) THEN
09344          WRITE( *, FMT = 9999 ) INFO / NPCOL, MOD( INFO, NPCOL ), MESS
09345       END IF
09346 *
09347  9999 FORMAT( '{', I5, ',', I5, '}:  Memory overwrite in ', A )
09348  9998 FORMAT( '{', I5, ',', I5, '}:  ', A, ' memory overwrite in ',
09349      $        A4, '-guardzone: loc(', I3, ') = ', G20.7 )
09350  9997 FORMAT( '{', I5, ',', I5, '}: ', A, ' memory overwrite in ',
09351      $        'lda-m gap: loc(', I3, ',', I3, ') = ', G20.7 )
09352 *
09353       RETURN
09354 *
09355 *     End of PB_DCHEKPAD
09356 *
09357       END
09358       SUBROUTINE PB_DLASET( UPLO, M, N, IOFFD, ALPHA, BETA, A, LDA )
09359 *
09360 *  -- PBLAS test routine (version 2.0) --
09361 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
09362 *     and University of California, Berkeley.
09363 *     April 1, 1998
09364 *
09365 *     .. Scalar Arguments ..
09366       CHARACTER*1        UPLO
09367       INTEGER            IOFFD, LDA, M, N
09368       DOUBLE PRECISION   ALPHA, BETA
09369 *     ..
09370 *     .. Array Arguments ..
09371       DOUBLE PRECISION   A( LDA, * )
09372 *     ..
09373 *
09374 *  Purpose
09375 *  =======
09376 *
09377 *  PB_DLASET initializes a two-dimensional array A to beta on the diago-
09378 *  nal specified by IOFFD and alpha on the offdiagonals.
09379 *
09380 *  Arguments
09381 *  =========
09382 *
09383 *  UPLO    (global input) CHARACTER*1
09384 *          On entry,  UPLO  specifies  which trapezoidal part of the ar-
09385 *          ray A is to be set as follows:
09386 *             = 'L' or 'l':   Lower triangular part is set; the strictly
09387 *                             upper triangular part of A is not changed,
09388 *             = 'U' or 'u':   Upper triangular part is set; the strictly
09389 *                             lower triangular part of A is not changed,
09390 *             = 'D' or 'd'    Only the diagonal of A is set,
09391 *             Otherwise:      All of the array A is set.
09392 *
09393 *  M       (input) INTEGER
09394 *          On entry,  M  specifies the number of rows of the array A.  M
09395 *          must be at least zero.
09396 *
09397 *  N       (input) INTEGER
09398 *          On entry,  N  specifies the number of columns of the array A.
09399 *          N must be at least zero.
09400 *
09401 *  IOFFD   (input) INTEGER
09402 *          On entry, IOFFD specifies the position of the offdiagonal de-
09403 *          limiting the upper and lower trapezoidal part of A as follows
09404 *          (see the notes below):
09405 *
09406 *             IOFFD = 0  specifies the main diagonal A( i, i ),
09407 *                        with i = 1 ... MIN( M, N ),
09408 *             IOFFD > 0  specifies the subdiagonal   A( i+IOFFD, i ),
09409 *                        with i = 1 ... MIN( M-IOFFD, N ),
09410 *             IOFFD < 0  specifies the superdiagonal A( i, i-IOFFD ),
09411 *                        with i = 1 ... MIN( M, N+IOFFD ).
09412 *
09413 *  ALPHA   (input) DOUBLE PRECISION
09414 *          On entry,  ALPHA specifies the value to which the offdiagonal
09415 *          array elements are set to.
09416 *
09417 *  BETA    (input) DOUBLE PRECISION
09418 *          On entry, BETA  specifies the value to which the diagonal ar-
09419 *          ray elements are set to.
09420 *
09421 *  A       (input/output) DOUBLE PRECISION array
09422 *          On entry, A is an array of dimension  (LDA,N).  Before  entry
09423 *          with UPLO = 'U' or 'u', the leading m by n part of the  array
09424 *          A  must  contain  the upper trapezoidal part of the matrix as
09425 *          specified by IOFFD to be set, and  the  strictly lower trape-
09426 *          zoidal  part of A is not referenced; When IUPLO = 'L' or 'l',
09427 *          the leading m by n part of  the  array  A  must  contain  the
09428 *          lower trapezoidal part of the matrix as specified by IOFFD to
09429 *          be set,  and  the  strictly  upper  trapezoidal part of  A is
09430 *          not referenced.
09431 *
09432 *  LDA     (input) INTEGER
09433 *          On entry, LDA specifies the leading dimension of the array A.
09434 *          LDA must be at least max( 1, M ).
09435 *
09436 *  Notes
09437 *  =====
09438 *                           N                                    N
09439 *             ----------------------------                  -----------
09440 *            |       d                    |                |           |
09441 *          M |         d        'U'       |                |      'U'  |
09442 *            |  'L'     'D'               |                |d          |
09443 *            |             d              |              M |  d        |
09444 *             ----------------------------                 |   'D'     |
09445 *                                                          |      d    |
09446 *               IOFFD < 0                                  | 'L'    d  |
09447 *                                                          |          d|
09448 *                  N                                       |           |
09449 *             -----------                                   -----------
09450 *            |    d   'U'|
09451 *            |      d    |                                   IOFFD > 0
09452 *          M |       'D' |
09453 *            |          d|                              N
09454 *            |  'L'      |                 ----------------------------
09455 *            |           |                |          'U'               |
09456 *            |           |                |d                           |
09457 *            |           |                | 'D'                        |
09458 *            |           |                |    d                       |
09459 *            |           |                |'L'   d                     |
09460 *             -----------                  ----------------------------
09461 *
09462 *  -- Written on April 1, 1998 by
09463 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
09464 *
09465 *  =====================================================================
09466 *
09467 *     .. Local Scalars ..
09468       INTEGER            I, J, JTMP, MN
09469 *     ..
09470 *     .. External Functions ..
09471       LOGICAL            LSAME
09472       EXTERNAL           LSAME
09473 *     ..
09474 *     .. Intrinsic Functions ..
09475       INTRINSIC          MAX, MIN
09476 *     ..
09477 *     .. Executable Statements ..
09478 *
09479 *     Quick return if possible
09480 *
09481       IF( M.LE.0 .OR. N.LE.0 )
09482      $   RETURN
09483 *
09484 *     Start the operations
09485 *
09486       IF( LSAME( UPLO, 'L' ) ) THEN
09487 *
09488 *        Set the diagonal to BETA and the strictly lower triangular
09489 *        part of the array to ALPHA.
09490 *
09491          MN = MAX( 0, -IOFFD )
09492          DO 20 J = 1, MIN( MN, N )
09493             DO 10 I = 1, M
09494                A( I, J ) = ALPHA
09495    10       CONTINUE
09496    20    CONTINUE
09497          DO 40 J = MN + 1, MIN( M - IOFFD, N )
09498             JTMP = J + IOFFD
09499             A( JTMP, J ) = BETA
09500             DO 30 I = JTMP + 1, M
09501                A( I, J ) = ALPHA
09502    30       CONTINUE
09503    40    CONTINUE
09504 *
09505       ELSE IF( LSAME( UPLO, 'U' ) ) THEN
09506 *
09507 *        Set the diagonal to BETA and the strictly upper triangular
09508 *        part of the array to ALPHA.
09509 *
09510          MN = MIN( M - IOFFD, N )
09511          DO 60 J = MAX( 0, -IOFFD ) + 1, MN
09512             JTMP = J + IOFFD
09513             DO 50 I = 1, JTMP - 1
09514                A( I, J ) = ALPHA
09515    50       CONTINUE
09516             A( JTMP, J ) = BETA
09517    60    CONTINUE
09518          DO 80 J = MAX( 0, MN ) + 1, N
09519             DO 70 I = 1, M
09520                A( I, J ) = ALPHA
09521    70       CONTINUE
09522    80    CONTINUE
09523 *
09524       ELSE IF( LSAME( UPLO, 'D' ) ) THEN
09525 *
09526 *        Set the array to BETA on the diagonal.
09527 *
09528          DO 90 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N )
09529             A( J + IOFFD, J ) = BETA
09530    90    CONTINUE
09531 *
09532       ELSE
09533 *
09534 *        Set the array to BETA on the diagonal and ALPHA on the
09535 *        offdiagonal.
09536 *
09537          DO 110 J = 1, N
09538             DO 100 I = 1, M
09539                A( I, J ) = ALPHA
09540   100       CONTINUE
09541   110    CONTINUE
09542          IF( ALPHA.NE.BETA .AND. IOFFD.LT.M .AND. IOFFD.GT.-N ) THEN
09543             DO 120 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N )
09544                A( J + IOFFD, J ) = BETA
09545   120       CONTINUE
09546          END IF
09547 *
09548       END IF
09549 *
09550       RETURN
09551 *
09552 *     End of PB_DLASET
09553 *
09554       END
09555       SUBROUTINE PB_DLASCAL( UPLO, M, N, IOFFD, ALPHA, A, LDA )
09556 *
09557 *  -- PBLAS test routine (version 2.0) --
09558 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
09559 *     and University of California, Berkeley.
09560 *     April 1, 1998
09561 *
09562 *     .. Scalar Arguments ..
09563       CHARACTER*1        UPLO
09564       INTEGER            IOFFD, LDA, M, N
09565       DOUBLE PRECISION   ALPHA
09566 *     ..
09567 *     .. Array Arguments ..
09568       DOUBLE PRECISION   A( LDA, * )
09569 *     ..
09570 *
09571 *  Purpose
09572 *  =======
09573 *
09574 *  PB_DLASCAL scales a two-dimensional array A by the scalar alpha.
09575 *
09576 *  Arguments
09577 *  =========
09578 *
09579 *  UPLO    (input) CHARACTER*1
09580 *          On entry,  UPLO  specifies  which trapezoidal part of the ar-
09581 *          ray A is to be scaled as follows:
09582 *             = 'L' or 'l':          the lower trapezoid of A is scaled,
09583 *             = 'U' or 'u':          the upper trapezoid of A is scaled,
09584 *             = 'D' or 'd':       diagonal specified by IOFFD is scaled,
09585 *             Otherwise:                   all of the array A is scaled.
09586 *
09587 *  M       (input) INTEGER
09588 *          On entry,  M  specifies the number of rows of the array A.  M
09589 *          must be at least zero.
09590 *
09591 *  N       (input) INTEGER
09592 *          On entry,  N  specifies the number of columns of the array A.
09593 *          N must be at least zero.
09594 *
09595 *  IOFFD   (input) INTEGER
09596 *          On entry, IOFFD specifies the position of the offdiagonal de-
09597 *          limiting the upper and lower trapezoidal part of A as follows
09598 *          (see the notes below):
09599 *
09600 *             IOFFD = 0  specifies the main diagonal A( i, i ),
09601 *                        with i = 1 ... MIN( M, N ),
09602 *             IOFFD > 0  specifies the subdiagonal   A( i+IOFFD, i ),
09603 *                        with i = 1 ... MIN( M-IOFFD, N ),
09604 *             IOFFD < 0  specifies the superdiagonal A( i, i-IOFFD ),
09605 *                        with i = 1 ... MIN( M, N+IOFFD ).
09606 *
09607 *  ALPHA   (input) DOUBLE PRECISION
09608 *          On entry, ALPHA specifies the scalar alpha.
09609 *
09610 *  A       (input/output) DOUBLE PRECISION array
09611 *          On entry, A is an array of dimension  (LDA,N).  Before  entry
09612 *          with  UPLO = 'U' or 'u', the leading m by n part of the array
09613 *          A must contain the upper trapezoidal  part  of the matrix  as
09614 *          specified by  IOFFD to be scaled, and the strictly lower tra-
09615 *          pezoidal part of A is not referenced; When UPLO = 'L' or 'l',
09616 *          the leading m by n part of the array A must contain the lower
09617 *          trapezoidal  part  of  the matrix as specified by IOFFD to be
09618 *          scaled,  and  the strictly upper trapezoidal part of A is not
09619 *          referenced. On exit, the entries of the  trapezoid part of  A
09620 *          determined by UPLO and IOFFD are scaled.
09621 *
09622 *  LDA     (input) INTEGER
09623 *          On entry, LDA specifies the leading dimension of the array A.
09624 *          LDA must be at least max( 1, M ).
09625 *
09626 *  Notes
09627 *  =====
09628 *                           N                                    N
09629 *             ----------------------------                  -----------
09630 *            |       d                    |                |           |
09631 *          M |         d        'U'       |                |      'U'  |
09632 *            |  'L'     'D'               |                |d          |
09633 *            |             d              |              M |  d        |
09634 *             ----------------------------                 |   'D'     |
09635 *                                                          |      d    |
09636 *              IOFFD < 0                                   | 'L'    d  |
09637 *                                                          |          d|
09638 *                  N                                       |           |
09639 *             -----------                                   -----------
09640 *            |    d   'U'|
09641 *            |      d    |                                   IOFFD > 0
09642 *          M |       'D' |
09643 *            |          d|                              N
09644 *            |  'L'      |                 ----------------------------
09645 *            |           |                |          'U'               |
09646 *            |           |                |d                           |
09647 *            |           |                | 'D'                        |
09648 *            |           |                |    d                       |
09649 *            |           |                |'L'   d                     |
09650 *             -----------                  ----------------------------
09651 *
09652 *  -- Written on April 1, 1998 by
09653 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
09654 *
09655 *  =====================================================================
09656 *
09657 *     .. Local Scalars ..
09658       INTEGER            I, J, JTMP, MN
09659 *     ..
09660 *     .. External Functions ..
09661       LOGICAL            LSAME
09662       EXTERNAL           LSAME
09663 *     ..
09664 *     .. Intrinsic Functions ..
09665       INTRINSIC          MAX, MIN
09666 *     ..
09667 *     .. Executable Statements ..
09668 *
09669 *     Quick return if possible
09670 *
09671       IF( M.LE.0 .OR. N.LE.0 )
09672      $   RETURN
09673 *
09674 *     Start the operations
09675 *
09676       IF( LSAME( UPLO, 'L' ) ) THEN
09677 *
09678 *        Scales the lower triangular part of the array by ALPHA.
09679 *
09680          MN = MAX( 0, -IOFFD )
09681          DO 20 J = 1, MIN( MN, N )
09682             DO 10 I = 1, M
09683                A( I, J ) = ALPHA * A( I, J )
09684    10       CONTINUE
09685    20    CONTINUE
09686          DO 40 J = MN + 1, MIN( M - IOFFD, N )
09687             DO 30 I = J + IOFFD, M
09688                A( I, J ) = ALPHA * A( I, J )
09689    30       CONTINUE
09690    40    CONTINUE
09691 *
09692       ELSE IF( LSAME( UPLO, 'U' ) ) THEN
09693 *
09694 *        Scales the upper triangular part of the array by ALPHA.
09695 *
09696          MN = MIN( M - IOFFD, N )
09697          DO 60 J = MAX( 0, -IOFFD ) + 1, MN
09698             DO 50 I = 1, J + IOFFD
09699                A( I, J ) = ALPHA * A( I, J )
09700    50       CONTINUE
09701    60    CONTINUE
09702          DO 80 J = MAX( 0, MN ) + 1, N
09703             DO 70 I = 1, M
09704                A( I, J ) = ALPHA * A( I, J )
09705    70       CONTINUE
09706    80    CONTINUE
09707 *
09708       ELSE IF( LSAME( UPLO, 'D' ) ) THEN
09709 *
09710 *        Scales the diagonal entries by ALPHA.
09711 *
09712          DO 90 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N )
09713             JTMP = J + IOFFD
09714             A( JTMP, J ) = ALPHA * A( JTMP, J )
09715    90    CONTINUE
09716 *
09717       ELSE
09718 *
09719 *        Scales the entire array by ALPHA.
09720 *
09721          DO 110 J = 1, N
09722             DO 100 I = 1, M
09723                A( I, J ) = ALPHA * A( I, J )
09724   100       CONTINUE
09725   110    CONTINUE
09726 *
09727       END IF
09728 *
09729       RETURN
09730 *
09731 *     End of PB_DLASCAL
09732 *
09733       END
09734       SUBROUTINE PB_DLAGEN( UPLO, AFORM, A, LDA, LCMT00, IRAN, MBLKS,
09735      $                      IMBLOC, MB, LMBLOC, NBLKS, INBLOC, NB,
09736      $                      LNBLOC, JMP, IMULADD )
09737 *
09738 *  -- PBLAS test routine (version 2.0) --
09739 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
09740 *     and University of California, Berkeley.
09741 *     April 1, 1998
09742 *
09743 *     .. Scalar Arguments ..
09744       CHARACTER*1        UPLO, AFORM
09745       INTEGER            IMBLOC, INBLOC, LCMT00, LDA, LMBLOC, LNBLOC,
09746      $                   MB, MBLKS, NB, NBLKS
09747 *     ..
09748 *     .. Array Arguments ..
09749       INTEGER            IMULADD( 4, * ), IRAN( * ), JMP( * )
09750       DOUBLE PRECISION   A( LDA, * )
09751 *     ..
09752 *
09753 *  Purpose
09754 *  =======
09755 *
09756 *  PB_DLAGEN locally initializes an array A.
09757 *
09758 *  Arguments
09759 *  =========
09760 *
09761 *  UPLO    (global input) CHARACTER*1
09762 *          On entry, UPLO  specifies whether the lower (UPLO='L') trape-
09763 *          zoidal part or the upper (UPLO='U') trapezoidal part is to be
09764 *          generated  when  the  matrix  to be generated is symmetric or
09765 *          Hermitian. For  all  the  other values of AFORM, the value of
09766 *          this input argument is ignored.
09767 *
09768 *  AFORM   (global input) CHARACTER*1
09769 *          On entry, AFORM specifies the type of submatrix to be genera-
09770 *          ted as follows:
09771 *             AFORM = 'S', sub( A ) is a symmetric matrix,
09772 *             AFORM = 'H', sub( A ) is a Hermitian matrix,
09773 *             AFORM = 'T', sub( A ) is overrwritten  with  the transpose
09774 *                          of what would normally be generated,
09775 *             AFORM = 'C', sub( A ) is overwritten  with  the  conjugate
09776 *                          transpose  of  what would normally be genera-
09777 *                          ted.
09778 *             AFORM = 'N', a random submatrix is generated.
09779 *
09780 *  A       (local output) DOUBLE PRECISION array
09781 *          On entry,  A  is  an array of dimension (LLD_A, *).  On exit,
09782 *          this array contains the local entries of the randomly genera-
09783 *          ted submatrix sub( A ).
09784 *
09785 *  LDA     (local input) INTEGER
09786 *          On entry,  LDA  specifies  the local leading dimension of the
09787 *          array A. LDA must be at least one.
09788 *
09789 *  LCMT00  (global input) INTEGER
09790 *          On entry, LCMT00 is the LCM value specifying the off-diagonal
09791 *          of the underlying matrix of interest. LCMT00=0 specifies  the
09792 *          main diagonal, LCMT00 > 0 specifies a subdiagonal, LCMT00 < 0
09793 *          specifies superdiagonals.
09794 *
09795 *  IRAN    (local input) INTEGER array
09796 *          On entry, IRAN  is an array of dimension 2 containing respec-
09797 *          tively the 16-lower and 16-higher bits of the encoding of the
09798 *          entry of  the  random  sequence  corresponding locally to the
09799 *          first local array entry to generate. Usually,  this  array is
09800 *          computed by PB_SETLOCRAN.
09801 *
09802 *  MBLKS   (local input) INTEGER
09803 *          On entry, MBLKS specifies the local number of blocks of rows.
09804 *          MBLKS is at least zero.
09805 *
09806 *  IMBLOC  (local input) INTEGER
09807 *          On entry, IMBLOC specifies  the  number of rows (size) of the
09808 *          local uppest  blocks. IMBLOC is at least zero.
09809 *
09810 *  MB      (global input) INTEGER
09811 *          On entry, MB  specifies the blocking factor used to partition
09812 *          the rows of the matrix.  MB  must be at least one.
09813 *
09814 *  LMBLOC  (local input) INTEGER
09815 *          On entry, LMBLOC specifies the number of  rows  (size) of the
09816 *          local lowest blocks. LMBLOC is at least zero.
09817 *
09818 *  NBLKS   (local input) INTEGER
09819 *          On entry,  NBLKS  specifies the local number of blocks of co-
09820 *          lumns. NBLKS is at least zero.
09821 *
09822 *  INBLOC  (local input) INTEGER
09823 *          On entry,  INBLOC  specifies the number of columns (size)  of
09824 *          the local leftmost blocks. INBLOC is at least zero.
09825 *
09826 *  NB      (global input) INTEGER
09827 *          On entry, NB  specifies the blocking factor used to partition
09828 *          the the columns of the matrix.  NB  must be at least one.
09829 *
09830 *  LNBLOC  (local input) INTEGER
09831 *          On entry,  LNBLOC  specifies  the number of columns (size) of
09832 *          the local rightmost blocks. LNBLOC is at least zero.
09833 *
09834 *  JMP     (local input) INTEGER array
09835 *          On entry, JMP is an array of dimension JMP_LEN containing the
09836 *          different jump values used by the random matrix generator.
09837 *
09838 *  IMULADD (local input) INTEGER array
09839 *          On entry, IMULADD is an array of dimension (4, JMP_LEN).  The
09840 *          jth  column  of this array contains the encoded initial cons-
09841 *          tants a_j and c_j to  jump  from X( n ) to  X( n + JMP( j ) )
09842 *          (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
09843 *          contains respectively the 16-lower and 16-higher bits of  the
09844 *          constant a_j, and IMULADD(3:4,j)  contains  the 16-lower  and
09845 *          16-higher bits of the constant c_j.
09846 *
09847 *  -- Written on April 1, 1998 by
09848 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
09849 *
09850 *  =====================================================================
09851 *
09852 *     .. Parameters ..
09853       INTEGER            JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
09854      $                   JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
09855      $                   JMP_NQINBLOC, JMP_NQNB, JMP_ROW
09856       PARAMETER          ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3,
09857      $                   JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6,
09858      $                   JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9,
09859      $                   JMP_NQNB = 10, JMP_NQINBLOC = 11,
09860      $                   JMP_LEN = 11 )
09861 *     ..
09862 *     .. Local Scalars ..
09863       INTEGER            I, IB, IBLK, II, IK, ITMP, JB, JBLK, JJ, JK,
09864      $                   JTMP, LCMTC, LCMTR, LOW, MNB, UPP
09865       DOUBLE PRECISION   DUMMY
09866 *     ..
09867 *     .. Local Arrays ..
09868       INTEGER            IB0( 2 ), IB1( 2 ), IB2( 2 ), IB3( 2 )
09869 *     ..
09870 *     .. External Subroutines ..
09871       EXTERNAL           PB_JUMPIT
09872 *     ..
09873 *     .. External Functions ..
09874       LOGICAL            LSAME
09875       DOUBLE PRECISION   PB_DRAND
09876       EXTERNAL           LSAME, PB_DRAND
09877 *     ..
09878 *     .. Intrinsic Functions ..
09879       INTRINSIC          MAX, MIN
09880 *     ..
09881 *     .. Executable Statements ..
09882 *
09883       DO 10 I = 1, 2
09884          IB1( I ) = IRAN( I )
09885          IB2( I ) = IRAN( I )
09886          IB3( I ) = IRAN( I )
09887    10 CONTINUE
09888 *
09889       IF( LSAME( AFORM, 'N' ) ) THEN
09890 *
09891 *        Generate random matrix
09892 *
09893          JJ = 1
09894 *
09895          DO 50 JBLK = 1, NBLKS
09896 *
09897             IF( JBLK.EQ.1 ) THEN
09898                JB = INBLOC
09899             ELSE IF( JBLK.EQ.NBLKS ) THEN
09900                JB = LNBLOC
09901             ELSE
09902                JB = NB
09903             END IF
09904 *
09905             DO 40 JK = JJ, JJ + JB - 1
09906 *
09907                II = 1
09908 *
09909                DO 30 IBLK = 1, MBLKS
09910 *
09911                   IF( IBLK.EQ.1 ) THEN
09912                      IB = IMBLOC
09913                   ELSE IF( IBLK.EQ.MBLKS ) THEN
09914                      IB = LMBLOC
09915                   ELSE
09916                      IB = MB
09917                   END IF
09918 *
09919 *                 Blocks are IB by JB
09920 *
09921                   DO 20 IK = II, II + IB - 1
09922                      A( IK, JK ) = PB_DRAND( 0 )
09923    20             CONTINUE
09924 *
09925                   II = II + IB
09926 *
09927                   IF( IBLK.EQ.1 ) THEN
09928 *
09929 *                    Jump IMBLOC + ( NPROW - 1 ) * MB rows
09930 *
09931                      CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1,
09932      $                               IB0 )
09933 *
09934                   ELSE
09935 *
09936 *                    Jump NPROW * MB rows
09937 *
09938                      CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1, IB0 )
09939 *
09940                   END IF
09941 *
09942                   IB1( 1 ) = IB0( 1 )
09943                   IB1( 2 ) = IB0( 2 )
09944 *
09945    30          CONTINUE
09946 *
09947 *              Jump one column
09948 *
09949                CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 )
09950 *
09951                IB1( 1 ) = IB0( 1 )
09952                IB1( 2 ) = IB0( 2 )
09953                IB2( 1 ) = IB0( 1 )
09954                IB2( 2 ) = IB0( 2 )
09955 *
09956    40       CONTINUE
09957 *
09958             JJ = JJ + JB
09959 *
09960             IF( JBLK.EQ.1 ) THEN
09961 *
09962 *              Jump INBLOC + ( NPCOL - 1 ) * NB columns
09963 *
09964                CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 )
09965 *
09966             ELSE
09967 *
09968 *              Jump NPCOL * NB columns
09969 *
09970                CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 )
09971 *
09972             END IF
09973 *
09974             IB1( 1 ) = IB0( 1 )
09975             IB1( 2 ) = IB0( 2 )
09976             IB2( 1 ) = IB0( 1 )
09977             IB2( 2 ) = IB0( 2 )
09978             IB3( 1 ) = IB0( 1 )
09979             IB3( 2 ) = IB0( 2 )
09980 *
09981    50    CONTINUE
09982 *
09983       ELSE IF( LSAME( AFORM, 'T' ) .OR. LSAME( AFORM, 'C' ) ) THEN
09984 *
09985 *        Generate the transpose of the matrix that would be normally
09986 *        generated.
09987 *
09988          II = 1
09989 *
09990          DO 90 IBLK = 1, MBLKS
09991 *
09992             IF( IBLK.EQ.1 ) THEN
09993                IB = IMBLOC
09994             ELSE IF( IBLK.EQ.MBLKS ) THEN
09995                IB = LMBLOC
09996             ELSE
09997                IB = MB
09998             END IF
09999 *
10000             DO 80 IK = II, II + IB - 1
10001 *
10002                JJ = 1
10003 *
10004                DO 70 JBLK = 1, NBLKS
10005 *
10006                   IF( JBLK.EQ.1 ) THEN
10007                      JB = INBLOC
10008                   ELSE IF( JBLK.EQ.NBLKS ) THEN
10009                      JB = LNBLOC
10010                   ELSE
10011                      JB = NB
10012                   END IF
10013 *
10014 *                 Blocks are IB by JB
10015 *
10016                   DO 60 JK = JJ, JJ + JB - 1
10017                      A( IK, JK ) = PB_DRAND( 0 )
10018    60             CONTINUE
10019 *
10020                   JJ = JJ + JB
10021 *
10022                   IF( JBLK.EQ.1 ) THEN
10023 *
10024 *                    Jump INBLOC + ( NPCOL - 1 ) * NB columns
10025 *
10026                      CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
10027      $                               IB0 )
10028 *
10029                   ELSE
10030 *
10031 *                    Jump NPCOL * NB columns
10032 *
10033                      CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1, IB0 )
10034 *
10035                   END IF
10036 *
10037                   IB1( 1 ) = IB0( 1 )
10038                   IB1( 2 ) = IB0( 2 )
10039 *
10040    70          CONTINUE
10041 *
10042 *              Jump one row
10043 *
10044                CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
10045 *
10046                IB1( 1 ) = IB0( 1 )
10047                IB1( 2 ) = IB0( 2 )
10048                IB2( 1 ) = IB0( 1 )
10049                IB2( 2 ) = IB0( 2 )
10050 *
10051    80       CONTINUE
10052 *
10053             II = II + IB
10054 *
10055             IF( IBLK.EQ.1 ) THEN
10056 *
10057 *              Jump IMBLOC + ( NPROW - 1 ) * MB rows
10058 *
10059                CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
10060 *
10061             ELSE
10062 *
10063 *              Jump NPROW * MB rows
10064 *
10065                CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
10066 *
10067             END IF
10068 *
10069             IB1( 1 ) = IB0( 1 )
10070             IB1( 2 ) = IB0( 2 )
10071             IB2( 1 ) = IB0( 1 )
10072             IB2( 2 ) = IB0( 2 )
10073             IB3( 1 ) = IB0( 1 )
10074             IB3( 2 ) = IB0( 2 )
10075 *
10076    90    CONTINUE
10077 *
10078       ELSE IF( ( LSAME( AFORM, 'S' ) ).OR.( LSAME( AFORM, 'H' ) ) ) THEN
10079 *
10080 *        Generate a symmetric matrix
10081 *
10082          IF( LSAME( UPLO, 'L' ) ) THEN
10083 *
10084 *           generate lower trapezoidal part
10085 *
10086             JJ = 1
10087             LCMTC = LCMT00
10088 *
10089             DO 170 JBLK = 1, NBLKS
10090 *
10091                IF( JBLK.EQ.1 ) THEN
10092                   JB  = INBLOC
10093                   LOW = 1 - INBLOC
10094                ELSE IF( JBLK.EQ.NBLKS ) THEN
10095                   JB = LNBLOC
10096                   LOW = 1 - NB
10097                ELSE
10098                   JB  = NB
10099                   LOW = 1 - NB
10100                END IF
10101 *
10102                DO 160 JK = JJ, JJ + JB - 1
10103 *
10104                   II = 1
10105                   LCMTR = LCMTC
10106 *
10107                   DO 150 IBLK = 1, MBLKS
10108 *
10109                      IF( IBLK.EQ.1 ) THEN
10110                         IB  = IMBLOC
10111                         UPP = IMBLOC - 1
10112                      ELSE IF( IBLK.EQ.MBLKS ) THEN
10113                         IB  = LMBLOC
10114                         UPP = MB - 1
10115                      ELSE
10116                         IB  = MB
10117                         UPP = MB - 1
10118                      END IF
10119 *
10120 *                    Blocks are IB by JB
10121 *
10122                      IF( LCMTR.GT.UPP ) THEN
10123 *
10124                         DO 100 IK = II, II + IB - 1
10125                            DUMMY = PB_DRAND( 0 )
10126   100                   CONTINUE
10127 *
10128                      ELSE IF( LCMTR.GE.LOW ) THEN
10129 *
10130                         JTMP = JK - JJ + 1
10131                         MNB  = MAX( 0, -LCMTR )
10132 *
10133                         IF( JTMP.LE.MIN( MNB, JB ) ) THEN
10134 *
10135                            DO 110 IK = II, II + IB - 1
10136                               A( IK, JK ) = PB_DRAND( 0 )
10137   110                      CONTINUE
10138 *
10139                         ELSE IF( ( JTMP.GE.( MNB + 1 )         ) .AND.
10140      $                           ( JTMP.LE.MIN( IB-LCMTR, JB ) ) ) THEN
10141 *
10142                            ITMP = II + JTMP + LCMTR - 1
10143 *
10144                            DO 120 IK = II, ITMP - 1
10145                               DUMMY = PB_DRAND( 0 )
10146   120                      CONTINUE
10147 *
10148                            DO 130 IK = ITMP, II + IB - 1
10149                               A( IK, JK ) = PB_DRAND( 0 )
10150   130                      CONTINUE
10151 *
10152                         END IF
10153 *
10154                      ELSE
10155 *
10156                         DO 140 IK = II, II + IB - 1
10157                            A( IK, JK ) = PB_DRAND( 0 )
10158   140                   CONTINUE
10159 *
10160                      END IF
10161 *
10162                      II = II + IB
10163 *
10164                      IF( IBLK.EQ.1 ) THEN
10165 *
10166 *                       Jump IMBLOC + ( NPROW - 1 ) * MB rows
10167 *
10168                         LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
10169                         CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1,
10170      $                                  IB0 )
10171 *
10172                      ELSE
10173 *
10174 *                       Jump NPROW * MB rows
10175 *
10176                         LCMTR = LCMTR - JMP( JMP_NPMB )
10177                         CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1,
10178      $                                  IB0 )
10179 *
10180                      END IF
10181 *
10182                      IB1( 1 ) = IB0( 1 )
10183                      IB1( 2 ) = IB0( 2 )
10184 *
10185   150             CONTINUE
10186 *
10187 *                 Jump one column
10188 *
10189                   CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 )
10190 *
10191                   IB1( 1 ) = IB0( 1 )
10192                   IB1( 2 ) = IB0( 2 )
10193                   IB2( 1 ) = IB0( 1 )
10194                   IB2( 2 ) = IB0( 2 )
10195 *
10196   160          CONTINUE
10197 *
10198                JJ = JJ + JB
10199 *
10200                IF( JBLK.EQ.1 ) THEN
10201 *
10202 *                 Jump INBLOC + ( NPCOL - 1 ) * NB columns
10203 *
10204                   LCMTC = LCMTC + JMP( JMP_NQINBLOC )
10205                   CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 )
10206 *
10207                ELSE
10208 *
10209 *                 Jump NPCOL * NB columns
10210 *
10211                   LCMTC = LCMTC + JMP( JMP_NQNB )
10212                   CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 )
10213 *
10214                END IF
10215 *
10216                IB1( 1 ) = IB0( 1 )
10217                IB1( 2 ) = IB0( 2 )
10218                IB2( 1 ) = IB0( 1 )
10219                IB2( 2 ) = IB0( 2 )
10220                IB3( 1 ) = IB0( 1 )
10221                IB3( 2 ) = IB0( 2 )
10222 *
10223   170       CONTINUE
10224 *
10225          ELSE
10226 *
10227 *           generate upper trapezoidal part
10228 *
10229             II = 1
10230             LCMTR = LCMT00
10231 *
10232             DO 250 IBLK = 1, MBLKS
10233 *
10234                IF( IBLK.EQ.1 ) THEN
10235                   IB  = IMBLOC
10236                   UPP = IMBLOC - 1
10237                ELSE IF( IBLK.EQ.MBLKS ) THEN
10238                   IB  = LMBLOC
10239                   UPP = MB - 1
10240                ELSE
10241                   IB  = MB
10242                   UPP = MB - 1
10243                END IF
10244 *
10245                DO 240 IK = II, II + IB - 1
10246 *
10247                   JJ = 1
10248                   LCMTC = LCMTR
10249 *
10250                   DO 230 JBLK = 1, NBLKS
10251 *
10252                      IF( JBLK.EQ.1 ) THEN
10253                         JB  = INBLOC
10254                         LOW = 1 - INBLOC
10255                      ELSE IF( JBLK.EQ.NBLKS ) THEN
10256                         JB  = LNBLOC
10257                         LOW = 1 - NB
10258                      ELSE
10259                         JB  = NB
10260                         LOW = 1 - NB
10261                      END IF
10262 *
10263 *                    Blocks are IB by JB
10264 *
10265                      IF( LCMTC.LT.LOW ) THEN
10266 *
10267                         DO 180 JK = JJ, JJ + JB - 1
10268                            DUMMY = PB_DRAND( 0 )
10269   180                   CONTINUE
10270 *
10271                      ELSE IF( LCMTC.LE.UPP ) THEN
10272 *
10273                         ITMP = IK - II + 1
10274                         MNB  = MAX( 0, LCMTC )
10275 *
10276                         IF( ITMP.LE.MIN( MNB, IB ) ) THEN
10277 *
10278                            DO 190 JK = JJ, JJ + JB - 1
10279                               A( IK, JK ) = PB_DRAND( 0 )
10280   190                      CONTINUE
10281 *
10282                         ELSE IF( ( ITMP.GE.( MNB + 1 )         ) .AND.
10283      $                           ( ITMP.LE.MIN( JB+LCMTC, IB ) ) ) THEN
10284 *
10285                            JTMP = JJ + ITMP - LCMTC - 1
10286 *
10287                            DO 200 JK = JJ, JTMP - 1
10288                               DUMMY = PB_DRAND( 0 )
10289   200                      CONTINUE
10290 *
10291                            DO 210 JK = JTMP, JJ + JB - 1
10292                               A( IK, JK ) = PB_DRAND( 0 )
10293   210                      CONTINUE
10294 *
10295                         END IF
10296 *
10297                      ELSE
10298 *
10299                         DO 220 JK = JJ, JJ + JB - 1
10300                            A( IK, JK ) = PB_DRAND( 0 )
10301   220                   CONTINUE
10302 *
10303                      END IF
10304 *
10305                      JJ = JJ + JB
10306 *
10307                      IF( JBLK.EQ.1 ) THEN
10308 *
10309 *                       Jump INBLOC + ( NPCOL - 1 ) * NB columns
10310 *
10311                         LCMTC = LCMTC + JMP( JMP_NQINBLOC )
10312                         CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
10313      $                                  IB0 )
10314 *
10315                      ELSE
10316 *
10317 *                       Jump NPCOL * NB columns
10318 *
10319                         LCMTC = LCMTC + JMP( JMP_NQNB )
10320                         CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1,
10321      $                                  IB0 )
10322 *
10323                      END IF
10324 *
10325                      IB1( 1 ) = IB0( 1 )
10326                      IB1( 2 ) = IB0( 2 )
10327 *
10328   230             CONTINUE
10329 *
10330 *                 Jump one row
10331 *
10332                   CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
10333 *
10334                   IB1( 1 ) = IB0( 1 )
10335                   IB1( 2 ) = IB0( 2 )
10336                   IB2( 1 ) = IB0( 1 )
10337                   IB2( 2 ) = IB0( 2 )
10338 *
10339   240          CONTINUE
10340 *
10341                II = II + IB
10342 *
10343                IF( IBLK.EQ.1 ) THEN
10344 *
10345 *                 Jump IMBLOC + ( NPROW - 1 ) * MB rows
10346 *
10347                   LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
10348                   CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
10349 *
10350                ELSE
10351 *
10352 *                 Jump NPROW * MB rows
10353 *
10354                   LCMTR = LCMTR - JMP( JMP_NPMB )
10355                   CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
10356 *
10357                END IF
10358 *
10359                IB1( 1 ) = IB0( 1 )
10360                IB1( 2 ) = IB0( 2 )
10361                IB2( 1 ) = IB0( 1 )
10362                IB2( 2 ) = IB0( 2 )
10363                IB3( 1 ) = IB0( 1 )
10364                IB3( 2 ) = IB0( 2 )
10365 *
10366   250       CONTINUE
10367 *
10368          END IF
10369 *
10370       END IF
10371 *
10372       RETURN
10373 *
10374 *     End of PB_DLAGEN
10375 *
10376       END
10377       DOUBLE PRECISION   FUNCTION PB_DRAND( IDUMM )
10378 *
10379 *  -- PBLAS test routine (version 2.0) --
10380 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
10381 *     and University of California, Berkeley.
10382 *     April 1, 1998
10383 *
10384 *     .. Scalar Arguments ..
10385       INTEGER            IDUMM
10386 *     ..
10387 *
10388 *  Purpose
10389 *  =======
10390 *
10391 *  PB_DRAND generates the next number in the random sequence. This func-
10392 *  tion ensures that this number will be in the interval ( -1.0, 1.0 ).
10393 *
10394 *  Arguments
10395 *  =========
10396 *
10397 *  IDUMM   (local input) INTEGER
10398 *          This argument is ignored, but necessary to a FORTRAN 77 func-
10399 *          tion.
10400 *
10401 *  Further Details
10402 *  ===============
10403 *
10404 *  On entry, the array IRAND stored in the common block  RANCOM contains
10405 *  the information (2 integers)  required to generate the next number in
10406 *  the sequence X( n ). This number is computed as
10407 *
10408 *     X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
10409 *
10410 *  where the constant d is the  largest  32 bit  positive  integer.  The
10411 *  array  IRAND  is  then  updated for the generation of the next number
10412 *  X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
10413 *  The constants  a  and c  should have been preliminarily stored in the
10414 *  array  IACS  as  2 pairs of integers. The initial set up of IRAND and
10415 *  IACS is performed by the routine PB_SETRAN.
10416 *
10417 *  -- Written on April 1, 1998 by
10418 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
10419 *
10420 *  =====================================================================
10421 *
10422 *     .. Parameters ..
10423       DOUBLE PRECISION   ONE, TWO
10424       PARAMETER          ( ONE = 1.0D+0, TWO = 2.0D+0 )
10425 *     ..
10426 *     .. External Functions ..
10427       DOUBLE PRECISION   PB_DRAN
10428       EXTERNAL           PB_DRAN
10429 *     ..
10430 *     .. Executable Statements ..
10431 *
10432       PB_DRAND = ONE - TWO * PB_DRAN( IDUMM )
10433 *
10434       RETURN
10435 *
10436 *     End of PB_DRAND
10437 *
10438       END
10439       DOUBLE PRECISION   FUNCTION PB_DRAN( IDUMM )
10440 *
10441 *  -- PBLAS test routine (version 2.0) --
10442 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
10443 *     and University of California, Berkeley.
10444 *     April 1, 1998
10445 *
10446 *     .. Scalar Arguments ..
10447       INTEGER            IDUMM
10448 *     ..
10449 *
10450 *  Purpose
10451 *  =======
10452 *
10453 *  PB_DRAN generates the next number in the random sequence.
10454 *
10455 *  Arguments
10456 *  =========
10457 *
10458 *  IDUMM   (local input) INTEGER
10459 *          This argument is ignored, but necessary to a FORTRAN 77 func-
10460 *          tion.
10461 *
10462 *  Further Details
10463 *  ===============
10464 *
10465 *  On entry, the array IRAND stored in the common block  RANCOM contains
10466 *  the information (2 integers)  required to generate the next number in
10467 *  the sequence X( n ). This number is computed as
10468 *
10469 *     X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
10470 *
10471 *  where the constant d is the  largest  32 bit  positive  integer.  The
10472 *  array  IRAND  is  then  updated for the generation of the next number
10473 *  X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
10474 *  The constants  a  and c  should have been preliminarily stored in the
10475 *  array  IACS  as  2 pairs of integers. The initial set up of IRAND and
10476 *  IACS is performed by the routine PB_SETRAN.
10477 *
10478 *  -- Written on April 1, 1998 by
10479 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
10480 *
10481 *  =====================================================================
10482 *
10483 *     .. Parameters ..
10484       DOUBLE PRECISION   DIVFAC, POW16
10485       PARAMETER          ( DIVFAC = 2.147483648D+9,
10486      $                   POW16 = 6.5536D+4 )
10487 *     ..
10488 *     .. Local Arrays ..
10489       INTEGER            J( 2 )
10490 *     ..
10491 *     .. External Subroutines ..
10492       EXTERNAL           PB_LADD, PB_LMUL
10493 *     ..
10494 *     .. Intrinsic Functions ..
10495       INTRINSIC          DBLE
10496 *     ..
10497 *     .. Common Blocks ..
10498       INTEGER            IACS( 4 ), IRAND( 2 )
10499       COMMON             /RANCOM/ IRAND, IACS
10500 *     ..
10501 *     .. Save Statements ..
10502       SAVE               /RANCOM/
10503 *     ..
10504 *     .. Executable Statements ..
10505 *
10506       PB_DRAN = ( DBLE( IRAND( 1 ) ) + POW16 * DBLE( IRAND( 2 ) ) ) /
10507      $            DIVFAC
10508 *
10509       CALL PB_LMUL( IRAND, IACS, J )
10510       CALL PB_LADD( J, IACS( 3 ), IRAND )
10511 *
10512       RETURN
10513 *
10514 *     End of PB_DRAN
10515 *
10516       END