ScaLAPACK  2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
psblastst.f
Go to the documentation of this file.
00001       SUBROUTINE PSOPTEE( 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 *  PSOPTEE  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            PSCHKOPT
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 PSCHKOPT( 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 PSCHKOPT( 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 PSCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS )
00177 *
00178 *        Check 2nd option
00179 *
00180          APOS = 2
00181          CALL PSCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
00182 *
00183 *        Check 3rd option
00184 *
00185          APOS = 3
00186          CALL PSCHKOPT( 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 PSCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
00196 *
00197 *        Check 2'nd option
00198 *
00199          APOS = 2
00200          CALL PSCHKOPT( 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 PSCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'S', APOS )
00208 *
00209 *        Check 2nd option
00210 *
00211          APOS = 2
00212          CALL PSCHKOPT( 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 PSCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS )
00221 *
00222 *        Check 2'nd option
00223 *
00224          APOS = 2
00225          CALL PSCHKOPT( 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 PSCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'S', APOS )
00233 *
00234 *        Check 2nd option
00235 *
00236          APOS = 2
00237          CALL PSCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'U', APOS )
00238 *
00239 *        Check 3rd option
00240 *
00241          APOS = 3
00242          CALL PSCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
00243 *
00244 *        Check 4th option
00245 *
00246          APOS = 4
00247          CALL PSCHKOPT( 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 PSCHKOPT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
00256 *
00257       END IF
00258 *
00259       RETURN
00260 *
00261 *     End of PSOPTEE
00262 *
00263       END
00264       SUBROUTINE PSCHKOPT( 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 *  PSCHKOPT 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, PSCALLSUB, PSSETPBLAS
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 PSSETPBLAS( 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 PSCALLSUB( SUBPTR, SCODE )
00447       CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
00448 *
00449       RETURN
00450 *
00451 *     End of PSCHKOPT
00452 *
00453       END
00454       SUBROUTINE PSDIMEE( 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 *  PSDIMEE  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            PSCHKDIM
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 PSCHKDIM( 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 PSCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00625 *
00626 *        Check 2nd dimension
00627 *
00628          APOS = 3
00629          CALL PSCHKDIM( 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 PSCHKDIM( 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 PSCHKDIM( 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 PSCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00652 *
00653 *        Check 2nd dimension
00654 *
00655          APOS = 2
00656          CALL PSCHKDIM( 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 PSCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00666 *
00667 *        Check 2nd dimension
00668 *
00669          APOS = 4
00670          CALL PSCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00671 *
00672 *        Check 3rd dimension
00673 *
00674          APOS = 5
00675          CALL PSCHKDIM( 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 PSCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00683 *
00684 *        Check 2nd dimension
00685 *
00686          APOS = 4
00687          CALL PSCHKDIM( 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 PSCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00696 *
00697 *        Check 2nd dimension
00698 *
00699          APOS = 4
00700          CALL PSCHKDIM( 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 PSCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00708 *
00709 *        Check 2nd dimension
00710 *
00711          APOS = 2
00712          CALL PSCHKDIM( 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 PSCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00720 *
00721 *        Check 2nd dimension
00722 *
00723          APOS = 6
00724          CALL PSCHKDIM( 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 PSCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00732 *
00733 *        Check 2nd dimension
00734 *
00735          APOS = 3
00736          CALL PSCHKDIM( 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 PSCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'M', APOS )
00744 *
00745 *        Check 2nd dimension
00746 *
00747          APOS = 4
00748          CALL PSCHKDIM( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'N', APOS )
00749 *
00750       END IF
00751 *
00752       RETURN
00753 *
00754 *     End of PSDIMEE
00755 *
00756       END
00757       SUBROUTINE PSCHKDIM( 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 *  PSCHKDIM 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, PSCALLSUB, PSSETPBLAS
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 PSSETPBLAS( 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 PSCALLSUB( SUBPTR, SCODE )
00928       CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
00929 *
00930       RETURN
00931 *
00932 *     End of PSCHKDIM
00933 *
00934       END
00935       SUBROUTINE PSVECEE( 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 *  PSVECEE  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            PSCHKMAT
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 PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01098 *
01099 *        Check 2nd vector
01100 *
01101          APOS = 7
01102          CALL PSCHKMAT( 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 PSCHKMAT( 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 PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01117 *
01118 *        Check 2nd vector
01119 *
01120          APOS = 8
01121          CALL PSCHKMAT( 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 PSCHKMAT( 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 PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01138 *
01139 *        Check 2nd vector
01140 *
01141          APOS = 15
01142          CALL PSCHKMAT( 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 PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01150 *
01151 *        Check 2nd vector
01152 *
01153          APOS = 14
01154          CALL PSCHKMAT( 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 PSCHKMAT( 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 PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01169 *
01170 *        Check 2nd vector
01171 *
01172          APOS = 9
01173          CALL PSCHKMAT( 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 PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'X', APOS )
01181 *
01182       END IF
01183 *
01184       RETURN
01185 *
01186 *     End of PSVECEE
01187 *
01188       END
01189       SUBROUTINE PSMATEE( 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 *  PSMATEE  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            PSCHKMAT
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 PSCHKMAT( 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 PSCHKMAT( 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 PSCHKMAT( 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 PSCHKMAT( 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 PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01382 *
01383 *        Check 2nd matrix
01384 *
01385          APOS = 11
01386          CALL PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'B', APOS )
01387 *
01388 *        Check 3nd matrix
01389 *
01390          APOS = 16
01391          CALL PSCHKMAT( 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 PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01399 *
01400 *        Check 2nd matrix
01401 *
01402          APOS = 10
01403          CALL PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'B', APOS )
01404 *
01405 *        Check 3nd matrix
01406 *
01407          APOS = 15
01408          CALL PSCHKMAT( 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 PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01416 *
01417 *        Check 2nd matrix
01418 *
01419          APOS = 11
01420          CALL PSCHKMAT( 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 PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01428 *
01429 *        Check 2nd matrix
01430 *
01431          APOS = 9
01432          CALL PSCHKMAT( 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 PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01440 *
01441 *        Check 2nd matrix
01442 *
01443          APOS = 12
01444          CALL PSCHKMAT( 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 PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01452 *
01453 *        Check 2nd matrix
01454 *
01455          APOS = 10
01456          CALL PSCHKMAT( 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 PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'A', APOS )
01464 *
01465 *        Check 2nd matrix
01466 *
01467          APOS = 11
01468          CALL PSCHKMAT( ICTXT, NOUT, SUBPTR, SCODE, SNAME, 'C', APOS )
01469 *
01470       END IF
01471 *
01472       RETURN
01473 *
01474 *     End of PSMATEE
01475 *
01476       END
01477       SUBROUTINE PSSETPBLAS( 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 *  PSSETPBLAS initializes *all* the dummy arguments to correct values.
01492 *
01493 *  Notes
01494 *  =====
01495 *
01496 *  A description  vector  is associated with each 2D block-cyclicly dis-
01497 *  tributed matrix.  This  vector  stores  the  information  required to
01498 *  establish the  mapping  between a  matrix entry and its corresponding
01499 *  process and memory location.
01500 *
01501 *  In  the  following  comments,   the character _  should  be  read  as
01502 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
01503 *  block cyclicly distributed matrix.  Its description vector is DESCA:
01504 *
01505 *  NOTATION         STORED IN       EXPLANATION
01506 *  ---------------- --------------- ------------------------------------
01507 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
01508 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
01509 *                                   the NPROW x NPCOL BLACS process grid
01510 *                                   A  is distributed over.  The context
01511 *                                   itself  is  global,  but  the handle
01512 *                                   (the integer value) may vary.
01513 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
01514 *                                   ted matrix A, M_A >= 0.
01515 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
01516 *                                   buted matrix A, N_A >= 0.
01517 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
01518 *                                   block of the matrix A, IMB_A > 0.
01519 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
01520 *                                   left   block   of   the   matrix  A,
01521 *                                   INB_A > 0.
01522 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
01523 *                                   bute the last  M_A-IMB_A rows of  A,
01524 *                                   MB_A > 0.
01525 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
01526 *                                   bute the last  N_A-INB_A  columns of
01527 *                                   A, NB_A > 0.
01528 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
01529 *                                   row of the matrix  A is distributed,
01530 *                                   NPROW > RSRC_A >= 0.
01531 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
01532 *                                   first  column of  A  is distributed.
01533 *                                   NPCOL > CSRC_A >= 0.
01534 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
01535 *                                   array  storing  the  local blocks of
01536 *                                   the distributed matrix A,
01537 *                                   IF( Lc( 1, N_A ) > 0 )
01538 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
01539 *                                   ELSE
01540 *                                      LLD_A >= 1.
01541 *
01542 *  Let K be the number of  rows of a matrix A starting at the global in-
01543 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
01544 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
01545 *  receive if these K rows were distributed over NPROW processes.  If  K
01546 *  is the number of columns of a matrix  A  starting at the global index
01547 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
01548 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
01549 *  these K columns were distributed over NPCOL processes.
01550 *
01551 *  The values of Lr() and Lc() may be determined via a call to the func-
01552 *  tion PB_NUMROC:
01553 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
01554 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
01555 *
01556 *  Arguments
01557 *  =========
01558 *
01559 *  ICTXT   (local input) INTEGER
01560 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
01561 *          ting the global  context of the operation. The context itself
01562 *          is global, but the value of ICTXT is local.
01563 *
01564 *  -- Written on April 1, 1998 by
01565 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
01566 *
01567 *  =====================================================================
01568 *
01569 *     .. Parameters ..
01570       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
01571      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
01572      $                   RSRC_
01573       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
01574      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
01575      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
01576      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
01577       REAL               ONE
01578       PARAMETER          ( ONE = 1.0E+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       REAL               USCLR, SCLR
01588       INTEGER            DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
01589      $                   DESCX( DLEN_ ), DESCY( DLEN_ )
01590       REAL               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 PSSETPBLAS
01670 *
01671       END
01672       SUBROUTINE PSCHKMAT( 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 *  PSCHKMAT 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, PSCALLSUB, PSSETPBLAS
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 PSSETPBLAS( ICTXT )
01836          IA    = -1
01837          INFOT = ARGPOS + 1
01838          CALL PSCALLSUB( SUBPTR, SCODE )
01839          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01840 *
01841 *        Check JA. Set all other OK, bad JA
01842 *
01843          CALL PSSETPBLAS( ICTXT )
01844          JA    = -1
01845          INFOT = ARGPOS + 2
01846          CALL PSCALLSUB( 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 PSSETPBLAS( ICTXT )
01856             DESCA( I ) =  -2
01857             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
01858             CALL PSCALLSUB( 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 PSSETPBLAS( 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 PSCALLSUB( 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 PSSETPBLAS( ICTXT )
01901          IB    = -1
01902          INFOT = ARGPOS + 1
01903          CALL PSCALLSUB( SUBPTR, SCODE )
01904          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01905 *
01906 *        Check JB. Set all other OK, bad JB
01907 *
01908          CALL PSSETPBLAS( ICTXT )
01909          JB    = -1
01910          INFOT = ARGPOS + 2
01911          CALL PSCALLSUB( 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 PSSETPBLAS( ICTXT )
01921             DESCB( I ) =  -2
01922             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
01923             CALL PSCALLSUB( 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 PSSETPBLAS( 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 PSCALLSUB( 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 PSSETPBLAS( ICTXT )
01966          IC    = -1
01967          INFOT = ARGPOS + 1
01968          CALL PSCALLSUB( SUBPTR, SCODE )
01969          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
01970 *
01971 *        Check JC. Set all other OK, bad JC
01972 *
01973          CALL PSSETPBLAS( ICTXT )
01974          JC    = -1
01975          INFOT = ARGPOS + 2
01976          CALL PSCALLSUB( 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 PSSETPBLAS( ICTXT )
01986             DESCC( I ) =  -2
01987             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
01988             CALL PSCALLSUB( 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 PSSETPBLAS( 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 PSCALLSUB( 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 PSSETPBLAS( ICTXT )
02031          IX    = -1
02032          INFOT = ARGPOS + 1
02033          CALL PSCALLSUB( SUBPTR, SCODE )
02034          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02035 *
02036 *        Check JX. Set all other OK, bad JX
02037 *
02038          CALL PSSETPBLAS( ICTXT )
02039          JX    = -1
02040          INFOT = ARGPOS + 2
02041          CALL PSCALLSUB( 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 PSSETPBLAS( ICTXT )
02051             DESCX( I ) =  -2
02052             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
02053             CALL PSCALLSUB( 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 PSSETPBLAS( 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 PSCALLSUB( 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 PSSETPBLAS( ICTXT )
02094          INCX  =  -1
02095          INFOT = ARGPOS + 4
02096          CALL PSCALLSUB( 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 PSSETPBLAS( ICTXT )
02104          IY    = -1
02105          INFOT = ARGPOS + 1
02106          CALL PSCALLSUB( SUBPTR, SCODE )
02107          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02108 *
02109 *        Check JY. Set all other OK, bad JY
02110 *
02111          CALL PSSETPBLAS( ICTXT )
02112          JY    = -1
02113          INFOT = ARGPOS + 2
02114          CALL PSCALLSUB( 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 PSSETPBLAS( ICTXT )
02124             DESCY( I ) =  -2
02125             INFOT = ( ( ARGPOS + 3 ) * DESCMULT ) + I
02126             CALL PSCALLSUB( 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 PSSETPBLAS( 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 PSCALLSUB( 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 PSSETPBLAS( ICTXT )
02167          INCY =  -1
02168          INFOT = ARGPOS + 4
02169          CALL PSCALLSUB( SUBPTR, SCODE )
02170          CALL PCHKPBE( ICTXT, NOUT, SNAME, INFOT )
02171 *
02172       END IF
02173 *
02174       RETURN
02175 *
02176 *     End of PSCHKMAT
02177 *
02178       END
02179       SUBROUTINE PSCALLSUB( 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 *  PSCALLSUB 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       REAL               USCLR, SCLR
02321       INTEGER            DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
02322      $                   DESCX( DLEN_ ), DESCY( DLEN_ )
02323       REAL               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 PSCALLSUB
02453 *
02454       END
02455       SUBROUTINE PSERRSET( 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       REAL               ERR, ERRMAX, X, XTRUE
02464 *     ..
02465 *
02466 *  Purpose
02467 *  =======
02468 *
02469 *  PSERRSET  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) REAL
02539 *          On exit, ERR specifies the absolute difference |XTRUE - X|.
02540 *
02541 *  ERRMAX  (local input/local output) REAL
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) REAL
02546 *          On entry, XTRUE specifies the true value.
02547 *
02548 *  X       (local input) REAL
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       REAL               PSDIFF
02558       EXTERNAL           PSDIFF
02559 *     ..
02560 *     .. Intrinsic Functions ..
02561       INTRINSIC          ABS, MAX
02562 *     ..
02563 *     .. Executable Statements ..
02564 *
02565       ERR = ABS( PSDIFF( XTRUE, X ) )
02566 *
02567       ERRMAX = MAX( ERRMAX, ERR )
02568 *
02569       RETURN
02570 *
02571 *     End of PSERRSET
02572 *
02573       END
02574       SUBROUTINE PSCHKVIN( 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       REAL               ERRMAX
02585 *     ..
02586 *     .. Array Arguments ..
02587       INTEGER            DESCX( * )
02588       REAL               PX( * ), X( * )
02589 *     ..
02590 *
02591 *  Purpose
02592 *  =======
02593 *
02594 *  PSCHKVIN  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) REAL
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) REAL 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) REAL 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       REAL               ZERO
02720       PARAMETER          ( ZERO = 0.0E+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       REAL               ERR, EPS
02728 *     ..
02729 *     .. External Subroutines ..
02730       EXTERNAL           BLACS_GRIDINFO, PB_INFOG2L, PSERRSET, SGAMX2D
02731 *     ..
02732 *     .. External Functions ..
02733       REAL               PSLAMCH
02734       EXTERNAL           PSLAMCH
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 = PSLAMCH( 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 PSERRSET( 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 PSERRSET( 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 PSERRSET( 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 PSERRSET( 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 PSERRSET( 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 SGAMX2D( 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 PSCHKVIN
02867 *
02868       END
02869       SUBROUTINE PSCHKVOUT( 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       REAL               PX( * ), X( * )
02882 *     ..
02883 *
02884 *  Purpose
02885 *  =======
02886 *
02887 *  PSCHKVOUT  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) REAL 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) REAL 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       REAL               ZERO
03009       PARAMETER          ( ZERO = 0.0E+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       REAL               EPS, ERR, ERRMAX
03018 *     ..
03019 *     .. External Subroutines ..
03020       EXTERNAL           BLACS_GRIDINFO, PSERRSET, SGAMX2D
03021 *     ..
03022 *     .. External Functions ..
03023       INTEGER            PB_NUMROC
03024       REAL               PSLAMCH
03025       EXTERNAL           PSLAMCH, 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 = PSLAMCH( 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 PSERRSET( 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 PSERRSET( 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 PSERRSET( 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 PSERRSET( 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 PSERRSET( 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 PSERRSET( 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 PSERRSET( 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 PSERRSET( 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 SGAMX2D( 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 PSCHKVOUT
03323 *
03324       END
03325       SUBROUTINE PSCHKMIN( 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       REAL               ERRMAX
03335 *     ..
03336 *     .. Array Arguments ..
03337       INTEGER            DESCA( * )
03338       REAL               PA( * ), A( * )
03339 *     ..
03340 *
03341 *  Purpose
03342 *  =======
03343 *
03344 *  PSCHKMIN  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) REAL
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) REAL 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) REAL 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       REAL               ZERO
03469       PARAMETER          ( ZERO = 0.0E+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       REAL               ERR, EPS
03477 *     ..
03478 *     .. External Subroutines ..
03479       EXTERNAL           BLACS_GRIDINFO, PB_INFOG2L, PSERRSET, SGAMX2D
03480 *     ..
03481 *     .. External Functions ..
03482       REAL               PSLAMCH
03483       EXTERNAL           PSLAMCH
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 = PSLAMCH( 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 PSERRSET( 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 PSERRSET( 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 PSERRSET( 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 PSERRSET( 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 SGAMX2D( 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 PSCHKMIN
03624 *
03625       END
03626       SUBROUTINE PSCHKMOUT( 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       REAL               A( * ), PA( * )
03639 *     ..
03640 *
03641 *  Purpose
03642 *  =======
03643 *
03644 *  PSCHKMOUT  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) REAL 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) REAL 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       REAL               ZERO
03765       PARAMETER          ( ZERO = 0.0E+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       REAL               EPS, ERR, ERRMAX
03773 *     ..
03774 *     .. External Subroutines ..
03775       EXTERNAL           BLACS_GRIDINFO, PSERRSET, SGAMX2D
03776 *     ..
03777 *     .. External Functions ..
03778       INTEGER            PB_NUMROC
03779       REAL               PSLAMCH
03780       EXTERNAL           PSLAMCH, 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 = PSLAMCH( 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 PSERRSET( 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 PSERRSET( 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 PSERRSET( 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 PSERRSET( 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 SGAMX2D( 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 PSCHKMOUT
03945 *
03946       END
03947       SUBROUTINE PSMPRNT( 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       REAL               A( LDA, * )
03961 *     ..
03962 *
03963 *  Purpose
03964 *  =======
03965 *
03966 *  PSMPRNT 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) REAL 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, ')=', E16.8 )
04048 *
04049       RETURN
04050 *
04051 *     End of PSMPRNT
04052 *
04053       END
04054       SUBROUTINE PSVPRNT( 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       REAL               X( * )
04068 *     ..
04069 *
04070 *  Purpose
04071 *  =======
04072 *
04073 *  PSVPRNT  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) REAL 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, ')=', E16.8 )
04148 *
04149       RETURN
04150 *
04151 *     End of PSVPRNT
04152 *
04153       END
04154       SUBROUTINE PSMVCH( 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       REAL               ALPHA, BETA, ERR
04168 *     ..
04169 *     .. Array Arguments ..
04170       INTEGER            DESCA( * ), DESCX( * ), DESCY( * )
04171       REAL               A( * ), G( * ), PY( * ), X( * ), Y( * )
04172 *     ..
04173 *
04174 *  Purpose
04175 *  =======
04176 *
04177 *  PSMVCH 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) REAL
04267 *          On entry, ALPHA specifies the scalar alpha.
04268 *
04269 *  A       (local input) REAL 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) REAL 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) REAL
04307 *          On entry, BETA specifies the scalar beta.
04308 *
04309 *  Y       (local input/local output) REAL 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) REAL 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) REAL 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) REAL
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       REAL               ZERO, ONE
04358       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+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       REAL               EPS, ERRI, GTMP, TBETA, YTMP
04367 *     ..
04368 *     .. External Subroutines ..
04369       EXTERNAL           BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D
04370 *     ..
04371 *     .. External Functions ..
04372       LOGICAL            LSAME
04373       REAL               PSLAMCH
04374       EXTERNAL           LSAME, PSLAMCH
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 = PSLAMCH( 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 SGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
04560      $              MYCOL )
04561 *
04562       RETURN
04563 *
04564 *     End of PSMVCH
04565 *
04566       END
04567       SUBROUTINE PSVMCH( 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       REAL               ALPHA, ERR
04581 *     ..
04582 *     .. Array Arguments ..
04583       INTEGER            DESCA( * ), DESCX( * ), DESCY( * )
04584       REAL               A( * ), G( * ), PA( * ), X( * ), Y( * )
04585 *     ..
04586 *
04587 *  Purpose
04588 *  =======
04589 *
04590 *  PSVMCH 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) REAL
04679 *          On entry, ALPHA specifies the scalar alpha.
04680 *
04681 *  X       (local input) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL
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       REAL               ZERO, ONE
04767       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+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       REAL               ATMP, EPS, ERRI, GTMP
04775 *     ..
04776 *     .. External Subroutines ..
04777       EXTERNAL           BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D
04778 *     ..
04779 *     .. External Functions ..
04780       LOGICAL            LSAME
04781       REAL               PSLAMCH
04782       EXTERNAL           LSAME, PSLAMCH
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 = PSLAMCH( 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 SGAMX2D( 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 PSVMCH
04914 *
04915       END
04916       SUBROUTINE PSVMCH2( 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       REAL               ALPHA, ERR
04930 *     ..
04931 *     .. Array Arguments ..
04932       INTEGER            DESCA( * ), DESCX( * ), DESCY( * )
04933       REAL               A( * ), G( * ), PA( * ), X( * ), Y( * )
04934 *     ..
04935 *
04936 *  Purpose
04937 *  =======
04938 *
04939 *  PSVMCH2 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) REAL
05028 *          On entry, ALPHA specifies the scalar alpha.
05029 *
05030 *  X       (local input) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL
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       REAL               ZERO, ONE
05116       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+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       REAL               EPS, ERRI, GTMP, ATMP
05125 *     ..
05126 *     .. External Subroutines ..
05127       EXTERNAL           BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D
05128 *     ..
05129 *     .. External Functions ..
05130       LOGICAL            LSAME
05131       REAL               PSLAMCH
05132       EXTERNAL           LSAME, PSLAMCH
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 = PSLAMCH( 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 SGAMX2D( 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 PSVMCH2
05267 *
05268       END
05269       SUBROUTINE PSMMCH( 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       REAL               ALPHA, BETA, ERR
05282 *     ..
05283 *     .. Array Arguments ..
05284       INTEGER            DESCA( * ), DESCB( * ), DESCC( * )
05285       REAL               A( * ), B( * ), C( * ), CT( * ), G( * ),
05286      $                   PC( * )
05287 *     ..
05288 *
05289 *  Purpose
05290 *  =======
05291 *
05292 *  PSMMCH 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) REAL
05385 *          On entry, ALPHA specifies the scalar alpha.
05386 *
05387 *  A       (local input) REAL 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) REAL 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) REAL
05420 *          On entry, BETA specifies the scalar beta.
05421 *
05422 *  C       (local input/local output) REAL 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) REAL 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) REAL 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) REAL 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) REAL
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       REAL               ZERO, ONE
05470       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+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       REAL               EPS, ERRI
05478 *     ..
05479 *     .. External Subroutines ..
05480       EXTERNAL           BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D
05481 *     ..
05482 *     .. External Functions ..
05483       LOGICAL            LSAME
05484       REAL               PSLAMCH
05485       EXTERNAL           LSAME, PSLAMCH
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 = PSLAMCH( 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 SGAMX2D( 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 PSMMCH
05644 *
05645       END
05646       SUBROUTINE PSMMCH1( 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       REAL               ALPHA, BETA, ERR
05659 *     ..
05660 *     .. Array Arguments ..
05661       INTEGER            DESCA( * ), DESCC( * )
05662       REAL               A( * ), C( * ), CT( * ), G( * ), PC( * )
05663 *     ..
05664 *
05665 *  Purpose
05666 *  =======
05667 *
05668 *  PSMMCH1 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) REAL
05759 *          On entry, ALPHA specifies the scalar alpha.
05760 *
05761 *  A       (local input) REAL 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) REAL
05778 *          On entry, BETA specifies the scalar beta.
05779 *
05780 *  C       (local input/local output) REAL 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) REAL 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) REAL 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) REAL 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) REAL
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       REAL               ZERO, ONE
05828       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+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       REAL               EPS, ERRI
05836 *     ..
05837 *     .. External Subroutines ..
05838       EXTERNAL           BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D
05839 *     ..
05840 *     .. External Functions ..
05841       LOGICAL            LSAME
05842       REAL               PSLAMCH
05843       EXTERNAL           LSAME, PSLAMCH
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 = PSLAMCH( 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 SGAMX2D( 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 PSMMCH1
05991 *
05992       END
05993       SUBROUTINE PSMMCH2( 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       REAL               ALPHA, BETA, ERR
06006 *     ..
06007 *     .. Array Arguments ..
06008       INTEGER            DESCA( * ), DESCB( * ), DESCC( * )
06009       REAL               A( * ), B( * ), C( * ), CT( * ), G( * ),
06010      $                   PC( * )
06011 *     ..
06012 *
06013 *  Purpose
06014 *  =======
06015 *
06016 *  PSMMCH2 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) REAL
06108 *          On entry, ALPHA specifies the scalar alpha.
06109 *
06110 *  A       (local input) REAL 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) REAL 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) REAL
06143 *          On entry, BETA specifies the scalar beta.
06144 *
06145 *  C       (local input/local output) REAL 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) REAL 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) REAL 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) REAL 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) REAL
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       REAL               ZERO, ONE
06193       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+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       REAL               EPS, ERRI
06202 *     ..
06203 *     .. External Subroutines ..
06204       EXTERNAL           BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L, SGAMX2D
06205 *     ..
06206 *     .. External Functions ..
06207       LOGICAL            LSAME
06208       REAL               PSLAMCH
06209       EXTERNAL           LSAME, PSLAMCH
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 = PSLAMCH( 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 SGAMX2D( 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 PSMMCH2
06368 *
06369       END
06370       SUBROUTINE PSMMCH3( 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       REAL               ALPHA, BETA, ERR
06382 *     ..
06383 *     .. Array Arguments ..
06384       INTEGER            DESCA( * ), DESCC( * )
06385       REAL               A( * ), C( * ), PC( * )
06386 *     ..
06387 *
06388 *  Purpose
06389 *  =======
06390 *
06391 *  PSMMCH3 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) REAL
06475 *          On entry, ALPHA specifies the scalar alpha.
06476 *
06477 *  A       (local input) REAL 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) REAL
06494 *          On entry, BETA specifies the scalar beta.
06495 *
06496 *  C       (local input/local output) REAL 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) REAL 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) REAL
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       REAL               ZERO
06536       PARAMETER          ( ZERO = 0.0E+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       REAL               ERR0, ERRI, PREC
06544 *     ..
06545 *     .. External Subroutines ..
06546       EXTERNAL           BLACS_GRIDINFO, IGSUM2D, PB_INFOG2L,
06547      $                   PSERRAXPBY, SGAMX2D
06548 *     ..
06549 *     .. External Functions ..
06550       LOGICAL            LSAME
06551       REAL               PSLAMCH
06552       EXTERNAL           LSAME, PSLAMCH
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   = PSLAMCH( 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 PSERRAXPBY( 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 PSERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06599      $                                C( IOFFC ), PREC )
06600                   ELSE
06601                      ERRI = ZERO
06602                   END IF
06603                ELSE
06604                   CALL PSERRAXPBY( 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 PSERRAXPBY( 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 PSERRAXPBY( ERRI, ALPHA, A( IOFFA ), BETA,
06644      $                               C( IOFFC ), PREC )
06645                   ELSE
06646                      ERRI = ZERO
06647                   END IF
06648                ELSE
06649                   CALL PSERRAXPBY( 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 SGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, I, J, -1, -1,
06676      $              MYCOL )
06677 *
06678       RETURN
06679 *
06680 *     End of PSMMCH3
06681 *
06682       END
06683       SUBROUTINE PSERRAXPBY( 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       REAL               ALPHA, BETA, ERRBND, PREC, X, Y
06692 *     ..
06693 *
06694 *  Purpose
06695 *  =======
06696 *
06697 *  PSERRAXPBY  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) REAL
06704 *          On exit, ERRBND  specifies the scaled relative acceptable er-
06705 *          ror bound.
06706 *
06707 *  ALPHA   (global input) REAL
06708 *          On entry, ALPHA specifies the scalar alpha.
06709 *
06710 *  X       (global input) REAL
06711 *          On entry, X  specifies the scalar x to be scaled.
06712 *
06713 *  BETA    (global input) REAL
06714 *          On entry, BETA specifies the scalar beta.
06715 *
06716 *  Y       (global input/global output) REAL
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) REAL
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       REAL               ONE, TWO, ZERO
06730       PARAMETER          ( ONE = 1.0E+0, TWO = 2.0E+0,
06731      $                   ZERO = 0.0E+0 )
06732 *     ..
06733 *     .. Local Scalars ..
06734       REAL               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 PSERRAXPBY
06766 *
06767       END
06768       REAL               FUNCTION PSLAMCH( 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 *  PSLAMCH determines single 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 PSLAMCH
06795 *          as follows:
06796 *             = 'E' or 'e',   PSLAMCH := eps,
06797 *             = 'S' or 's ,   PSLAMCH := sfmin,
06798 *             = 'B' or 'b',   PSLAMCH := base,
06799 *             = 'P' or 'p',   PSLAMCH := eps*base,
06800 *             = 'N' or 'n',   PSLAMCH := t,
06801 *             = 'R' or 'r',   PSLAMCH := rnd,
06802 *             = 'M' or 'm',   PSLAMCH := emin,
06803 *             = 'U' or 'u',   PSLAMCH := rmin,
06804 *             = 'L' or 'l',   PSLAMCH := emax,
06805 *             = 'O' or 'o',   PSLAMCH := 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       REAL               TEMP
06829 *     ..
06830 *     .. External Subroutines ..
06831       EXTERNAL           PB_TOPGET, SGAMN2D, SGAMX2D
06832 *     ..
06833 *     .. External Functions ..
06834       LOGICAL            LSAME
06835       REAL               SLAMCH
06836       EXTERNAL           LSAME, SLAMCH
06837 *     ..
06838 *     .. Executable Statements ..
06839 *
06840       TEMP = SLAMCH( CMACH )
06841 *
06842       IF( LSAME( CMACH, 'E' ).OR.LSAME( CMACH, 'S' ).OR.
06843      $    LSAME( CMACH, 'M' ).OR.LSAME( CMACH, 'U' ) ) THEN
06844          CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP )
06845          IDUMM = 0
06846          CALL SGAMX2D( 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          IDUMM = 0
06851          CALL SGAMN2D( ICTXT, 'All', TOP, 1, 1, TEMP, 1, IDUMM,
06852      $                 IDUMM, -1, -1, IDUMM )
06853       END IF
06854 *
06855       PSLAMCH = TEMP
06856 *
06857       RETURN
06858 *
06859 *     End of PSLAMCH
06860 *
06861       END
06862       SUBROUTINE PSLASET( UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA )
06863 *
06864 *  -- PBLAS test routine (version 2.0) --
06865 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
06866 *     and University of California, Berkeley.
06867 *     April 1, 1998
06868 *
06869 *     .. Scalar Arguments ..
06870       CHARACTER*1        UPLO
06871       INTEGER            IA, JA, M, N
06872       REAL               ALPHA, BETA
06873 *     ..
06874 *     .. Array Arguments ..
06875       INTEGER            DESCA( * )
06876       REAL               A( * )
06877 *     ..
06878 *
06879 *  Purpose
06880 *  =======
06881 *
06882 *  PSLASET  initializes an m by n submatrix A(IA:IA+M-1,JA:JA+N-1) deno-
06883 *  ted  by  sub( A )  to beta on the diagonal and alpha on the offdiago-
06884 *  nals.
06885 *
06886 *  Notes
06887 *  =====
06888 *
06889 *  A description  vector  is associated with each 2D block-cyclicly dis-
06890 *  tributed matrix.  This  vector  stores  the  information  required to
06891 *  establish the  mapping  between a  matrix entry and its corresponding
06892 *  process and memory location.
06893 *
06894 *  In  the  following  comments,   the character _  should  be  read  as
06895 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
06896 *  block cyclicly distributed matrix.  Its description vector is DESCA:
06897 *
06898 *  NOTATION         STORED IN       EXPLANATION
06899 *  ---------------- --------------- ------------------------------------
06900 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
06901 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
06902 *                                   the NPROW x NPCOL BLACS process grid
06903 *                                   A  is distributed over.  The context
06904 *                                   itself  is  global,  but  the handle
06905 *                                   (the integer value) may vary.
06906 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
06907 *                                   ted matrix A, M_A >= 0.
06908 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
06909 *                                   buted matrix A, N_A >= 0.
06910 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
06911 *                                   block of the matrix A, IMB_A > 0.
06912 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
06913 *                                   left   block   of   the   matrix  A,
06914 *                                   INB_A > 0.
06915 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
06916 *                                   bute the last  M_A-IMB_A rows of  A,
06917 *                                   MB_A > 0.
06918 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
06919 *                                   bute the last  N_A-INB_A  columns of
06920 *                                   A, NB_A > 0.
06921 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
06922 *                                   row of the matrix  A is distributed,
06923 *                                   NPROW > RSRC_A >= 0.
06924 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
06925 *                                   first  column of  A  is distributed.
06926 *                                   NPCOL > CSRC_A >= 0.
06927 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
06928 *                                   array  storing  the  local blocks of
06929 *                                   the distributed matrix A,
06930 *                                   IF( Lc( 1, N_A ) > 0 )
06931 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
06932 *                                   ELSE
06933 *                                      LLD_A >= 1.
06934 *
06935 *  Let K be the number of  rows of a matrix A starting at the global in-
06936 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
06937 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
06938 *  receive if these K rows were distributed over NPROW processes.  If  K
06939 *  is the number of columns of a matrix  A  starting at the global index
06940 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
06941 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
06942 *  these K columns were distributed over NPCOL processes.
06943 *
06944 *  The values of Lr() and Lc() may be determined via a call to the func-
06945 *  tion PB_NUMROC:
06946 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
06947 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
06948 *
06949 *  Arguments
06950 *  =========
06951 *
06952 *  UPLO    (global input) CHARACTER*1
06953 *          On entry, UPLO specifies the part  of  the submatrix sub( A )
06954 *          to be set:
06955 *             = 'L' or 'l':   Lower triangular part is set; the strictly
06956 *                      upper triangular part of sub( A ) is not changed;
06957 *             = 'U' or 'u':   Upper triangular part is set; the strictly
06958 *                      lower triangular part of sub( A ) is not changed;
06959 *             Otherwise:  All of the matrix sub( A ) is set.
06960 *
06961 *  M       (global input) INTEGER
06962 *          On entry,  M  specifies the number of rows of  the  submatrix
06963 *          sub( A ). M  must be at least zero.
06964 *
06965 *  N       (global input) INTEGER
06966 *          On entry, N  specifies the number of columns of the submatrix
06967 *          sub( A ). N must be at least zero.
06968 *
06969 *  ALPHA   (global input) REAL
06970 *          On entry,  ALPHA  specifies the scalar alpha, i.e., the cons-
06971 *          tant to which the offdiagonal elements are to be set.
06972 *
06973 *  BETA    (global input) REAL
06974 *          On entry, BETA  specifies the scalar beta, i.e., the constant
06975 *          to which the diagonal elements are to be set.
06976 *
06977 *  A       (local input/local output) REAL array
06978 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
06979 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
06980 *          the local entries of the matrix  A  to be  set.  On exit, the
06981 *          leading m by n submatrix sub( A ) is set as follows:
06982 *
06983 *          if UPLO = 'U',  A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=j-1, 1<=j<=N,
06984 *          if UPLO = 'L',  A(IA+i-1,JA+j-1) = ALPHA, j+1<=i<=M, 1<=j<=N,
06985 *          otherwise,      A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=M,   1<=j<=N,
06986 *                                                      and IA+i.NE.JA+j,
06987 *          and, for all UPLO,  A(IA+i-1,JA+i-1) = BETA,  1<=i<=min(M,N).
06988 *
06989 *  IA      (global input) INTEGER
06990 *          On entry, IA  specifies A's global row index, which points to
06991 *          the beginning of the submatrix sub( A ).
06992 *
06993 *  JA      (global input) INTEGER
06994 *          On entry, JA  specifies A's global column index, which points
06995 *          to the beginning of the submatrix sub( A ).
06996 *
06997 *  DESCA   (global and local input) INTEGER array
06998 *          On entry, DESCA  is an integer array of dimension DLEN_. This
06999 *          is the array descriptor for the matrix A.
07000 *
07001 *  -- Written on April 1, 1998 by
07002 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
07003 *
07004 *  =====================================================================
07005 *
07006 *     .. Parameters ..
07007       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
07008      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
07009      $                   RSRC_
07010       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
07011      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
07012      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
07013      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
07014 *     ..
07015 *     .. Local Scalars ..
07016       LOGICAL            GODOWN, GOLEFT, ISCOLREP, ISROWREP, LOWER,
07017      $                   UPPER
07018       INTEGER            IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1,
07019      $                   IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP, JJA,
07020      $                   JJMAX, JOFFA, JOFFD, LCMT, LCMT00, LDA, LMBLOC,
07021      $                   LNBLOC, LOW, M1, MB, MBLKD, MBLKS, MBLOC, MP,
07022      $                   MRCOL, MRROW, MYCOL, MYROW, N1, NB, NBLKD,
07023      $                   NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB, QNB, TMP1,
07024      $                   UPP
07025 *     ..
07026 *     .. Local Arrays ..
07027       INTEGER            DESCA2( DLEN_ )
07028 *     ..
07029 *     .. External Subroutines ..
07030       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
07031      $                   PB_DESCTRANS, PB_SLASET
07032 *     ..
07033 *     .. External Functions ..
07034       LOGICAL            LSAME
07035       EXTERNAL           LSAME
07036 *     ..
07037 *     .. Intrinsic Functions ..
07038       INTRINSIC          MIN
07039 *     ..
07040 *     .. Executable Statements ..
07041 *
07042       IF( M.EQ.0 .OR. N.EQ.0 )
07043      $   RETURN
07044 *
07045 *     Convert descriptor
07046 *
07047       CALL PB_DESCTRANS( DESCA, DESCA2 )
07048 *
07049 *     Get grid parameters
07050 *
07051       ICTXT = DESCA2( CTXT_ )
07052       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
07053 *
07054       CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
07055      $                  MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
07056      $                  IACOL, MRROW, MRCOL )
07057 *
07058       IF( MP.LE.0 .OR. NQ.LE.0 )
07059      $   RETURN
07060 *
07061       ISROWREP = ( DESCA2( RSRC_ ).LT.0 )
07062       ISCOLREP = ( DESCA2( CSRC_ ).LT.0 )
07063       LDA      = DESCA2( LLD_ )
07064 *
07065       UPPER = .NOT.( LSAME( UPLO, 'L' ) )
07066       LOWER = .NOT.( LSAME( UPLO, 'U' ) )
07067 *
07068       IF( ( ( LOWER.AND.UPPER ).AND.( ALPHA.EQ.BETA ) ).OR.
07069      $    (   ISROWREP        .AND.  ISCOLREP        ) ) THEN
07070          IF( ( MP.GT.0 ).AND.( NQ.GT.0 ) )
07071      $      CALL PB_SLASET( UPLO, MP, NQ, 0, ALPHA, BETA,
07072      $                      A( IIA + ( JJA - 1 ) * LDA ), LDA )
07073          RETURN
07074       END IF
07075 *
07076 *     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
07077 *     ILOW, LOW, IUPP, and UPP.
07078 *
07079       MB = DESCA2( MB_ )
07080       NB = DESCA2( NB_ )
07081       CALL PB_BINFO( 0, MP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL,
07082      $               LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
07083      $               LNBLOC, ILOW, LOW, IUPP, UPP )
07084 *
07085       IOFFA = IIA - 1
07086       JOFFA = JJA - 1
07087       IIMAX = IOFFA + MP
07088       JJMAX = JOFFA + NQ
07089 *
07090       IF( ISROWREP ) THEN
07091          PMB = MB
07092       ELSE
07093          PMB = NPROW * MB
07094       END IF
07095       IF( ISCOLREP ) THEN
07096          QNB = NB
07097       ELSE
07098          QNB = NPCOL * NB
07099       END IF
07100 *
07101       M1 = MP
07102       N1 = NQ
07103 *
07104 *     Handle the first block of rows or columns separately, and update
07105 *     LCMT00, MBLKS and NBLKS.
07106 *
07107       GODOWN = ( LCMT00.GT.IUPP )
07108       GOLEFT = ( LCMT00.LT.ILOW )
07109 *
07110       IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN
07111 *
07112 *        LCMT00 >= ILOW && LCMT00 <= IUPP
07113 *
07114          GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW )
07115          GODOWN = .NOT.GOLEFT
07116 *
07117          CALL PB_SLASET( UPLO, IMBLOC, INBLOC, LCMT00, ALPHA, BETA,
07118      $                   A( IIA+JOFFA*LDA ), LDA )
07119          IF( GODOWN ) THEN
07120             IF( UPPER .AND. NQ.GT.INBLOC )
07121      $         CALL PB_SLASET( 'All', IMBLOC, NQ-INBLOC, 0, ALPHA,
07122      $                         ALPHA, A( IIA+(JOFFA+INBLOC)*LDA ), LDA )
07123             IIA = IIA + IMBLOC
07124             M1  = M1 - IMBLOC
07125          ELSE
07126             IF( LOWER .AND. MP.GT.IMBLOC )
07127      $         CALL PB_SLASET( 'All', MP-IMBLOC, INBLOC, 0, ALPHA,
07128      $                         ALPHA, A( IIA+IMBLOC+JOFFA*LDA ), LDA )
07129             JJA = JJA + INBLOC
07130             N1  = N1 - INBLOC
07131          END IF
07132 *
07133       END IF
07134 *
07135       IF( GODOWN ) THEN
07136 *
07137          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
07138          MBLKS  = MBLKS - 1
07139          IOFFA  = IOFFA + IMBLOC
07140 *
07141    10    CONTINUE
07142          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
07143             LCMT00 = LCMT00 - PMB
07144             MBLKS  = MBLKS - 1
07145             IOFFA  = IOFFA + MB
07146             GO TO 10
07147          END IF
07148 *
07149          TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
07150          IF( UPPER .AND. TMP1.GT.0 ) THEN
07151             CALL PB_SLASET( 'All', TMP1, N1, 0, ALPHA, ALPHA,
07152      $                      A( IIA+JOFFA*LDA ), LDA )
07153             IIA = IIA + TMP1
07154             M1  = M1 - TMP1
07155          END IF
07156 *
07157          IF( MBLKS.LE.0 )
07158      $      RETURN
07159 *
07160          LCMT  = LCMT00
07161          MBLKD = MBLKS
07162          IOFFD = IOFFA
07163 *
07164          MBLOC = MB
07165    20    CONTINUE
07166          IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN
07167             IF( MBLKD.EQ.1 )
07168      $         MBLOC = LMBLOC
07169             CALL PB_SLASET( UPLO, MBLOC, INBLOC, LCMT, ALPHA, BETA,
07170      $                      A( IOFFD+1+JOFFA*LDA ), LDA )
07171             LCMT00 = LCMT
07172             LCMT   = LCMT - PMB
07173             MBLKS  = MBLKD
07174             MBLKD  = MBLKD - 1
07175             IOFFA  = IOFFD
07176             IOFFD  = IOFFD + MBLOC
07177             GO TO 20
07178          END IF
07179 *
07180          TMP1 = M1 - IOFFD + IIA - 1
07181          IF( LOWER .AND. TMP1.GT.0 )
07182      $      CALL PB_SLASET( 'ALL', TMP1, INBLOC, 0, ALPHA, ALPHA,
07183      $                      A( IOFFD+1+JOFFA*LDA ), LDA )
07184 *
07185          TMP1   = IOFFA - IIA + 1
07186          M1     = M1 - TMP1
07187          N1     = N1 - INBLOC
07188          LCMT00 = LCMT00 + LOW - ILOW + QNB
07189          NBLKS  = NBLKS - 1
07190          JOFFA  = JOFFA + INBLOC
07191 *
07192          IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 )
07193      $      CALL PB_SLASET( 'ALL', TMP1, N1, 0, ALPHA, ALPHA,
07194      $                      A( IIA+JOFFA*LDA ), LDA )
07195 *
07196          IIA = IOFFA + 1
07197          JJA = JOFFA + 1
07198 *
07199       ELSE IF( GOLEFT ) THEN
07200 *
07201          LCMT00 = LCMT00 + LOW - ILOW + QNB
07202          NBLKS  = NBLKS - 1
07203          JOFFA  = JOFFA + INBLOC
07204 *
07205    30    CONTINUE
07206          IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN
07207             LCMT00 = LCMT00 + QNB
07208             NBLKS  = NBLKS - 1
07209             JOFFA  = JOFFA + NB
07210             GO TO 30
07211          END IF
07212 *
07213          TMP1 = MIN( JOFFA, JJMAX ) - JJA + 1
07214          IF( LOWER .AND. TMP1.GT.0 ) THEN
07215             CALL PB_SLASET( 'All', M1, TMP1, 0, ALPHA, ALPHA,
07216      $                      A( IIA+(JJA-1)*LDA ), LDA )
07217             JJA = JJA + TMP1
07218             N1  = N1 - TMP1
07219          END IF
07220 *
07221          IF( NBLKS.LE.0 )
07222      $      RETURN
07223 *
07224          LCMT  = LCMT00
07225          NBLKD = NBLKS
07226          JOFFD = JOFFA
07227 *
07228          NBLOC = NB
07229    40    CONTINUE
07230          IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN
07231             IF( NBLKD.EQ.1 )
07232      $         NBLOC = LNBLOC
07233             CALL PB_SLASET( UPLO, IMBLOC, NBLOC, LCMT, ALPHA, BETA,
07234      $                      A( IIA+JOFFD*LDA ), LDA )
07235             LCMT00 = LCMT
07236             LCMT   = LCMT + QNB
07237             NBLKS  = NBLKD
07238             NBLKD  = NBLKD - 1
07239             JOFFA  = JOFFD
07240             JOFFD  = JOFFD + NBLOC
07241             GO TO 40
07242          END IF
07243 *
07244          TMP1 = N1 - JOFFD + JJA - 1
07245          IF( UPPER .AND. TMP1.GT.0 )
07246      $      CALL PB_SLASET( 'All', IMBLOC, TMP1, 0, ALPHA, ALPHA,
07247      $                      A( IIA+JOFFD*LDA ), LDA )
07248 *
07249          TMP1   = JOFFA - JJA + 1
07250          M1     = M1 - IMBLOC
07251          N1     = N1 - TMP1
07252          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
07253          MBLKS  = MBLKS - 1
07254          IOFFA  = IOFFA + IMBLOC
07255 *
07256          IF( LOWER .AND. M1.GT.0 .AND. TMP1.GT.0 )
07257      $      CALL PB_SLASET( 'All', M1, TMP1, 0, ALPHA, ALPHA,
07258      $                      A( IOFFA+1+(JJA-1)*LDA ), LDA )
07259 *
07260          IIA = IOFFA + 1
07261          JJA = JOFFA + 1
07262 *
07263       END IF
07264 *
07265       NBLOC = NB
07266    50 CONTINUE
07267       IF( NBLKS.GT.0 ) THEN
07268          IF( NBLKS.EQ.1 )
07269      $      NBLOC = LNBLOC
07270    60    CONTINUE
07271          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
07272             LCMT00 = LCMT00 - PMB
07273             MBLKS  = MBLKS - 1
07274             IOFFA  = IOFFA + MB
07275             GO TO 60
07276          END IF
07277 *
07278          TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
07279          IF( UPPER .AND. TMP1.GT.0 ) THEN
07280             CALL PB_SLASET( 'All', TMP1, N1, 0, ALPHA, ALPHA,
07281      $                      A( IIA+JOFFA*LDA ), LDA )
07282             IIA = IIA + TMP1
07283             M1  = M1 - TMP1
07284          END IF
07285 *
07286          IF( MBLKS.LE.0 )
07287      $      RETURN
07288 *
07289          LCMT  = LCMT00
07290          MBLKD = MBLKS
07291          IOFFD = IOFFA
07292 *
07293          MBLOC = MB
07294    70    CONTINUE
07295          IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN
07296             IF( MBLKD.EQ.1 )
07297      $         MBLOC = LMBLOC
07298             CALL PB_SLASET( UPLO, MBLOC, NBLOC, LCMT, ALPHA, BETA,
07299      $                      A( IOFFD+1+JOFFA*LDA ), LDA )
07300             LCMT00 = LCMT
07301             LCMT   = LCMT - PMB
07302             MBLKS  = MBLKD
07303             MBLKD  = MBLKD - 1
07304             IOFFA  = IOFFD
07305             IOFFD  = IOFFD + MBLOC
07306             GO TO 70
07307          END IF
07308 *
07309          TMP1 = M1 - IOFFD + IIA - 1
07310          IF( LOWER .AND. TMP1.GT.0 )
07311      $      CALL PB_SLASET( 'All', TMP1, NBLOC, 0, ALPHA, ALPHA,
07312      $                      A( IOFFD+1+JOFFA*LDA ), LDA )
07313 *
07314          TMP1   = MIN( IOFFA, IIMAX )  - IIA + 1
07315          M1     = M1 - TMP1
07316          N1     = N1 - NBLOC
07317          LCMT00 = LCMT00 + QNB
07318          NBLKS  = NBLKS - 1
07319          JOFFA  = JOFFA + NBLOC
07320 *
07321          IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 )
07322      $      CALL PB_SLASET( 'All', TMP1, N1, 0, ALPHA, ALPHA,
07323      $                      A( IIA+JOFFA*LDA ), LDA )
07324 *
07325          IIA = IOFFA + 1
07326          JJA = JOFFA + 1
07327 *
07328          GO TO 50
07329 *
07330       END IF
07331 *
07332       RETURN
07333 *
07334 *     End of PSLASET
07335 *
07336       END
07337       SUBROUTINE PSLASCAL( TYPE, M, N, ALPHA, A, IA, JA, DESCA )
07338 *
07339 *  -- PBLAS test routine (version 2.0) --
07340 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
07341 *     and University of California, Berkeley.
07342 *     April 1, 1998
07343 *
07344 *     .. Scalar Arguments ..
07345       CHARACTER*1        TYPE
07346       INTEGER            IA, JA, M, N
07347       REAL               ALPHA
07348 *     ..
07349 *     .. Array Arguments ..
07350       INTEGER            DESCA( * )
07351       REAL               A( * )
07352 *     ..
07353 *
07354 *  Purpose
07355 *  =======
07356 *
07357 *  PSLASCAL  scales the  m by n submatrix A(IA:IA+M-1,JA:JA+N-1) denoted
07358 *  by sub( A ) by the scalar alpha. TYPE  specifies if sub( A ) is full,
07359 *  upper triangular, lower triangular or upper Hessenberg.
07360 *
07361 *  Notes
07362 *  =====
07363 *
07364 *  A description  vector  is associated with each 2D block-cyclicly dis-
07365 *  tributed matrix.  This  vector  stores  the  information  required to
07366 *  establish the  mapping  between a  matrix entry and its corresponding
07367 *  process and memory location.
07368 *
07369 *  In  the  following  comments,   the character _  should  be  read  as
07370 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
07371 *  block cyclicly distributed matrix.  Its description vector is DESCA:
07372 *
07373 *  NOTATION         STORED IN       EXPLANATION
07374 *  ---------------- --------------- ------------------------------------
07375 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
07376 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
07377 *                                   the NPROW x NPCOL BLACS process grid
07378 *                                   A  is distributed over.  The context
07379 *                                   itself  is  global,  but  the handle
07380 *                                   (the integer value) may vary.
07381 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
07382 *                                   ted matrix A, M_A >= 0.
07383 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
07384 *                                   buted matrix A, N_A >= 0.
07385 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
07386 *                                   block of the matrix A, IMB_A > 0.
07387 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
07388 *                                   left   block   of   the   matrix  A,
07389 *                                   INB_A > 0.
07390 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
07391 *                                   bute the last  M_A-IMB_A rows of  A,
07392 *                                   MB_A > 0.
07393 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
07394 *                                   bute the last  N_A-INB_A  columns of
07395 *                                   A, NB_A > 0.
07396 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
07397 *                                   row of the matrix  A is distributed,
07398 *                                   NPROW > RSRC_A >= 0.
07399 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
07400 *                                   first  column of  A  is distributed.
07401 *                                   NPCOL > CSRC_A >= 0.
07402 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
07403 *                                   array  storing  the  local blocks of
07404 *                                   the distributed matrix A,
07405 *                                   IF( Lc( 1, N_A ) > 0 )
07406 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
07407 *                                   ELSE
07408 *                                      LLD_A >= 1.
07409 *
07410 *  Let K be the number of  rows of a matrix A starting at the global in-
07411 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
07412 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
07413 *  receive if these K rows were distributed over NPROW processes.  If  K
07414 *  is the number of columns of a matrix  A  starting at the global index
07415 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
07416 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
07417 *  these K columns were distributed over NPCOL processes.
07418 *
07419 *  The values of Lr() and Lc() may be determined via a call to the func-
07420 *  tion PB_NUMROC:
07421 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
07422 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
07423 *
07424 *  Arguments
07425 *  =========
07426 *
07427 *  TYPE    (global input) CHARACTER*1
07428 *          On entry,  TYPE  specifies the type of the input submatrix as
07429 *          follows:
07430 *             = 'L' or 'l':  sub( A ) is a lower triangular matrix,
07431 *             = 'U' or 'u':  sub( A ) is an upper triangular matrix,
07432 *             = 'H' or 'h':  sub( A ) is an upper Hessenberg matrix,
07433 *             otherwise sub( A ) is a  full matrix.
07434 *
07435 *  M       (global input) INTEGER
07436 *          On entry,  M  specifies the number of rows of  the  submatrix
07437 *          sub( A ). M  must be at least zero.
07438 *
07439 *  N       (global input) INTEGER
07440 *          On entry, N  specifies the number of columns of the submatrix
07441 *          sub( A ). N  must be at least zero.
07442 *
07443 *  ALPHA   (global input) REAL
07444 *          On entry, ALPHA specifies the scalar alpha.
07445 *
07446 *  A       (local input/local output) REAL array
07447 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
07448 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
07449 *          the local entries of the matrix  A.
07450 *          On exit, the local entries of this array corresponding to the
07451 *          to  the entries of the submatrix sub( A ) are  overwritten by
07452 *          the local entries of the m by n scaled submatrix.
07453 *
07454 *  IA      (global input) INTEGER
07455 *          On entry, IA  specifies A's global row index, which points to
07456 *          the beginning of the submatrix sub( A ).
07457 *
07458 *  JA      (global input) INTEGER
07459 *          On entry, JA  specifies A's global column index, which points
07460 *          to the beginning of the submatrix sub( A ).
07461 *
07462 *  DESCA   (global and local input) INTEGER array
07463 *          On entry, DESCA  is an integer array of dimension DLEN_. This
07464 *          is the array descriptor for the matrix A.
07465 *
07466 *  -- Written on April 1, 1998 by
07467 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
07468 *
07469 *  =====================================================================
07470 *
07471 *     .. Parameters ..
07472       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
07473      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
07474      $                   RSRC_
07475       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
07476      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
07477      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
07478      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
07479 *     ..
07480 *     .. Local Scalars ..
07481       CHARACTER*1        UPLO
07482       LOGICAL            GODOWN, GOLEFT, LOWER, UPPER
07483       INTEGER            IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1,
07484      $                   IMBLOC, INB1, INBLOC, IOFFA, IOFFD, ITYPE,
07485      $                   IUPP, JJA, JJMAX, JOFFA, JOFFD, LCMT, LCMT00,
07486      $                   LDA, LMBLOC, LNBLOC, LOW, M1, MB, MBLKD, MBLKS,
07487      $                   MBLOC, MP, MRCOL, MRROW, MYCOL, MYROW, N1, NB,
07488      $                   NBLKD, NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB,
07489      $                   QNB, TMP1, UPP
07490 *     ..
07491 *     .. Local Arrays ..
07492       INTEGER            DESCA2( DLEN_ )
07493 *     ..
07494 *     .. External Subroutines ..
07495       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
07496      $                   PB_DESCTRANS, PB_INFOG2L, PB_SLASCAL
07497 *     ..
07498 *     .. External Functions ..
07499       LOGICAL            LSAME
07500       INTEGER            PB_NUMROC
07501       EXTERNAL           LSAME, PB_NUMROC
07502 *     ..
07503 *     .. Intrinsic Functions ..
07504       INTRINSIC          MIN
07505 *     ..
07506 *     .. Executable Statements ..
07507 *
07508 *     Convert descriptor
07509 *
07510       CALL PB_DESCTRANS( DESCA, DESCA2 )
07511 *
07512 *     Get grid parameters
07513 *
07514       ICTXT = DESCA2( CTXT_ )
07515       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
07516 *
07517 *     Quick return if possible
07518 *
07519       IF( M.EQ.0 .OR. N.EQ.0 )
07520      $   RETURN
07521 *
07522       IF( LSAME( TYPE, 'L' ) ) THEN
07523          ITYPE = 1
07524          UPLO  = TYPE
07525          UPPER = .FALSE.
07526          LOWER = .TRUE.
07527          IOFFD = 0
07528       ELSE IF( LSAME( TYPE, 'U' ) ) THEN
07529          ITYPE = 2
07530          UPLO  = TYPE
07531          UPPER = .TRUE.
07532          LOWER = .FALSE.
07533          IOFFD = 0
07534       ELSE IF( LSAME( TYPE, 'H' ) ) THEN
07535          ITYPE = 3
07536          UPLO  = 'U'
07537          UPPER = .TRUE.
07538          LOWER = .FALSE.
07539          IOFFD = 1
07540       ELSE
07541          ITYPE = 0
07542          UPLO  = 'A'
07543          UPPER = .TRUE.
07544          LOWER = .TRUE.
07545          IOFFD = 0
07546       END IF
07547 *
07548 *     Compute local indexes
07549 *
07550       IF( ITYPE.EQ.0 ) THEN
07551 *
07552 *        Full matrix
07553 *
07554          CALL PB_INFOG2L( IA, JA, DESCA2, NPROW, NPCOL, MYROW, MYCOL,
07555      $                    IIA, JJA, IAROW, IACOL )
07556          MP = PB_NUMROC( M, IA, DESCA2( IMB_ ), DESCA2( MB_ ), MYROW,
07557      $                   DESCA2( RSRC_ ), NPROW )
07558          NQ = PB_NUMROC( N, JA, DESCA2( INB_ ), DESCA2( NB_ ), MYCOL,
07559      $                   DESCA2( CSRC_ ), NPCOL )
07560 *
07561          IF( MP.LE.0 .OR. NQ.LE.0 )
07562      $      RETURN
07563 *
07564          LDA   = DESCA2( LLD_ )
07565          IOFFA = IIA + ( JJA - 1 ) * LDA
07566 *
07567          CALL PB_SLASCAL( 'All', MP, NQ, 0, ALPHA, A( IOFFA ), LDA )
07568 *
07569       ELSE
07570 *
07571 *        Trapezoidal matrix
07572 *
07573          CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
07574      $                     MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
07575      $                     IACOL, MRROW, MRCOL )
07576 *
07577          IF( MP.LE.0 .OR. NQ.LE.0 )
07578      $      RETURN
07579 *
07580 *        Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
07581 *        LNBLOC, ILOW, LOW, IUPP, and UPP.
07582 *
07583          MB  = DESCA2( MB_ )
07584          NB  = DESCA2( NB_ )
07585          LDA = DESCA2( LLD_ )
07586 *
07587          CALL PB_BINFO( IOFFD, MP, NQ, IMB1, INB1, MB, NB, MRROW,
07588      $                  MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC,
07589      $                  LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP )
07590 *
07591          M1    = MP
07592          N1    = NQ
07593          IOFFA = IIA - 1
07594          JOFFA = JJA - 1
07595          IIMAX = IOFFA + MP
07596          JJMAX = JOFFA + NQ
07597 *
07598          IF( DESCA2( RSRC_ ).LT.0 ) THEN
07599             PMB = MB
07600          ELSE
07601             PMB = NPROW * MB
07602          END IF
07603          IF( DESCA2( CSRC_ ).LT.0 ) THEN
07604             QNB = NB
07605          ELSE
07606             QNB = NPCOL * NB
07607          END IF
07608 *
07609 *        Handle the first block of rows or columns separately, and
07610 *        update LCMT00, MBLKS and NBLKS.
07611 *
07612          GODOWN = ( LCMT00.GT.IUPP )
07613          GOLEFT = ( LCMT00.LT.ILOW )
07614 *
07615          IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN
07616 *
07617 *           LCMT00 >= ILOW && LCMT00 <= IUPP
07618 *
07619             GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW )
07620             GODOWN = .NOT.GOLEFT
07621 *
07622             CALL PB_SLASCAL( UPLO, IMBLOC, INBLOC, LCMT00, ALPHA,
07623      $                       A( IIA+JOFFA*LDA ), LDA )
07624             IF( GODOWN ) THEN
07625                IF( UPPER .AND. NQ.GT.INBLOC )
07626      $            CALL PB_SLASCAL( 'All', IMBLOC, NQ-INBLOC, 0, ALPHA,
07627      $                             A( IIA+(JOFFA+INBLOC)*LDA ), LDA )
07628                IIA = IIA + IMBLOC
07629                M1  = M1 - IMBLOC
07630             ELSE
07631                IF( LOWER .AND. MP.GT.IMBLOC )
07632      $            CALL PB_SLASCAL( 'All', MP-IMBLOC, INBLOC, 0, ALPHA,
07633      $                             A( IIA+IMBLOC+JOFFA*LDA ), LDA )
07634                JJA = JJA + INBLOC
07635                N1  = N1 - INBLOC
07636             END IF
07637 *
07638          END IF
07639 *
07640          IF( GODOWN ) THEN
07641 *
07642             LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
07643             MBLKS  = MBLKS - 1
07644             IOFFA  = IOFFA + IMBLOC
07645 *
07646    10       CONTINUE
07647             IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
07648                LCMT00 = LCMT00 - PMB
07649                MBLKS  = MBLKS - 1
07650                IOFFA  = IOFFA + MB
07651                GO TO 10
07652             END IF
07653 *
07654             TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
07655             IF( UPPER .AND. TMP1.GT.0 ) THEN
07656                CALL PB_SLASCAL( 'All', TMP1, N1, 0, ALPHA,
07657      $                          A( IIA+JOFFA*LDA ), LDA )
07658                IIA = IIA + TMP1
07659                M1  = M1 - TMP1
07660             END IF
07661 *
07662             IF( MBLKS.LE.0 )
07663      $         RETURN
07664 *
07665             LCMT  = LCMT00
07666             MBLKD = MBLKS
07667             IOFFD = IOFFA
07668 *
07669             MBLOC = MB
07670    20       CONTINUE
07671             IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN
07672                IF( MBLKD.EQ.1 )
07673      $            MBLOC = LMBLOC
07674                CALL PB_SLASCAL( UPLO, MBLOC, INBLOC, LCMT, ALPHA,
07675      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
07676                LCMT00 = LCMT
07677                LCMT   = LCMT - PMB
07678                MBLKS  = MBLKD
07679                MBLKD  = MBLKD - 1
07680                IOFFA  = IOFFD
07681                IOFFD  = IOFFD + MBLOC
07682                GO TO 20
07683             END IF
07684 *
07685             TMP1 = M1 - IOFFD + IIA - 1
07686             IF( LOWER .AND. TMP1.GT.0 )
07687      $         CALL PB_SLASCAL( 'All', TMP1, INBLOC, 0, ALPHA,
07688      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
07689 *
07690             TMP1   = IOFFA - IIA + 1
07691             M1     = M1 - TMP1
07692             N1     = N1 - INBLOC
07693             LCMT00 = LCMT00 + LOW - ILOW + QNB
07694             NBLKS  = NBLKS - 1
07695             JOFFA  = JOFFA + INBLOC
07696 *
07697             IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 )
07698      $         CALL PB_SLASCAL( 'All', TMP1, N1, 0, ALPHA,
07699      $                          A( IIA+JOFFA*LDA ), LDA )
07700 *
07701             IIA = IOFFA + 1
07702             JJA = JOFFA + 1
07703 *
07704          ELSE IF( GOLEFT ) THEN
07705 *
07706             LCMT00 = LCMT00 + LOW - ILOW + QNB
07707             NBLKS  = NBLKS - 1
07708             JOFFA  = JOFFA + INBLOC
07709 *
07710    30       CONTINUE
07711             IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN
07712                LCMT00 = LCMT00 + QNB
07713                NBLKS  = NBLKS - 1
07714                JOFFA  = JOFFA + NB
07715                GO TO 30
07716             END IF
07717 *
07718             TMP1 = MIN( JOFFA, JJMAX ) - JJA + 1
07719             IF( LOWER .AND. TMP1.GT.0 ) THEN
07720                CALL PB_SLASCAL( 'All', M1, TMP1, 0, ALPHA,
07721      $                          A( IIA+(JJA-1)*LDA ), LDA )
07722                JJA = JJA + TMP1
07723                N1  = N1 - TMP1
07724             END IF
07725 *
07726             IF( NBLKS.LE.0 )
07727      $         RETURN
07728 *
07729             LCMT  = LCMT00
07730             NBLKD = NBLKS
07731             JOFFD = JOFFA
07732 *
07733             NBLOC = NB
07734    40       CONTINUE
07735             IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN
07736                IF( NBLKD.EQ.1 )
07737      $            NBLOC = LNBLOC
07738                CALL PB_SLASCAL( UPLO, IMBLOC, NBLOC, LCMT, ALPHA,
07739      $                          A( IIA+JOFFD*LDA ), LDA )
07740                LCMT00 = LCMT
07741                LCMT   = LCMT + QNB
07742                NBLKS  = NBLKD
07743                NBLKD  = NBLKD - 1
07744                JOFFA  = JOFFD
07745                JOFFD  = JOFFD + NBLOC
07746                GO TO 40
07747             END IF
07748 *
07749             TMP1 = N1 - JOFFD + JJA - 1
07750             IF( UPPER .AND. TMP1.GT.0 )
07751      $         CALL PB_SLASCAL( 'All', IMBLOC, TMP1, 0, ALPHA,
07752      $                          A( IIA+JOFFD*LDA ), LDA )
07753 *
07754             TMP1   = JOFFA - JJA + 1
07755             M1     = M1 - IMBLOC
07756             N1     = N1 - TMP1
07757             LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
07758             MBLKS  = MBLKS - 1
07759             IOFFA  = IOFFA + IMBLOC
07760 *
07761             IF( LOWER .AND. M1.GT.0 .AND. TMP1.GT.0 )
07762      $         CALL PB_SLASCAL( 'All', M1, TMP1, 0, ALPHA,
07763      $                          A( IOFFA+1+(JJA-1)*LDA ), LDA )
07764 *
07765             IIA = IOFFA + 1
07766             JJA = JOFFA + 1
07767 *
07768          END IF
07769 *
07770          NBLOC = NB
07771    50    CONTINUE
07772          IF( NBLKS.GT.0 ) THEN
07773             IF( NBLKS.EQ.1 )
07774      $         NBLOC = LNBLOC
07775    60       CONTINUE
07776             IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
07777                LCMT00 = LCMT00 - PMB
07778                MBLKS  = MBLKS - 1
07779                IOFFA  = IOFFA + MB
07780                GO TO 60
07781             END IF
07782 *
07783             TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
07784             IF( UPPER .AND. TMP1.GT.0 ) THEN
07785                CALL PB_SLASCAL( 'All', TMP1, N1, 0, ALPHA,
07786      $                          A( IIA+JOFFA*LDA ), LDA )
07787                IIA = IIA + TMP1
07788                M1  = M1 - TMP1
07789             END IF
07790 *
07791             IF( MBLKS.LE.0 )
07792      $         RETURN
07793 *
07794             LCMT  = LCMT00
07795             MBLKD = MBLKS
07796             IOFFD = IOFFA
07797 *
07798             MBLOC = MB
07799    70       CONTINUE
07800             IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN
07801                IF( MBLKD.EQ.1 )
07802      $            MBLOC = LMBLOC
07803                CALL PB_SLASCAL( UPLO, MBLOC, NBLOC, LCMT, ALPHA,
07804      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
07805                LCMT00 = LCMT
07806                LCMT   = LCMT - PMB
07807                MBLKS  = MBLKD
07808                MBLKD  = MBLKD - 1
07809                IOFFA  = IOFFD
07810                IOFFD  = IOFFD + MBLOC
07811                GO TO 70
07812             END IF
07813 *
07814             TMP1 = M1 - IOFFD + IIA - 1
07815             IF( LOWER .AND. TMP1.GT.0 )
07816      $         CALL PB_SLASCAL( 'All', TMP1, NBLOC, 0, ALPHA,
07817      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
07818 *
07819             TMP1   = MIN( IOFFA, IIMAX )  - IIA + 1
07820             M1     = M1 - TMP1
07821             N1     = N1 - NBLOC
07822             LCMT00 = LCMT00 + QNB
07823             NBLKS  = NBLKS - 1
07824             JOFFA  = JOFFA + NBLOC
07825 *
07826             IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 )
07827      $         CALL PB_SLASCAL( 'All', TMP1, N1, 0, ALPHA,
07828      $                          A( IIA+JOFFA*LDA ), LDA )
07829 *
07830             IIA = IOFFA + 1
07831             JJA = JOFFA + 1
07832 *
07833             GO TO 50
07834 *
07835          END IF
07836 *
07837       END IF
07838 *
07839       RETURN
07840 *
07841 *     End of PSLASCAL
07842 *
07843       END
07844       SUBROUTINE PSLAGEN( INPLACE, AFORM, DIAG, OFFA, M, N, IA, JA,
07845      $                    DESCA, IASEED, A, LDA )
07846 *
07847 *  -- PBLAS test routine (version 2.0) --
07848 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
07849 *     and University of California, Berkeley.
07850 *     April 1, 1998
07851 *
07852 *     .. Scalar Arguments ..
07853       LOGICAL            INPLACE
07854       CHARACTER*1        AFORM, DIAG
07855       INTEGER            IA, IASEED, JA, LDA, M, N, OFFA
07856 *     ..
07857 *     .. Array Arguments ..
07858       INTEGER            DESCA( * )
07859       REAL               A( LDA, * )
07860 *     ..
07861 *
07862 *  Purpose
07863 *  =======
07864 *
07865 *  PSLAGEN  generates  (or regenerates)  a  submatrix  sub( A ) denoting
07866 *  A(IA:IA+M-1,JA:JA+N-1).
07867 *
07868 *  Notes
07869 *  =====
07870 *
07871 *  A description  vector  is associated with each 2D block-cyclicly dis-
07872 *  tributed matrix.  This  vector  stores  the  information  required to
07873 *  establish the  mapping  between a  matrix entry and its corresponding
07874 *  process and memory location.
07875 *
07876 *  In  the  following  comments,   the character _  should  be  read  as
07877 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
07878 *  block cyclicly distributed matrix.  Its description vector is DESCA:
07879 *
07880 *  NOTATION         STORED IN       EXPLANATION
07881 *  ---------------- --------------- ------------------------------------
07882 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
07883 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
07884 *                                   the NPROW x NPCOL BLACS process grid
07885 *                                   A  is distributed over.  The context
07886 *                                   itself  is  global,  but  the handle
07887 *                                   (the integer value) may vary.
07888 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
07889 *                                   ted matrix A, M_A >= 0.
07890 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
07891 *                                   buted matrix A, N_A >= 0.
07892 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
07893 *                                   block of the matrix A, IMB_A > 0.
07894 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
07895 *                                   left   block   of   the   matrix  A,
07896 *                                   INB_A > 0.
07897 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
07898 *                                   bute the last  M_A-IMB_A rows of  A,
07899 *                                   MB_A > 0.
07900 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
07901 *                                   bute the last  N_A-INB_A  columns of
07902 *                                   A, NB_A > 0.
07903 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
07904 *                                   row of the matrix  A is distributed,
07905 *                                   NPROW > RSRC_A >= 0.
07906 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
07907 *                                   first  column of  A  is distributed.
07908 *                                   NPCOL > CSRC_A >= 0.
07909 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
07910 *                                   array  storing  the  local blocks of
07911 *                                   the distributed matrix A,
07912 *                                   IF( Lc( 1, N_A ) > 0 )
07913 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
07914 *                                   ELSE
07915 *                                      LLD_A >= 1.
07916 *
07917 *  Let K be the number of  rows of a matrix A starting at the global in-
07918 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
07919 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
07920 *  receive if these K rows were distributed over NPROW processes.  If  K
07921 *  is the number of columns of a matrix  A  starting at the global index
07922 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
07923 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
07924 *  these K columns were distributed over NPCOL processes.
07925 *
07926 *  The values of Lr() and Lc() may be determined via a call to the func-
07927 *  tion PB_NUMROC:
07928 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
07929 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
07930 *
07931 *  Arguments
07932 *  =========
07933 *
07934 *  INPLACE (global input) LOGICAL
07935 *          On entry, INPLACE specifies if the matrix should be generated
07936 *          in place or not. If INPLACE is .TRUE., the local random array
07937 *          to be generated  will start in memory at the local memory lo-
07938 *          cation A( 1, 1 ),  otherwise it will start at the local posi-
07939 *          tion induced by IA and JA.
07940 *
07941 *  AFORM   (global input) CHARACTER*1
07942 *          On entry, AFORM specifies the type of submatrix to be genera-
07943 *          ted as follows:
07944 *             AFORM = 'S', sub( A ) is a symmetric matrix,
07945 *             AFORM = 'H', sub( A ) is a Hermitian matrix,
07946 *             AFORM = 'T', sub( A ) is overrwritten  with  the transpose
07947 *                          of what would normally be generated,
07948 *             AFORM = 'C', sub( A ) is overwritten  with  the  conjugate
07949 *                          transpose  of  what would normally be genera-
07950 *                          ted.
07951 *             AFORM = 'N', a random submatrix is generated.
07952 *
07953 *  DIAG    (global input) CHARACTER*1
07954 *          On entry, DIAG specifies if the generated submatrix is diago-
07955 *          nally dominant or not as follows:
07956 *             DIAG = 'D' : sub( A ) is diagonally dominant,
07957 *             DIAG = 'N' : sub( A ) is not diagonally dominant.
07958 *
07959 *  OFFA    (global input) INTEGER
07960 *          On entry, OFFA  specifies  the  offdiagonal of the underlying
07961 *          matrix A(1:DESCA(M_),1:DESCA(N_)) of interest when the subma-
07962 *          trix is symmetric, Hermitian or diagonally dominant. OFFA = 0
07963 *          specifies the main diagonal,  OFFA > 0  specifies a subdiago-
07964 *          nal,  and OFFA < 0 specifies a superdiagonal (see further de-
07965 *          tails).
07966 *
07967 *  M       (global input) INTEGER
07968 *          On entry, M specifies the global number of matrix rows of the
07969 *          submatrix sub( A ) to be generated. M must be at least zero.
07970 *
07971 *  N       (global input) INTEGER
07972 *          On entry,  N specifies the global number of matrix columns of
07973 *          the  submatrix  sub( A )  to be generated. N must be at least
07974 *          zero.
07975 *
07976 *  IA      (global input) INTEGER
07977 *          On entry, IA  specifies A's global row index, which points to
07978 *          the beginning of the submatrix sub( A ).
07979 *
07980 *  JA      (global input) INTEGER
07981 *          On entry, JA  specifies A's global column index, which points
07982 *          to the beginning of the submatrix sub( A ).
07983 *
07984 *  DESCA   (global and local input) INTEGER array
07985 *          On entry, DESCA  is an integer array of dimension DLEN_. This
07986 *          is the array descriptor for the matrix A.
07987 *
07988 *  IASEED  (global input) INTEGER
07989 *          On entry, IASEED  specifies  the  seed number to generate the
07990 *          matrix A. IASEED must be at least zero.
07991 *
07992 *  A       (local output) REAL array
07993 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
07994 *          at least Lc( 1, JA+N-1 ).  On  exit, this array  contains the
07995 *          local entries of the randomly generated submatrix sub( A ).
07996 *
07997 *  LDA     (local input) INTEGER
07998 *          On entry,  LDA  specifies  the local leading dimension of the
07999 *          array A. When INPLACE is .FALSE., LDA is usually DESCA(LLD_).
08000 *          This restriction is however not enforced, and this subroutine
08001 *          requires only that LDA >= MAX( 1, Mp ) where
08002 *
08003 *          Mp = PB_NUMROC( M, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ).
08004 *
08005 *          PB_NUMROC  is  a ScaLAPACK tool function; MYROW, MYCOL, NPROW
08006 *          and NPCOL  can  be determined by calling the BLACS subroutine
08007 *          BLACS_GRIDINFO.
08008 *
08009 *  Further Details
08010 *  ===============
08011 *
08012 *  OFFD  is  tied  to  the matrix described by  DESCA, as opposed to the
08013 *  piece that is currently  (re)generated.  This is a global information
08014 *  independent from the distribution  parameters.  Below are examples of
08015 *  the meaning of OFFD for a global 7 by 5 matrix:
08016 *
08017 *  ---------------------------------------------------------------------
08018 *  OFFD   |  0 -1 -2 -3 -4         0 -1 -2 -3 -4          0 -1 -2 -3 -4
08019 *  -------|-------------------------------------------------------------
08020 *         |     | OFFD=-1          |   OFFD=0                 OFFD=2
08021 *         |     V                  V
08022 *  0      |  .  d  .  .  .      -> d  .  .  .  .          .  .  .  .  .
08023 *  1      |  .  .  d  .  .         .  d  .  .  .          .  .  .  .  .
08024 *  2      |  .  .  .  d  .         .  .  d  .  .       -> d  .  .  .  .
08025 *  3      |  .  .  .  .  d         .  .  .  d  .          .  d  .  .  .
08026 *  4      |  .  .  .  .  .         .  .  .  .  d          .  .  d  .  .
08027 *  5      |  .  .  .  .  .         .  .  .  .  .          .  .  .  d  .
08028 *  6      |  .  .  .  .  .         .  .  .  .  .          .  .  .  .  d
08029 *  ---------------------------------------------------------------------
08030 *
08031 *  -- Written on April 1, 1998 by
08032 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
08033 *
08034 *  =====================================================================
08035 *
08036 *     .. Parameters ..
08037       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
08038      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
08039      $                   RSRC_
08040       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
08041      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
08042      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
08043      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
08044       INTEGER            JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
08045      $                   JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
08046      $                   JMP_NQINBLOC, JMP_NQNB, JMP_ROW
08047       PARAMETER          ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3,
08048      $                   JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6,
08049      $                   JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9,
08050      $                   JMP_NQNB = 10, JMP_NQINBLOC = 11,
08051      $                   JMP_LEN = 11 )
08052 *     ..
08053 *     .. Local Scalars ..
08054       LOGICAL            DIAGDO, SYMM, HERM, NOTRAN
08055       INTEGER            CSRC, I, IACOL, IAROW, ICTXT, IIA, ILOCBLK,
08056      $                   ILOCOFF, ILOW, IMB, IMB1, IMBLOC, IMBVIR, INB,
08057      $                   INB1, INBLOC, INBVIR, INFO, IOFFDA, ITMP, IUPP,
08058      $                   IVIR, JJA, JLOCBLK, JLOCOFF, JVIR, LCMT00,
08059      $                   LMBLOC, LNBLOC, LOW, MAXMN, MB, MBLKS, MP,
08060      $                   MRCOL, MRROW, MYCDIST, MYCOL, MYRDIST, MYROW,
08061      $                   NB, NBLKS, NPCOL, NPROW, NQ, NVIR, RSRC, UPP
08062       REAL               ALPHA
08063 *     ..
08064 *     .. Local Arrays ..
08065       INTEGER            DESCA2( DLEN_ ), IMULADD( 4, JMP_LEN ),
08066      $                   IRAN( 2 ), JMP( JMP_LEN ), MULADD0( 4 )
08067 *     ..
08068 *     .. External Subroutines ..
08069       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
08070      $                   PB_CHKMAT, PB_DESCTRANS, PB_INITJMP,
08071      $                   PB_INITMULADD, PB_JUMP, PB_JUMPIT, PB_LOCINFO,
08072      $                   PB_SETLOCRAN, PB_SETRAN, PB_SLAGEN, PSLADOM,
08073      $                   PXERBLA
08074 *     ..
08075 *     .. External Functions ..
08076       LOGICAL            LSAME
08077       EXTERNAL           LSAME
08078 *     ..
08079 *     .. Intrinsic Functions ..
08080       INTRINSIC          MAX, MIN, REAL
08081 *     ..
08082 *     .. Data Statements ..
08083       DATA               ( MULADD0( I ), I = 1, 4 ) / 20077, 16838,
08084      $                   12345, 0 /
08085 *     ..
08086 *     .. Executable Statements ..
08087 *
08088 *     Convert descriptor
08089 *
08090       CALL PB_DESCTRANS( DESCA, DESCA2 )
08091 *
08092 *     Test the input arguments
08093 *
08094       ICTXT = DESCA2( CTXT_ )
08095       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
08096 *
08097 *     Test the input parameters
08098 *
08099       INFO = 0
08100       IF( NPROW.EQ.-1 ) THEN
08101          INFO = -( 1000 + CTXT_ )
08102       ELSE
08103          SYMM   = LSAME( AFORM, 'S' )
08104          HERM   = LSAME( AFORM, 'H' )
08105          NOTRAN = LSAME( AFORM, 'N' )
08106          DIAGDO = LSAME( DIAG, 'D' )
08107          IF( .NOT.( SYMM.OR.HERM.OR.NOTRAN ) .AND.
08108      $       .NOT.( LSAME( AFORM, 'T' )    ) .AND.
08109      $       .NOT.( LSAME( AFORM, 'C' )    ) ) THEN
08110             INFO = -2
08111          ELSE IF( ( .NOT.DIAGDO ) .AND.
08112      $            ( .NOT.LSAME( DIAG, 'N' ) ) ) THEN
08113             INFO = -3
08114          END IF
08115          CALL PB_CHKMAT( ICTXT, M, 5, N, 6, IA, JA, DESCA2, 10, INFO )
08116       END IF
08117 *
08118       IF( INFO.NE.0 ) THEN
08119          CALL PXERBLA( ICTXT, 'PSLAGEN', -INFO )
08120          RETURN
08121       END IF
08122 *
08123 *     Quick return if possible
08124 *
08125       IF( ( M.LE.0 ).OR.( N.LE.0 ) )
08126      $   RETURN
08127 *
08128 *     Start the operations
08129 *
08130       MB   = DESCA2( MB_   )
08131       NB   = DESCA2( NB_   )
08132       IMB  = DESCA2( IMB_  )
08133       INB  = DESCA2( INB_  )
08134       RSRC = DESCA2( RSRC_ )
08135       CSRC = DESCA2( CSRC_ )
08136 *
08137 *     Figure out local information about the distributed matrix operand
08138 *
08139       CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
08140      $                  MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
08141      $                  IACOL, MRROW, MRCOL )
08142 *
08143 *     Decide where the entries shall be stored in memory
08144 *
08145       IF( INPLACE ) THEN
08146          IIA = 1
08147          JJA = 1
08148       END IF
08149 *
08150 *     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
08151 *     ILOW, LOW, IUPP, and UPP.
08152 *
08153       IOFFDA = JA + OFFA - IA
08154       CALL PB_BINFO( IOFFDA, MP, NQ, IMB1, INB1, MB, NB, MRROW,
08155      $               MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC,
08156      $               LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP )
08157 *
08158 *     Initialize ILOCBLK, ILOCOFF, MYRDIST, JLOCBLK, JLOCOFF, MYCDIST
08159 *     This values correspond to the square virtual underlying matrix
08160 *     of size MAX( M_ + MAX( 0, -OFFA ), N_ + MAX( 0, OFFA ) ) used
08161 *     to set up the random sequence. For practical purposes, the size
08162 *     of this virtual matrix is upper bounded by M_ + N_ - 1.
08163 *
08164       ITMP   = MAX( 0, -OFFA )
08165       IVIR   = IA  + ITMP
08166       IMBVIR = IMB + ITMP
08167       NVIR   = DESCA2( M_ ) + ITMP
08168 *
08169       CALL PB_LOCINFO( IVIR, IMBVIR, MB, MYROW, RSRC, NPROW, ILOCBLK,
08170      $                 ILOCOFF, MYRDIST )
08171 *
08172       ITMP   = MAX( 0, OFFA )
08173       JVIR   = JA  + ITMP
08174       INBVIR = INB + ITMP
08175       NVIR   = MAX( MAX( NVIR, DESCA2( N_ ) + ITMP ),
08176      $              DESCA2( M_ ) + DESCA2( N_ ) - 1 )
08177 *
08178       CALL PB_LOCINFO( JVIR, INBVIR, NB, MYCOL, CSRC, NPCOL, JLOCBLK,
08179      $                 JLOCOFF, MYCDIST )
08180 *
08181       IF( SYMM .OR. HERM .OR. NOTRAN ) THEN
08182 *
08183          CALL PB_INITJMP( .TRUE., NVIR, IMBVIR, INBVIR, IMBLOC, INBLOC,
08184      $                    MB, NB, RSRC, CSRC, NPROW, NPCOL, 1, JMP )
08185 *
08186 *        Compute constants to jump JMP( * ) numbers in the sequence
08187 *
08188          CALL PB_INITMULADD( MULADD0, JMP, IMULADD )
08189 *
08190 *        Compute and set the random value corresponding to A( IA, JA )
08191 *
08192          CALL PB_SETLOCRAN( IASEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF,
08193      $                      MYRDIST, MYCDIST, NPROW, NPCOL, JMP,
08194      $                      IMULADD, IRAN )
08195 *
08196          CALL PB_SLAGEN( 'Lower', AFORM, A( IIA, JJA ), LDA, LCMT00,
08197      $                   IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC,
08198      $                   NB, LNBLOC, JMP, IMULADD )
08199 *
08200       END IF
08201 *
08202       IF( SYMM .OR. HERM .OR. ( .NOT. NOTRAN ) ) THEN
08203 *
08204          CALL PB_INITJMP( .FALSE., NVIR, IMBVIR, INBVIR, IMBLOC, INBLOC,
08205      $                    MB, NB, RSRC, CSRC, NPROW, NPCOL, 1, JMP )
08206 *
08207 *        Compute constants to jump JMP( * ) numbers in the sequence
08208 *
08209          CALL PB_INITMULADD( MULADD0, JMP, IMULADD )
08210 *
08211 *        Compute and set the random value corresponding to A( IA, JA )
08212 *
08213          CALL PB_SETLOCRAN( IASEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF,
08214      $                      MYRDIST, MYCDIST, NPROW, NPCOL, JMP,
08215      $                      IMULADD, IRAN )
08216 *
08217          CALL PB_SLAGEN( 'Upper', AFORM, A( IIA, JJA ), LDA, LCMT00,
08218      $                   IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC,
08219      $                   NB, LNBLOC, JMP, IMULADD )
08220 *
08221       END IF
08222 *
08223       IF( DIAGDO ) THEN
08224 *
08225          MAXMN = MAX( DESCA2( M_ ), DESCA2( N_ ) )
08226          ALPHA = REAL( MAXMN )
08227 *
08228          IF( IOFFDA.GE.0 ) THEN
08229             CALL PSLADOM( INPLACE, MIN( MAX( 0, M-IOFFDA ), N ), ALPHA,
08230      $                    A, MIN( IA+IOFFDA, IA+M-1 ), JA, DESCA )
08231          ELSE
08232             CALL PSLADOM( INPLACE, MIN( M, MAX( 0, N+IOFFDA ) ), ALPHA,
08233      $                    A, IA, MIN( JA-IOFFDA, JA+N-1 ), DESCA )
08234          END IF
08235 *
08236       END IF
08237 *
08238       RETURN
08239 *
08240 *     End of PSLAGEN
08241 *
08242       END
08243       SUBROUTINE PSLADOM( INPLACE, N, ALPHA, A, IA, JA, DESCA )
08244 *
08245 *  -- PBLAS test routine (version 2.0) --
08246 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
08247 *     and University of California, Berkeley.
08248 *     April 1, 1998
08249 *
08250 *     .. Scalar Arguments ..
08251       LOGICAL            INPLACE
08252       INTEGER            IA, JA, N
08253       REAL               ALPHA
08254 *     ..
08255 *     .. Array Arguments ..
08256       INTEGER            DESCA( * )
08257       REAL               A( * )
08258 *     ..
08259 *
08260 *  Purpose
08261 *  =======
08262 *
08263 *  PSLADOM  adds alpha to the diagonal entries  of  an  n by n submatrix
08264 *  sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ).
08265 *
08266 *  Notes
08267 *  =====
08268 *
08269 *  A description  vector  is associated with each 2D block-cyclicly dis-
08270 *  tributed matrix.  This  vector  stores  the  information  required to
08271 *  establish the  mapping  between a  matrix entry and its corresponding
08272 *  process and memory location.
08273 *
08274 *  In  the  following  comments,   the character _  should  be  read  as
08275 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
08276 *  block cyclicly distributed matrix.  Its description vector is DESCA:
08277 *
08278 *  NOTATION         STORED IN       EXPLANATION
08279 *  ---------------- --------------- ------------------------------------
08280 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
08281 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
08282 *                                   the NPROW x NPCOL BLACS process grid
08283 *                                   A  is distributed over.  The context
08284 *                                   itself  is  global,  but  the handle
08285 *                                   (the integer value) may vary.
08286 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
08287 *                                   ted matrix A, M_A >= 0.
08288 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
08289 *                                   buted matrix A, N_A >= 0.
08290 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
08291 *                                   block of the matrix A, IMB_A > 0.
08292 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
08293 *                                   left   block   of   the   matrix  A,
08294 *                                   INB_A > 0.
08295 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
08296 *                                   bute the last  M_A-IMB_A rows of  A,
08297 *                                   MB_A > 0.
08298 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
08299 *                                   bute the last  N_A-INB_A  columns of
08300 *                                   A, NB_A > 0.
08301 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
08302 *                                   row of the matrix  A is distributed,
08303 *                                   NPROW > RSRC_A >= 0.
08304 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
08305 *                                   first  column of  A  is distributed.
08306 *                                   NPCOL > CSRC_A >= 0.
08307 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
08308 *                                   array  storing  the  local blocks of
08309 *                                   the distributed matrix A,
08310 *                                   IF( Lc( 1, N_A ) > 0 )
08311 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
08312 *                                   ELSE
08313 *                                      LLD_A >= 1.
08314 *
08315 *  Let K be the number of  rows of a matrix A starting at the global in-
08316 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
08317 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
08318 *  receive if these K rows were distributed over NPROW processes.  If  K
08319 *  is the number of columns of a matrix  A  starting at the global index
08320 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
08321 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
08322 *  these K columns were distributed over NPCOL processes.
08323 *
08324 *  The values of Lr() and Lc() may be determined via a call to the func-
08325 *  tion PB_NUMROC:
08326 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
08327 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
08328 *
08329 *  Arguments
08330 *  =========
08331 *
08332 *  INPLACE (global input) LOGICAL
08333 *          On entry, INPLACE specifies if the matrix should be generated
08334 *          in place or not. If INPLACE is .TRUE., the local random array
08335 *          to be generated  will start in memory at the local memory lo-
08336 *          cation A( 1, 1 ),  otherwise it will start at the local posi-
08337 *          tion induced by IA and JA.
08338 *
08339 *  N       (global input) INTEGER
08340 *          On entry,  N  specifies  the  global  order  of the submatrix
08341 *          sub( A ) to be modified. N must be at least zero.
08342 *
08343 *  ALPHA   (global input) REAL
08344 *          On entry, ALPHA specifies the scalar alpha.
08345 *
08346 *  A       (local input/local output) REAL array
08347 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
08348 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
08349 *          the local entries of the matrix A. On exit, the local entries
08350 *          of this array corresponding to the main diagonal of  sub( A )
08351 *          have been updated.
08352 *
08353 *  IA      (global input) INTEGER
08354 *          On entry, IA  specifies A's global row index, which points to
08355 *          the beginning of the submatrix sub( A ).
08356 *
08357 *  JA      (global input) INTEGER
08358 *          On entry, JA  specifies A's global column index, which points
08359 *          to the beginning of the submatrix sub( A ).
08360 *
08361 *  DESCA   (global and local input) INTEGER array
08362 *          On entry, DESCA  is an integer array of dimension DLEN_. This
08363 *          is the array descriptor for the matrix A.
08364 *
08365 *  -- Written on April 1, 1998 by
08366 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
08367 *
08368 *  =====================================================================
08369 *
08370 *     .. Parameters ..
08371       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
08372      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
08373      $                   RSRC_
08374       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
08375      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
08376      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
08377      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
08378 *     ..
08379 *     .. Local Scalars ..
08380       LOGICAL            GODOWN, GOLEFT
08381       INTEGER            I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW,
08382      $                   IMB1, IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP,
08383      $                   JJA, JOFFA, JOFFD, LCMT, LCMT00, LDA, LDAP1,
08384      $                   LMBLOC, LNBLOC, LOW, MB, MBLKD, MBLKS, MBLOC,
08385      $                   MRCOL, MRROW, MYCOL, MYROW, NB, NBLKD, NBLKS,
08386      $                   NBLOC, NP, NPCOL, NPROW, NQ, PMB, QNB, UPP
08387       REAL               ATMP
08388 *     ..
08389 *     .. Local Scalars ..
08390       INTEGER            DESCA2( DLEN_ )
08391 *     ..
08392 *     .. External Subroutines ..
08393       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
08394      $                   PB_DESCTRANS
08395 *     ..
08396 *     .. Intrinsic Functions ..
08397       INTRINSIC          ABS, MAX, MIN
08398 *     ..
08399 *     .. Executable Statements ..
08400 *
08401 *     Convert descriptor
08402 *
08403       CALL PB_DESCTRANS( DESCA, DESCA2 )
08404 *
08405 *     Get grid parameters
08406 *
08407       ICTXT = DESCA2( CTXT_ )
08408       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
08409 *
08410       IF( N.EQ.0 )
08411      $   RETURN
08412 *
08413       CALL PB_AINFOG2L( N, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
08414      $                  MYCOL, IMB1, INB1, NP, NQ, IIA, JJA, IAROW,
08415      $                  IACOL, MRROW, MRCOL )
08416 *
08417 *     Decide where the entries shall be stored in memory
08418 *
08419       IF( INPLACE ) THEN
08420          IIA = 1
08421          JJA = 1
08422       END IF
08423 *
08424 *     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
08425 *     ILOW, LOW, IUPP, and UPP.
08426 *
08427       MB = DESCA2( MB_ )
08428       NB = DESCA2( NB_ )
08429 *
08430       CALL PB_BINFO( 0, NP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL,
08431      $               LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
08432      $               LNBLOC, ILOW, LOW, IUPP, UPP )
08433 *
08434       IOFFA  = IIA - 1
08435       JOFFA  = JJA - 1
08436       LDA    = DESCA2( LLD_ )
08437       LDAP1  = LDA + 1
08438 *
08439       IF( DESCA2( RSRC_ ).LT.0 ) THEN
08440          PMB = MB
08441       ELSE
08442          PMB = NPROW * MB
08443       END IF
08444       IF( DESCA2( CSRC_ ).LT.0 ) THEN
08445          QNB = NB
08446       ELSE
08447          QNB = NPCOL * NB
08448       END IF
08449 *
08450 *     Handle the first block of rows or columns separately, and update
08451 *     LCMT00, MBLKS and NBLKS.
08452 *
08453       GODOWN = ( LCMT00.GT.IUPP )
08454       GOLEFT = ( LCMT00.LT.ILOW )
08455 *
08456       IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN
08457 *
08458 *        LCMT00 >= ILOW && LCMT00 <= IUPP
08459 *
08460          IF( LCMT00.GE.0 ) THEN
08461             IJOFFA = IOFFA+LCMT00 + ( JOFFA - 1 ) * LDA
08462             DO 10 I = 1, MIN( INBLOC, MAX( 0, IMBLOC - LCMT00 ) )
08463                ATMP = A( IJOFFA + I*LDAP1 )
08464                A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
08465    10       CONTINUE
08466          ELSE
08467             IJOFFA = IOFFA + ( JOFFA - LCMT00 - 1 ) * LDA
08468             DO 20 I = 1, MIN( IMBLOC, MAX( 0, INBLOC + LCMT00 ) )
08469                ATMP = A( IJOFFA + I*LDAP1 )
08470                A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
08471    20       CONTINUE
08472          END IF
08473          GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW )
08474          GODOWN = .NOT.GOLEFT
08475 *
08476       END IF
08477 *
08478       IF( GODOWN ) THEN
08479 *
08480          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
08481          MBLKS  = MBLKS - 1
08482          IOFFA  = IOFFA + IMBLOC
08483 *
08484    30    CONTINUE
08485          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
08486             LCMT00 = LCMT00 - PMB
08487             MBLKS  = MBLKS - 1
08488             IOFFA  = IOFFA + MB
08489             GO TO 30
08490          END IF
08491 *
08492          LCMT  = LCMT00
08493          MBLKD = MBLKS
08494          IOFFD = IOFFA
08495 *
08496          MBLOC = MB
08497    40    CONTINUE
08498          IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN
08499             IF( MBLKD.EQ.1 )
08500      $         MBLOC = LMBLOC
08501             IF( LCMT.GE.0 ) THEN
08502                IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
08503                DO 50 I = 1, MIN( INBLOC, MAX( 0, MBLOC - LCMT ) )
08504                   ATMP = A( IJOFFA + I*LDAP1 )
08505                   A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
08506    50          CONTINUE
08507             ELSE
08508                IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
08509                DO 60 I = 1, MIN( MBLOC, MAX( 0, INBLOC + LCMT ) )
08510                   ATMP = A( IJOFFA + I*LDAP1 )
08511                   A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
08512    60          CONTINUE
08513             END IF
08514             LCMT00 = LCMT
08515             LCMT   = LCMT - PMB
08516             MBLKS  = MBLKD
08517             MBLKD  = MBLKD - 1
08518             IOFFA  = IOFFD
08519             IOFFD  = IOFFD + MBLOC
08520             GO TO 40
08521          END IF
08522 *
08523          LCMT00 = LCMT00 + LOW - ILOW + QNB
08524          NBLKS  = NBLKS - 1
08525          JOFFA  = JOFFA + INBLOC
08526 *
08527       ELSE IF( GOLEFT ) THEN
08528 *
08529          LCMT00 = LCMT00 + LOW - ILOW + QNB
08530          NBLKS  = NBLKS - 1
08531          JOFFA  = JOFFA + INBLOC
08532 *
08533    70    CONTINUE
08534          IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN
08535             LCMT00 = LCMT00 + QNB
08536             NBLKS  = NBLKS - 1
08537             JOFFA  = JOFFA + NB
08538             GO TO 70
08539          END IF
08540 *
08541          LCMT  = LCMT00
08542          NBLKD = NBLKS
08543          JOFFD = JOFFA
08544 *
08545          NBLOC = NB
08546    80    CONTINUE
08547          IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN
08548             IF( NBLKD.EQ.1 )
08549      $         NBLOC = LNBLOC
08550             IF( LCMT.GE.0 ) THEN
08551                IJOFFA = IOFFA + LCMT + ( JOFFD - 1 ) * LDA
08552                DO 90 I = 1, MIN( NBLOC, MAX( 0, IMBLOC - LCMT ) )
08553                   ATMP = A( IJOFFA + I*LDAP1 )
08554                   A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
08555    90          CONTINUE
08556             ELSE
08557                IJOFFA = IOFFA + ( JOFFD - LCMT - 1 ) * LDA
08558                DO 100 I = 1, MIN( IMBLOC, MAX( 0, NBLOC + LCMT ) )
08559                   ATMP = A( IJOFFA + I*LDAP1 )
08560                   A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
08561   100          CONTINUE
08562             END IF
08563             LCMT00 = LCMT
08564             LCMT   = LCMT + QNB
08565             NBLKS  = NBLKD
08566             NBLKD  = NBLKD - 1
08567             JOFFA  = JOFFD
08568             JOFFD  = JOFFD + NBLOC
08569             GO TO 80
08570          END IF
08571 *
08572          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
08573          MBLKS  = MBLKS - 1
08574          IOFFA  = IOFFA + IMBLOC
08575 *
08576       END IF
08577 *
08578       NBLOC = NB
08579   110 CONTINUE
08580       IF( NBLKS.GT.0 ) THEN
08581          IF( NBLKS.EQ.1 )
08582      $      NBLOC = LNBLOC
08583   120    CONTINUE
08584          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
08585             LCMT00 = LCMT00 - PMB
08586             MBLKS  = MBLKS - 1
08587             IOFFA  = IOFFA + MB
08588             GO TO 120
08589          END IF
08590 *
08591          LCMT  = LCMT00
08592          MBLKD = MBLKS
08593          IOFFD = IOFFA
08594 *
08595          MBLOC = MB
08596   130    CONTINUE
08597          IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN
08598             IF( MBLKD.EQ.1 )
08599      $         MBLOC = LMBLOC
08600             IF( LCMT.GE.0 ) THEN
08601                IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
08602                DO 140 I = 1, MIN( NBLOC, MAX( 0, MBLOC - LCMT ) )
08603                   ATMP = A( IJOFFA + I*LDAP1 )
08604                   A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
08605   140          CONTINUE
08606             ELSE
08607                IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
08608                DO 150 I = 1, MIN( MBLOC, MAX( 0, NBLOC + LCMT ) )
08609                   ATMP = A( IJOFFA + I*LDAP1 )
08610                   A( IJOFFA + I*LDAP1 ) = ABS( ATMP ) + ALPHA
08611   150          CONTINUE
08612             END IF
08613             LCMT00 = LCMT
08614             LCMT   = LCMT - PMB
08615             MBLKS  = MBLKD
08616             MBLKD  = MBLKD - 1
08617             IOFFA  = IOFFD
08618             IOFFD  = IOFFD + MBLOC
08619             GO TO 130
08620          END IF
08621 *
08622          LCMT00 = LCMT00 + QNB
08623          NBLKS  = NBLKS - 1
08624          JOFFA  = JOFFA + NBLOC
08625          GO TO 110
08626 *
08627       END IF
08628 *
08629       RETURN
08630 *
08631 *     End of PSLADOM
08632 *
08633       END
08634       SUBROUTINE PB_PSLAPRNT( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT,
08635      $                        CMATNM, NOUT, WORK )
08636 *
08637 *  -- PBLAS test routine (version 2.0) --
08638 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
08639 *     and University of California, Berkeley.
08640 *     April 1, 1998
08641 *
08642 *     .. Scalar Arguments ..
08643       INTEGER            IA, ICPRNT, IRPRNT, JA, M, N, NOUT
08644 *     ..
08645 *     .. Array Arguments ..
08646       CHARACTER*(*)      CMATNM
08647       INTEGER            DESCA( * )
08648       REAL               A( * ), WORK( * )
08649 *     ..
08650 *
08651 *  Purpose
08652 *  =======
08653 *
08654 *  PB_PSLAPRNT  prints to the standard output a submatrix sub( A ) deno-
08655 *  ting A(IA:IA+M-1,JA:JA+N-1). The local pieces are sent and printed by
08656 *  the process of coordinates (IRPRNT, ICPRNT).
08657 *
08658 *  Notes
08659 *  =====
08660 *
08661 *  A description  vector  is associated with each 2D block-cyclicly dis-
08662 *  tributed matrix.  This  vector  stores  the  information  required to
08663 *  establish the  mapping  between a  matrix entry and its corresponding
08664 *  process and memory location.
08665 *
08666 *  In  the  following  comments,   the character _  should  be  read  as
08667 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
08668 *  block cyclicly distributed matrix.  Its description vector is DESCA:
08669 *
08670 *  NOTATION         STORED IN       EXPLANATION
08671 *  ---------------- --------------- ------------------------------------
08672 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
08673 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
08674 *                                   the NPROW x NPCOL BLACS process grid
08675 *                                   A  is distributed over.  The context
08676 *                                   itself  is  global,  but  the handle
08677 *                                   (the integer value) may vary.
08678 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
08679 *                                   ted matrix A, M_A >= 0.
08680 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
08681 *                                   buted matrix A, N_A >= 0.
08682 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
08683 *                                   block of the matrix A, IMB_A > 0.
08684 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
08685 *                                   left   block   of   the   matrix  A,
08686 *                                   INB_A > 0.
08687 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
08688 *                                   bute the last  M_A-IMB_A rows of  A,
08689 *                                   MB_A > 0.
08690 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
08691 *                                   bute the last  N_A-INB_A  columns of
08692 *                                   A, NB_A > 0.
08693 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
08694 *                                   row of the matrix  A is distributed,
08695 *                                   NPROW > RSRC_A >= 0.
08696 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
08697 *                                   first  column of  A  is distributed.
08698 *                                   NPCOL > CSRC_A >= 0.
08699 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
08700 *                                   array  storing  the  local blocks of
08701 *                                   the distributed matrix A,
08702 *                                   IF( Lc( 1, N_A ) > 0 )
08703 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
08704 *                                   ELSE
08705 *                                      LLD_A >= 1.
08706 *
08707 *  Let K be the number of  rows of a matrix A starting at the global in-
08708 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
08709 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
08710 *  receive if these K rows were distributed over NPROW processes.  If  K
08711 *  is the number of columns of a matrix  A  starting at the global index
08712 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
08713 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
08714 *  these K columns were distributed over NPCOL processes.
08715 *
08716 *  The values of Lr() and Lc() may be determined via a call to the func-
08717 *  tion PB_NUMROC:
08718 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
08719 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
08720 *
08721 *  Arguments
08722 *  =========
08723 *
08724 *  M       (global input) INTEGER
08725 *          On entry,  M  specifies the number of rows of  the  submatrix
08726 *          sub( A ). M  must be at least zero.
08727 *
08728 *  N       (global input) INTEGER
08729 *          On entry, N  specifies the number of columns of the submatrix
08730 *          sub( A ). N must be at least zero.
08731 *
08732 *  A       (local input) REAL array
08733 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
08734 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
08735 *          the local entries of the matrix A.
08736 *
08737 *  IA      (global input) INTEGER
08738 *          On entry, IA  specifies A's global row index, which points to
08739 *          the beginning of the submatrix sub( A ).
08740 *
08741 *  JA      (global input) INTEGER
08742 *          On entry, JA  specifies A's global column index, which points
08743 *          to the beginning of the submatrix sub( A ).
08744 *
08745 *  DESCA   (global and local input) INTEGER array
08746 *          On entry, DESCA  is an integer array of dimension DLEN_. This
08747 *          is the array descriptor for the matrix A.
08748 *
08749 *  IRPRNT  (global input) INTEGER
08750 *          On entry, IRPRNT specifies the row index of the printing pro-
08751 *          cess.
08752 *
08753 *  ICPRNT  (global input) INTEGER
08754 *          On entry, ICPRNT specifies the  column  index of the printing
08755 *          process.
08756 *
08757 *  CMATNM  (global input) CHARACTER*(*)
08758 *          On entry, CMATNM is the name of the matrix to be printed.
08759 *
08760 *  NOUT    (global input) INTEGER
08761 *          On entry, NOUT specifies the output unit number. When NOUT is
08762 *          equal to 6, the submatrix is printed on the screen.
08763 *
08764 *  WORK    (local workspace) REAL array
08765 *          On entry, WORK is a work array of dimension at least equal to
08766 *          MAX( IMB_A, MB_A ).
08767 *
08768 *  -- Written on April 1, 1998 by
08769 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
08770 *
08771 *  =====================================================================
08772 *
08773 *     .. Parameters ..
08774       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
08775      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
08776      $                   RSRC_
08777       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
08778      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
08779      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
08780      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
08781 *     ..
08782 *     .. Local Scalars ..
08783       INTEGER            MYCOL, MYROW, NPCOL, NPROW, PCOL, PROW
08784 *     ..
08785 *     .. Local Arrays ..
08786       INTEGER            DESCA2( DLEN_ )
08787 *     ..
08788 *     .. External Subroutines ..
08789       EXTERNAL           BLACS_GRIDINFO, PB_DESCTRANS, PB_PSLAPRN2
08790 *     ..
08791 *     .. Executable Statements ..
08792 *
08793 *     Quick return if possible
08794 *
08795       IF( ( M.LE.0 ).OR.( N.LE.0 ) )
08796      $   RETURN
08797 *
08798 *     Convert descriptor
08799 *
08800       CALL PB_DESCTRANS( DESCA, DESCA2 )
08801 *
08802       CALL BLACS_GRIDINFO( DESCA2( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
08803 *
08804       IF( DESCA2( RSRC_ ).GE.0 ) THEN
08805          IF( DESCA2( CSRC_ ).GE.0 ) THEN
08806             CALL PB_PSLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT, ICPRNT,
08807      $                        CMATNM, NOUT, DESCA2( RSRC_ ),
08808      $                        DESCA2( CSRC_ ), WORK )
08809          ELSE
08810             DO 10 PCOL = 0, NPCOL - 1
08811                IF( ( MYROW.EQ.IRPRNT ).AND.( MYCOL.EQ.ICPRNT ) )
08812      $            WRITE( NOUT, * ) 'Colum-replicated array -- ' ,
08813      $                             'copy in process column: ', PCOL
08814                CALL PB_PSLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT,
08815      $                           ICPRNT, CMATNM, NOUT, DESCA2( RSRC_ ),
08816      $                           PCOL, WORK )
08817    10       CONTINUE
08818          END IF
08819       ELSE
08820          IF( DESCA2( CSRC_ ).GE.0 ) THEN
08821             DO 20 PROW = 0, NPROW - 1
08822                IF( ( MYROW.EQ.IRPRNT ).AND.( MYCOL.EQ.ICPRNT ) )
08823      $            WRITE( NOUT, * ) 'Row-replicated array -- ' ,
08824      $                             'copy in process row: ', PROW
08825                CALL PB_PSLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT,
08826      $                           ICPRNT, CMATNM, NOUT, PROW,
08827      $                           DESCA2( CSRC_ ), WORK )
08828    20       CONTINUE
08829          ELSE
08830             DO 40 PROW = 0, NPROW - 1
08831                DO 30 PCOL = 0, NPCOL - 1
08832                   IF( ( MYROW.EQ.IRPRNT ).AND.( MYCOL.EQ.ICPRNT ) )
08833      $               WRITE( NOUT, * ) 'Replicated array -- ' ,
08834      $                      'copy in process (', PROW, ',', PCOL, ')'
08835                   CALL PB_PSLAPRN2( M, N, A, IA, JA, DESCA2, IRPRNT,
08836      $                              ICPRNT, CMATNM, NOUT, PROW, PCOL,
08837      $                              WORK )
08838    30          CONTINUE
08839    40       CONTINUE
08840          END IF
08841       END IF
08842 *
08843       RETURN
08844 *
08845 *     End of PB_PSLAPRNT
08846 *
08847       END
08848       SUBROUTINE PB_PSLAPRN2( M, N, A, IA, JA, DESCA, IRPRNT, ICPRNT,
08849      $                        CMATNM, NOUT, PROW, PCOL, WORK )
08850 *
08851 *  -- PBLAS test routine (version 2.0) --
08852 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
08853 *     and University of California, Berkeley.
08854 *     April 1, 1998
08855 *
08856 *     .. Scalar Arguments ..
08857       INTEGER            IA, ICPRNT, IRPRNT, JA, M, N, NOUT, PCOL, PROW
08858 *     ..
08859 *     .. Array Arguments ..
08860       CHARACTER*(*)      CMATNM
08861       INTEGER            DESCA( * )
08862       REAL               A( * ), WORK( * )
08863 *     ..
08864 *
08865 *     .. Parameters ..
08866       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
08867      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
08868      $                   RSRC_
08869       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
08870      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
08871      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
08872      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
08873 *     ..
08874 *     .. Local Scalars ..
08875       LOGICAL            AISCOLREP, AISROWREP
08876       INTEGER            H, I, IACOL, IAROW, IB, ICTXT, ICURCOL,
08877      $                   ICURROW, II, IIA, IN, J, JB, JJ, JJA, JN, K,
08878      $                   LDA, LDW, MYCOL, MYROW, NPCOL, NPROW
08879 *     ..
08880 *     .. External Subroutines ..
08881       EXTERNAL           BLACS_BARRIER, BLACS_GRIDINFO, PB_INFOG2L,
08882      $                   SGERV2D, SGESD2D
08883 *     ..
08884 *     .. Intrinsic Functions ..
08885       INTRINSIC          MIN
08886 *     ..
08887 *     .. Executable Statements ..
08888 *
08889 *     Get grid parameters
08890 *
08891       ICTXT = DESCA( CTXT_ )
08892       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
08893       CALL PB_INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL,
08894      $                 IIA, JJA, IAROW, IACOL )
08895       II = IIA
08896       JJ = JJA
08897       IF( DESCA( RSRC_ ).LT.0 ) THEN
08898          AISROWREP = .TRUE.
08899          IAROW     = PROW
08900          ICURROW   = PROW
08901       ELSE
08902          AISROWREP = .FALSE.
08903          ICURROW   = IAROW
08904       END IF
08905       IF( DESCA( CSRC_ ).LT.0 ) THEN
08906          AISCOLREP = .TRUE.
08907          IACOL     = PCOL
08908          ICURCOL   = PCOL
08909       ELSE
08910          AISCOLREP = .FALSE.
08911          ICURCOL   = IACOL
08912       END IF
08913       LDA = DESCA( LLD_ )
08914       LDW = MAX( DESCA( IMB_ ), DESCA( MB_ ) )
08915 *
08916 *     Handle the first block of column separately
08917 *
08918       JB = DESCA( INB_ ) - JA + 1
08919       IF( JB.LE.0 )
08920      $   JB = ( (-JB) / DESCA( NB_ ) + 1 ) * DESCA( NB_ ) + JB
08921       JB = MIN( JB, N )
08922       JN = JA+JB-1
08923       DO 60 H = 0, JB-1
08924          IB = DESCA( IMB_ ) - IA + 1
08925          IF( IB.LE.0 )
08926      $      IB = ( (-IB) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
08927          IB = MIN( IB, M )
08928          IN = IA+IB-1
08929          IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN
08930             IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
08931                DO 10 K = 0, IB-1
08932                   WRITE( NOUT, FMT = 9999 )
08933      $                   CMATNM, IA+K, JA+H, A( II+K+(JJ+H-1)*LDA )
08934    10          CONTINUE
08935             END IF
08936          ELSE
08937             IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN
08938                CALL SGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ), LDA,
08939      $                       IRPRNT, ICPRNT )
08940             ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
08941                CALL SGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW, ICURCOL )
08942                DO 20 K = 1, IB
08943                   WRITE( NOUT, FMT = 9999 )
08944      $                   CMATNM, IA+K-1, JA+H, WORK( K )
08945    20          CONTINUE
08946             END IF
08947          END IF
08948          IF( MYROW.EQ.ICURROW )
08949      $      II = II + IB
08950          IF( .NOT.AISROWREP )
08951      $      ICURROW = MOD( ICURROW+1, NPROW )
08952          CALL BLACS_BARRIER( ICTXT, 'All' )
08953 *
08954 *        Loop over remaining block of rows
08955 *
08956          DO 50 I = IN+1, IA+M-1, DESCA( MB_ )
08957             IB = MIN( DESCA( MB_ ), IA+M-I )
08958             IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN
08959                IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
08960                   DO 30 K = 0, IB-1
08961                      WRITE( NOUT, FMT = 9999 )
08962      $                      CMATNM, I+K, JA+H, A( II+K+(JJ+H-1)*LDA )
08963    30             CONTINUE
08964                END IF
08965             ELSE
08966                IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN
08967                   CALL SGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ),
08968      $                          LDA, IRPRNT, ICPRNT )
08969                ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
08970                   CALL SGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW,
08971      $                          ICURCOL )
08972                   DO 40 K = 1, IB
08973                      WRITE( NOUT, FMT = 9999 )
08974      $                      CMATNM, I+K-1, JA+H, WORK( K )
08975    40             CONTINUE
08976                END IF
08977             END IF
08978             IF( MYROW.EQ.ICURROW )
08979      $         II = II + IB
08980             IF( .NOT.AISROWREP )
08981      $         ICURROW = MOD( ICURROW+1, NPROW )
08982             CALL BLACS_BARRIER( ICTXT, 'All' )
08983    50    CONTINUE
08984 *
08985          II = IIA
08986          ICURROW = IAROW
08987    60 CONTINUE
08988 *
08989       IF( MYCOL.EQ.ICURCOL )
08990      $   JJ = JJ + JB
08991       IF( .NOT.AISCOLREP )
08992      $   ICURCOL = MOD( ICURCOL+1, NPCOL )
08993       CALL BLACS_BARRIER( ICTXT, 'All' )
08994 *
08995 *     Loop over remaining column blocks
08996 *
08997       DO 130 J = JN+1, JA+N-1, DESCA( NB_ )
08998          JB = MIN(  DESCA( NB_ ), JA+N-J )
08999          DO 120 H = 0, JB-1
09000             IB = DESCA( IMB_ )-IA+1
09001             IF( IB.LE.0 )
09002      $         IB = ( (-IB) / DESCA( MB_ ) + 1 ) * DESCA( MB_ ) + IB
09003             IB = MIN( IB, M )
09004             IN = IA+IB-1
09005             IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN
09006                IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09007                   DO 70 K = 0, IB-1
09008                      WRITE( NOUT, FMT = 9999 )
09009      $                      CMATNM, IA+K, J+H, A( II+K+(JJ+H-1)*LDA )
09010    70             CONTINUE
09011                END IF
09012             ELSE
09013                IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN
09014                   CALL SGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ),
09015      $                          LDA, IRPRNT, ICPRNT )
09016                ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09017                   CALL SGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW,
09018      $                          ICURCOL )
09019                   DO 80 K = 1, IB
09020                      WRITE( NOUT, FMT = 9999 )
09021      $                      CMATNM, IA+K-1, J+H, WORK( K )
09022    80             CONTINUE
09023                END IF
09024             END IF
09025             IF( MYROW.EQ.ICURROW )
09026      $         II = II + IB
09027             ICURROW = MOD( ICURROW+1, NPROW )
09028             CALL BLACS_BARRIER( ICTXT, 'All' )
09029 *
09030 *           Loop over remaining block of rows
09031 *
09032             DO 110 I = IN+1, IA+M-1, DESCA( MB_ )
09033                IB = MIN( DESCA( MB_ ), IA+M-I )
09034                IF( ICURROW.EQ.IRPRNT .AND. ICURCOL.EQ.ICPRNT ) THEN
09035                   IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09036                      DO 90 K = 0, IB-1
09037                         WRITE( NOUT, FMT = 9999 )
09038      $                         CMATNM, I+K, J+H, A( II+K+(JJ+H-1)*LDA )
09039    90                CONTINUE
09040                   END IF
09041                ELSE
09042                   IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN
09043                      CALL SGESD2D( ICTXT, IB, 1, A( II+(JJ+H-1)*LDA ),
09044      $                             LDA, IRPRNT, ICPRNT )
09045                    ELSE IF( MYROW.EQ.IRPRNT .AND. MYCOL.EQ.ICPRNT ) THEN
09046                      CALL SGERV2D( ICTXT, IB, 1, WORK, LDW, ICURROW,
09047      $                             ICURCOL )
09048                      DO 100 K = 1, IB
09049                         WRITE( NOUT, FMT = 9999 )
09050      $                         CMATNM, I+K-1, J+H, WORK( K )
09051   100                CONTINUE
09052                   END IF
09053                END IF
09054                IF( MYROW.EQ.ICURROW )
09055      $            II = II + IB
09056                IF( .NOT.AISROWREP )
09057      $            ICURROW = MOD( ICURROW+1, NPROW )
09058                CALL BLACS_BARRIER( ICTXT, 'All' )
09059   110       CONTINUE
09060 *
09061             II = IIA
09062             ICURROW = IAROW
09063   120    CONTINUE
09064 *
09065          IF( MYCOL.EQ.ICURCOL )
09066      $      JJ = JJ + JB
09067          IF( .NOT.AISCOLREP )
09068      $      ICURCOL = MOD( ICURCOL+1, NPCOL )
09069          CALL BLACS_BARRIER( ICTXT, 'All' )
09070 *
09071   130 CONTINUE
09072 *
09073  9999 FORMAT( 1X, A, '(', I6, ',', I6, ')=', E16.8 )
09074 *
09075       RETURN
09076 *
09077 *     End of PB_PSLAPRN2
09078 *
09079       END
09080       SUBROUTINE PB_SFILLPAD( ICTXT, M, N, A, LDA, IPRE, IPOST, CHKVAL )
09081 *
09082 *  -- PBLAS test routine (version 2.0) --
09083 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
09084 *     and University of California, Berkeley.
09085 *     April 1, 1998
09086 *
09087 *     .. Scalar Arguments ..
09088       INTEGER            ICTXT, IPOST, IPRE, LDA, M, N
09089       REAL               CHKVAL
09090 *     ..
09091 *     .. Array Arguments ..
09092       REAL               A( * )
09093 *     ..
09094 *
09095 *  Purpose
09096 *  =======
09097 *
09098 *  PB_SFILLPAD surrounds a two dimensional local array with a guard-zone
09099 *  initialized to the value CHKVAL. The user may later call the  routine
09100 *  PB_SCHEKPAD to discover if the guardzone has been violated. There are
09101 *  three guardzones. The first is a buffer of size  IPRE  that is before
09102 *  the start of the array. The second is the buffer of size IPOST  which
09103 *  is after the end of the array to be padded. Finally, there is a guard
09104 *  zone inside every column of the array to be padded, in  the  elements
09105 *  of A(M+1:LDA, J).
09106 *
09107 *  Arguments
09108 *  =========
09109 *
09110 *  ICTXT   (local input) INTEGER
09111 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
09112 *          ting the global  context of the operation. The context itself
09113 *          is global, but the value of ICTXT is local.
09114 *
09115 *  M       (local input) INTEGER
09116 *          On entry, M  specifies the number of rows in the local  array
09117 *          A.  M must be at least zero.
09118 *
09119 *  N       (local input) INTEGER
09120 *          On entry, N  specifies the number of columns in the local ar-
09121 *          ray A. N must be at least zero.
09122 *
09123 *  A       (local input/local output) REAL array
09124 *          On entry,  A  is an array of dimension (LDA,N). On exit, this
09125 *          array is the padded array.
09126 *
09127 *  LDA     (local input) INTEGER
09128 *          On entry,  LDA  specifies  the leading dimension of the local
09129 *          array to be padded. LDA must be at least MAX( 1, M ).
09130 *
09131 *  IPRE    (local input) INTEGER
09132 *          On entry, IPRE specifies the size of  the  guard zone  to put
09133 *          before the start of the padded array.
09134 *
09135 *  IPOST   (local input) INTEGER
09136 *          On entry, IPOST specifies the size of the  guard zone  to put
09137 *          after the end of the padded array.
09138 *
09139 *  CHKVAL  (local input) REAL
09140 *          On entry, CHKVAL specifies the value to pad the array with.
09141 *
09142 *  -- Written on April 1, 1998 by
09143 *     R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
09144 *
09145 *  =====================================================================
09146 *
09147 *     .. Local Scalars ..
09148       INTEGER            I, J, K
09149 *     ..
09150 *     .. Executable Statements ..
09151 *
09152 *     Put check buffer in front of A
09153 *
09154       IF( IPRE.GT.0 ) THEN
09155          DO 10 I = 1, IPRE
09156             A( I ) = CHKVAL
09157    10    CONTINUE
09158       ELSE
09159          WRITE( *, FMT = '(A)' )
09160      $          'WARNING no pre-guardzone in PB_SFILLPAD'
09161       END IF
09162 *
09163 *     Put check buffer in back of A
09164 *
09165       IF( IPOST.GT.0 ) THEN
09166          J = IPRE+LDA*N+1
09167          DO 20 I = J, J+IPOST-1
09168             A( I ) = CHKVAL
09169    20    CONTINUE
09170       ELSE
09171          WRITE( *, FMT = '(A)' )
09172      $          'WARNING no post-guardzone in PB_SFILLPAD'
09173       END IF
09174 *
09175 *     Put check buffer in all (LDA-M) gaps
09176 *
09177       IF( LDA.GT.M ) THEN
09178          K = IPRE + M + 1
09179          DO 40 J = 1, N
09180             DO 30 I = K, K + ( LDA - M ) - 1
09181                A( I ) = CHKVAL
09182    30       CONTINUE
09183             K = K + LDA
09184    40    CONTINUE
09185       END IF
09186 *
09187       RETURN
09188 *
09189 *     End of PB_SFILLPAD
09190 *
09191       END
09192       SUBROUTINE PB_SCHEKPAD( ICTXT, MESS, M, N, A, LDA, IPRE, IPOST,
09193      $                        CHKVAL )
09194 *
09195 *  -- PBLAS test routine (version 2.0) --
09196 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
09197 *     and University of California, Berkeley.
09198 *     April 1, 1998
09199 *
09200 *     .. Scalar Arguments ..
09201       INTEGER            ICTXT, IPOST, IPRE, LDA, M, N
09202       REAL               CHKVAL
09203 *     ..
09204 *     .. Array Arguments ..
09205       CHARACTER*(*)      MESS
09206       REAL               A( * )
09207 *     ..
09208 *
09209 *  Purpose
09210 *  =======
09211 *
09212 *  PB_SCHEKPAD checks that the padding around a local array has not been
09213 *  overwritten since the call to PB_SFILLPAD.  Three types of errors are
09214 *  reported:
09215 *
09216 *  1) Overwrite in pre-guardzone.  This indicates a memory overwrite has
09217 *  occurred in the  first  IPRE  elements which form a buffer before the
09218 *  beginning of A. Therefore, the error message:
09219 *     'Overwrite in  pre-guardzone: loc(  5) =         18.00000'
09220 *  tells that the 5th element of the IPRE long buffer has been overwrit-
09221 *  ten with the value 18, where it should still have the value CHKVAL.
09222 *
09223 *  2) Overwrite in post-guardzone. This indicates a memory overwrite has
09224 *  occurred in the last IPOST elements which form a buffer after the end
09225 *  of A. Error reports are refered from the end of A.  Therefore,
09226 *     'Overwrite in post-guardzone: loc( 19) =         24.00000'
09227 *  tells  that the  19th element after the end of A was overwritten with
09228 *  the value 24, where it should still have the value of CHKVAL.
09229 *
09230 *  3) Overwrite in lda-m gap.  Tells you elements between M and LDA were
09231 *  overwritten.  So,
09232 *     'Overwrite in lda-m gap: A( 12,  3) =         22.00000'
09233 *  tells  that the element at the 12th row and 3rd column of A was over-
09234 *  written with the value of 22, where it should still have the value of
09235 *  CHKVAL.
09236 *
09237 *  Arguments
09238 *  =========
09239 *
09240 *  ICTXT   (local input) INTEGER
09241 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
09242 *          ting the global  context of the operation. The context itself
09243 *          is global, but the value of ICTXT is local.
09244 *
09245 *  MESS    (local input) CHARACTER*(*)
09246 *          On entry, MESS is a ttring containing a user-defined message.
09247 *
09248 *  M       (local input) INTEGER
09249 *          On entry, M  specifies the number of rows in the local  array
09250 *          A.  M must be at least zero.
09251 *
09252 *  N       (local input) INTEGER
09253 *          On entry, N  specifies the number of columns in the local ar-
09254 *          ray A. N must be at least zero.
09255 *
09256 *  A       (local input) REAL array
09257 *          On entry,  A  is an array of dimension (LDA,N).
09258 *
09259 *  LDA     (local input) INTEGER
09260 *          On entry,  LDA  specifies  the leading dimension of the local
09261 *          array to be padded. LDA must be at least MAX( 1, M ).
09262 *
09263 *  IPRE    (local input) INTEGER
09264 *          On entry, IPRE specifies the size of  the  guard zone  to put
09265 *          before the start of the padded array.
09266 *
09267 *  IPOST   (local input) INTEGER
09268 *          On entry, IPOST specifies the size of the  guard zone  to put
09269 *          after the end of the padded array.
09270 *
09271 *  CHKVAL  (local input) REAL
09272 *          On entry, CHKVAL specifies the value to pad the array with.
09273 *
09274 *
09275 *  -- Written on April 1, 1998 by
09276 *     R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
09277 *
09278 *  =====================================================================
09279 *
09280 *     .. Local Scalars ..
09281       CHARACTER*1        TOP
09282       INTEGER            I, IAM, IDUMM, INFO, J, K, MYCOL, MYROW, NPCOL,
09283      $                   NPROW
09284 *     ..
09285 *     .. External Subroutines ..
09286       EXTERNAL           BLACS_GRIDINFO, IGAMX2D, PB_TOPGET
09287 *     ..
09288 *     .. Executable Statements ..
09289 *
09290 *     Get grid parameters
09291 *
09292       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
09293       IAM  = MYROW*NPCOL + MYCOL
09294       INFO = -1
09295 *
09296 *     Check buffer in front of A
09297 *
09298       IF( IPRE.GT.0 ) THEN
09299          DO 10 I = 1, IPRE
09300             IF( A( I ).NE.CHKVAL ) THEN
09301                WRITE( *, FMT = 9998 ) MYROW, MYCOL, MESS, ' pre', I,
09302      $                                A( I )
09303                INFO = IAM
09304             END IF
09305    10    CONTINUE
09306       ELSE
09307          WRITE( *, FMT = * ) 'WARNING no pre-guardzone in PB_SCHEKPAD'
09308       END IF
09309 *
09310 *     Check buffer after A
09311 *
09312       IF( IPOST.GT.0 ) THEN
09313          J = IPRE+LDA*N+1
09314          DO 20 I = J, J+IPOST-1
09315             IF( A( I ).NE.CHKVAL ) THEN
09316                WRITE( *, FMT = 9998 ) MYROW, MYCOL, MESS, 'post',
09317      $                                I-J+1, A( I )
09318                INFO = IAM
09319             END IF
09320    20    CONTINUE
09321       ELSE
09322          WRITE( *, FMT = * )
09323      $          'WARNING no post-guardzone buffer in PB_SCHEKPAD'
09324       END IF
09325 *
09326 *     Check all (LDA-M) gaps
09327 *
09328       IF( LDA.GT.M ) THEN
09329          K = IPRE + M + 1
09330          DO 40 J = 1, N
09331             DO 30 I = K, K + (LDA-M) - 1
09332                IF( A( I ).NE.CHKVAL ) THEN
09333                   WRITE( *, FMT = 9997 ) MYROW, MYCOL, MESS,
09334      $               I-IPRE-LDA*(J-1), J, A( I )
09335                   INFO = IAM
09336                END IF
09337    30       CONTINUE
09338             K = K + LDA
09339    40    CONTINUE
09340       END IF
09341 *
09342       CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP )
09343       CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, IDUMM, IDUMM, -1,
09344      $              0, 0 )
09345       IF( IAM.EQ.0 .AND. INFO.GE.0 ) THEN
09346          WRITE( *, FMT = 9999 ) INFO / NPCOL, MOD( INFO, NPCOL ), MESS
09347       END IF
09348 *
09349  9999 FORMAT( '{', I5, ',', I5, '}:  Memory overwrite in ', A )
09350  9998 FORMAT( '{', I5, ',', I5, '}:  ', A, ' memory overwrite in ',
09351      $        A4, '-guardzone: loc(', I3, ') = ', G11.4 )
09352  9997 FORMAT( '{', I5, ',', I5, '}: ', A, ' memory overwrite in ',
09353      $        'lda-m gap: loc(', I3, ',', I3, ') = ', G11.4 )
09354 *
09355       RETURN
09356 *
09357 *     End of PB_SCHEKPAD
09358 *
09359       END
09360       SUBROUTINE PB_SLASET( UPLO, M, N, IOFFD, ALPHA, BETA, A, LDA )
09361 *
09362 *  -- PBLAS test routine (version 2.0) --
09363 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
09364 *     and University of California, Berkeley.
09365 *     April 1, 1998
09366 *
09367 *     .. Scalar Arguments ..
09368       CHARACTER*1        UPLO
09369       INTEGER            IOFFD, LDA, M, N
09370       REAL               ALPHA, BETA
09371 *     ..
09372 *     .. Array Arguments ..
09373       REAL               A( LDA, * )
09374 *     ..
09375 *
09376 *  Purpose
09377 *  =======
09378 *
09379 *  PB_SLASET initializes a two-dimensional array A to beta on the diago-
09380 *  nal specified by IOFFD and alpha on the offdiagonals.
09381 *
09382 *  Arguments
09383 *  =========
09384 *
09385 *  UPLO    (global input) CHARACTER*1
09386 *          On entry,  UPLO  specifies  which trapezoidal part of the ar-
09387 *          ray A is to be set as follows:
09388 *             = 'L' or 'l':   Lower triangular part is set; the strictly
09389 *                             upper triangular part of A is not changed,
09390 *             = 'U' or 'u':   Upper triangular part is set; the strictly
09391 *                             lower triangular part of A is not changed,
09392 *             = 'D' or 'd'    Only the diagonal of A is set,
09393 *             Otherwise:      All of the array A is set.
09394 *
09395 *  M       (input) INTEGER
09396 *          On entry,  M  specifies the number of rows of the array A.  M
09397 *          must be at least zero.
09398 *
09399 *  N       (input) INTEGER
09400 *          On entry,  N  specifies the number of columns of the array A.
09401 *          N must be at least zero.
09402 *
09403 *  IOFFD   (input) INTEGER
09404 *          On entry, IOFFD specifies the position of the offdiagonal de-
09405 *          limiting the upper and lower trapezoidal part of A as follows
09406 *          (see the notes below):
09407 *
09408 *             IOFFD = 0  specifies the main diagonal A( i, i ),
09409 *                        with i = 1 ... MIN( M, N ),
09410 *             IOFFD > 0  specifies the subdiagonal   A( i+IOFFD, i ),
09411 *                        with i = 1 ... MIN( M-IOFFD, N ),
09412 *             IOFFD < 0  specifies the superdiagonal A( i, i-IOFFD ),
09413 *                        with i = 1 ... MIN( M, N+IOFFD ).
09414 *
09415 *  ALPHA   (input) REAL
09416 *          On entry,  ALPHA specifies the value to which the offdiagonal
09417 *          array elements are set to.
09418 *
09419 *  BETA    (input) REAL
09420 *          On entry, BETA  specifies the value to which the diagonal ar-
09421 *          ray elements are set to.
09422 *
09423 *  A       (input/output) REAL array
09424 *          On entry, A is an array of dimension  (LDA,N).  Before  entry
09425 *          with UPLO = 'U' or 'u', the leading m by n part of the  array
09426 *          A  must  contain  the upper trapezoidal part of the matrix as
09427 *          specified by IOFFD to be set, and  the  strictly lower trape-
09428 *          zoidal  part of A is not referenced; When IUPLO = 'L' or 'l',
09429 *          the leading m by n part of  the  array  A  must  contain  the
09430 *          lower trapezoidal part of the matrix as specified by IOFFD to
09431 *          be set,  and  the  strictly  upper  trapezoidal part of  A is
09432 *          not referenced.
09433 *
09434 *  LDA     (input) INTEGER
09435 *          On entry, LDA specifies the leading dimension of the array A.
09436 *          LDA must be at least max( 1, M ).
09437 *
09438 *  Notes
09439 *  =====
09440 *                           N                                    N
09441 *             ----------------------------                  -----------
09442 *            |       d                    |                |           |
09443 *          M |         d        'U'       |                |      'U'  |
09444 *            |  'L'     'D'               |                |d          |
09445 *            |             d              |              M |  d        |
09446 *             ----------------------------                 |   'D'     |
09447 *                                                          |      d    |
09448 *               IOFFD < 0                                  | 'L'    d  |
09449 *                                                          |          d|
09450 *                  N                                       |           |
09451 *             -----------                                   -----------
09452 *            |    d   'U'|
09453 *            |      d    |                                   IOFFD > 0
09454 *          M |       'D' |
09455 *            |          d|                              N
09456 *            |  'L'      |                 ----------------------------
09457 *            |           |                |          'U'               |
09458 *            |           |                |d                           |
09459 *            |           |                | 'D'                        |
09460 *            |           |                |    d                       |
09461 *            |           |                |'L'   d                     |
09462 *             -----------                  ----------------------------
09463 *
09464 *  -- Written on April 1, 1998 by
09465 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
09466 *
09467 *  =====================================================================
09468 *
09469 *     .. Local Scalars ..
09470       INTEGER            I, J, JTMP, MN
09471 *     ..
09472 *     .. External Functions ..
09473       LOGICAL            LSAME
09474       EXTERNAL           LSAME
09475 *     ..
09476 *     .. Intrinsic Functions ..
09477       INTRINSIC          MAX, MIN
09478 *     ..
09479 *     .. Executable Statements ..
09480 *
09481 *     Quick return if possible
09482 *
09483       IF( M.LE.0 .OR. N.LE.0 )
09484      $   RETURN
09485 *
09486 *     Start the operations
09487 *
09488       IF( LSAME( UPLO, 'L' ) ) THEN
09489 *
09490 *        Set the diagonal to BETA and the strictly lower triangular
09491 *        part of the array to ALPHA.
09492 *
09493          MN = MAX( 0, -IOFFD )
09494          DO 20 J = 1, MIN( MN, N )
09495             DO 10 I = 1, M
09496                A( I, J ) = ALPHA
09497    10       CONTINUE
09498    20    CONTINUE
09499          DO 40 J = MN + 1, MIN( M - IOFFD, N )
09500             JTMP = J + IOFFD
09501             A( JTMP, J ) = BETA
09502             DO 30 I = JTMP + 1, M
09503                A( I, J ) = ALPHA
09504    30       CONTINUE
09505    40    CONTINUE
09506 *
09507       ELSE IF( LSAME( UPLO, 'U' ) ) THEN
09508 *
09509 *        Set the diagonal to BETA and the strictly upper triangular
09510 *        part of the array to ALPHA.
09511 *
09512          MN = MIN( M - IOFFD, N )
09513          DO 60 J = MAX( 0, -IOFFD ) + 1, MN
09514             JTMP = J + IOFFD
09515             DO 50 I = 1, JTMP - 1
09516                A( I, J ) = ALPHA
09517    50       CONTINUE
09518             A( JTMP, J ) = BETA
09519    60    CONTINUE
09520          DO 80 J = MAX( 0, MN ) + 1, N
09521             DO 70 I = 1, M
09522                A( I, J ) = ALPHA
09523    70       CONTINUE
09524    80    CONTINUE
09525 *
09526       ELSE IF( LSAME( UPLO, 'D' ) ) THEN
09527 *
09528 *        Set the array to BETA on the diagonal.
09529 *
09530          DO 90 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N )
09531             A( J + IOFFD, J ) = BETA
09532    90    CONTINUE
09533 *
09534       ELSE
09535 *
09536 *        Set the array to BETA on the diagonal and ALPHA on the
09537 *        offdiagonal.
09538 *
09539          DO 110 J = 1, N
09540             DO 100 I = 1, M
09541                A( I, J ) = ALPHA
09542   100       CONTINUE
09543   110    CONTINUE
09544          IF( ALPHA.NE.BETA .AND. IOFFD.LT.M .AND. IOFFD.GT.-N ) THEN
09545             DO 120 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N )
09546                A( J + IOFFD, J ) = BETA
09547   120       CONTINUE
09548          END IF
09549 *
09550       END IF
09551 *
09552       RETURN
09553 *
09554 *     End of PB_SLASET
09555 *
09556       END
09557       SUBROUTINE PB_SLASCAL( UPLO, M, N, IOFFD, ALPHA, A, LDA )
09558 *
09559 *  -- PBLAS test routine (version 2.0) --
09560 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
09561 *     and University of California, Berkeley.
09562 *     April 1, 1998
09563 *
09564 *     .. Scalar Arguments ..
09565       CHARACTER*1        UPLO
09566       INTEGER            IOFFD, LDA, M, N
09567       REAL               ALPHA
09568 *     ..
09569 *     .. Array Arguments ..
09570       REAL               A( LDA, * )
09571 *     ..
09572 *
09573 *  Purpose
09574 *  =======
09575 *
09576 *  PB_SLASCAL scales a two-dimensional array A by the scalar alpha.
09577 *
09578 *  Arguments
09579 *  =========
09580 *
09581 *  UPLO    (input) CHARACTER*1
09582 *          On entry,  UPLO  specifies  which trapezoidal part of the ar-
09583 *          ray A is to be scaled as follows:
09584 *             = 'L' or 'l':          the lower trapezoid of A is scaled,
09585 *             = 'U' or 'u':          the upper trapezoid of A is scaled,
09586 *             = 'D' or 'd':       diagonal specified by IOFFD is scaled,
09587 *             Otherwise:                   all of the array A is scaled.
09588 *
09589 *  M       (input) INTEGER
09590 *          On entry,  M  specifies the number of rows of the array A.  M
09591 *          must be at least zero.
09592 *
09593 *  N       (input) INTEGER
09594 *          On entry,  N  specifies the number of columns of the array A.
09595 *          N must be at least zero.
09596 *
09597 *  IOFFD   (input) INTEGER
09598 *          On entry, IOFFD specifies the position of the offdiagonal de-
09599 *          limiting the upper and lower trapezoidal part of A as follows
09600 *          (see the notes below):
09601 *
09602 *             IOFFD = 0  specifies the main diagonal A( i, i ),
09603 *                        with i = 1 ... MIN( M, N ),
09604 *             IOFFD > 0  specifies the subdiagonal   A( i+IOFFD, i ),
09605 *                        with i = 1 ... MIN( M-IOFFD, N ),
09606 *             IOFFD < 0  specifies the superdiagonal A( i, i-IOFFD ),
09607 *                        with i = 1 ... MIN( M, N+IOFFD ).
09608 *
09609 *  ALPHA   (input) REAL
09610 *          On entry, ALPHA specifies the scalar alpha.
09611 *
09612 *  A       (input/output) REAL array
09613 *          On entry, A is an array of dimension  (LDA,N).  Before  entry
09614 *          with  UPLO = 'U' or 'u', the leading m by n part of the array
09615 *          A must contain the upper trapezoidal  part  of the matrix  as
09616 *          specified by  IOFFD to be scaled, and the strictly lower tra-
09617 *          pezoidal part of A is not referenced; When UPLO = 'L' or 'l',
09618 *          the leading m by n part of the array A must contain the lower
09619 *          trapezoidal  part  of  the matrix as specified by IOFFD to be
09620 *          scaled,  and  the strictly upper trapezoidal part of A is not
09621 *          referenced. On exit, the entries of the  trapezoid part of  A
09622 *          determined by UPLO and IOFFD are scaled.
09623 *
09624 *  LDA     (input) INTEGER
09625 *          On entry, LDA specifies the leading dimension of the array A.
09626 *          LDA must be at least max( 1, M ).
09627 *
09628 *  Notes
09629 *  =====
09630 *                           N                                    N
09631 *             ----------------------------                  -----------
09632 *            |       d                    |                |           |
09633 *          M |         d        'U'       |                |      'U'  |
09634 *            |  'L'     'D'               |                |d          |
09635 *            |             d              |              M |  d        |
09636 *             ----------------------------                 |   'D'     |
09637 *                                                          |      d    |
09638 *              IOFFD < 0                                   | 'L'    d  |
09639 *                                                          |          d|
09640 *                  N                                       |           |
09641 *             -----------                                   -----------
09642 *            |    d   'U'|
09643 *            |      d    |                                   IOFFD > 0
09644 *          M |       'D' |
09645 *            |          d|                              N
09646 *            |  'L'      |                 ----------------------------
09647 *            |           |                |          'U'               |
09648 *            |           |                |d                           |
09649 *            |           |                | 'D'                        |
09650 *            |           |                |    d                       |
09651 *            |           |                |'L'   d                     |
09652 *             -----------                  ----------------------------
09653 *
09654 *  -- Written on April 1, 1998 by
09655 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
09656 *
09657 *  =====================================================================
09658 *
09659 *     .. Local Scalars ..
09660       INTEGER            I, J, JTMP, MN
09661 *     ..
09662 *     .. External Functions ..
09663       LOGICAL            LSAME
09664       EXTERNAL           LSAME
09665 *     ..
09666 *     .. Intrinsic Functions ..
09667       INTRINSIC          MAX, MIN
09668 *     ..
09669 *     .. Executable Statements ..
09670 *
09671 *     Quick return if possible
09672 *
09673       IF( M.LE.0 .OR. N.LE.0 )
09674      $   RETURN
09675 *
09676 *     Start the operations
09677 *
09678       IF( LSAME( UPLO, 'L' ) ) THEN
09679 *
09680 *        Scales the lower triangular part of the array by ALPHA.
09681 *
09682          MN = MAX( 0, -IOFFD )
09683          DO 20 J = 1, MIN( MN, N )
09684             DO 10 I = 1, M
09685                A( I, J ) = ALPHA * A( I, J )
09686    10       CONTINUE
09687    20    CONTINUE
09688          DO 40 J = MN + 1, MIN( M - IOFFD, N )
09689             DO 30 I = J + IOFFD, M
09690                A( I, J ) = ALPHA * A( I, J )
09691    30       CONTINUE
09692    40    CONTINUE
09693 *
09694       ELSE IF( LSAME( UPLO, 'U' ) ) THEN
09695 *
09696 *        Scales the upper triangular part of the array by ALPHA.
09697 *
09698          MN = MIN( M - IOFFD, N )
09699          DO 60 J = MAX( 0, -IOFFD ) + 1, MN
09700             DO 50 I = 1, J + IOFFD
09701                A( I, J ) = ALPHA * A( I, J )
09702    50       CONTINUE
09703    60    CONTINUE
09704          DO 80 J = MAX( 0, MN ) + 1, N
09705             DO 70 I = 1, M
09706                A( I, J ) = ALPHA * A( I, J )
09707    70       CONTINUE
09708    80    CONTINUE
09709 *
09710       ELSE IF( LSAME( UPLO, 'D' ) ) THEN
09711 *
09712 *        Scales the diagonal entries by ALPHA.
09713 *
09714          DO 90 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N )
09715             JTMP = J + IOFFD
09716             A( JTMP, J ) = ALPHA * A( JTMP, J )
09717    90    CONTINUE
09718 *
09719       ELSE
09720 *
09721 *        Scales the entire array by ALPHA.
09722 *
09723          DO 110 J = 1, N
09724             DO 100 I = 1, M
09725                A( I, J ) = ALPHA * A( I, J )
09726   100       CONTINUE
09727   110    CONTINUE
09728 *
09729       END IF
09730 *
09731       RETURN
09732 *
09733 *     End of PB_SLASCAL
09734 *
09735       END
09736       SUBROUTINE PB_SLAGEN( UPLO, AFORM, A, LDA, LCMT00, IRAN, MBLKS,
09737      $                      IMBLOC, MB, LMBLOC, NBLKS, INBLOC, NB,
09738      $                      LNBLOC, JMP, IMULADD )
09739 *
09740 *  -- PBLAS test routine (version 2.0) --
09741 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
09742 *     and University of California, Berkeley.
09743 *     April 1, 1998
09744 *
09745 *     .. Scalar Arguments ..
09746       CHARACTER*1        UPLO, AFORM
09747       INTEGER            IMBLOC, INBLOC, LCMT00, LDA, LMBLOC, LNBLOC,
09748      $                   MB, MBLKS, NB, NBLKS
09749 *     ..
09750 *     .. Array Arguments ..
09751       INTEGER            IMULADD( 4, * ), IRAN( * ), JMP( * )
09752       REAL               A( LDA, * )
09753 *     ..
09754 *
09755 *  Purpose
09756 *  =======
09757 *
09758 *  PB_SLAGEN locally initializes an array A.
09759 *
09760 *  Arguments
09761 *  =========
09762 *
09763 *  UPLO    (global input) CHARACTER*1
09764 *          On entry, UPLO  specifies whether the lower (UPLO='L') trape-
09765 *          zoidal part or the upper (UPLO='U') trapezoidal part is to be
09766 *          generated  when  the  matrix  to be generated is symmetric or
09767 *          Hermitian. For  all  the  other values of AFORM, the value of
09768 *          this input argument is ignored.
09769 *
09770 *  AFORM   (global input) CHARACTER*1
09771 *          On entry, AFORM specifies the type of submatrix to be genera-
09772 *          ted as follows:
09773 *             AFORM = 'S', sub( A ) is a symmetric matrix,
09774 *             AFORM = 'H', sub( A ) is a Hermitian matrix,
09775 *             AFORM = 'T', sub( A ) is overrwritten  with  the transpose
09776 *                          of what would normally be generated,
09777 *             AFORM = 'C', sub( A ) is overwritten  with  the  conjugate
09778 *                          transpose  of  what would normally be genera-
09779 *                          ted.
09780 *             AFORM = 'N', a random submatrix is generated.
09781 *
09782 *  A       (local output) REAL array
09783 *          On entry,  A  is  an array of dimension (LLD_A, *).  On exit,
09784 *          this array contains the local entries of the randomly genera-
09785 *          ted submatrix sub( A ).
09786 *
09787 *  LDA     (local input) INTEGER
09788 *          On entry,  LDA  specifies  the local leading dimension of the
09789 *          array A. LDA must be at least one.
09790 *
09791 *  LCMT00  (global input) INTEGER
09792 *          On entry, LCMT00 is the LCM value specifying the off-diagonal
09793 *          of the underlying matrix of interest. LCMT00=0 specifies  the
09794 *          main diagonal, LCMT00 > 0 specifies a subdiagonal, LCMT00 < 0
09795 *          specifies superdiagonals.
09796 *
09797 *  IRAN    (local input) INTEGER array
09798 *          On entry, IRAN  is an array of dimension 2 containing respec-
09799 *          tively the 16-lower and 16-higher bits of the encoding of the
09800 *          entry of  the  random  sequence  corresponding locally to the
09801 *          first local array entry to generate. Usually,  this  array is
09802 *          computed by PB_SETLOCRAN.
09803 *
09804 *  MBLKS   (local input) INTEGER
09805 *          On entry, MBLKS specifies the local number of blocks of rows.
09806 *          MBLKS is at least zero.
09807 *
09808 *  IMBLOC  (local input) INTEGER
09809 *          On entry, IMBLOC specifies  the  number of rows (size) of the
09810 *          local uppest  blocks. IMBLOC is at least zero.
09811 *
09812 *  MB      (global input) INTEGER
09813 *          On entry, MB  specifies the blocking factor used to partition
09814 *          the rows of the matrix.  MB  must be at least one.
09815 *
09816 *  LMBLOC  (local input) INTEGER
09817 *          On entry, LMBLOC specifies the number of  rows  (size) of the
09818 *          local lowest blocks. LMBLOC is at least zero.
09819 *
09820 *  NBLKS   (local input) INTEGER
09821 *          On entry,  NBLKS  specifies the local number of blocks of co-
09822 *          lumns. NBLKS is at least zero.
09823 *
09824 *  INBLOC  (local input) INTEGER
09825 *          On entry,  INBLOC  specifies the number of columns (size)  of
09826 *          the local leftmost blocks. INBLOC is at least zero.
09827 *
09828 *  NB      (global input) INTEGER
09829 *          On entry, NB  specifies the blocking factor used to partition
09830 *          the the columns of the matrix.  NB  must be at least one.
09831 *
09832 *  LNBLOC  (local input) INTEGER
09833 *          On entry,  LNBLOC  specifies  the number of columns (size) of
09834 *          the local rightmost blocks. LNBLOC is at least zero.
09835 *
09836 *  JMP     (local input) INTEGER array
09837 *          On entry, JMP is an array of dimension JMP_LEN containing the
09838 *          different jump values used by the random matrix generator.
09839 *
09840 *  IMULADD (local input) INTEGER array
09841 *          On entry, IMULADD is an array of dimension (4, JMP_LEN).  The
09842 *          jth  column  of this array contains the encoded initial cons-
09843 *          tants a_j and c_j to  jump  from X( n ) to  X( n + JMP( j ) )
09844 *          (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
09845 *          contains respectively the 16-lower and 16-higher bits of  the
09846 *          constant a_j, and IMULADD(3:4,j)  contains  the 16-lower  and
09847 *          16-higher bits of the constant c_j.
09848 *
09849 *  -- Written on April 1, 1998 by
09850 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
09851 *
09852 *  =====================================================================
09853 *
09854 *     .. Parameters ..
09855       INTEGER            JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
09856      $                   JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
09857      $                   JMP_NQINBLOC, JMP_NQNB, JMP_ROW
09858       PARAMETER          ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3,
09859      $                   JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6,
09860      $                   JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9,
09861      $                   JMP_NQNB = 10, JMP_NQINBLOC = 11,
09862      $                   JMP_LEN = 11 )
09863 *     ..
09864 *     .. Local Scalars ..
09865       INTEGER            I, IB, IBLK, II, IK, ITMP, JB, JBLK, JJ, JK,
09866      $                   JTMP, LCMTC, LCMTR, LOW, MNB, UPP
09867       REAL               DUMMY
09868 *     ..
09869 *     .. Local Arrays ..
09870       INTEGER            IB0( 2 ), IB1( 2 ), IB2( 2 ), IB3( 2 )
09871 *     ..
09872 *     .. External Subroutines ..
09873       EXTERNAL           PB_JUMPIT
09874 *     ..
09875 *     .. External Functions ..
09876       LOGICAL            LSAME
09877       REAL               PB_SRAND
09878       EXTERNAL           LSAME, PB_SRAND
09879 *     ..
09880 *     .. Intrinsic Functions ..
09881       INTRINSIC          MAX, MIN
09882 *     ..
09883 *     .. Executable Statements ..
09884 *
09885       DO 10 I = 1, 2
09886          IB1( I ) = IRAN( I )
09887          IB2( I ) = IRAN( I )
09888          IB3( I ) = IRAN( I )
09889    10 CONTINUE
09890 *
09891       IF( LSAME( AFORM, 'N' ) ) THEN
09892 *
09893 *        Generate random matrix
09894 *
09895          JJ = 1
09896 *
09897          DO 50 JBLK = 1, NBLKS
09898 *
09899             IF( JBLK.EQ.1 ) THEN
09900                JB = INBLOC
09901             ELSE IF( JBLK.EQ.NBLKS ) THEN
09902                JB = LNBLOC
09903             ELSE
09904                JB = NB
09905             END IF
09906 *
09907             DO 40 JK = JJ, JJ + JB - 1
09908 *
09909                II = 1
09910 *
09911                DO 30 IBLK = 1, MBLKS
09912 *
09913                   IF( IBLK.EQ.1 ) THEN
09914                      IB = IMBLOC
09915                   ELSE IF( IBLK.EQ.MBLKS ) THEN
09916                      IB = LMBLOC
09917                   ELSE
09918                      IB = MB
09919                   END IF
09920 *
09921 *                 Blocks are IB by JB
09922 *
09923                   DO 20 IK = II, II + IB - 1
09924                      A( IK, JK ) = PB_SRAND( 0 )
09925    20             CONTINUE
09926 *
09927                   II = II + IB
09928 *
09929                   IF( IBLK.EQ.1 ) THEN
09930 *
09931 *                    Jump IMBLOC + ( NPROW - 1 ) * MB rows
09932 *
09933                      CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1,
09934      $                               IB0 )
09935 *
09936                   ELSE
09937 *
09938 *                    Jump NPROW * MB rows
09939 *
09940                      CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1, IB0 )
09941 *
09942                   END IF
09943 *
09944                   IB1( 1 ) = IB0( 1 )
09945                   IB1( 2 ) = IB0( 2 )
09946 *
09947    30          CONTINUE
09948 *
09949 *              Jump one column
09950 *
09951                CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 )
09952 *
09953                IB1( 1 ) = IB0( 1 )
09954                IB1( 2 ) = IB0( 2 )
09955                IB2( 1 ) = IB0( 1 )
09956                IB2( 2 ) = IB0( 2 )
09957 *
09958    40       CONTINUE
09959 *
09960             JJ = JJ + JB
09961 *
09962             IF( JBLK.EQ.1 ) THEN
09963 *
09964 *              Jump INBLOC + ( NPCOL - 1 ) * NB columns
09965 *
09966                CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 )
09967 *
09968             ELSE
09969 *
09970 *              Jump NPCOL * NB columns
09971 *
09972                CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 )
09973 *
09974             END IF
09975 *
09976             IB1( 1 ) = IB0( 1 )
09977             IB1( 2 ) = IB0( 2 )
09978             IB2( 1 ) = IB0( 1 )
09979             IB2( 2 ) = IB0( 2 )
09980             IB3( 1 ) = IB0( 1 )
09981             IB3( 2 ) = IB0( 2 )
09982 *
09983    50    CONTINUE
09984 *
09985       ELSE IF( LSAME( AFORM, 'T' ) .OR. LSAME( AFORM, 'C' ) ) THEN
09986 *
09987 *        Generate the transpose of the matrix that would be normally
09988 *        generated.
09989 *
09990          II = 1
09991 *
09992          DO 90 IBLK = 1, MBLKS
09993 *
09994             IF( IBLK.EQ.1 ) THEN
09995                IB = IMBLOC
09996             ELSE IF( IBLK.EQ.MBLKS ) THEN
09997                IB = LMBLOC
09998             ELSE
09999                IB = MB
10000             END IF
10001 *
10002             DO 80 IK = II, II + IB - 1
10003 *
10004                JJ = 1
10005 *
10006                DO 70 JBLK = 1, NBLKS
10007 *
10008                   IF( JBLK.EQ.1 ) THEN
10009                      JB = INBLOC
10010                   ELSE IF( JBLK.EQ.NBLKS ) THEN
10011                      JB = LNBLOC
10012                   ELSE
10013                      JB = NB
10014                   END IF
10015 *
10016 *                 Blocks are IB by JB
10017 *
10018                   DO 60 JK = JJ, JJ + JB - 1
10019                      A( IK, JK ) = PB_SRAND( 0 )
10020    60             CONTINUE
10021 *
10022                   JJ = JJ + JB
10023 *
10024                   IF( JBLK.EQ.1 ) THEN
10025 *
10026 *                    Jump INBLOC + ( NPCOL - 1 ) * NB columns
10027 *
10028                      CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
10029      $                               IB0 )
10030 *
10031                   ELSE
10032 *
10033 *                    Jump NPCOL * NB columns
10034 *
10035                      CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1, IB0 )
10036 *
10037                   END IF
10038 *
10039                   IB1( 1 ) = IB0( 1 )
10040                   IB1( 2 ) = IB0( 2 )
10041 *
10042    70          CONTINUE
10043 *
10044 *              Jump one row
10045 *
10046                CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
10047 *
10048                IB1( 1 ) = IB0( 1 )
10049                IB1( 2 ) = IB0( 2 )
10050                IB2( 1 ) = IB0( 1 )
10051                IB2( 2 ) = IB0( 2 )
10052 *
10053    80       CONTINUE
10054 *
10055             II = II + IB
10056 *
10057             IF( IBLK.EQ.1 ) THEN
10058 *
10059 *              Jump IMBLOC + ( NPROW - 1 ) * MB rows
10060 *
10061                CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
10062 *
10063             ELSE
10064 *
10065 *              Jump NPROW * MB rows
10066 *
10067                CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
10068 *
10069             END IF
10070 *
10071             IB1( 1 ) = IB0( 1 )
10072             IB1( 2 ) = IB0( 2 )
10073             IB2( 1 ) = IB0( 1 )
10074             IB2( 2 ) = IB0( 2 )
10075             IB3( 1 ) = IB0( 1 )
10076             IB3( 2 ) = IB0( 2 )
10077 *
10078    90    CONTINUE
10079 *
10080       ELSE IF( ( LSAME( AFORM, 'S' ) ).OR.( LSAME( AFORM, 'H' ) ) ) THEN
10081 *
10082 *        Generate a symmetric matrix
10083 *
10084          IF( LSAME( UPLO, 'L' ) ) THEN
10085 *
10086 *           generate lower trapezoidal part
10087 *
10088             JJ = 1
10089             LCMTC = LCMT00
10090 *
10091             DO 170 JBLK = 1, NBLKS
10092 *
10093                IF( JBLK.EQ.1 ) THEN
10094                   JB  = INBLOC
10095                   LOW = 1 - INBLOC
10096                ELSE IF( JBLK.EQ.NBLKS ) THEN
10097                   JB = LNBLOC
10098                   LOW = 1 - NB
10099                ELSE
10100                   JB  = NB
10101                   LOW = 1 - NB
10102                END IF
10103 *
10104                DO 160 JK = JJ, JJ + JB - 1
10105 *
10106                   II = 1
10107                   LCMTR = LCMTC
10108 *
10109                   DO 150 IBLK = 1, MBLKS
10110 *
10111                      IF( IBLK.EQ.1 ) THEN
10112                         IB  = IMBLOC
10113                         UPP = IMBLOC - 1
10114                      ELSE IF( IBLK.EQ.MBLKS ) THEN
10115                         IB  = LMBLOC
10116                         UPP = MB - 1
10117                      ELSE
10118                         IB  = MB
10119                         UPP = MB - 1
10120                      END IF
10121 *
10122 *                    Blocks are IB by JB
10123 *
10124                      IF( LCMTR.GT.UPP ) THEN
10125 *
10126                         DO 100 IK = II, II + IB - 1
10127                            DUMMY = PB_SRAND( 0 )
10128   100                   CONTINUE
10129 *
10130                      ELSE IF( LCMTR.GE.LOW ) THEN
10131 *
10132                         JTMP = JK - JJ + 1
10133                         MNB  = MAX( 0, -LCMTR )
10134 *
10135                         IF( JTMP.LE.MIN( MNB, JB ) ) THEN
10136 *
10137                            DO 110 IK = II, II + IB - 1
10138                               A( IK, JK ) = PB_SRAND( 0 )
10139   110                      CONTINUE
10140 *
10141                         ELSE IF( ( JTMP.GE.( MNB + 1 )         ) .AND.
10142      $                           ( JTMP.LE.MIN( IB-LCMTR, JB ) ) ) THEN
10143 *
10144                            ITMP = II + JTMP + LCMTR - 1
10145 *
10146                            DO 120 IK = II, ITMP - 1
10147                               DUMMY = PB_SRAND( 0 )
10148   120                      CONTINUE
10149 *
10150                            DO 130 IK = ITMP, II + IB - 1
10151                               A( IK, JK ) = PB_SRAND( 0 )
10152   130                      CONTINUE
10153 *
10154                         END IF
10155 *
10156                      ELSE
10157 *
10158                         DO 140 IK = II, II + IB - 1
10159                            A( IK, JK ) = PB_SRAND( 0 )
10160   140                   CONTINUE
10161 *
10162                      END IF
10163 *
10164                      II = II + IB
10165 *
10166                      IF( IBLK.EQ.1 ) THEN
10167 *
10168 *                       Jump IMBLOC + ( NPROW - 1 ) * MB rows
10169 *
10170                         LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
10171                         CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1,
10172      $                                  IB0 )
10173 *
10174                      ELSE
10175 *
10176 *                       Jump NPROW * MB rows
10177 *
10178                         LCMTR = LCMTR - JMP( JMP_NPMB )
10179                         CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1,
10180      $                                  IB0 )
10181 *
10182                      END IF
10183 *
10184                      IB1( 1 ) = IB0( 1 )
10185                      IB1( 2 ) = IB0( 2 )
10186 *
10187   150             CONTINUE
10188 *
10189 *                 Jump one column
10190 *
10191                   CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 )
10192 *
10193                   IB1( 1 ) = IB0( 1 )
10194                   IB1( 2 ) = IB0( 2 )
10195                   IB2( 1 ) = IB0( 1 )
10196                   IB2( 2 ) = IB0( 2 )
10197 *
10198   160          CONTINUE
10199 *
10200                JJ = JJ + JB
10201 *
10202                IF( JBLK.EQ.1 ) THEN
10203 *
10204 *                 Jump INBLOC + ( NPCOL - 1 ) * NB columns
10205 *
10206                   LCMTC = LCMTC + JMP( JMP_NQINBLOC )
10207                   CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 )
10208 *
10209                ELSE
10210 *
10211 *                 Jump NPCOL * NB columns
10212 *
10213                   LCMTC = LCMTC + JMP( JMP_NQNB )
10214                   CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 )
10215 *
10216                END IF
10217 *
10218                IB1( 1 ) = IB0( 1 )
10219                IB1( 2 ) = IB0( 2 )
10220                IB2( 1 ) = IB0( 1 )
10221                IB2( 2 ) = IB0( 2 )
10222                IB3( 1 ) = IB0( 1 )
10223                IB3( 2 ) = IB0( 2 )
10224 *
10225   170       CONTINUE
10226 *
10227          ELSE
10228 *
10229 *           generate upper trapezoidal part
10230 *
10231             II = 1
10232             LCMTR = LCMT00
10233 *
10234             DO 250 IBLK = 1, MBLKS
10235 *
10236                IF( IBLK.EQ.1 ) THEN
10237                   IB  = IMBLOC
10238                   UPP = IMBLOC - 1
10239                ELSE IF( IBLK.EQ.MBLKS ) THEN
10240                   IB  = LMBLOC
10241                   UPP = MB - 1
10242                ELSE
10243                   IB  = MB
10244                   UPP = MB - 1
10245                END IF
10246 *
10247                DO 240 IK = II, II + IB - 1
10248 *
10249                   JJ = 1
10250                   LCMTC = LCMTR
10251 *
10252                   DO 230 JBLK = 1, NBLKS
10253 *
10254                      IF( JBLK.EQ.1 ) THEN
10255                         JB  = INBLOC
10256                         LOW = 1 - INBLOC
10257                      ELSE IF( JBLK.EQ.NBLKS ) THEN
10258                         JB  = LNBLOC
10259                         LOW = 1 - NB
10260                      ELSE
10261                         JB  = NB
10262                         LOW = 1 - NB
10263                      END IF
10264 *
10265 *                    Blocks are IB by JB
10266 *
10267                      IF( LCMTC.LT.LOW ) THEN
10268 *
10269                         DO 180 JK = JJ, JJ + JB - 1
10270                            DUMMY = PB_SRAND( 0 )
10271   180                   CONTINUE
10272 *
10273                      ELSE IF( LCMTC.LE.UPP ) THEN
10274 *
10275                         ITMP = IK - II + 1
10276                         MNB  = MAX( 0, LCMTC )
10277 *
10278                         IF( ITMP.LE.MIN( MNB, IB ) ) THEN
10279 *
10280                            DO 190 JK = JJ, JJ + JB - 1
10281                               A( IK, JK ) = PB_SRAND( 0 )
10282   190                      CONTINUE
10283 *
10284                         ELSE IF( ( ITMP.GE.( MNB + 1 )         ) .AND.
10285      $                           ( ITMP.LE.MIN( JB+LCMTC, IB ) ) ) THEN
10286 *
10287                            JTMP = JJ + ITMP - LCMTC - 1
10288 *
10289                            DO 200 JK = JJ, JTMP - 1
10290                               DUMMY = PB_SRAND( 0 )
10291   200                      CONTINUE
10292 *
10293                            DO 210 JK = JTMP, JJ + JB - 1
10294                               A( IK, JK ) = PB_SRAND( 0 )
10295   210                      CONTINUE
10296 *
10297                         END IF
10298 *
10299                      ELSE
10300 *
10301                         DO 220 JK = JJ, JJ + JB - 1
10302                            A( IK, JK ) = PB_SRAND( 0 )
10303   220                   CONTINUE
10304 *
10305                      END IF
10306 *
10307                      JJ = JJ + JB
10308 *
10309                      IF( JBLK.EQ.1 ) THEN
10310 *
10311 *                       Jump INBLOC + ( NPCOL - 1 ) * NB columns
10312 *
10313                         LCMTC = LCMTC + JMP( JMP_NQINBLOC )
10314                         CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
10315      $                                  IB0 )
10316 *
10317                      ELSE
10318 *
10319 *                       Jump NPCOL * NB columns
10320 *
10321                         LCMTC = LCMTC + JMP( JMP_NQNB )
10322                         CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1,
10323      $                                  IB0 )
10324 *
10325                      END IF
10326 *
10327                      IB1( 1 ) = IB0( 1 )
10328                      IB1( 2 ) = IB0( 2 )
10329 *
10330   230             CONTINUE
10331 *
10332 *                 Jump one row
10333 *
10334                   CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
10335 *
10336                   IB1( 1 ) = IB0( 1 )
10337                   IB1( 2 ) = IB0( 2 )
10338                   IB2( 1 ) = IB0( 1 )
10339                   IB2( 2 ) = IB0( 2 )
10340 *
10341   240          CONTINUE
10342 *
10343                II = II + IB
10344 *
10345                IF( IBLK.EQ.1 ) THEN
10346 *
10347 *                 Jump IMBLOC + ( NPROW - 1 ) * MB rows
10348 *
10349                   LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
10350                   CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
10351 *
10352                ELSE
10353 *
10354 *                 Jump NPROW * MB rows
10355 *
10356                   LCMTR = LCMTR - JMP( JMP_NPMB )
10357                   CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
10358 *
10359                END IF
10360 *
10361                IB1( 1 ) = IB0( 1 )
10362                IB1( 2 ) = IB0( 2 )
10363                IB2( 1 ) = IB0( 1 )
10364                IB2( 2 ) = IB0( 2 )
10365                IB3( 1 ) = IB0( 1 )
10366                IB3( 2 ) = IB0( 2 )
10367 *
10368   250       CONTINUE
10369 *
10370          END IF
10371 *
10372       END IF
10373 *
10374       RETURN
10375 *
10376 *     End of PB_SLAGEN
10377 *
10378       END
10379       REAL               FUNCTION PB_SRAND( IDUMM )
10380 *
10381 *  -- PBLAS test routine (version 2.0) --
10382 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
10383 *     and University of California, Berkeley.
10384 *     April 1, 1998
10385 *
10386 *     .. Scalar Arguments ..
10387       INTEGER            IDUMM
10388 *     ..
10389 *
10390 *  Purpose
10391 *  =======
10392 *
10393 *  PB_SRAND generates the next number in the random sequence. This func-
10394 *  tion ensures that this number will be in the interval ( -1.0, 1.0 ).
10395 *
10396 *  Arguments
10397 *  =========
10398 *
10399 *  IDUMM   (local input) INTEGER
10400 *          This argument is ignored, but necessary to a FORTRAN 77 func-
10401 *          tion.
10402 *
10403 *  Further Details
10404 *  ===============
10405 *
10406 *  On entry, the array IRAND stored in the common block  RANCOM contains
10407 *  the information (2 integers)  required to generate the next number in
10408 *  the sequence X( n ). This number is computed as
10409 *
10410 *     X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
10411 *
10412 *  where the constant d is the  largest  32 bit  positive  integer.  The
10413 *  array  IRAND  is  then  updated for the generation of the next number
10414 *  X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
10415 *  The constants  a  and c  should have been preliminarily stored in the
10416 *  array  IACS  as  2 pairs of integers. The initial set up of IRAND and
10417 *  IACS is performed by the routine PB_SETRAN.
10418 *
10419 *  -- Written on April 1, 1998 by
10420 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
10421 *
10422 *  =====================================================================
10423 *
10424 *     .. Parameters ..
10425       REAL               ONE, TWO
10426       PARAMETER          ( ONE = 1.0E+0, TWO = 2.0E+0 )
10427 *     ..
10428 *     .. External Functions ..
10429       REAL               PB_SRAN
10430       EXTERNAL           PB_SRAN
10431 *     ..
10432 *     .. Executable Statements ..
10433 *
10434       PB_SRAND = ONE - TWO * PB_SRAN( IDUMM )
10435 *
10436       RETURN
10437 *
10438 *     End of PB_SRAND
10439 *
10440       END
10441       REAL               FUNCTION PB_SRAN( IDUMM )
10442 *
10443 *  -- PBLAS test routine (version 2.0) --
10444 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
10445 *     and University of California, Berkeley.
10446 *     April 1, 1998
10447 *
10448 *     .. Scalar Arguments ..
10449       INTEGER            IDUMM
10450 *     ..
10451 *
10452 *  Purpose
10453 *  =======
10454 *
10455 *  PB_SRAN generates the next number in the random sequence.
10456 *
10457 *  Arguments
10458 *  =========
10459 *
10460 *  IDUMM   (local input) INTEGER
10461 *          This argument is ignored, but necessary to a FORTRAN 77 func-
10462 *          tion.
10463 *
10464 *  Further Details
10465 *  ===============
10466 *
10467 *  On entry, the array IRAND stored in the common block  RANCOM contains
10468 *  the information (2 integers)  required to generate the next number in
10469 *  the sequence X( n ). This number is computed as
10470 *
10471 *     X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
10472 *
10473 *  where the constant d is the  largest  32 bit  positive  integer.  The
10474 *  array  IRAND  is  then  updated for the generation of the next number
10475 *  X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
10476 *  The constants  a  and c  should have been preliminarily stored in the
10477 *  array  IACS  as  2 pairs of integers. The initial set up of IRAND and
10478 *  IACS is performed by the routine PB_SETRAN.
10479 *
10480 *  -- Written on April 1, 1998 by
10481 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
10482 *
10483 *  =====================================================================
10484 *
10485 *     .. Parameters ..
10486       REAL               DIVFAC, POW16
10487       PARAMETER          ( DIVFAC = 2.147483648E+9,
10488      $                   POW16 = 6.5536E+4 )
10489 *     ..
10490 *     .. Local Arrays ..
10491       INTEGER            J( 2 )
10492 *     ..
10493 *     .. External Subroutines ..
10494       EXTERNAL           PB_LADD, PB_LMUL
10495 *     ..
10496 *     .. Intrinsic Functions ..
10497       INTRINSIC          REAL
10498 *     ..
10499 *     .. Common Blocks ..
10500       INTEGER            IACS( 4 ), IRAND( 2 )
10501       COMMON             /RANCOM/ IRAND, IACS
10502 *     ..
10503 *     .. Save Statements ..
10504       SAVE               /RANCOM/
10505 *     ..
10506 *     .. Executable Statements ..
10507 *
10508       PB_SRAN = ( REAL( IRAND( 1 ) ) + POW16 * REAL( IRAND( 2 ) ) ) /
10509      $            DIVFAC
10510 *
10511       CALL PB_LMUL( IRAND, IACS, J )
10512       CALL PB_LADD( J, IACS( 3 ), IRAND )
10513 *
10514       RETURN
10515 *
10516 *     End of PB_SRAN
10517 *
10518       END