#include "options.inc"




      subroutine pe0_recv_2D(a)
c
c--------------------------------------------------------------
c     all PEs send their data of a 2D array to PE0
c--------------------------------------------------------------
c
#ifndef no_mpp
      use spflame_module
      implicit none
#include "sub_mpif.h"

      real, dimension(imt,jmt)     :: a
      integer                      :: is,ie,js,je,iproc
      integer                      :: tag, ierr,len
      integer, dimension(MPI_STATUS_SIZE) :: Status

      tag  = 0; is=is_pe; ie=ie_pe; js=js_pe; je=je_pe

      do iproc=1,n_pes-1
       call mpi_barrier(my_comm,ierr)
       if ( my_pe == iproc ) then
        call mpi_send(is,1,impiinteger,0,tag,my_comm,ierr)
        call mpi_send(ie,1,impiinteger,0,tag,my_comm,ierr)
        call mpi_send(js,1,impiinteger,0,tag,my_comm,ierr)
        call mpi_send(je,1,impiinteger,0,tag,my_comm,ierr)
        len=(ie-is+1)*(je-js+1)
        call mpi_send(a(is:ie,js:je),len,impireal,0,tag,my_comm,ierr)
       endif
       if ( my_pe == 0 ) then
        call mpi_recv(is,1,impiinteger,iproc,tag,my_comm,Status,ierr)
        call mpi_recv(ie,1,impiinteger,iproc,tag,my_comm,Status,ierr)
        call mpi_recv(js,1,impiinteger,iproc,tag,my_comm,Status,ierr)
        call mpi_recv(je,1,impiinteger,iproc,tag,my_comm,Status,ierr)
        len=(ie-is+1)*(je-js+1)
        call  mpi_recv(a(is:ie,js:je),len,impireal,iproc,tag,my_comm,
     &                  Status,ierr)
       endif
       call mpi_barrier(my_comm,ierr)
      enddo
#endif
      end subroutine pe0_recv_2D




      subroutine pe0_send_2D(a)
c
c--------------------------------------------------------------
c     all PEs gets data of a 2D array from PE0
c--------------------------------------------------------------
c
#ifndef no_mpp
      use spflame_module
      implicit none
#include "sub_mpif.h"

      real, dimension(imt,jmt)     :: a
      integer                      :: is,ie,js,je,iproc
      integer                      :: tag, ierr,len
      integer, dimension(MPI_STATUS_SIZE) :: Status

      tag  = 0; is=is_pe; ie=ie_pe; js=js_pe; je=je_pe

      do iproc=1,n_pes-1
       call mpi_barrier(my_comm,ierr)
       if ( my_pe == iproc ) then
        call mpi_send(is,1,impiinteger,0,tag,my_comm,ierr)
        call mpi_send(ie,1,impiinteger,0,tag,my_comm,ierr)
        call mpi_send(js,1,impiinteger,0,tag,my_comm,ierr)
        call mpi_send(je,1,impiinteger,0,tag,my_comm,ierr)
        len=(ie-is+1)*(je-js+1)
        call mpi_recv(a(is:ie,js:je),len,impireal,0,tag,my_comm,
     &                status,ierr)
       endif
       if ( my_pe == 0 ) then
        call mpi_recv(is,1,impiinteger,iproc,tag,my_comm,Status,ierr)
        call mpi_recv(ie,1,impiinteger,iproc,tag,my_comm,Status,ierr)
        call mpi_recv(js,1,impiinteger,iproc,tag,my_comm,Status,ierr)
        call mpi_recv(je,1,impiinteger,iproc,tag,my_comm,Status,ierr)
        len=(ie-is+1)*(je-js+1)
        call mpi_send(a(is:ie,js:je),len,impireal,iproc,tag,my_comm,
     &                  ierr)
       endif
       call mpi_barrier(my_comm,ierr)
      enddo
#endif
      end subroutine pe0_send_2D




      subroutine pe0_send_2D_overlp(a,nx)
c
c--------------------------------------------------------------
c     all PEs gets data of a 2D array from PE0
c     send nx j-and irows overlapping infromation
c--------------------------------------------------------------
c
#ifndef no_mpp
      use spflame_module
      implicit none
#include "sub_mpif.h"
      integer                      :: nx
      real, dimension(imt,jmt)     :: a
      integer                      :: is,ie,js,je,iproc
      integer                      :: tag, ierr,len
      integer, dimension(MPI_STATUS_SIZE) :: Status

      tag  = 0; 

      is=max(is_pe-nx,1); ie=min(ie_pe+nx,imt)
      js=max(js_pe-nx,1); je=min(je_pe+nx,jmt)

      do iproc=1,n_pes-1
       call mpi_barrier(my_comm,ierr)
       if ( my_pe == iproc ) then
        call mpi_send(is,1,impiinteger,0,tag,my_comm,ierr)
        call mpi_send(ie,1,impiinteger,0,tag,my_comm,ierr)
        call mpi_send(js,1,impiinteger,0,tag,my_comm,ierr)
        call mpi_send(je,1,impiinteger,0,tag,my_comm,ierr)
        len=(ie-is+1)*(je-js+1)
        call mpi_recv(a(is:ie,js:je),len,impireal,0,tag,my_comm,
     &                status,ierr)
       endif
       if ( my_pe == 0 ) then
        call mpi_recv(is,1,impiinteger,iproc,tag,my_comm,Status,ierr)
        call mpi_recv(ie,1,impiinteger,iproc,tag,my_comm,Status,ierr)
        call mpi_recv(js,1,impiinteger,iproc,tag,my_comm,Status,ierr)
        call mpi_recv(je,1,impiinteger,iproc,tag,my_comm,Status,ierr)
        len=(ie-is+1)*(je-js+1)
        call mpi_send(a(is:ie,js:je),len,impireal,iproc,tag,my_comm,
     &                  ierr)
       endif
       call mpi_barrier(my_comm,ierr)
      enddo
#endif
      end subroutine pe0_send_2D_overlp


      subroutine border_exchg(a,kk,jx)
c
c--------------------------------------------------------------
c     Exchange overlapping areas of array a in all PEs of sub 
c     domain. Number of overlapping indicees are given by jx.
c     Second dimension is given by kk (maybe 1 for 2D array)
c--------------------------------------------------------------
c
      use spflame_module
      implicit none
      integer jx ,kk
      real a(is_pe-jx:ie_pe+jx,kk,js_pe-jx:je_pe+jx)
#ifndef no_mpp
#include "sub_mpif.h"
      real       buffer(max(j_blk+jx*2+1,i_blk+jx*2+1)*jx)      
      integer    is,ie,js,je
      integer    i1,i2,k,len,jj,jxx,ii,j1,j2
      integer                             :: tag, ierr, req
      integer,dimension(MPI_STATUS_SIZE)  :: Status
c
      tag  = 0
      is = is_pe
      ie = ie_pe
      i1=max(1,is_pe-jx)
      i2=min(imt,ie_pe+jx)
      j1=js_pe-jx
      j2=je_pe+jx
      js=max(1,js_pe-jx)
      je=min(jmt,je_pe+jx)
      do k=1,kk
       if (n_pes_i .gt. 1) then
        jj=je-js+1
        len=jj*jx
        if (len > max(j_blk+jx*2+1,i_blk+jx*2+1)*jx ) 
     &      call halt_stop('in border_exchg (1)')
c      Austausch von Osten nach Westen
        call mpi_barrier(my_comm,ierr)
        if (my_blk_i /=1 ) then
         do jxx=1,jx
           buffer(jj*(jxx-1)+1:jj*jxx) =a(is+jxx-1,k,js:je)
         enddo
         call mpi_send(buffer,len,impireal,my_pe-1,
     &                 tag,my_comm,ierr)
        endif
        if (my_blk_i /= n_pes_i ) then
         call mpi_recv(buffer,len,impireal,my_pe+1,
     &                 tag,my_comm,status,ierr)
         do jxx=1,jx
          a(ie+jxx,k,js:je)    = buffer(jj*(jxx-1)+1:jj*jxx)
         enddo
        endif
c      Austausch von Westen nach Osten
        call mpi_barrier(my_comm,ierr)
        if (my_blk_i /= n_pes_i ) then
         do jxx=1,jx
          buffer(jj*(jxx-1)+1:jj*jxx)=a(ie-(jxx-1),k,js:je)   
         enddo
         call mpi_send(buffer,len,impireal,my_pe+1,
     &                 tag,my_comm,ierr)
        endif
        if (my_blk_i /=1 ) then
         call mpi_recv(buffer,len,impireal,my_pe-1,
     &                 tag,my_comm,status,ierr)
         do jxx=1,jx
          a(is-jxx,k,js:je)   = buffer(jj*(jxx-1)+1:jj*jxx)
         enddo
        endif
       endif
c
       if ( n_pes_j .gt. 1) then
        ii=i2-i1+1
        len=ii*jx
        if (len > max(j_blk+jx*2+1,i_blk+jx*2+1)*jx ) 
     &      call halt_stop('in border_exchg (2)')
c    Austausch von Norden nach Sueden
        call mpi_barrier(my_comm,ierr)
        if (my_blk_j /=1 ) then
         do jxx=2*jx-1,jx,-1
          call mpi_send(a(i1,k,j1+jxx),ii,impireal,my_pe-n_pes_i,
     &                  tag,my_comm,ierr)
         enddo
        endif
        if (my_blk_j /= n_pes_j) then 
         do jxx=0,jx-1
          call mpi_recv(a(i1,k,j2-jxx),ii,
     &        impireal,my_pe+n_pes_i,tag,my_comm,Status,ierr)
         enddo
        endif
c     Austausch von Sueden nach Norden
        call mpi_barrier(my_comm,ierr)
        if (my_blk_j /= n_pes_j) then 
         do jxx=jx,2*jx-1
         call mpi_send(a(i1,k,j2-jxx),ii,impireal,my_pe+n_pes_i,
     &                tag,my_comm,ierr)
         enddo
        endif
        if (my_blk_j /=1 ) then
         do jxx=jx-1,0,-1
          call mpi_recv(a(i1,k,j1+jxx),ii,
     &        impireal,my_pe-n_pes_i,tag,my_comm,Status,ierr)
         enddo
        endif
       endif
      enddo
#endif
      end subroutine border_exchg


      subroutine border_exchg_north(a,kk,jx)
c
c--------------------------------------------------------------
c     Exchange overlapping areas of array a(jmt,km) in all PEs of sub 
c     domain. Number of overlapping indicees are given by jx.
c     Second dimension is given by kk (maybe 1 for 2D array)
c     Diff to border_exchange: no i-dir here
c--------------------------------------------------------------
c
      use spflame_module
      implicit none
      integer jx ,kk
      real a(js_pe-jx:je_pe+jx,kk)
#ifndef no_mpp
#include "sub_mpif.h"
      real       buffer(max(j_blk+jx*2+1,i_blk+jx*2+1)*jx)      
      integer    js,je
      integer    k,len,jj,jxx,j1,j2
      integer                             :: tag, ierr, req
      integer,dimension(MPI_STATUS_SIZE)  :: Status
c
      tag  = 0
      j1=js_pe-jx
      j2=je_pe+jx
      js=max(1,js_pe-jx)
      je=min(jmt,je_pe+jx)
      do k=1,kk
       if ( n_pes_j .gt. 1) then
        if (jx > max(j_blk+jx*2+1,i_blk+jx*2+1)*jx ) 
     &      call halt_stop('in border_exchg_north (2)')
c    Austausch von Norden nach Sueden
        call mpi_barrier(my_comm,ierr)
        if (my_blk_j /=1 ) then
         do jxx=2*jx-1,jx,-1
          call mpi_send(a(j1+jxx,k),1,impireal,my_pe-n_pes_i,
     &                  tag,my_comm,ierr)
         enddo
        endif
        if (my_blk_j /= n_pes_j) then 
         do jxx=0,jx-1
          call mpi_recv(a(j2-jxx,k),1,
     &        impireal,my_pe+n_pes_i,tag,my_comm,Status,ierr)
         enddo
        endif
c     Austausch von Sueden nach Norden
        call mpi_barrier(my_comm,ierr)
        if (my_blk_j /= n_pes_j) then 
         do jxx=jx,2*jx-1
         call mpi_send(a(j2-jxx,k),1,impireal,my_pe+n_pes_i,
     &                tag,my_comm,ierr)
         enddo
        endif
        if (my_blk_j /=1 ) then
         do jxx=jx-1,0,-1
          call mpi_recv(a(j1+jxx,k),1,
     &        impireal,my_pe-n_pes_i,tag,my_comm,Status,ierr)
         enddo
        endif
       endif
      enddo
#endif
      end subroutine border_exchg_north



      subroutine set_cyclic(v,kx,jx)
c
c-----------------------------------------------------------------------
c     adjust borders of an array for cyclic and symmetry settings
c     Communicate in local sub domain.
c-----------------------------------------------------------------------
c
      use spflame_module
      implicit none
      integer kx,jx
      real, dimension(is_pe-jx:ie_pe+jx,kx,js_pe-jx:je_pe+jx) :: v
#ifndef no_mpp
#include "sub_mpif.h"
      integer tag,ierr,len
      integer,dimension(MPI_STATUS_SIZE)  :: Status
#endif
      if (cyclic) then
       if (n_pes_i == 1) then
        v(1,:,:)   = v(imt-1,:,:)
	v(imt,:,:) = v(2,:,:)
       else
#ifndef no_mpp
        len=kx*(je_pe-js_pe+1+2*jx)
        tag=1
        if (my_blk_i ==1 )        call mpi_send(v(2,:,:),len,
     &      impireal,my_pe+(n_pes_i-1),tag,my_comm,ierr)
        if (my_blk_i == n_pes_i ) call mpi_recv(v(imt,:,:),len,
     &      impireal,my_pe-(n_pes_i-1),tag,my_comm,status,ierr)
        tag=2
        if (my_blk_i ==n_pes_i )  call mpi_send(v(imt-1,:,:),len,
     &       impireal,my_pe-(n_pes_i-1),tag,my_comm,ierr)
        if (my_blk_i == 1 )       call mpi_recv(v(1,:,:),len,
     &       impireal,my_pe+(n_pes_i-1),tag,my_comm,status,ierr)
#else
        call halt_stop(' in set_cyclic')
#endif
       endif
      endif
      end subroutine set_cyclic



      subroutine set_cyclic_nx(v,kx,jx)
c
c-----------------------------------------------------------------------
c     adjust borders of an array for cyclic and symmetry settings
c     Communicate in local sub domain.
c     adjust for nx i-slabs at cyclic boundary
c-----------------------------------------------------------------------
c
      use spflame_module
      implicit none
      integer kx,jx
      real, dimension(is_pe-jx:ie_pe+jx,kx,js_pe-jx:je_pe+jx) :: v
      integer i
#ifndef no_mpp
#include "sub_mpif.h"
      integer tag,ierr,len
      integer,dimension(MPI_STATUS_SIZE)  :: Status
#endif

      if (cyclic) then
       if (n_pes_i == 1) then
        do i=1,jx
         v(1-i+1  ,:,:)= v(imt-i,:,:)
	 v(imt+i-1,:,:) = v(i+1,:,:)
        enddo
       else
#ifndef no_mpp
        len=kx*(je_pe-js_pe+1+2*jx)
        do i=1,jx
         tag=1
         if (my_blk_i ==1 )        call mpi_send(v(i+1,:,:),len,
     &      impireal,my_pe+(n_pes_i-1),tag,my_comm,ierr)
         if (my_blk_i == n_pes_i ) call mpi_recv(v(imt+i-1,:,:),len,
     &      impireal,my_pe-(n_pes_i-1),tag,my_comm,status,ierr)
         tag=2
         if (my_blk_i ==n_pes_i )  call mpi_send(v(imt-i,:,:),len,
     &       impireal,my_pe-(n_pes_i-1),tag,my_comm,ierr)
         if (my_blk_i == 1 )       call mpi_recv(v(1-i+1,:,:),len,
     &       impireal,my_pe+(n_pes_i-1),tag,my_comm,status,ierr)
        enddo
#else
        call halt_stop(' in set_cyclic_nx')
#endif
       endif
      endif
      end subroutine set_cyclic_nx



      subroutine set_cyclic_4th_order(v,kx,jx)
c
c-----------------------------------------------------------------------
c     adjust borders of an array for cyclic and symmetry settings
c     Communicate in local sub domain.
c     adjust for 4th order advection schemes
c-----------------------------------------------------------------------
c
      use spflame_module
      implicit none
      integer kx,jx
      real, dimension(is_pe-jx:ie_pe+jx,kx,js_pe-jx:je_pe+jx) :: v
#ifndef no_mpp
#include "sub_mpif.h"
      integer tag,ierr,len
      integer,dimension(MPI_STATUS_SIZE)  :: Status
#endif
      if (jx<2) then
        if (my_pe==0) then
          print*,' adjust arrays for 4th order advection schemes'
          print*,' only if they are dimensioned correctly.'
          print*,' (jx=',jx,' must be greater or equal 2)'
        endif
        call halt_stop(' in set_cyclic_4th_order')
      endif

      if (cyclic) then
       if (n_pes_i == 1) then
        v(0,:,:)   = v(imt-2,:,:)
	v(imt+1,:,:) = v(3,:,:)
       else
#ifndef no_mpp
        len=kx*(je_pe-js_pe+1+2*jx)
        tag=1
        if (my_blk_i ==1 )        call mpi_send(v(3,:,:),len,
     &      impireal,my_pe+(n_pes_i-1),tag,my_comm,ierr)
        if (my_blk_i == n_pes_i ) call mpi_recv(v(imt+1,:,:),len,
     &      impireal,my_pe-(n_pes_i-1),tag,my_comm,status,ierr)
        tag=2
        if (my_blk_i ==n_pes_i )  call mpi_send(v(imt-2,:,:),len,
     &       impireal,my_pe-(n_pes_i-1),tag,my_comm,ierr)
        if (my_blk_i == 1 )       call mpi_recv(v(0,:,:),len,
     &       impireal,my_pe+(n_pes_i-1),tag,my_comm,status,ierr)
#else
        call halt_stop(' in set_cyclic_4th_order')
#endif
       endif
      endif
      end subroutine set_cyclic_4th_order


      subroutine set_cyclic_int(v,kx,jx)
c
c-----------------------------------------------------------------------
c     adjust borders of an array for cyclic and symmetry settings
c     Communicate in local sub domain.
c-----------------------------------------------------------------------
c
      use spflame_module
      implicit none
      integer kx,jx
      integer, dimension(is_pe-jx:ie_pe+jx,kx,js_pe-jx:je_pe+jx) :: v
#ifndef no_mpp
#include "sub_mpif.h"
      integer tag,ierr,len
      integer,dimension(MPI_STATUS_SIZE)  :: Status
#endif
      if (cyclic) then
       if (n_pes_i == 1) then
        v(1,:,:)   = v(imt-1,:,:)
	v(imt,:,:) = v(2,:,:)
       else
#ifndef no_mpp
        len=kx*(je_pe-js_pe+1+2*jx)
        tag=1
        if (my_blk_i ==1 )        call mpi_send(v(2,:,:),len,
     &      impiinteger,my_pe+(n_pes_i-1),tag,my_comm,ierr)
        if (my_blk_i == n_pes_i ) call mpi_recv(v(imt,:,:),len,
     &      impiinteger,my_pe-(n_pes_i-1),tag,my_comm,status,ierr)
        tag=2
        if (my_blk_i ==n_pes_i )  call mpi_send(v(imt-1,:,:),len,
     &       impiinteger,my_pe-(n_pes_i-1),tag,my_comm,ierr)
        if (my_blk_i == 1 )       call mpi_recv(v(1,:,:),len,
     &       impiinteger,my_pe+(n_pes_i-1),tag,my_comm,status,ierr)
#else
        call halt_stop(' in set_cyclic_int')
#endif
       endif
      endif
      end subroutine set_cyclic_int




      subroutine   sum_along_jrow(v,k)
c
c-----------------------------------------------------------------------
c     sum over jrow, store result in v of the westernmost PE
c     all in local domain
c-----------------------------------------------------------------------
c
      use spflame_module
      implicit none
      integer k
      real v(k), buf(k)
#ifndef no_mpp
#include "sub_mpif.h"
      integer :: comm,i_first_pe,n,ierr
      integer :: status(MPI_STATUS_SIZE)

      if ( n_pes_i .gt. 1 ) then
        i_first_pe =  (my_blk_j - 1) * n_pes_i
        buf=v
        do n=i_first_pe+1, i_first_pe+n_pes_i-1
         if ( my_pe == n )  call mpi_send (buf,k,
     &         impireal,i_first_pe,1,my_comm,ierr)
         if ( my_pe == i_first_pe  ) call mpi_recv (buf,k,
     &         impireal,n,1,my_comm,status,ierr)
         if (my_pe == i_first_pe) v=v+buf
        enddo
      endif
#endif
      end subroutine sum_along_jrow



      subroutine   max_along_jrow(v,k)
c
c-----------------------------------------------------------------------
c     maximum over jrow, store result in v of the westernmost PE
c     all in local domain
c-----------------------------------------------------------------------
c
      use spflame_module
      implicit none
      integer k
      real v(k), buf(k)
#ifndef no_mpp
#include "sub_mpif.h"
      integer :: comm,i_first_pe,n,ierr
      integer :: status(MPI_STATUS_SIZE)

      if ( n_pes_i .gt. 1 ) then
        i_first_pe =  (my_blk_j - 1) * n_pes_i
        buf=v
        do n=i_first_pe+1, i_first_pe+n_pes_i-1
         if ( my_pe == n )  call mpi_send (buf,k,
     &         impireal,i_first_pe,1,my_comm,ierr)
         if ( my_pe == i_first_pe  ) call mpi_recv (buf,k,
     &         impireal,n,1,my_comm,status,ierr)
         if (my_pe == i_first_pe) v=max(v,buf)
        enddo
      endif
#endif
      end subroutine max_along_jrow



      subroutine pe0_recv_vec_along_jrow(a,sdim)
c
c--------------------------------------------------------------
c     all PEs send their data of a 2D vector along j to PE0
c     meant mainly for overturning and heat transport
c--------------------------------------------------------------
c
#ifndef no_mpp
      use spflame_module
      implicit none
#include "sub_mpif.h"
      integer                      :: sdim
      real, dimension(jmt,sdim)    :: a
      integer                      :: is,ie,js,je,iproc
      integer                      :: tag, ierr,len
      integer, dimension(MPI_STATUS_SIZE) :: Status

      tag  = 0; is=is_pe; ie=ie_pe; js=js_pe; je=je_pe

      do iproc=1,n_pes-1
       call mpi_barrier(my_comm,ierr)
       if ( my_pe == iproc ) then
        call mpi_send(js,1,impiinteger,0,tag,my_comm,ierr)
        call mpi_send(je,1,impiinteger,0,tag,my_comm,ierr)
        len=(sdim)*(je-js+1)
        call mpi_send(a(js:je,:),len,impireal,0,tag,my_comm,ierr)
       endif
       if ( my_pe == 0 ) then
        call mpi_recv(js,1,impiinteger,iproc,tag,my_comm,Status,ierr)
        call mpi_recv(je,1,impiinteger,iproc,tag,my_comm,Status,ierr)
        len=(sdim)*(je-js+1)
        call  mpi_recv(a(js:je,:),len,impireal,iproc,tag,my_comm,
     &                  Status,ierr)
       endif
       call mpi_barrier(my_comm,ierr)
      enddo
#endif
      end subroutine pe0_recv_vec_along_jrow


      subroutine pe0_recv_merid_vec(a,sdim,i0)
c
c--------------------------------------------------------------
c     all PEs whos domains contain longitudinal slab i0
c     send their data of 2D vector a along j to PE0
c--------------------------------------------------------------
c
#ifndef no_mpp
      use spflame_module
      implicit none
#include "sub_mpif.h"
      integer                      :: sdim,i0
      real, dimension(jmt,sdim)    :: a
      integer                      :: is,ie,js,je
      integer                      :: is2,ie2,js2,je2,k
      integer                      :: iproc
      integer                      :: tag, ierr,len
      integer, dimension(MPI_STATUS_SIZE) :: Status

      tag  = 0; is=is_pe; ie=ie_pe; js=js_pe; je=je_pe

      do iproc=1,n_pes-1

       call mpi_barrier(my_comm,ierr)
       if ( my_pe == iproc ) then
        if (is <= i0 .and. ie >= i0 ) then
         k=1
         call mpi_send(k,1,impiinteger,0,tag,my_comm,ierr)
         call mpi_send(js,1,impiinteger,0,tag,my_comm,ierr)
         call mpi_send(je,1,impiinteger,0,tag,my_comm,ierr)
         len=(sdim)*(je-js+1)
         call mpi_send(a(js:je,:),len,impireal,0,tag,my_comm,ierr)
        else
         k=0
         call mpi_send(k,1,impiinteger,0,tag,my_comm,ierr)
        endif
       endif

       if ( my_pe == 0 ) then
        call mpi_recv(k,1,impiinteger,iproc,tag,my_comm,Status,ierr)
        if (k==1) then
         call mpi_recv(js2,1,impiinteger,iproc,tag,my_comm,Status,ierr)
         call mpi_recv(je2,1,impiinteger,iproc,tag,my_comm,Status,ierr)
         len=(sdim)*(je2-js2+1)
         call  mpi_recv(a(js2:je2,:),len,impireal,iproc,tag,my_comm,
     &                   Status,ierr)
        endif
       endif
       call mpi_barrier(my_comm,ierr)
      enddo
#endif
      end subroutine pe0_recv_merid_vec



      subroutine pe0_recv_zonal_vec(a,sdim,j0)
c
c--------------------------------------------------------------
c     all PEs whos domains contain latitudinal slab j0
c     send their data of 2D vector a along i to PE0
c--------------------------------------------------------------
c
#ifndef no_mpp
      use spflame_module
      implicit none
#include "sub_mpif.h"
      integer                      :: sdim,j0
      real, dimension(imt,sdim)    :: a
      integer                      :: is,ie,js,je
      integer                      :: is2,ie2,js2,je2,k
      integer                      :: iproc
      integer                      :: tag, ierr,len
      integer, dimension(MPI_STATUS_SIZE) :: Status

      tag  = 0; is=is_pe; ie=ie_pe; js=js_pe; je=je_pe

      do iproc=1,n_pes-1

       call mpi_barrier(my_comm,ierr)
       if ( my_pe == iproc ) then
        if (js <= j0 .and. je >= j0 ) then
         k=1
         call mpi_send(k,1,impiinteger,0,tag,my_comm,ierr)
         call mpi_send(is,1,impiinteger,0,tag,my_comm,ierr)
         call mpi_send(ie,1,impiinteger,0,tag,my_comm,ierr)
         len=(sdim)*(ie-is+1)
         call mpi_send(a(is:ie,:),len,impireal,0,tag,my_comm,ierr)
        else
         k=0
         call mpi_send(k,1,impiinteger,0,tag,my_comm,ierr)
        endif
       endif

       if ( my_pe == 0 ) then
        call mpi_recv(k,1,impiinteger,iproc,tag,my_comm,Status,ierr)
        if (k==1) then
         call mpi_recv(is2,1,impiinteger,iproc,tag,my_comm,Status,ierr)
         call mpi_recv(ie2,1,impiinteger,iproc,tag,my_comm,Status,ierr)
         len=(sdim)*(ie2-is2+1)
         call  mpi_recv(a(is2:ie2,:),len,impireal,iproc,tag,my_comm,
     &                   Status,ierr)
        endif
       endif
       call mpi_barrier(my_comm,ierr)
      enddo
#endif
      end subroutine pe0_recv_zonal_vec



      subroutine pe0_recv_depth_vec(a,sdim,i0,j0)
c
c--------------------------------------------------------------
c     the PE whos domain contain position i0,j0
c     send its data a(km,sdim) to PE0
c--------------------------------------------------------------
c
#ifndef no_mpp
      use spflame_module
      implicit none
#include "sub_mpif.h"
      integer                      :: sdim,j0,i0
      real, dimension(km,sdim)     :: a
      integer                      :: is,ie,js,je
      integer                      :: is2,ie2,js2,je2,k
      integer                      :: iproc
      integer                      :: tag, ierr,len
      integer, dimension(MPI_STATUS_SIZE) :: Status

      tag = 0; is=is_pe; ie=ie_pe; js=js_pe; je=je_pe

      do iproc=1,n_pes-1

       call mpi_barrier(my_comm,ierr)
       if ( my_pe == iproc ) then
        if (js <= j0 .and. je >= j0 .and. is <= i0 .and. ie >= i0 ) then
         k=1
         call mpi_send(k,1,impiinteger,0,tag,my_comm,ierr)
         len=sdim*km
         call mpi_send(a,len,impireal,0,tag,my_comm,ierr)
        else
         k=0
         call mpi_send(k,1,impiinteger,0,tag,my_comm,ierr)
        endif
       endif

       if ( my_pe == 0 ) then
        call mpi_recv(k,1,impiinteger,iproc,tag,my_comm,Status,ierr)
        if (k==1) then
         len=sdim*km
         call  mpi_recv(a,len,impireal,iproc,tag,my_comm,Status,ierr)
        endif
       endif
       call mpi_barrier(my_comm,ierr)
      enddo
#endif
      end subroutine pe0_recv_depth_vec



