pitreecomb.f

Go to the documentation of this file.

      SUBROUTINE pitreecomb( ICTXT, SCOPE, N, MINE, RDEST0, CDEST0,
     $                       SUBPTR )
*
*  -- ScaLAPACK tools routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      CHARACTER          SCOPE
      INTEGER            CDEST0, ICTXT, N, RDEST0
*     ..
*     .. Array Arguments ..
      INTEGER            MINE( * )
*     ..
*     .. Subroutine Arguments ..
      EXTERNAL           subptr
*     ..
*
*  Purpose
*  =======
*
*  PITREECOMB does a 1-tree parallel combine operation on scalars,
*  using the subroutine indicated by SUBPTR to perform the required
*  computation.
*
*  Arguments
*  =========
*
*  ICTXT   (global input) INTEGER
*          The BLACS context handle, indicating the global context of
*          the operation. The context itself is global.
*
*  SCOPE   (global input) CHARACTER
*          The scope of the operation:  'Rowwise', 'Columnwise', or
*          'All'.
*
*  N       (global input) INTEGER
*          The number of elements in MINE.  N = 1 for the norm-2
*          computation and 2 for the sum of square.
*
*  MINE    (local input/global output) @(typec) array of
*          dimension at least equal to N. The local data to use in the
*          combine.
*
*  RDEST0  (global input) INTEGER
*          The process row to receive the answer. If RDEST0 = -1,
*          every process in the scope gets the answer.
*
*  CDEST0  (global input) INTEGER
*          The process column to receive the answer. If CDEST0 = -1,
*          every process in the scope gets the answer.
*
*  SUBPTR  (local input) Pointer to the subroutine to call to perform
*          the required combine.
*
*  =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            BCAST, RSCOPE, CSCOPE
      INTEGER            CMSSG, DEST, DIST, HISDIST, I, IAM, MYCOL,
     $                   myrow, mydist, mydist2, np, npcol, nprow,
     $                   rmssg, tcdest, trdest
*     ..
*     .. Local Arrays ..
      INTEGER            HIS( 2 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_gridinfo, igebr2d, igebs2d,
     $                   igerv2d, igesd2d
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           lsame
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          mod
*     ..
*     .. Executable Statements ..
*
    dest = 0
*
*     See if everyone wants the answer (need to broadcast the answer)
*
      bcast = ( ( rdest0.EQ.-1 ).OR.( cdest0.EQ.-1 ) )
      IF( bcast ) THEN
         trdest = 0
         tcdest = 0
      ELSE
         trdest = rdest0
         tcdest = cdest0
      END IF
*
*     Get grid parameters.
*
      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
*
*     Figure scope-dependant variables, or report illegal scope
*
      rscope = lsame( scope, 'R' )
      cscope = lsame( scope, 'C' )
*
      IF( rscope ) THEN
         IF( bcast ) THEN
            trdest = myrow
         ELSE IF( myrow.NE.trdest ) THEN
            RETURN
         END IF
         np = npcol
         mydist = mod( npcol + mycol - tcdest, npcol )
      ELSE IF( cscope ) THEN
         IF( bcast ) THEN
            tcdest = mycol
         ELSE IF( mycol.NE.tcdest ) THEN
            RETURN
         END IF
         np = nprow
         mydist = mod( nprow + myrow - trdest, nprow )
      ELSE IF( lsame( scope, 'A' ) ) THEN
         np = nprow * npcol
         iam = myrow*npcol + mycol
         dest = trdest*npcol + tcdest
         mydist = mod( np + iam - dest, np )
      ELSE
         RETURN
      END IF
*
      IF( np.LT.2 )
     $   RETURN
*
      mydist2 = mydist
      rmssg = myrow
      cmssg = mycol
      i = 1
*
   10 CONTINUE
*
         IF( mod( mydist, 2 ).NE.0 ) THEN
*
*           If I am process that sends information
*
            dist = i * ( mydist - mod( mydist, 2 ) )
*
*           Figure coordinates of dest of message
*
            IF( rscope ) THEN
               cmssg = mod( tcdest + dist, np )
            ELSE IF( cscope ) THEN
               rmssg = mod( trdest + dist, np )
            ELSE
               cmssg = mod( dest + dist, np )
               rmssg = cmssg / npcol
               cmssg = mod( cmssg, npcol )
            END IF
*
            CALL igesd2d( ictxt, n, 1, mine, n, rmssg, cmssg )
*
            GO TO 20
*
         ELSE
*
*           If I am a process receiving information, figure coordinates
*           of source of message
*
            dist = mydist2 + i
            IF( rscope ) THEN
               cmssg = mod( tcdest + dist, np )
               hisdist = mod( np + cmssg - tcdest, np )
            ELSE IF( cscope ) THEN
               rmssg = mod( trdest + dist, np )
               hisdist = mod( np + rmssg - trdest, np )
            ELSE
               cmssg = mod( dest + dist, np )
               rmssg = cmssg / npcol
               cmssg = mod( cmssg, npcol )
               hisdist = mod( np + rmssg*npcol+cmssg - dest, np )
            END IF
*
            IF( mydist2.LT.hisdist ) THEN
*
*              If I have anyone sending to me
*
               CALL igerv2d( ictxt, n, 1, his, n, rmssg, cmssg )
               CALL subptr( mine, his )
*
            END IF
            mydist = mydist / 2
*
         END IF
         i = i * 2
*
      IF( i.LT.np )
     $   GO TO 10
*
   20 CONTINUE
*
      IF( bcast ) THEN
         IF( mydist2.EQ.0 ) THEN
            CALL igebs2d( ictxt, scope, ' ', n, 1, mine, n )
         ELSE
            CALL igebr2d( ictxt, scope, ' ', n, 1, mine, n,
     $                    trdest, tcdest )
         END IF
      END IF
*
      RETURN
*
*     End of PITREECOMB
*
      END