001        REAL FUNCTION PSLANHS( NORM , N , A , IA , JA , DESCA ,
002       $WORK )
003  
004  *     -- ScaLAPACK auxiliary routine(version 1.7) --
005  *     University of Tennessee , Knoxville , Oak Ridge National Laboratory ,
006  *     and University of California , Berkeley.
007  *     May 1 , 1997
008  
009  *     .. Scalar Arguments ..
010        CHARACTER NORM
011        INTEGER IA , JA , N
012  *     ..
013  *     .. Array Arguments ..
014        INTEGER DESCA( * )
015        REAL A( * ) , WORK( * )
016  *     ..
017  
018  *     Purpose
019  *     === ====
020  
021  *     PSLANHS returns the value of the one norm , or the Frobenius norm ,
022  *     or the infinity norm , or the element of largest absolute value of a
023  *     Hessenberg distributed matrix sub( A ) = A(IA : IA + N - 1 , JA : JA + N - 1).
024  
025  *     PSLANHS returns the value
026  
027  *     ( max(abs(A(i , j))) , NORM = 'M' or 'm' with IA <= i <= IA + N - 1 ,
028  *     ( and JA <= j <= JA + N - 1 ,
029  *     (
030  *     ( norm1( sub( A ) ) , NORM = '1' , 'O' or 'o'
031  *     (
032  *     ( normI( sub( A ) ) , NORM = 'I' or 'i'
033  *     (
034  *     ( normF( sub( A ) ) , NORM = 'F' , 'f' , 'E' or 'e'
035  
036  *     where norm1 denotes the one norm of a matrix(maximum column sum) ,
037  *     normI denotes the infinity norm of a matrix(maximum row sum) and
038  *     normF denotes the Frobenius norm of a matrix(square root of sum of
039  *     squares). Note that max(abs(A(i , j))) is not a matrix norm.
040  
041  *     Notes
042  *     === ==
043  
044  *     Each global data object is described by an associated description
045  *     vector. This vector stores the information required to establish
046  *     the mapping between an object element and its corresponding process
047  *     and memory location.
048  
049  *     Let A be a generic term for any 2D block cyclicly distributed array.
050  *     Such a global array has an associated description vector DESCA.
051  *     In the following comments , the character _ should be read as
052  *     "of the global array".
053  
054  *     NOTATION STORED IN EXPLANATION
055  *     --- ------------ -------------- --------------------------------------
056  *     DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case ,
057  *     DTYPE_A = 1.
058  *     CTXT_A(global) DESCA( CTXT_ ) The BLACS context handle , indicating
059  *     the BLACS process grid A is distribu -
060  *     ted over. The context itself is glo -
061  *     bal , but the handle(the integer
062  *     value) may vary.
063  *     M_A(global) DESCA( M_ ) The number of rows in the global
064  *     array A.
065  *     N_A(global) DESCA( N_ ) The number of columns in the global
066  *     array A.
067  *     MB_A(global) DESCA( MB_ ) The blocking factor used to distribute
068  *     the rows of the array.
069  *     NB_A(global) DESCA( NB_ ) The blocking factor used to distribute
070  *     the columns of the array.
071  *     RSRC_A(global) DESCA( RSRC_ ) The process row over which the first
072  *     row of the array A is distributed.
073  *     CSRC_A(global) DESCA( CSRC_ ) The process column over which the
074  *     first column of the array A is
075  *     distributed.
076  *     LLD_A(local) DESCA( LLD_ ) The leading dimension of the local
077  *     array. LLD_A >= MAX(1 , LOCr(M_A)).
078  
079  *     Let K be the number of rows or columns of a distributed matrix ,
080  *     and assume that its process grid has dimension p x q.
081  *     LOCr( K ) denotes the number of elements of K that a process
082  *     would receive if K were distributed over the p processes of its
083  *     process column.
084  *     Similarly , LOCc( K ) denotes the number of elements of K that a
085  *     process would receive if K were distributed over the q processes of
086  *     its process row.
087  *     The values of LOCr() and LOCc() may be determined via a call to the
088  *     ScaLAPACK tool function , NUMROC :
089  *     LOCr( M ) = NUMROC( M , MB_A , MYROW , RSRC_A , NPROW ) ,
090  *     LOCc( N ) = NUMROC( N , NB_A , MYCOL , CSRC_A , NPCOL ).
091  *     An upper bound for these quantities may be computed by :
092  *     LOCr( M ) <= ceil( ceil(M / MB_A) / NPROW )*MB_A
093  *     LOCc( N ) <= ceil( ceil(N / NB_A) / NPCOL )*NB_A
094  
095  *     Arguments
096  *     === ======
097  
098  *     NORM(global input) CHARACTER
099  *     Specifies the value to be returned in PSLANHS as described
100  *     above.
101  
102  *     N(global input) INTEGER
103  *     The number of rows and columns to be operated on i.e the
104  *     number of rows and columns of the distributed submatrix
105  *     sub( A ). When N = 0 , PSLANHS is set to zero. N >= 0.
106  
107  *     A(local input) REAL pointer into the local memory
108  *     to an array of dimension(LLD_A , LOCc(JA + N - 1) ) containing
109  *     the local pieces of sub( A ).
110  
111  *     IA(global input) INTEGER
112  *     The row index in the global array A indicating the first
113  *     row of sub( A ).
114  
115  *     JA(global input) INTEGER
116  *     The column index in the global array A indicating the
117  *     first column of sub( A ).
118  
119  *     DESCA(global and local input) INTEGER array of dimension DLEN_.
120  *     The array descriptor for the distributed matrix A.
121  
122  *     WORK(local workspace) REAL array dimension(LWORK)
123  *     LWORK >= 0 if NORM = 'M' or 'm'(not referenced) ,
124  *     Nq0 if NORM = '1' , 'O' or 'o' ,
125  *     Mp0 if NORM = 'I' or 'i' ,
126  *     0 if NORM = 'F' , 'f' , 'E' or 'e'(not referenced) ,
127  *     where
128  
129  *     IROFFA = MOD( IA - 1 , MB_A ) , ICOFFA = MOD( JA - 1 , NB_A ) ,
130  *     IAROW = INDXG2P( IA , MB_A , MYROW , RSRC_A , NPROW ) ,
131  *     IACOL = INDXG2P( JA , NB_A , MYCOL , CSRC_A , NPCOL ) ,
132  *     Np0 = NUMROC( N + IROFFA , MB_A , MYROW , IAROW , NPROW ) ,
133  *     Nq0 = NUMROC( N + ICOFFA , NB_A , MYCOL , IACOL , NPCOL ) ,
134  
135  *     INDXG2P and NUMROC are ScaLAPACK tool functions ; MYROW ,
136  *     MYCOL , NPROW and NPCOL can be determined by calling the
137  *     subroutine BLACS_GRIDINFO.
138  
139  *     === ==================================================================
140  
141  *     .. Parameters ..
142        INTEGER BLOCK_CYCLIC_2D , CSRC_ , CTXT_ , DLEN_ , DTYPE_ ,
143       $LLD_ , MB_ , M_ , NB_ , N_ , RSRC_
144        PARAMETER( BLOCK_CYCLIC_2D = 1 , DLEN_ = 9 , DTYPE_ = 1 ,
145       $CTXT_ = 2 , M_ = 3 , N_ = 4 , MB_ = 5 , NB_ = 6 ,
146       $RSRC_ = 7 , CSRC_ = 8 , LLD_ = 9 )
147        REAL ONE , ZERO
148        PARAMETER( ONE = 1.0E + 0 , ZERO = 0.0E + 0 )
149        IACOL = MOD( IACOL + 1 , NPCOL )
150  
151  *     Loop over remaining block of columns
152  
153        DO 460 J = JN + 1 , JA + N - 1 , DESCA( NB_ )
153               
154            JB = MIN( JA + N - J , DESCA( NB_ ) )
155  
156            IF( MYCOL.EQ.IACOL ) THEN
156                   
157                DO 450 LL = JJ , JJ + JB - 1
157                       
158                    CALL SLASSQ( MIN( II + LL - JJ + 1 , IIA + NP - 1 ) - IIA + 1 ,
159       $            A( IIA + IOFFA ) , 1 , SCALE , SUM )
160                    IOFFA = IOFFA + LDA
161    450         CONTINUE
161                   
162                JJ = JJ + JB
163            END IF
164  
165            II = II + JB
166            IACOL = MOD( IACOL + 1 , NPCOL )
167  
168    460 CONTINUE
169  
170        ELSE
171  
172  *         Handle first block of columns separately
173  
173               
174            INXTROW = MOD( IAROW + 1 , NPROW )
175            IF( MYCOL.EQ.IACOL ) THEN
175                   
176                IF( MYROW.EQ.IAROW ) THEN
176                       
177                    DO 470 LL = JJ , JJ + JB - 1
177                           
178                        CALL SLASSQ( MIN( II + LL - JJ + 1 , IIA + NP - 1 ) - IIA + 1 ,
179       $                A( IIA + IOFFA ) , 1 , SCALE , SUM )
180                        IOFFA = IOFFA + LDA
181    470             CONTINUE
181                   
182                ELSE
182                       
183                    DO 480 LL = JJ , JJ + JB - 1
183                           
184                        CALL SLASSQ( MIN( II - 1 , IIA + NP - 1 ) - IIA + 1 ,
185       $                A( IIA + IOFFA ) , 1 , SCALE , SUM )
186                        IOFFA = IOFFA + LDA
187    480             CONTINUE
187                       
188                    IF( MYROW.EQ.INXTROW .AND. II.LE.IIA + NP - 1 )
188                           
189       $                CALL SLASSQ( 1 , A( II + (JJ + JB - 2)*LDA ) , 1 ,
190       $                SCALE , SUM )
191                    END IF
192                    JJ = JJ + JB
193                END IF
194  
195                IF( MYROW.EQ.IAROW )
195                       
196       $            II = II + JB
197                    IAROW = INXTROW
198                    IAROW = MOD( IAROW + 1 , NPROW )
199                    IACOL = MOD( IACOL + 1 , NPCOL )
200  
201  *                 Loop over remaining block of columns
202  
203                    DO 510 J = JN + 1 , JA + N - 1 , DESCA( NB_ )
203                           
204                        JB = MIN( JA + N - J , DESCA( NB_ ) )
205  
206                        IF( MYCOL.EQ.IACOL ) THEN
206                               
207                            IF( MYROW.EQ.IAROW ) THEN
207                                   
208                                DO 490 LL = JJ , JJ + JB - 1
208                                       
209                                    CALL SLASSQ( MIN( II + LL - JJ + 1 , IIA + NP - 1 ) - IIA + 1 ,
210       $                            A( IIA + IOFFA ) , 1 , SCALE , SUM )
211                                    IOFFA = IOFFA + LDA
212    490                         CONTINUE
212                               
213                            ELSE
213                                   
214                                DO 500 LL = JJ , JJ + JB - 1
214                                       
215                                    CALL SLASSQ( MIN( II - 1 , IIA + NP - 1 ) - IIA + 1 ,
216       $                            A( IIA + IOFFA ) , 1 , SCALE , SUM )
217                                    IOFFA = IOFFA + LDA
218    500                         CONTINUE
218                                   
219                                IF( MYROW.EQ.INXTROW .AND. II.LE.IIA + NP - 1 )
219                                       
220       $                            CALL SLASSQ( 1 , A( II + (JJ + JB - 2)*LDA ) , 1 ,
221       $                            SCALE , SUM )
222                                END IF
223                                JJ = JJ + JB
224                            END IF
225  
226                            IF( MYROW.EQ.IAROW )
226                                   
227       $                        II = II + JB
228                                IAROW = INXTROW
229                                IAROW = MOD( IAROW + 1 , NPROW )
230                                IACOL = MOD( IACOL + 1 , NPCOL )
231  
232    510             CONTINUE
233  
233                   
234                END IF
235  
236  *             Perform the global scaled sum
237  
238                RWORK( 1 ) = SCALE
239                RWORK( 2 ) = SUM
240                CALL PSTREECOMB( ICTXT , 'All' , 2 , RWORK , 0 , 0 , SCOMBSSQ )
241                VALUE = RWORK( 1 ) * SQRT( RWORK( 2 ) )
242  
243            END IF
244  
245            IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
245                   
246                CALL SGEBS2D( ICTXT , 'All' , ' ' , 1 , 1 , VALUE , 1 )
247            ELSE
247                   
248                CALL SGEBR2D( ICTXT , 'All' , ' ' , 1 , 1 , VALUE , 1 , 0 , 0 )
249            END IF
250  
251            PSLANHS = VALUE
252  
253            RETURN
254  
255  *         End of PSLANHS
256  
257        END11647