C $Header: /u/gcmpack/MITgcm/pkg/flt/flt_exch2.F,v 1.4 2017/02/11 21:07:13 gforget Exp $ C $Name: $ #include "FLT_OPTIONS.h" #undef DBUG_EXCH_VEC SUBROUTINE FLT_EXCH2 ( I myTime, myIter, myThid ) C ================================================================== C SUBROUTINE FLT_EXCH2 C ================================================================== C o Exchange particles between tiles. C started: Arne Biastoch C changed: Antti Westerlund antti.westerlund@helsinki.fi 2004.06.10 C adapted to exch2: Oliver Jahn 2010.09 C ================================================================== C !USES: IMPLICIT NONE C == global variables == #include "SIZE.h" #include "EEPARAMS.h" #include "EESUPPORT.h" #include "PARAMS.h" #include "FLT_SIZE.h" #include "FLT.h" #ifdef ALLOW_EXCH2 #include "W2_EXCH2_SIZE.h" #include "W2_EXCH2_PARAMS.h" #include "W2_EXCH2_TOPOLOGY.h" #endif C == routine arguments == _RL myTime INTEGER myIter, myThid #ifdef ALLOW_EXCH2 C == local variables == INTEGER bi, bj, ic INTEGER ip, jp, jl, npNew INTEGER icountE, icountW, icountN, icountS INTEGER deleteList(max_npart_exch*2) INTEGER imax, imax2, m INTEGER N, nT, ipass, myFace INTEGER e2_msgHandles( 2, W2_maxNeighbours, nSx, nSy ) _RL ilo, ihi, jlo, jhi, iNew, jNew PARAMETER(imax=9) PARAMETER(imax2=imax*max_npart_exch) CHARACTER*(MAX_LEN_MBUF) msgBuf C buffer for sending/receiving variables (4 levels <-> N,S,E,W) COMMON/FLTBUF/fltbuf_send,fltbuf_recv _RL fltbuf_send(imax2,nSx,nSy,4) _RL fltbuf_recv(imax2,nSx,nSy,4) LOGICAL wSide, eSide, sSide, nSide _RL flt_stopped C == end of interface == C have to do 2 passes to get into tiles diagonally across DO ipass=1,2 C Prevent anyone to access shared buffer while an other thread modifies it C-- not needed here since send buffer is different fron recv buffer C (which is not the case for usual 3-D field exch in EXCH2) c CALL BAR2( myThid ) C-- Choose floats that have to exchanged with eastern and western tiles C and pack to arrays DO bj=myByLo(myThid),myByHi(myThid) DO bi=myBxLo(myThid),myBxHi(myThid) nT = W2_myTileList(bi,bj) myFace = exch2_myFace(nT) C initialize buffers DO N=1,4 DO m=1,imax2 fltbuf_send(m,bi,bj,N) = 0. fltbuf_recv(m,bi,bj,N) = 0. ENDDO ENDDO icountE=0 icountW=0 jl = 0 ilo = 0.5 _d 0 ihi = 0.5 _d 0 + DFLOAT(sNx) wSide = exch2_isWedge(nT).EQ.1 & .AND. facet_link(W2_WEST,myFace).EQ.0. eSide = exch2_isEedge(nT).EQ.1 & .AND. facet_link(W2_EAST,myFace).EQ.0. flt_stopped = -2. flt_stopped = MIN( baseTime, flt_stopped ) DO ip=1,npart_tile(bi,bj) IF ( eSide .AND. & (myTime.LE.tend(ip,bi,bj) .OR. tend(ip,bi,bj).EQ.-1.) & .AND. ipart(ip,bi,bj).GE.ihi ) THEN C stop the float: tend(ip,bi,bj) = flt_stopped ELSEIF ( ipart(ip,bi,bj).GE.ihi ) THEN icountE=icountE+1 IF ( icountE.LE.max_npart_exch ) THEN ic = (icountE-1)*imax iNew = ipart(ip,bi,bj) - DFLOAT(sNx) fltbuf_send(ic+1,bi,bj,W2_EAST) = npart(ip,bi,bj) fltbuf_send(ic+2,bi,bj,W2_EAST) = tstart(ip,bi,bj) #ifdef DEVEL_FLT_EXCH2 fltbuf_send(ic+3,bi,bj,W2_EAST) = ipart(ip,bi,bj) #else fltbuf_send(ic+3,bi,bj,W2_EAST) = iNew #endif fltbuf_send(ic+4,bi,bj,W2_EAST) = jpart(ip,bi,bj) fltbuf_send(ic+5,bi,bj,W2_EAST) = kpart(ip,bi,bj) fltbuf_send(ic+6,bi,bj,W2_EAST) = kfloat(ip,bi,bj) fltbuf_send(ic+7,bi,bj,W2_EAST) = iup(ip,bi,bj) fltbuf_send(ic+8,bi,bj,W2_EAST) = itop(ip,bi,bj) fltbuf_send(ic+9,bi,bj,W2_EAST) = tend(ip,bi,bj) C tag this float to be removed: jl = jl + 1 deleteList(jl) = ip npart(ip,bi,bj) = 0. ENDIF ENDIF IF ( wSide .AND. & (myTime.LE.tend(ip,bi,bj) .OR. tend(ip,bi,bj).EQ.-1.) & .AND. ipart(ip,bi,bj).LT.ilo ) THEN C stop the float: tend(ip,bi,bj) = flt_stopped ELSEIF ( ipart(ip,bi,bj).LT.ilo ) THEN icountW=icountW+1 IF ( icountW.LE.max_npart_exch ) THEN ic = (icountW-1)*imax iNew = ipart(ip,bi,bj) + DFLOAT(sNx) fltbuf_send(ic+1,bi,bj,W2_WEST) = npart(ip,bi,bj) fltbuf_send(ic+2,bi,bj,W2_WEST) = tstart(ip,bi,bj) #ifdef DEVEL_FLT_EXCH2 fltbuf_send(ic+3,bi,bj,W2_WEST) = ipart(ip,bi,bj) #else fltbuf_send(ic+3,bi,bj,W2_WEST) = iNew #endif fltbuf_send(ic+4,bi,bj,W2_WEST) = jpart(ip,bi,bj) fltbuf_send(ic+5,bi,bj,W2_WEST) = kpart(ip,bi,bj) fltbuf_send(ic+6,bi,bj,W2_WEST) = kfloat(ip,bi,bj) fltbuf_send(ic+7,bi,bj,W2_WEST) = iup(ip,bi,bj) fltbuf_send(ic+8,bi,bj,W2_WEST) = itop(ip,bi,bj) fltbuf_send(ic+9,bi,bj,W2_WEST) = tend(ip,bi,bj) C tag this float to be removed: jl = jl + 1 deleteList(jl) = ip npart(ip,bi,bj) = 0. ENDIF ENDIF ENDDO IF ( icountE.GT.max_npart_exch ) THEN WRITE(msgBuf,'(2A,2I4,2(A,I8))') ' FLT_EXCH2:', & ' bi,bj=', bi, bj, & ' icountE=', icountE, & ' > max_npart_exch=', max_npart_exch CALL PRINT_ERROR( msgBuf, myThid ) ENDIF IF ( icountW.GT.max_npart_exch ) THEN WRITE(msgBuf,'(2A,2I4,2(A,I8))') ' FLT_EXCH2:', & ' bi,bj=', bi, bj, & ' icountW=', icountW, & ' > max_npart_exch=', max_npart_exch CALL PRINT_ERROR( msgBuf, myThid ) ENDIF IF ( icountE.GT.max_npart_exch & .OR. icountW.GT.max_npart_exch ) THEN STOP 'ABNORMAL END: S/R FLT_EXCH2' ENDIF IF ( (icountE+icountW).GT.0 ) THEN C Remove from this tile-list, floats which have been sent to an other tile npNew = npart_tile(bi,bj) - (icountE+icountW) jl = 0 DO jp = npNew+1,npart_tile(bi,bj) IF ( npart(jp,bi,bj).NE.0. _d 0 ) THEN jl = jl + 1 ip = deleteList(jl) C copy: ip <-- jp npart (ip,bi,bj) = npart (jp,bi,bj) tstart(ip,bi,bj) = tstart(jp,bi,bj) ipart (ip,bi,bj) = ipart (jp,bi,bj) jpart (ip,bi,bj) = jpart (jp,bi,bj) kpart (ip,bi,bj) = kpart (jp,bi,bj) kfloat(ip,bi,bj) = kfloat(jp,bi,bj) iup (ip,bi,bj) = iup (jp,bi,bj) itop (ip,bi,bj) = itop (jp,bi,bj) tend (ip,bi,bj) = tend (jp,bi,bj) ENDIF ENDDO npart_tile(bi,bj) = npNew ENDIF icountN=0 icountS=0 jl = 0 jlo = 0.5 _d 0 jhi = 0.5 _d 0 + DFLOAT(sNy) sSide = exch2_isSedge(nT).EQ.1 & .AND. facet_link(W2_SOUTH,myFace).EQ.0. nSide = exch2_isNedge(nT).EQ.1 & .AND. facet_link(W2_NORTH,myFace).EQ.0. flt_stopped = -2. flt_stopped = MIN( baseTime, flt_stopped ) DO ip=1,npart_tile(bi,bj) IF ( npart(ip,bi,bj).NE.0 ) THEN IF ( nSide .AND. & (myTime.LE.tend(ip,bi,bj) .OR. tend(ip,bi,bj).EQ.-1.) & .AND. jpart(ip,bi,bj).GE.jhi ) THEN C stop the float: tend(ip,bi,bj) = flt_stopped ELSEIF ( jpart(ip,bi,bj).GE.jhi ) THEN icountN=icountN+1 IF ( icountN.LE.max_npart_exch ) THEN ic = (icountN-1)*imax jNew = jpart(ip,bi,bj) - DFLOAT(sNy) fltbuf_send(ic+1,bi,bj,W2_NORTH) = npart(ip,bi,bj) fltbuf_send(ic+2,bi,bj,W2_NORTH) = tstart(ip,bi,bj) fltbuf_send(ic+3,bi,bj,W2_NORTH) = ipart(ip,bi,bj) #ifdef DEVEL_FLT_EXCH2 fltbuf_send(ic+4,bi,bj,W2_NORTH) = jpart(ip,bi,bj) #else fltbuf_send(ic+4,bi,bj,W2_NORTH) = jNew #endif fltbuf_send(ic+5,bi,bj,W2_NORTH) = kpart(ip,bi,bj) fltbuf_send(ic+6,bi,bj,W2_NORTH) = kfloat(ip,bi,bj) fltbuf_send(ic+7,bi,bj,W2_NORTH) = iup(ip,bi,bj) fltbuf_send(ic+8,bi,bj,W2_NORTH) = itop(ip,bi,bj) fltbuf_send(ic+9,bi,bj,W2_NORTH) = tend(ip,bi,bj) C tag this float to be removed: jl = jl + 1 deleteList(jl) = ip npart(ip,bi,bj) = 0. c ELSE c WRITE(msgBuf,'(2A,2I4,I6,A,2F17.6))') ' FLT_EXCH2,N:', c & ' bi,bj,ip=', bi, bj, ip, c & ' yp,yHi=', jpart(ip,bi,bj), jhi c CALL PRINT_ERROR( msgBuf, myThid ) ENDIF ENDIF IF ( sSide .AND. & (myTime.LE.tend(ip,bi,bj) .OR. tend(ip,bi,bj).EQ.-1.) & .AND. jpart(ip,bi,bj).LT.jlo ) THEN C stop the float: tend(ip,bi,bj) = flt_stopped ELSEIF ( jpart(ip,bi,bj).LT.jlo ) THEN icountS=icountS+1 IF ( icountS.LE.max_npart_exch ) THEN ic = (icountS-1)*imax jNew = jpart(ip,bi,bj) + DFLOAT(sNy) fltbuf_send(ic+1,bi,bj,W2_SOUTH) = npart(ip,bi,bj) fltbuf_send(ic+2,bi,bj,W2_SOUTH) = tstart(ip,bi,bj) fltbuf_send(ic+3,bi,bj,W2_SOUTH) = ipart(ip,bi,bj) #ifdef DEVEL_FLT_EXCH2 fltbuf_send(ic+4,bi,bj,W2_SOUTH) = jpart(ip,bi,bj) #else fltbuf_send(ic+4,bi,bj,W2_SOUTH) = jNew #endif fltbuf_send(ic+5,bi,bj,W2_SOUTH) = kpart(ip,bi,bj) fltbuf_send(ic+6,bi,bj,W2_SOUTH) = kfloat(ip,bi,bj) fltbuf_send(ic+7,bi,bj,W2_SOUTH) = iup(ip,bi,bj) fltbuf_send(ic+8,bi,bj,W2_SOUTH) = itop(ip,bi,bj) fltbuf_send(ic+9,bi,bj,W2_SOUTH) = tend(ip,bi,bj) C tag this float to be removed: jl = jl + 1 deleteList(jl) = ip npart(ip,bi,bj) = 0. c ELSE c WRITE(msgBuf,'(2A,2I4,I6,A,2F17.6))') ' FLT_EXCH2,S:', c & ' bi,bj,ip=', bi, bj, ip, c & ' yp,yLo=', jpart(ip,bi,bj), jlo c CALL PRINT_ERROR( msgBuf, myThid ) ENDIF ENDIF ENDIF ENDDO IF ( icountN.GT.max_npart_exch ) THEN WRITE(msgBuf,'(2A,2I4,2(A,I8))') ' FLT_EXCH2:', & ' bi,bj=', bi, bj, & ' icountN=', icountN, & ' > max_npart_exch=', max_npart_exch CALL PRINT_ERROR( msgBuf, myThid ) ENDIF IF ( icountS.GT.max_npart_exch ) THEN WRITE(msgBuf,'(2A,2I4,2(A,I8))') ' FLT_EXCH2:', & ' bi,bj=', bi, bj, & ' icountS=', icountS, & ' > max_npart_exch=', max_npart_exch CALL PRINT_ERROR( msgBuf, myThid ) ENDIF IF ( icountN.GT.max_npart_exch & .OR. icountS.GT.max_npart_exch ) THEN STOP 'ABNORMAL END: S/R FLT_EXCH2' ENDIF IF ( (icountN+icountS).GT.0 ) THEN C Remove from this tile-list, floats which have been sent to an other tile npNew = npart_tile(bi,bj) - (icountN+icountS) jl = 0 DO jp = npNew+1,npart_tile(bi,bj) IF ( npart(jp,bi,bj).NE.0. _d 0 ) THEN jl = jl + 1 ip = deleteList(jl) C copy: ip <-- jp npart (ip,bi,bj) = npart (jp,bi,bj) tstart(ip,bi,bj) = tstart(jp,bi,bj) ipart (ip,bi,bj) = ipart (jp,bi,bj) jpart (ip,bi,bj) = jpart (jp,bi,bj) kpart (ip,bi,bj) = kpart (jp,bi,bj) kfloat(ip,bi,bj) = kfloat(jp,bi,bj) iup (ip,bi,bj) = iup (jp,bi,bj) itop (ip,bi,bj) = itop (jp,bi,bj) tend (ip,bi,bj) = tend (jp,bi,bj) ENDIF ENDDO npart_tile(bi,bj) = npNew ENDIF ENDDO ENDDO C Prevent anyone to access shared buffer while an other thread modifies it _BARRIER C-- Send or Put east and west edges. #ifdef DBUG_EXCH_VEC WRITE(errorMessageUnit,'(A,I8)') 'FLT_EXCH: 0x', myIter #endif CALL EXCH2_SEND_PUT_VEC_RL( I fltbuf_send, O fltbuf_recv, O e2_msgHandles(1,1,1,1), I imax2, myThid ) #ifdef DBUG_EXCH_VEC WRITE(errorMessageUnit,'(A,I8)') 'FLT_EXCH2: 1x', myIter #endif #ifdef ALLOW_USE_MPI IF ( usingMPI ) THEN C-- Receive east/west arrays CALL EXCH2_RECV_GET_VEC_RL( U fltbuf_recv, I e2_msgHandles(1,1,1,1), I imax2, myThid ) #ifdef DBUG_EXCH_VEC WRITE(errorMessageUnit,'(A,I8)') 'FLT_EXCH2: 2x', myIter #endif ENDIF #endif /* ALLOW_USE_MPI */ C-- need to sync threads after master has received data ; C (done after mpi waitall in case waitall is really needed) _BARRIER C-- Unpack arrays on new tiles DO bj=myByLo(myThid),myByHi(myThid) DO bi=myBxLo(myThid),myBxHi(myThid) DO ip=1,max_npart_exch ic=(ip-1)*imax IF ( fltbuf_recv(ic+1,bi,bj,W2_EAST).NE.0. ) THEN npart_tile(bi,bj) = npart_tile(bi,bj) + 1 IF ( npart_tile(bi,bj).LE.max_npart_tile ) THEN jp = npart_tile(bi,bj) npart( jp,bi,bj) = fltbuf_recv(ic+1,bi,bj,W2_EAST) tstart(jp,bi,bj) = fltbuf_recv(ic+2,bi,bj,W2_EAST) ipart( jp,bi,bj) = fltbuf_recv(ic+3,bi,bj,W2_EAST) jpart( jp,bi,bj) = fltbuf_recv(ic+4,bi,bj,W2_EAST) kpart( jp,bi,bj) = fltbuf_recv(ic+5,bi,bj,W2_EAST) kfloat(jp,bi,bj) = fltbuf_recv(ic+6,bi,bj,W2_EAST) iup( jp,bi,bj) = fltbuf_recv(ic+7,bi,bj,W2_EAST) itop( jp,bi,bj) = fltbuf_recv(ic+8,bi,bj,W2_EAST) tend( jp,bi,bj) = fltbuf_recv(ic+9,bi,bj,W2_EAST) ENDIF ENDIF ENDDO IF ( npart_tile(bi,bj).GT.max_npart_tile ) THEN WRITE(msgBuf,'(2A,2I4,2(A,I8))') 'FLT_EXCH2:+E', & ' bi,bj=', bi, bj, & ' npart_tile=', npart_tile(bi,bj), & ' > max_npart_tile=', max_npart_tile CALL PRINT_ERROR( msgBuf, myThid ) STOP 'ABNORMAL END: S/R FLT_EXCH2' ENDIF DO ip=1,max_npart_exch ic=(ip-1)*imax IF ( fltbuf_recv(ic+1,bi,bj,W2_WEST).NE.0. ) THEN npart_tile(bi,bj) = npart_tile(bi,bj) + 1 IF ( npart_tile(bi,bj).LE.max_npart_tile ) THEN jp = npart_tile(bi,bj) npart( jp,bi,bj) = fltbuf_recv(ic+1,bi,bj,W2_WEST) tstart(jp,bi,bj) = fltbuf_recv(ic+2,bi,bj,W2_WEST) ipart( jp,bi,bj) = fltbuf_recv(ic+3,bi,bj,W2_WEST) jpart( jp,bi,bj) = fltbuf_recv(ic+4,bi,bj,W2_WEST) kpart( jp,bi,bj) = fltbuf_recv(ic+5,bi,bj,W2_WEST) kfloat(jp,bi,bj) = fltbuf_recv(ic+6,bi,bj,W2_WEST) iup( jp,bi,bj) = fltbuf_recv(ic+7,bi,bj,W2_WEST) itop( jp,bi,bj) = fltbuf_recv(ic+8,bi,bj,W2_WEST) tend( jp,bi,bj) = fltbuf_recv(ic+9,bi,bj,W2_WEST) ENDIF ENDIF ENDDO IF ( npart_tile(bi,bj).GT.max_npart_tile ) THEN WRITE(msgBuf,'(2A,2I4,2(A,I8))') 'FLT_EXCH2:+W', & ' bi,bj=', bi, bj, & ' npart_tile=', npart_tile(bi,bj), & ' > max_npart_tile=', max_npart_tile CALL PRINT_ERROR( msgBuf, myThid ) STOP 'ABNORMAL END: S/R FLT_EXCH2' ENDIF DO ip=1,max_npart_exch ic=(ip-1)*imax IF ( fltbuf_recv(ic+1,bi,bj,W2_NORTH).NE.0. ) THEN npart_tile(bi,bj) = npart_tile(bi,bj) + 1 IF ( npart_tile(bi,bj).LE.max_npart_tile ) THEN jp = npart_tile(bi,bj) npart( jp,bi,bj) = fltbuf_recv(ic+1,bi,bj,W2_NORTH) tstart(jp,bi,bj) = fltbuf_recv(ic+2,bi,bj,W2_NORTH) ipart( jp,bi,bj) = fltbuf_recv(ic+3,bi,bj,W2_NORTH) jpart( jp,bi,bj) = fltbuf_recv(ic+4,bi,bj,W2_NORTH) kpart( jp,bi,bj) = fltbuf_recv(ic+5,bi,bj,W2_NORTH) kfloat(jp,bi,bj) = fltbuf_recv(ic+6,bi,bj,W2_NORTH) iup( jp,bi,bj) = fltbuf_recv(ic+7,bi,bj,W2_NORTH) itop( jp,bi,bj) = fltbuf_recv(ic+8,bi,bj,W2_NORTH) tend( jp,bi,bj) = fltbuf_recv(ic+9,bi,bj,W2_NORTH) ENDIF ENDIF ENDDO IF ( npart_tile(bi,bj).GT.max_npart_tile ) THEN WRITE(msgBuf,'(2A,2I4,2(A,I8))') 'FLT_EXCH2:+N', & ' bi,bj=', bi, bj, & ' npart_tile=', npart_tile(bi,bj), & ' > max_npart_tile=', max_npart_tile CALL PRINT_ERROR( msgBuf, myThid ) STOP 'ABNORMAL END: S/R FLT_EXCH2' ENDIF DO ip=1,max_npart_exch ic=(ip-1)*imax IF ( fltbuf_recv(ic+1,bi,bj,W2_SOUTH).NE.0. ) THEN npart_tile(bi,bj) = npart_tile(bi,bj) + 1 IF ( npart_tile(bi,bj).LE.max_npart_tile ) THEN jp = npart_tile(bi,bj) npart( jp,bi,bj) = fltbuf_recv(ic+1,bi,bj,W2_SOUTH) tstart(jp,bi,bj) = fltbuf_recv(ic+2,bi,bj,W2_SOUTH) ipart( jp,bi,bj) = fltbuf_recv(ic+3,bi,bj,W2_SOUTH) jpart( jp,bi,bj) = fltbuf_recv(ic+4,bi,bj,W2_SOUTH) kpart( jp,bi,bj) = fltbuf_recv(ic+5,bi,bj,W2_SOUTH) kfloat(jp,bi,bj) = fltbuf_recv(ic+6,bi,bj,W2_SOUTH) iup( jp,bi,bj) = fltbuf_recv(ic+7,bi,bj,W2_SOUTH) itop( jp,bi,bj) = fltbuf_recv(ic+8,bi,bj,W2_SOUTH) tend( jp,bi,bj) = fltbuf_recv(ic+9,bi,bj,W2_SOUTH) ENDIF ENDIF ENDDO IF ( npart_tile(bi,bj).GT.max_npart_tile ) THEN WRITE(msgBuf,'(2A,2I4,2(A,I8))') 'FLT_EXCH2:+S', & ' bi,bj=', bi, bj, & ' npart_tile=', npart_tile(bi,bj), & ' > max_npart_tile=', max_npart_tile CALL PRINT_ERROR( msgBuf, myThid ) STOP 'ABNORMAL END: S/R FLT_EXCH2' ENDIF ENDDO ENDDO C ipass ENDDO #endif /* ALLOW_EXCH2 */ RETURN END