ScaLAPACK  2.0.2 ScaLAPACK: Scalable Linear Algebra PACKage
pzlanhe.f
Go to the documentation of this file.
```00001       DOUBLE PRECISION FUNCTION PZLANHE( NORM, UPLO, N, A, IA, JA,
00002      \$                                   DESCA, WORK )
00003 *
00004 *  -- ScaLAPACK auxiliary routine (version 1.7) --
00005 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
00006 *     and University of California, Berkeley.
00007 *     May 1, 1997
00008 *
00009 *     .. Scalar Arguments ..
00010       CHARACTER          NORM, UPLO
00011       INTEGER            IA, JA, N
00012 *     ..
00013 *     .. Array Arguments ..
00014       INTEGER            DESCA( * )
00015       DOUBLE PRECISION   WORK( * )
00016       COMPLEX*16         A( * )
00017 *     ..
00018 *
00019 *  Purpose
00020 *  =======
00021 *
00022 *  PZLANHE returns the value of the one norm, or the Frobenius norm,
00023 *  or the infinity norm, or the element of largest absolute value of a
00024 *  complex hermitian distributed matrix sub(A) = A(IA:IA+N-1,JA:JA+N-1).
00025 *
00026 *  PZLANHE returns the value
00027 *
00028 *     ( max(abs(A(i,j))),  NORM = 'M' or 'm' with IA <= i <= IA+N-1,
00029 *     (                                      and  JA <= j <= JA+N-1,
00030 *     (
00031 *     ( norm1( sub( A ) ), NORM = '1', 'O' or 'o'
00032 *     (
00033 *     ( normI( sub( A ) ), NORM = 'I' or 'i'
00034 *     (
00035 *     ( normF( sub( A ) ), NORM = 'F', 'f', 'E' or 'e'
00036 *
00037 *  where norm1  denotes the  one norm of a matrix (maximum column sum),
00038 *  normI denotes the  infinity norm  of a matrix  (maximum row sum) and
00039 *  normF denotes the  Frobenius norm of a matrix (square root of sum of
00040 *  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
00041 *
00042 *  Notes
00043 *  =====
00044 *
00045 *  Each global data object is described by an associated description
00046 *  vector.  This vector stores the information required to establish
00047 *  the mapping between an object element and its corresponding process
00048 *  and memory location.
00049 *
00050 *  Let A be a generic term for any 2D block cyclicly distributed array.
00051 *  Such a global array has an associated description vector DESCA.
00052 *  In the following comments, the character _ should be read as
00053 *  "of the global array".
00054 *
00055 *  NOTATION        STORED IN      EXPLANATION
00056 *  --------------- -------------- --------------------------------------
00057 *  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
00058 *                                 DTYPE_A = 1.
00059 *  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
00060 *                                 the BLACS process grid A is distribu-
00061 *                                 ted over. The context itself is glo-
00062 *                                 bal, but the handle (the integer
00063 *                                 value) may vary.
00064 *  M_A    (global) DESCA( M_ )    The number of rows in the global
00065 *                                 array A.
00066 *  N_A    (global) DESCA( N_ )    The number of columns in the global
00067 *                                 array A.
00068 *  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
00069 *                                 the rows of the array.
00070 *  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
00071 *                                 the columns of the array.
00072 *  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
00073 *                                 row of the array A is distributed.
00074 *  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
00075 *                                 first column of the array A is
00076 *                                 distributed.
00077 *  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
00078 *                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
00079 *
00080 *  Let K be the number of rows or columns of a distributed matrix,
00081 *  and assume that its process grid has dimension p x q.
00082 *  LOCr( K ) denotes the number of elements of K that a process
00083 *  would receive if K were distributed over the p processes of its
00084 *  process column.
00085 *  Similarly, LOCc( K ) denotes the number of elements of K that a
00086 *  process would receive if K were distributed over the q processes of
00087 *  its process row.
00088 *  The values of LOCr() and LOCc() may be determined via a call to the
00089 *  ScaLAPACK tool function, NUMROC:
00090 *          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
00091 *          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
00092 *  An upper bound for these quantities may be computed by:
00093 *          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
00094 *          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
00095 *
00096 *  Arguments
00097 *  =========
00098 *
00099 *  NORM    (global input) CHARACTER
00100 *          Specifies the value to be returned in PZLANHE as described
00101 *          above.
00102 *
00103 *  UPLO    (global input) CHARACTER
00104 *          Specifies whether the upper or lower triangular part of the
00105 *          hermitian matrix sub( A ) is to be referenced.
00106 *          = 'U':  Upper triangular part of sub( A ) is referenced,
00107 *          = 'L':  Lower triangular part of sub( A ) is referenced.
00108 *
00109 *  N       (global input) INTEGER
00110 *          The number of rows and columns to be operated on i.e the
00111 *          number of rows and columns of the distributed submatrix
00112 *          sub( A ). When N = 0, PZLANHE is set to zero. N >= 0.
00113 *
00114 *  A       (local input) COMPLEX*16 pointer into the local memory
00115 *          to an array of dimension (LLD_A, LOCc(JA+N-1)) containing the
00116 *          local pieces of the hermitian distributed matrix sub( A ).
00117 *          If UPLO = 'U', the leading N-by-N upper triangular part of
00118 *          sub( A ) contains the upper triangular matrix which norm is
00119 *          to be computed, and the strictly lower triangular part of
00120 *          this matrix is not referenced.  If UPLO = 'L', the leading
00121 *          N-by-N lower triangular part of sub( A ) contains the lower
00122 *          triangular matrix which norm is to be computed, and the
00123 *          strictly upper triangular part of sub( A ) is not referenced.
00124 *
00125 *  IA      (global input) INTEGER
00126 *          The row index in the global array A indicating the first
00127 *          row of sub( A ).
00128 *
00129 *  JA      (global input) INTEGER
00130 *          The column index in the global array A indicating the
00131 *          first column of sub( A ).
00132 *
00133 *  DESCA   (global and local input) INTEGER array of dimension DLEN_.
00134 *          The array descriptor for the distributed matrix A.
00135 *
00136 *  WORK    (local workspace) DOUBLE PRECISION array dimension (LWORK)
00137 *          LWORK >= 0 if NORM = 'M' or 'm' (not referenced),
00138 *                   2*Nq0+Np0+LDW if NORM = '1', 'O', 'o', 'I' or 'i',
00139 *                     where LDW is given by:
00140 *                     IF( NPROW.NE.NPCOL ) THEN
00141 *                        LDW = MB_A*CEIL(CEIL(Np0/MB_A)/(LCM/NPROW))
00142 *                     ELSE
00143 *                        LDW = 0
00144 *                     END IF
00145 *                   0 if NORM = 'F', 'f', 'E' or 'e' (not referenced),
00146 *
00147 *          where LCM is the least common multiple of NPROW and NPCOL
00148 *          LCM = ILCM( NPROW, NPCOL ) and CEIL denotes the ceiling
00149 *          operation (ICEIL).
00150 *
00151 *          IROFFA = MOD( IA-1, MB_A ), ICOFFA = MOD( JA-1, NB_A ),
00152 *          IAROW = INDXG2P( IA, MB_A, MYROW, RSRC_A, NPROW ),
00153 *          IACOL = INDXG2P( JA, NB_A, MYCOL, CSRC_A, NPCOL ),
00154 *          Np0 = NUMROC( N+IROFFA, MB_A, MYROW, IAROW, NPROW ),
00155 *          Nq0 = NUMROC( N+ICOFFA, NB_A, MYCOL, IACOL, NPCOL ),
00156 *
00157 *          ICEIL, ILCM, INDXG2P and NUMROC are ScaLAPACK tool functions;
00158 *          MYROW, MYCOL, NPROW and NPCOL can be determined by calling
00159 *          the subroutine BLACS_GRIDINFO.
00160 *
00161 *  =====================================================================
00162 *
00163 *     .. Parameters ..
00164       INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
00165      \$                   LLD_, MB_, M_, NB_, N_, RSRC_
00166       PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
00167      \$                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
00168      \$                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
00169       DOUBLE PRECISION   ONE, ZERO
00170       PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
00171 *     ..
00172 *     .. Local Scalars ..
00173       INTEGER            I, IAROW, IACOL, IB, ICOFF, ICTXT, ICURCOL,
00174      \$                   ICURROW, II, IIA, IN, IROFF, ICSR, ICSR0,
00175      \$                   IOFFA, IRSC, IRSC0, IRSR, IRSR0, JJ, JJA, K,
00176      \$                   LDA, LL, MYCOL, MYROW, NP, NPCOL, NPROW, NQ
00177       DOUBLE PRECISION   ABSA, SCALE, SUM, VALUE
00178 *     ..
00179 *     .. Local Arrays ..
00180       DOUBLE PRECISION   RWORK( 2 )
00181 *     ..
00182 *     .. External Subroutines ..
00183       EXTERNAL           BLACS_GRIDINFO, DAXPY, DCOMBSSQ,
00184      \$                   DGAMX2D, DGSUM2D, DGEBR2D,
00185      \$                   DGEBS2D,  PDCOL2ROW, PDTREECOMB,
00186      \$                   ZLASSQ
00187 *     ..
00188 *     .. External Functions ..
00189       LOGICAL            LSAME
00190       INTEGER            ICEIL, IDAMAX, NUMROC
00191       EXTERNAL           ICEIL, IDAMAX, LSAME, NUMROC
00192 *     ..
00193 *     .. Intrinsic Functions ..
00194       INTRINSIC          ABS, DBLE, MAX, MIN, MOD, SQRT
00195 *     ..
00196 *     .. Executable Statements ..
00197 *
00198 *     Get grid parameters and local indexes.
00199 *
00200       ICTXT = DESCA( CTXT_ )
00201       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
00202       CALL INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL,
00203      \$              IIA, JJA, IAROW, IACOL )
00204 *
00205       IROFF = MOD( IA-1, DESCA( MB_ ) )
00206       ICOFF = MOD( JA-1, DESCA( NB_ ) )
00207       NP = NUMROC( N+IROFF, DESCA( MB_ ), MYROW, IAROW, NPROW )
00208       NQ = NUMROC( N+ICOFF, DESCA( NB_ ), MYCOL, IACOL, NPCOL )
00209       ICSR = 1
00210       IRSR = ICSR + NQ
00211       IRSC = IRSR + NQ
00212       IF( MYROW.EQ.IAROW ) THEN
00213          IRSC0 = IRSC + IROFF
00214          NP = NP - IROFF
00215       ELSE
00216          IRSC0 = IRSC
00217       END IF
00218       IF( MYCOL.EQ.IACOL ) THEN
00219          ICSR0 = ICSR + ICOFF
00220          IRSR0 = IRSR + ICOFF
00221          NQ = NQ - ICOFF
00222       ELSE
00223          ICSR0 = ICSR
00224          IRSR0 = IRSR
00225       END IF
00226       IN = MIN( ICEIL( IA, DESCA( MB_ ) ) * DESCA( MB_ ), IA+N-1 )
00227       LDA = DESCA( LLD_ )
00228 *
00229 *     If the matrix is Hermitian, we address only a triangular portion
00230 *     of the matrix.  A sum of row (column) i of the complete matrix
00231 *     can be obtained by adding along row i and column i of the the
00232 *     triangular matrix, stopping/starting at the diagonal, which is
00233 *     the point of reflection.  The pictures below demonstrate this.
00234 *     In the following code, the row sums created by --- rows below are
00235 *     refered to as ROWSUMS, and the column sums shown by | are refered
00236 *     to as COLSUMS. Infinity-norm = 1-norm = ROWSUMS+COLSUMS.
00237 *
00238 *      UPLO = 'U'                        UPLO = 'L'
00239 *      ____i______                       ___________
00240 *     |\   |      |                     |\          |
00241 *     | \  |      |                     | \         |
00242 *     |  \ |      |                     |  \        |
00243 *     |   \|------| i                  i|---\       |
00244 *     |    \      |                     |   |\      |
00245 *     |     \     |                     |   | \     |
00246 *     |      \    |                     |   |  \    |
00247 *     |       \   |                     |   |   \   |
00248 *     |        \  |                     |   |    \  |
00249 *     |         \ |                     |   |     \ |
00250 *     |__________\|                     |___|______\|
00251 *                                           i
00252 *
00253 *     II, JJ  : local indices into array A
00254 *     ICURROW : process row containing diagonal block
00255 *     ICURCOL : process column containing diagonal block
00256 *     IRSC0   : pointer to part of work used to store the ROWSUMS while
00257 *               they are stored along a process column
00258 *     IRSR0   : pointer to part of work used to store the ROWSUMS after
00259 *               they have been transposed to be along a process row
00260 *
00261       II = IIA
00262       JJ = JJA
00263 *
00264       IF( N.EQ.0 ) THEN
00265 *
00266          VALUE = ZERO
00267 *
00268       ELSE IF( LSAME( NORM, 'M' ) ) THEN
00269 *
00270 *        Find max(abs(A(i,j))).
00271 *
00272          VALUE = ZERO
00273 *
00274          IF( LSAME( UPLO, 'U' ) ) THEN
00275 *
00276 *           Handle first block separately
00277 *
00278             IB = IN-IA+1
00279 *
00280 *           Find COLMAXS
00281 *
00282             IF( MYCOL.EQ.IACOL ) THEN
00283                DO 20 K = (JJ-1)*LDA, (JJ+IB-2)*LDA, LDA
00284                   IF( II.GT.IIA ) THEN
00285                      DO 10 LL = IIA, II-1
00286                         VALUE = MAX( VALUE, ABS( A( LL+K ) ) )
00287    10                CONTINUE
00288                   END IF
00289                   IF( MYROW.EQ.IAROW )
00290      \$               II = II + 1
00291    20          CONTINUE
00292 *
00293 *              Reset local indices so we can find ROWMAXS
00294 *
00295                IF( MYROW.EQ.IAROW )
00296      \$            II = II - IB
00297 *
00298             END IF
00299 *
00300 *           Find ROWMAXS
00301 *
00302             IF( MYROW.EQ.IAROW ) THEN
00303                DO 40 K = II, II+IB-1
00304                   IF( MYCOL.EQ.IACOL ) THEN
00305                      IF( JJ.LE.JJA+NQ-1 ) THEN
00306                         VALUE = MAX( VALUE,
00307      \$                               ABS( DBLE( A( K+(JJ-1)*LDA ) ) ) )
00308                         DO 30 LL = JJ*LDA, (JJA+NQ-2)*LDA, LDA
00309                            VALUE = MAX( VALUE, ABS( A( K+LL ) ) )
00310    30                   CONTINUE
00311                      END IF
00312                   ELSE
00313                      IF( JJ.LE.JJA+NQ-1 ) THEN
00314                         DO 35 LL = (JJ-1)*LDA, (JJA+NQ-2)*LDA, LDA
00315                           VALUE = MAX( VALUE, ABS( A( K+LL ) ) )
00316    35                   CONTINUE
00317                      END IF
00318                   END IF
00319                   IF( MYCOL.EQ.IACOL )
00320      \$               JJ = JJ + 1
00321    40          CONTINUE
00322                II = II + IB
00323             ELSE IF( MYCOL.EQ.IACOL ) THEN
00324                JJ = JJ + IB
00325             END IF
00326 *
00327             ICURROW = MOD( IAROW+1, NPROW )
00328             ICURCOL = MOD( IACOL+1, NPCOL )
00329 *
00330 *           Loop over the remaining rows/columns of the matrix.
00331 *
00332             DO 90 I = IN+1, IA+N-1, DESCA( MB_ )
00333                IB = MIN( DESCA( MB_ ), IA+N-I )
00334 *
00335 *              Find COLMAXS
00336 *
00337                IF( MYCOL.EQ.ICURCOL ) THEN
00338                   DO 60 K = (JJ-1)*LDA, (JJ+IB-2)*LDA, LDA
00339                      IF( II.GT.IIA ) THEN
00340                         DO 50 LL = IIA, II-1
00341                            VALUE = MAX( VALUE, ABS( A( LL+K ) ) )
00342    50                   CONTINUE
00343                      END IF
00344                      IF( MYROW.EQ.ICURROW )
00345      \$                  II = II + 1
00346    60             CONTINUE
00347 *
00348 *                 Reset local indices so we can find ROWMAXS
00349 *
00350                   IF( MYROW.EQ.ICURROW )
00351      \$               II = II - IB
00352                END IF
00353 *
00354 *              Find ROWMAXS
00355 *
00356                IF( MYROW.EQ.ICURROW ) THEN
00357                   DO 80 K = II, II+IB-1
00358                      IF( MYCOL.EQ.ICURCOL ) THEN
00359                         IF( JJ.LE.JJA+NQ-1 ) THEN
00360                            VALUE = MAX( VALUE,
00361      \$                             ABS( DBLE( A( K+(JJ-1)*LDA ) ) ) )
00362                            DO 70 LL = JJ*LDA, (JJA+NQ-2)*LDA, LDA
00363                               VALUE = MAX( VALUE, ABS( A( K+LL ) ) )
00364    70                      CONTINUE
00365                         END IF
00366                      ELSE
00367                         IF( JJ.LE.JJA+NQ-1 ) THEN
00368                            DO 75 LL = (JJ-1)*LDA, (JJA+NQ-2)*LDA, LDA
00369                              VALUE = MAX( VALUE, ABS( A( K+LL ) ) )
00370    75                      CONTINUE
00371                         END IF
00372                      END IF
00373                      IF( MYCOL.EQ.ICURCOL )
00374      \$                  JJ = JJ + 1
00375    80             CONTINUE
00376                   II = II + IB
00377                ELSE IF( MYCOL.EQ.ICURCOL ) THEN
00378                   JJ = JJ + IB
00379                END IF
00380                ICURROW = MOD( ICURROW+1, NPROW )
00381                ICURCOL = MOD( ICURCOL+1, NPCOL )
00382    90       CONTINUE
00383 *
00384          ELSE
00385 *
00386 *           Handle first block separately
00387 *
00388             IB = IN-IA+1
00389 *
00390 *           Find COLMAXS
00391 *
00392             IF( MYCOL.EQ.IACOL ) THEN
00393                DO 110 K = (JJ-1)*LDA, (JJ+IB-2)*LDA, LDA
00394                   IF( MYROW.EQ.IAROW ) THEN
00395                      IF( II.LE.IIA+NP-1 ) THEN
00396                         VALUE = MAX( VALUE, ABS( DBLE( A( II+K ) ) ) )
00397                         DO 100 LL = II+1, IIA+NP-1
00398                            VALUE = MAX( VALUE, ABS( A( LL+K ) ) )
00399   100                   CONTINUE
00400                      END IF
00401                   ELSE
00402                      IF( II.LE.IIA+NP-1 ) THEN
00403                         DO 105 LL = II, IIA+NP-1
00404                           VALUE = MAX( VALUE, ABS( A( LL+K ) ) )
00405   105                   CONTINUE
00406                      END IF
00407                   END IF
00408                   IF( MYROW.EQ.IAROW )
00409      \$               II = II + 1
00410   110          CONTINUE
00411 *
00412 *              Reset local indices so we can find ROWMAXS
00413 *
00414                IF( MYROW.EQ.IAROW )
00415      \$            II = II - IB
00416             END IF
00417 *
00418 *           Find ROWMAXS
00419 *
00420             IF( MYROW.EQ.IAROW ) THEN
00421                DO 130 K = 0, IB-1
00422                   IF( JJ.GT.JJA ) THEN
00423                      DO 120 LL = (JJA-1)*LDA, (JJ-2)*LDA, LDA
00424                         VALUE = MAX( VALUE, ABS( A( II+LL ) ) )
00425   120                CONTINUE
00426                   END IF
00427                   II = II + 1
00428                   IF( MYCOL.EQ.IACOL )
00429      \$               JJ = JJ + 1
00430   130          CONTINUE
00431             ELSE IF( MYCOL.EQ.IACOL ) THEN
00432                JJ = JJ + IB
00433             END IF
00434 *
00435             ICURROW = MOD( IAROW+1, NPROW )
00436             ICURCOL = MOD( IACOL+1, NPCOL )
00437 *
00438 *           Loop over rows/columns of global matrix.
00439 *
00440             DO 180 I = IN+1, IA+N-1, DESCA( MB_ )
00441                IB = MIN( DESCA( MB_ ), IA+N-I )
00442 *
00443 *              Find COLMAXS
00444 *
00445                IF( MYCOL.EQ.ICURCOL ) THEN
00446                   DO 150 K = (JJ-1)*LDA, (JJ+IB-2)*LDA, LDA
00447                      IF( MYROW.EQ.ICURROW ) THEN
00448                         IF( II.LE.IIA+NP-1 ) THEN
00449                            VALUE = MAX( VALUE,
00450      \$                                  ABS( DBLE( A( II+K ) ) ) )
00451                            DO 140 LL = II+1, IIA+NP-1
00452                               VALUE = MAX( VALUE, ABS( A( LL+K ) ) )
00453   140                      CONTINUE
00454                         END IF
00455                      ELSE
00456                         IF( II.LE.IIA+NP-1 ) THEN
00457                            DO 145 LL = II, IIA+NP-1
00458                              VALUE = MAX( VALUE, ABS( A( LL+K ) ) )
00459   145                      CONTINUE
00460                         END IF
00461                      END IF
00462                       IF( MYROW.EQ.ICURROW )
00463      \$                   II = II + 1
00464   150             CONTINUE
00465 *
00466 *                 Reset local indices so we can find ROWMAXS
00467 *
00468                   IF( MYROW.EQ.ICURROW )
00469      \$               II = II - IB
00470                END IF
00471 *
00472 *              Find ROWMAXS
00473 *
00474                IF( MYROW.EQ.ICURROW ) THEN
00475                   DO 170 K = 0, IB-1
00476                      IF( JJ.GT.JJA ) THEN
00477                         DO 160 LL = (JJA-1)*LDA, (JJ-2)*LDA, LDA
00478                            VALUE = MAX( VALUE, ABS( A( II+LL ) ) )
00479   160                   CONTINUE
00480                      END IF
00481                      II = II + 1
00482                      IF( MYCOL.EQ.ICURCOL )
00483      \$                  JJ = JJ + 1
00484   170             CONTINUE
00485                ELSE IF( MYCOL.EQ.ICURCOL ) THEN
00486                   JJ = JJ + IB
00487                END IF
00488                ICURROW = MOD( ICURROW+1, NPROW )
00489                ICURCOL = MOD( ICURCOL+1, NPCOL )
00490 *
00491   180       CONTINUE
00492 *
00493          END IF
00494 *
00495 *        Gather the result on process (IAROW,IACOL).
00496 *
00497          CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, VALUE, 1, I, K, -1,
00498      \$                 IAROW, IACOL )
00499 *
00500       ELSE IF( LSAME( NORM, 'I' ) .OR. LSAME( NORM, 'O' ) .OR.
00501      \$         NORM.EQ.'1' ) THEN
00502 *
00503 *        Find normI( sub( A ) ) ( = norm1( sub( A ) ), since sub( A ) is
00504 *        hermitian).
00505 *
00506          IF( LSAME( UPLO, 'U' ) ) THEN
00507 *
00508 *           Handle first block separately
00509 *
00510             IB = IN-IA+1
00511 *
00512 *           Find COLSUMS
00513 *
00514             IF( MYCOL.EQ.IACOL ) THEN
00515                IOFFA = ( JJ - 1 ) * LDA
00516                DO 200 K = 0, IB-1
00517                   SUM = ZERO
00518                   IF( II.GT.IIA ) THEN
00519                      DO 190 LL = IIA, II-1
00520                         SUM = SUM + ABS( A( LL+IOFFA ) )
00521   190                CONTINUE
00522                   END IF
00523                   IOFFA = IOFFA + LDA
00524                   WORK( JJ+K-JJA+ICSR0 ) = SUM
00525                   IF( MYROW.EQ.IAROW )
00526      \$               II = II + 1
00527   200          CONTINUE
00528 *
00529 *              Reset local indices so we can find ROWSUMS
00530 *
00531                IF( MYROW.EQ.IAROW )
00532      \$            II = II - IB
00533 *
00534             END IF
00535 *
00536 *           Find ROWSUMS
00537 *
00538             IF( MYROW.EQ.IAROW ) THEN
00539                DO 220 K = II, II+IB-1
00540                   SUM = ZERO
00541                   IF( MYCOL.EQ.IACOL ) THEN
00542                      IF( JJA+NQ.GT.JJ ) THEN
00543                         SUM = ABS( DBLE( A( K+(JJ-1)*LDA ) ) )
00544                         DO 210 LL = JJ*LDA, (JJA+NQ-2)*LDA, LDA
00545                            SUM = SUM + ABS( A( K+LL ) )
00546   210                   CONTINUE
00547                      END IF
00548                   ELSE
00549                      IF( JJA+NQ.GT.JJ ) THEN
00550                         DO 215 LL = (JJ-1)*LDA, (JJA+NQ-2)*LDA, LDA
00551                            SUM = SUM + ABS( A( K+LL ) )
00552   215                   CONTINUE
00553                      END IF
00554                   END IF
00555                   WORK( K-IIA+IRSC0 ) = SUM
00556                   IF( MYCOL.EQ.IACOL )
00557      \$               JJ = JJ + 1
00558   220          CONTINUE
00559                II = II + IB
00560             ELSE IF( MYCOL.EQ.IACOL ) THEN
00561                JJ = JJ + IB
00562             END IF
00563 *
00564             ICURROW = MOD( IAROW+1, NPROW )
00565             ICURCOL = MOD( IACOL+1, NPCOL )
00566 *
00567 *           Loop over remaining rows/columns of global matrix.
00568 *
00569             DO 270 I = IN+1, IA+N-1, DESCA( MB_ )
00570                IB = MIN( DESCA( MB_ ), IA+N-I )
00571 *
00572 *              Find COLSUMS
00573 *
00574                IF( MYCOL.EQ.ICURCOL ) THEN
00575                   IOFFA = ( JJ - 1 ) * LDA
00576                   DO 240 K = 0, IB-1
00577                      SUM = ZERO
00578                      IF( II.GT.IIA ) THEN
00579                         DO 230 LL = IIA, II-1
00580                            SUM = SUM + ABS( A( IOFFA+LL ) )
00581   230                   CONTINUE
00582                      END IF
00583                      IOFFA = IOFFA + LDA
00584                      WORK( JJ+K-JJA+ICSR0 ) = SUM
00585                      IF( MYROW.EQ.ICURROW )
00586      \$                  II = II + 1
00587   240             CONTINUE
00588 *
00589 *                 Reset local indices so we can find ROWSUMS
00590 *
00591                   IF( MYROW.EQ.ICURROW )
00592      \$               II = II - IB
00593 *
00594                END IF
00595 *
00596 *              Find ROWSUMS
00597 *
00598                IF( MYROW.EQ.ICURROW ) THEN
00599                   DO 260 K = II, II+IB-1
00600                      SUM = ZERO
00601                      IF( MYCOL.EQ.ICURCOL ) THEN
00602                         IF( JJA+NQ.GT.JJ ) THEN
00603                            SUM = ABS( DBLE( A( K+(JJ-1)*LDA ) ) )
00604                            DO 250 LL = JJ*LDA, (JJA+NQ-2)*LDA, LDA
00605                               SUM = SUM + ABS( A( K+LL ) )
00606   250                      CONTINUE
00607                         END IF
00608                      ELSE
00609                         IF( JJA+NQ.GT.JJ ) THEN
00610                            DO 255 LL = (JJ-1)*LDA, (JJA+NQ-2)*LDA, LDA
00611                               SUM = SUM + ABS( A( K+LL ) )
00612   255                      CONTINUE
00613                         END IF
00614                      END IF
00615                      WORK( K-IIA+IRSC0 ) = SUM
00616                      IF( MYCOL.EQ.ICURCOL )
00617      \$                  JJ = JJ + 1
00618   260             CONTINUE
00619                   II = II + IB
00620                ELSE IF( MYCOL.EQ.ICURCOL ) THEN
00621                   JJ = JJ + IB
00622                END IF
00623 *
00624                ICURROW = MOD( ICURROW+1, NPROW )
00625                ICURCOL = MOD( ICURCOL+1, NPCOL )
00626 *
00627   270       CONTINUE
00628 *
00629          ELSE
00630 *
00631 *           Handle first block separately
00632 *
00633             IB = IN-IA+1
00634 *
00635 *           Find COLSUMS
00636 *
00637             IF( MYCOL.EQ.IACOL ) THEN
00638                IOFFA = (JJ-1)*LDA
00639                DO 290 K = 0, IB-1
00640                   SUM = ZERO
00641                   IF( MYROW.EQ.IAROW ) THEN
00642                      IF( IIA+NP.GT.II ) THEN
00643                         SUM = ABS( DBLE( A( IOFFA+II ) ) )
00644                         DO 280 LL = II+1, IIA+NP-1
00645                            SUM = SUM + ABS( A( IOFFA+LL ) )
00646   280                   CONTINUE
00647                      END IF
00648                   ELSE
00649                      DO 285 LL = II, IIA+NP-1
00650                         SUM = SUM + ABS( A( IOFFA+LL ) )
00651   285                CONTINUE
00652                   END IF
00653                   IOFFA = IOFFA + LDA
00654                   WORK( JJ+K-JJA+ICSR0 ) = SUM
00655                   IF( MYROW.EQ.IAROW )
00656      \$               II = II + 1
00657   290          CONTINUE
00658 *
00659 *              Reset local indices so we can find ROWSUMS
00660 *
00661                IF( MYROW.EQ.IAROW )
00662      \$            II = II - IB
00663 *
00664             END IF
00665 *
00666 *           Find ROWSUMS
00667 *
00668             IF( MYROW.EQ.IAROW ) THEN
00669                DO 310 K = II, II+IB-1
00670                   SUM = ZERO
00671                   IF( JJ.GT.JJA ) THEN
00672                      DO 300 LL = (JJA-1)*LDA, (JJ-2)*LDA, LDA
00673                         SUM = SUM + ABS( A( K+LL ) )
00674   300                CONTINUE
00675                   END IF
00676                   WORK( K-IIA+IRSC0 ) = SUM
00677                   IF( MYCOL.EQ.IACOL )
00678      \$               JJ = JJ + 1
00679   310          CONTINUE
00680                II = II + IB
00681             ELSE IF( MYCOL.EQ.IACOL ) THEN
00682                JJ = JJ + IB
00683             END IF
00684 *
00685             ICURROW = MOD( IAROW+1, NPROW )
00686             ICURCOL = MOD( IACOL+1, NPCOL )
00687 *
00688 *           Loop over rows/columns of global matrix.
00689 *
00690             DO 360 I = IN+1, IA+N-1, DESCA( MB_ )
00691                IB = MIN( DESCA( MB_ ), IA+N-I )
00692 *
00693 *              Find COLSUMS
00694 *
00695                IF( MYCOL.EQ.ICURCOL ) THEN
00696                   IOFFA = ( JJ - 1 ) * LDA
00697                   DO 330 K = 0, IB-1
00698                      SUM = ZERO
00699                      IF( MYROW.EQ.ICURROW ) THEN
00700                         IF( IIA+NP.GT.II ) THEN
00701                            SUM = ABS( DBLE( A( II+IOFFA ) ) )
00702                            DO 320 LL = II+1, IIA+NP-1
00703                               SUM = SUM + ABS( A( LL+IOFFA ) )
00704   320                      CONTINUE
00705                         ELSE IF( II.EQ.IIA+NP-1 ) THEN
00706                            SUM = ABS( DBLE( A( II+IOFFA ) ) )
00707                         END IF
00708                      ELSE
00709                         DO 325 LL = II, IIA+NP-1
00710                            SUM = SUM + ABS( A( LL+IOFFA ) )
00711   325                   CONTINUE
00712                      END IF
00713                      IOFFA = IOFFA + LDA
00714                      WORK( JJ+K-JJA+ICSR0 ) = SUM
00715                      IF( MYROW.EQ.ICURROW )
00716      \$                  II = II + 1
00717   330             CONTINUE
00718 *
00719 *                 Reset local indices so we can find ROWSUMS
00720 *
00721                   IF( MYROW.EQ.ICURROW )
00722      \$               II = II - IB
00723 *
00724                END IF
00725 *
00726 *              Find ROWSUMS
00727 *
00728                IF( MYROW.EQ.ICURROW ) THEN
00729                   DO 350 K = II, II+IB-1
00730                      SUM = ZERO
00731                      IF( JJ.GT.JJA ) THEN
00732                         DO 340 LL = (JJA-1)*LDA, (JJ-2)*LDA, LDA
00733                            SUM = SUM + ABS( A( K+LL ) )
00734   340                   CONTINUE
00735                      END IF
00736                      WORK(K-IIA+IRSC0) = SUM
00737                      IF( MYCOL.EQ.ICURCOL )
00738      \$                  JJ = JJ + 1
00739   350             CONTINUE
00740                   II = II + IB
00741                ELSE IF( MYCOL.EQ.ICURCOL ) THEN
00742                   JJ = JJ + IB
00743                END IF
00744 *
00745                ICURROW = MOD( ICURROW+1, NPROW )
00746                ICURCOL = MOD( ICURCOL+1, NPCOL )
00747 *
00748   360       CONTINUE
00749          END IF
00750 *
00751 *        After calls to DGSUM2D, process row 0 will have global
00752 *        COLSUMS and process column 0 will have global ROWSUMS.
00753 *        Transpose ROWSUMS and add to COLSUMS to get global row/column
00754 *        sum, the max of which is the infinity or 1 norm.
00755 *
00756          IF( MYCOL.EQ.IACOL )
00757      \$      NQ = NQ + ICOFF
00758          CALL DGSUM2D( ICTXT, 'Columnwise', ' ', 1, NQ, WORK( ICSR ), 1,
00759      \$                 IAROW, MYCOL )
00760          IF( MYROW.EQ.IAROW )
00761      \$      NP = NP + IROFF
00762          CALL DGSUM2D( ICTXT, 'Rowwise', ' ', NP, 1, WORK( IRSC ),
00763      \$                 MAX( 1, NP ), MYROW, IACOL )
00764 *
00765          CALL PDCOL2ROW( ICTXT, N, 1, DESCA( MB_ ), WORK( IRSC ),
00766      \$                   MAX( 1, NP ), WORK( IRSR ), MAX( 1, NQ ),
00767      \$                   IAROW, IACOL, IAROW, IACOL, WORK( IRSC+NP ) )
00768 *
00769          IF( MYROW.EQ.IAROW ) THEN
00770             IF( MYCOL.EQ.IACOL )
00771      \$         NQ = NQ - ICOFF
00772             CALL DAXPY( NQ, ONE, WORK( IRSR0 ), 1, WORK( ICSR0 ), 1 )
00773             IF( NQ.LT.1 ) THEN
00774                VALUE = ZERO
00775             ELSE
00776                VALUE = WORK( IDAMAX( NQ, WORK( ICSR0 ), 1 ) )
00777             END IF
00778             CALL DGAMX2D( ICTXT, 'Rowwise', ' ', 1, 1, VALUE, 1, I, K,
00779      \$                    -1, IAROW, IACOL )
00780          END IF
00781 *
00782       ELSE IF( LSAME( NORM, 'F' ) .OR. LSAME( NORM, 'E' ) ) THEN
00783 *
00784 *        Find normF( sub( A ) ).
00785 *
00786          SCALE = ZERO
00787          SUM = ONE
00788 *
00789 *        Add off-diagonal entries, first
00790 *
00791          IF( LSAME( UPLO, 'U' ) ) THEN
00792 *
00793 *           Handle first block separately
00794 *
00795             IB = IN-IA+1
00796 *
00797             IF( MYCOL.EQ.IACOL ) THEN
00798                DO 370 K = (JJ-1)*LDA, (JJ+IB-2)*LDA, LDA
00799                   CALL ZLASSQ( II-IIA, A( IIA+K ), 1, SCALE, SUM )
00800                   CALL ZLASSQ( II-IIA, A( IIA+K ), 1, SCALE, SUM )
00801                   IF( MYROW.EQ.IAROW ) THEN
00802                      IF( DBLE( A( II+K ) ).NE.ZERO ) THEN
00803                         ABSA = ABS( DBLE( A( II+K ) ) )
00804                         IF( SCALE.LT.ABSA ) THEN
00805                            SUM = ONE + SUM * ( SCALE / ABSA )**2
00806                            SCALE = ABSA
00807                         ELSE
00808                            SUM = SUM + ( ABSA / SCALE )**2
00809                         END IF
00810                      END IF
00811                      II = II + 1
00812                   END IF
00813   370          CONTINUE
00814 *
00815                JJ = JJ + IB
00816             ELSE IF( MYROW.EQ.IAROW ) THEN
00817                II = II + IB
00818             END IF
00819 *
00820             ICURROW = MOD( IAROW+1, NPROW )
00821             ICURCOL = MOD( IACOL+1, NPCOL )
00822 *
00823 *           Loop over rows/columns of global matrix.
00824 *
00825             DO 390 I = IN+1, IA+N-1, DESCA( MB_ )
00826                IB = MIN( DESCA( MB_ ), IA+N-I )
00827 *
00828                IF( MYCOL.EQ.ICURCOL ) THEN
00829                   DO 380 K = (JJ-1)*LDA, (JJ+IB-2)*LDA, LDA
00830                      CALL ZLASSQ( II-IIA, A( IIA+K ), 1, SCALE, SUM )
00831                      CALL ZLASSQ( II-IIA, A( IIA+K ), 1, SCALE, SUM )
00832                      IF( MYROW.EQ.ICURROW ) THEN
00833                         IF( DBLE( A( II+K ) ).NE.ZERO ) THEN
00834                            ABSA = ABS( DBLE( A( II+K ) ) )
00835                            IF( SCALE.LT.ABSA ) THEN
00836                               SUM = ONE + SUM * ( SCALE / ABSA )**2
00837                               SCALE = ABSA
00838                            ELSE
00839                               SUM = SUM + ( ABSA / SCALE )**2
00840                            END IF
00841                         END IF
00842                         II = II + 1
00843                      END IF
00844   380             CONTINUE
00845 *
00846                   JJ = JJ + IB
00847                ELSE IF( MYROW.EQ.ICURROW ) THEN
00848                   II = II + IB
00849                END IF
00850 *
00851                ICURROW = MOD( ICURROW+1, NPROW )
00852                ICURCOL = MOD( ICURCOL+1, NPCOL )
00853 *
00854   390       CONTINUE
00855 *
00856          ELSE
00857 *
00858 *           Handle first block separately
00859 *
00860             IB = IN-IA+1
00861 *
00862             IF( MYCOL.EQ.IACOL ) THEN
00863                DO 400 K = (JJ-1)*LDA, (JJ+IB-2)*LDA, LDA
00864                   IF( MYROW.EQ.IAROW ) THEN
00865                      IF( DBLE( A( II+K ) ).NE.ZERO ) THEN
00866                         ABSA = ABS( DBLE( A( II+K ) ) )
00867                         IF( SCALE.LT.ABSA ) THEN
00868                            SUM = ONE + SUM * ( SCALE / ABSA )**2
00869                            SCALE = ABSA
00870                         ELSE
00871                            SUM = SUM + ( ABSA / SCALE )**2
00872                         END IF
00873                      END IF
00874                      II = II + 1
00875                   END IF
00876                   CALL ZLASSQ( IIA+NP-II, A( II+K ), 1, SCALE, SUM )
00877                   CALL ZLASSQ( IIA+NP-II, A( II+K ), 1, SCALE, SUM )
00878   400          CONTINUE
00879 *
00880                JJ = JJ + IB
00881             ELSE IF( MYROW.EQ.IAROW ) THEN
00882                II = II + IB
00883             END IF
00884 *
00885             ICURROW = MOD( IAROW+1, NPROW )
00886             ICURCOL = MOD( IACOL+1, NPCOL )
00887 *
00888 *           Loop over rows/columns of global matrix.
00889 *
00890             DO 420 I = IN+1, IA+N-1, DESCA( MB_ )
00891                IB = MIN( DESCA( MB_ ), IA+N-I )
00892 *
00893                IF( MYCOL.EQ.ICURCOL ) THEN
00894                   DO 410 K = (JJ-1)*LDA, (JJ+IB-2)*LDA, LDA
00895                      IF( MYROW.EQ.ICURROW ) THEN
00896                         IF( DBLE( A( II+K ) ).NE.ZERO ) THEN
00897                            ABSA = ABS( DBLE( A( II+K ) ) )
00898                            IF( SCALE.LT.ABSA ) THEN
00899                               SUM = ONE + SUM * ( SCALE / ABSA )**2
00900                               SCALE = ABSA
00901                            ELSE
00902                               SUM = SUM + ( ABSA / SCALE )**2
00903                            END IF
00904                         END IF
00905                         II = II + 1
00906                      END IF
00907                      CALL ZLASSQ( IIA+NP-II, A( II+K ), 1, SCALE, SUM )
00908                      CALL ZLASSQ( IIA+NP-II, A( II+K ), 1, SCALE, SUM )
00909   410             CONTINUE
00910 *
00911                   JJ = JJ + IB
00912                ELSE IF( MYROW.EQ.ICURROW ) THEN
00913                   II = II + IB
00914                END IF
00915 *
00916                ICURROW = MOD( ICURROW+1, NPROW )
00917                ICURCOL = MOD( ICURCOL+1, NPCOL )
00918 *
00919   420       CONTINUE
00920 *
00921          END IF
00922 *
00923 *        Perform the global scaled sum
00924 *
00925          RWORK( 1 ) = SCALE
00926          RWORK( 2 ) = SUM
00927 *
00928          CALL PDTREECOMB( ICTXT, 'All', 2, RWORK, IAROW, IACOL,
00929      \$                    DCOMBSSQ )
00930          VALUE = RWORK( 1 ) * SQRT( RWORK( 2 ) )
00931 *
00932       END IF
00933 *
00934 *     Broadcast the result to the other processes
00935 *
00936       IF( MYROW.EQ.IAROW .AND. MYCOL.EQ.IACOL ) THEN
00937           CALL DGEBS2D( ICTXT, 'All', ' ', 1, 1, VALUE, 1 )
00938       ELSE
00939           CALL DGEBR2D( ICTXT, 'All', ' ', 1, 1, VALUE, 1, IAROW,
00940      \$                  IACOL )
00941       END IF
00942 *
00943       PZLANHE = VALUE
00944 *
00945       RETURN
00946 *
00947 *     End of PZLANHE
00948 *
00949       END
```