Routine: PCLASSQ()  File: SRC\pclassq.f

 
 
# lines: 286
  # code: 286
  # comment: 0
  # blank:0
# Variables:37
# Callers:0
# Callings:0
# Words:127
# Keywords:75
 

 

..
     .. Array Arguments ..
     ..
  Purpose
  =======
  PCLASSQ  returns the values  scl  and  smsq  such that
     ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
  where x( i ) = sub( X ) = abs( X( IX+(JX-1)*DESCX(M_)+(i-1)*INCX ) ).
  The value of sumsq is assumed to be at least unity and the value of
  ssq will then satisfy
     1.0 .le. ssq .le. ( sumsq + 2*n ).
  scale is assumed to be non-negative and scl returns the value
     scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),
            i
  scale and sumsq must be supplied in SCALE and SUMSQ respectively.
  SCALE and SUMSQ are overwritten by scl and ssq respectively.
  The routine makes only one pass through the vector sub( X ).
  Notes
  =====
  Each global data object is described by an associated description
  vector.  This vector stores the information required to establish
  the mapping between an object element and its corresponding process
  and memory location.
  Let A be a generic term for any 2D block cyclicly distributed array.
  Such a global array has an associated description vector DESCA.
  In the following comments, the character _ should be read as
  "of the global array".
  NOTATION        STORED IN      EXPLANATION
  --------------- -------------- --------------------------------------
  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
                                 DTYPE_A = 1.
  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
                                 the BLACS process grid A is distribu-
                                 ted over. The context itself is glo-
                                 bal, but the handle (the integer
                                 value) may vary.
  M_A    (global) DESCA( M_ )    The number of rows in the global
                                 array A.
  N_A    (global) DESCA( N_ )    The number of columns in the global
                                 array A.
  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
                                 the rows of the array.
  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
                                 the columns of the array.
  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
                                 row of the array A is distributed.
  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
                                 first column of the array A is
                                 distributed.
  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
  Let K be the number of rows or columns of a distributed matrix,
  and assume that its process grid has dimension p x q.
  LOCr( K ) denotes the number of elements of K that a process
  would receive if K were distributed over the p processes of its
  process column.
  Similarly, LOCc( K ) denotes the number of elements of K that a
  process would receive if K were distributed over the q processes of
  its process row.
  The values of LOCr() and LOCc() may be determined via a call to the
  ScaLAPACK tool function, NUMROC:
          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
  An upper bound for these quantities may be computed by:
          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
  Because vectors may be viewed as a subclass of matrices, a
  distributed vector is considered to be a distributed matrix.
  The result are only available in the scope of sub( X ), i.e if
  sub( X ) is distributed along a process row, the correct results are
  only available in this process row of the grid. Similarly if sub( X )
  is distributed along a process column, the correct results are only
  available in this process column of the grid.
  Arguments
  =========
  N       (global input) INTEGER
          The length of the distributed vector sub( X ).
  X       (input) COMPLEX
          The vector for which a scaled sum of squares is computed.
             x( i )  = X(IX+(JX-1)*M_X +(i-1)*INCX ), 1 <= i <= n.
  IX      (global input) INTEGER
          The row index in the global array X indicating the first
          row of sub( X ).
  JX      (global input) INTEGER
          The column index in the global array X indicating the
          first column of sub( X ).
  DESCX   (global and local input) INTEGER array of dimension DLEN_.
          The array descriptor for the distributed matrix X.
  INCX    (global input) INTEGER
          The global increment for the elements of X. Only two values
          of INCX are supported in this version, namely 1 and M_X.
          INCX must not be zero.
  SCALE   (local input/local output) REAL
          On entry, the value  scale  in the equation above.
          On exit, SCALE is overwritten with  scl , the scaling factor
          for the sum of squares.
  SUMSQ   (local input/local output) REAL
          On entry, the value  sumsq  in the equation above.
          On exit, SUMSQ is overwritten with  smsq , the basic sum of
          squares from which  scl  has been factored out.
  =====================================================================
     .. Parameters ..

 
Display dynamic version Find AutoScroll Reload FontSize: - + Hide Comments Hide Blanks Frame FullScreen MailPrint

 
001        SUBROUTINE PCLASSQ( N , X , IX , JX , DESCX , INCX , SCALE , SUMSQ )
002  
003  *     -- ScaLAPACK auxiliary routine(version 1.7) --
004  *     University of Tennessee , Knoxville , Oak Ridge National Laboratory ,
005  *     and University of California , Berkeley.
006  *     May 1 , 1997
007  
008  *     .. Scalar Arguments ..
009        INTEGER IX , INCX , JX , N
010        REAL SCALE , SUMSQ
011        INTEGER BLOCK_CYCLIC_2D , CSRC_ , CTXT_ , DLEN_ , DTYPE_ ,
012       $LLD_ , MB_ , M_ , NB_ , N_ , RSRC_
013        PARAMETER( BLOCK_CYCLIC_2D = 1 , DLEN_ = 9 , DTYPE_ = 1 ,
014       $CTXT_ = 2 , M_ = 3 , N_ = 4 , MB_ = 5 , NB_ = 6 ,
015       $RSRC_ = 7 , CSRC_ = 8 , LLD_ = 9 )
016        REAL ZERO
017        PARAMETER( ZERO = 0.0E + 0 )
018  *     ..
019  *     .. Local Scalars ..
020        INTEGER I , ICOFF , ICTXT , IIX , IOFF , IROFF , IXCOL ,
021       $IXROW , JJX , LDX , MYCOL , MYROW , NP , NPCOL ,
022       $NPROW , NQ
023        REAL TEMP1
024  *     ..
025  *     .. Local Arrays ..
026        REAL WORK( 2 )
027  *     ..
028  *     .. External Subroutines ..
029        EXTERNAL BLACS_GRIDINFO , INFOG2L , PSTREECOMB , SCOMBSSQ
030  *     ..
031  *     .. External Functions ..
032        INTEGER NUMROC
033        EXTERNAL NUMROC
034  *     ..
035  *     .. Intrinsic Functions ..
036        INTRINSIC ABS , AIMAG , MOD , REAL
037  *     ..
038  *     .. Executable Statements ..
039  
040  *     Get grid parameters.
041  
042        ICTXT = DESCX( CTXT_ )
043        CALL BLACS_GRIDINFO( ICTXT , NPROW , NPCOL , MYROW , MYCOL )
044  
045  *     Figure local indexes
046  
047        CALL INFOG2L( IX , JX , DESCX , NPROW , NPCOL , MYROW , MYCOL , IIX , JJX ,
048       $IXROW , IXCOL )
049  
050        LDX = DESCX( LLD_ )
051        IF( INCX.EQ.DESCX( M_ ) ) THEN
052  
053  *         X is rowwise distributed.
054  
055            IF( MYROW.NE.IXROW )
056       $        RETURN
057                ICOFF = MOD( JX , DESCX( NB_ ) )
058                NQ = NUMROC( N + ICOFF , DESCX( NB_ ) , MYCOL , IXCOL , NPCOL )
059                IF( MYCOL.EQ.IXCOL )
060       $            NQ = NQ - ICOFF
061  
062  *                 Code direct from LAPACK's CLASSQ ,(save subroutine call)
063  
064                    IF( NQ.GT.0 ) THEN
065                        IOFF = IIX + ( JJX - 1 ) * LDX
066                        DO 10 I = 1 , NQ
067                            IF( REAL( X( IOFF ) ).NE.ZERO ) THEN
068                                TEMP1 = ABS( REAL( X( IOFF ) ) )
069                                IF( SCALE.LT.TEMP1 ) THEN
070                                    SUMSQ = 1 + SUMSQ * ( SCALE / TEMP1 )**2
071                                    SCALE = TEMP1
072                                ELSE
073                                    SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
074                                END IF
075                            END IF
076                            IF( AIMAG( X( IOFF ) ).NE.ZERO ) THEN
077                                TEMP1 = ABS( AIMAG( X( IOFF ) ) )
078                                IF( SCALE.LT.TEMP1 ) THEN
079                                    SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
080                                    SCALE = TEMP1
081                                ELSE
082                                    SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
083                                END IF
084                            END IF
085                            IOFF = IOFF + LDX
086     10                 CONTINUE
087                    END IF
088  
089  *                 Take local result and find global
090  
091                    WORK( 1 ) = SCALE
092                    WORK( 2 ) = SUMSQ
093  
094                    CALL PSTREECOMB( ICTXT , 'Rowwise' , 2 , WORK , - 1 , IXCOL ,
095       $            SCOMBSSQ )
096  
097                    SCALE = WORK( 1 )
098                    SUMSQ = WORK( 2 )
099  
100                ELSE IF( INCX.EQ.1 ) THEN
101  
102  *                 X is columnwise distributed.
103  
104                    IF( MYCOL.NE.IXCOL )
105       $                RETURN
106                        IROFF = MOD( IX , DESCX( MB_ ) )
107                        NP = NUMROC( N + IROFF , DESCX( MB_ ) , MYROW , IXROW , NPROW )
108                        IF( MYROW.EQ.IXROW )
109       $                    NP = NP - IROFF
110  
111  *                         Code direct from LAPACK's CLASSQ ,(save subroutine call)
112  
113                            IF( NP.GT.0 ) THEN
114                                IOFF = IIX + ( JJX - 1 ) * LDX
115                                DO 20 I = 1 , NP
116                                    IF( REAL( X( IOFF ) ).NE.ZERO ) THEN
117                                        TEMP1 = ABS( REAL( X( IOFF ) ) )
118                                        IF( SCALE.LT.TEMP1 ) THEN
119                                            SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
120                                            SCALE = TEMP1
121                                        ELSE
122                                            SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
123                                        END IF
124                                    END IF
125                                    IF( AIMAG( X( IOFF ) ).NE.ZERO ) THEN
126                                        TEMP1 = ABS( AIMAG( X( IOFF ) ) )
127                                        IF( SCALE.LT.TEMP1 ) THEN
128                                            SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
129                                            SCALE = TEMP1
130                                        ELSE
131                                            SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
132                                        END IF
133                                    END IF
134                                    IOFF = IOFF + 1
135     20                         CONTINUE
136                            END IF
137  
138  *                         Take local result and find global
139  
140                            WORK( 1 ) = SCALE
141                            WORK( 2 ) = SUMSQ
142  
143                            CALL PSTREECOMB( ICTXT , 'Columnwise' , 2 , WORK , - 1 , IXCOL ,
144       $                    SCOMBSSQ )
145  
146                            SCALE = WORK( 1 )
147                            SUMSQ = WORK( 2 )
148  
149                        END IF
150  
151                        RETURN
152  
153  *                     End of PCLASSQ
154  
155                    END