c**********************************************************************
c  Basic Communication Process Library
c  
c  Fortran90 version
c   
c  1996 9/8
c    composed by T.Katagiri
c
c***********************************************************************
c   All Rights Reserved, Copyright (C) 1998, T.Katagiri
c/*-
c * Copyright (c) 1998 Information Promotion Agency of Japan and T.Katagiri
c * All rights reserved.
c *
c * Redistribution and non-commercial use in source and binary forms,
c * with or without modification, are permitted provided that the following
c * conditions are met:
c *
c * 1. Redistributions of source code must retain the above copyright
c *    notice, this list of conditions and the following disclaimer.
c *
c * 2. Redistributions in binary form must reproduce the above copyright
c *    notice, this list of conditions and the following disclaimer in the
c *    documentation and/or other materials provided with the distribution.
c *
c * 3. All advertising materials mentioning features or use of this
c *    software must display the following acknowledgement:
c *
c *    This product includes software developed by Information Promotion
c *    Agency of Japan and T.Katagiri
c *
c * 4. The name "Information Promotion Agency" or "T.Katagiri" should not be
c *    used to endorse or promote products derived from this software
c *    without specific prior written permission.
c *
c * 5. Any use of the source code or the binary in a commercial product,
c *    whether may it be the origial representation or in some modified form,
c *    is not permitted without specific prior written permission.
c *
c * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
c * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
c * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
c * ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
c * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
c * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
c * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
c * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
c * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
c * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
c * SUCH DAMAGE.
c */

      subroutine reduction_vector_tree(x, nx, rbuf,nr, spe, p,
     &  cid, block_length, logp)
      include  'mppf.h'
      common  /MPI2d/ MPP_COMM_X, MPP_COMM_Y, ISTATUS
      integer  nx, nr
      real*8   x(0:nx),rbuf(0:nr)
      integer  spe, p, cid, block_length, logp
  
      integer i,j,k
      integer ierr 

      k = 1
c     === reduction vector
      do i=0, logp-1
        if (iand(cid,k) .eq. 0) then
          if(cid .ge. spe) then
            call MPP_SEND(x, block_length, MPP_DOUBLE_PRECISION, 
     &                  cid+k, i, MPP_COMM_WORLD, ierr)
          endif
          goto 220
        else
          if (cid-k .ge. spe) then
            call MPP_RECV(rbuf, block_length, MPP_DOUBLE_PRECISION, 
     &                  cid-k, i, MPP_COMM_WORLD, ISTATUS, ierr)
            do j=0,block_length-1
              x(j) = x(j) + rbuf(j)
            enddo
          endif
        endif 
        k = k * 2
      enddo
 220  continue
     
      call MPP_BCAST(x, block_length, MPP_DOUBLE_PRECISION,
     &                p-1, MPP_COMM_WORLD, ierr)

      return 
      end


      subroutine reduction_vector_tree_x(x, nx, rbuf,nr, spe,ncelx,
     &  ncidx, block_length_y, logp)
      include  'mppf.h'
      common  /MPI2d/ MPP_COMM_X, MPP_COMM_Y, ISTATUS

      integer  nx, nr
      real*8   x(0:nx),rbuf(0:nr)
      integer  spe, ncelx, ncidx, block_length_y,logp
  
      integer i,j,k
      integer ierr 

 
      k = 1
c     === reduction vector
      do i=0, logp-1
        if (iand(ncidx,k) .eq. 0) then
          if(ncidx .ge. spe) then
            call MPP_SEND(x, block_length_y, MPP_DOUBLE_PRECISION, 
     &                  ncidx+k, i, MPP_COMM_X, ierr)
          endif
          goto 200
        else
          if (ncidx-k .ge. spe) then
            call MPP_RECV(rbuf, block_length_y, MPP_DOUBLE_PRECISION, 
     &                  ncidx-k, i, MPP_COMM_X, ISTATUS, ierr)
            do j=0,block_length_y-1
              x(j) = x(j) + rbuf(j)
            enddo
          endif
        endif 
        k = k * 2
      enddo
 200  continue
     
      call MPP_BCAST(x, block_length_y, MPP_DOUBLE_PRECISION,
     &                ncelx-1, MPP_COMM_X, ierr)

      return 
      end


      subroutine reduction_vector_tree_y(x, nx, rbuf, nr, spe, ncely,
     & ncidy, block_length_x, logp)
      include  'mppf.h'
      common  /MPI2d/ MPP_COMM_X, MPP_COMM_Y, ISTATUS

      integer  nx, nr
      real*8   x(0:nx), rbuf(0:nr)
      integer  spe, ncely, ncidy, block_length_x  
      integer i,j,k 
      integer ierr 

      k = 1
c     === reduction vector
      do i=0, logp-1
        if (iand(ncidy,k) .eq. 0) then
          if(ncidy .ge. spe) then
            call MPP_SEND(x, block_length_x, MPP_DOUBLE_PRECISION, 
     &                  ncidy+k, i, MPP_COMM_Y, ierr)
          endif
        else
          if (ncidy-k .ge. spe) then
            call MPP_RECV(rbuf, block_length_x, MPP_DOUBLE_PRECISION, 
     &                  ncidy-k, i, MPP_COMM_Y, ISTATUS, ierr)
            do j=0,block_length_x-1
              x(j) = x(j) + rbuf(j)
            enddo
          endif
        endif 
        k = k * 2
      enddo
 200  continue

      call MPP_BCAST(x, block_length_x, MPP_DOUBLE_PRECISION,
     &                   ncely-1, MPP_COMM_Y, ierr)

      return 
      end