pkg/compon_communic/comprecv_r8tiles.F

bf4be02920 Jean*0001 !=======================================================================
                0002       subroutine comprecv_r8tiles( dataname, Ni,Oi,Nj,Oj,Nk,Tx,Ty, arr )
                0003       implicit none
                0004 ! Arguments
                0005       character*(*) dataname
                0006       integer Ni,Oi,Nj,Oj,Io,Jo,Nk,Tx,Ty
                0007       real*8 arr(1-Oi:Ni+Oi,1-Oj:Nj+Oj,Nk,Tx,Ty)
                0008 ! Predefined constants/arrays
                0009 #include "CPLR_SIG.h"
                0010 ! MPI variables
                0011 #include "mpif.h"
                0012       integer count,dtype,rank,tag,comm,ierr
                0013       integer stat(MPI_STATUS_SIZE)
                0014 ! Functions
                0015       integer generate_tag
                0016 ! Local
                0017       integer i,j,ij,nx,ny,k,bibj,bi,bj
                0018       character*(MAXLEN_COMP_NAME) recvdname
                0019 !     ------------------------------------------------------------------
                0020
                0021       if (HEADER_SIZE+Ni*Nj.gt.MAX_R8_BUFLEN)
                0022      &    stop 'comprecv_r8tiles: Nx*Ny too big'
                0023
                0024 ! Foreach tile which is non-blank
                0025       do bibj=1,my_num_tiles
                0026
                0027        bi=my_tile_bi(bibj)
                0028        bj=my_tile_bj(bibj)
                0029
                0030 ! Receive message
                0031        count=MAX_R8_BUFLEN
                0032        dtype=MPI_DOUBLE_PRECISION
                0033        tag=generate_tag(123,bibj,dataname)
                0034        rank=my_coupler_rank
                0035        comm=MPI_COMM_myglobal
                0036
                0037        if (VERB) then
                0038         write(LogUnit,*) 'comprecv_r8tiles: calling MPI_Recv rank=',rank
                0039         write(LogUnit,*) 'comprecv_r8tiles: dataname=',dataname
                0040         call flush(LogUnit)
                0041        endif
                0042        call MPI_Recv(r8buf, count, dtype, rank, tag, comm, stat, ierr)
                0043        if (VERB) then
                0044         write(LogUnit,*) 'comprecv_r8tiles: returned ierr=',ierr
                0045         call flush(LogUnit)
                0046        endif
                0047
                0048        if (ierr.ne.0) then
                0049         write(LogUnit,*) 'comprecv_r8tiles: rank(W,G)=',
                0050      &            my_rank_in_world,my_rank_in_global,
                0051      &            ' ierr=',ierr
                0052         stop 'comprecv_r8tiles: MPI_Recv failed'
                0053        endif
                0054
                0055 ! Extract buffer
                0056        Io=int(0.5+r8buf(1))
                0057        Jo=int(0.5+r8buf(2))
                0058        nx=int(0.5+r8buf(3))
                0059        ny=int(0.5+r8buf(4))
e5266ce10c Jean*0060        call mitcplr_dbl2char( r8buf(9), recvdname )
bf4be02920 Jean*0061
                0062        if (Io.ne.my_tile_i0(bibj)) stop 'comprecv_r8tiles: bad Io'
                0063        if (Jo.ne.my_tile_j0(bibj)) stop 'comprecv_r8tiles: bad Jo'
                0064        if (nx.ne.my_tile_nx(bibj)) stop 'comprecv_r8tiles: bad nx'
                0065        if (ny.ne.my_tile_ny(bibj)) stop 'comprecv_r8tiles: bad ny'
                0066        if (recvdname .ne. dataname) then
                0067         write(LogUnit,*) 'comprecv_r8tiles: recvdname = ',recvdname
                0068         write(LogUnit,*) 'comprecv_r8tiles:  dataname = ',dataname
                0069         stop 'comprecv_r8tiles: recvdname != dataname'
                0070        endif
                0071
                0072 ! Copy buffer to interior of tile
                0073        k=1
                0074        do j=1,Nj
                0075         do i=1,Ni
                0076          ij=HEADER_SIZE+i+Ni*(j-1)
                0077          arr(i,j,k,bi,bj)=r8buf(ij)
                0078         enddo
                0079        enddo
                0080
                0081       enddo ! bibj
                0082
                0083 !     ------------------------------------------------------------------
                0084       return
                0085       end
                0086 !=======================================================================