Back to home page

MITgcm

 
 

    


File indexing completed on 2018-03-02 18:40:48 UTC

view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
0a3ae49bfc Jean*0001 #include "FLT_OPTIONS.h"
e09457787a Jean*0002 #undef DBUG_EXCH_VEC
c806179eb4 Alis*0003 
eacecc7041 Jean*0004       SUBROUTINE FLT_EXCHG (
                0005      I                       myTime, myIter, myThid )
                0006 
                0007 C     ==================================================================
a11169c200 Jean*0008 C     SUBROUTINE FLT_EXCHG
eacecc7041 Jean*0009 C     ==================================================================
                0010 C     o Exchange particles between tiles.
                0011 C     started: Arne Biastoch
                0012 C     changed: Antti Westerlund antti.westerlund@helsinki.fi 2004.06.10
                0013 C     ==================================================================
                0014 
a11169c200 Jean*0015 C     !USES:
                0016       IMPLICIT NONE
c806179eb4 Alis*0017 
a11169c200 Jean*0018 C     == global variables ==
c806179eb4 Alis*0019 #include "SIZE.h"
                0020 #include "EEPARAMS.h"
                0021 #include "PARAMS.h"
730d8469b1 Oliv*0022 #include "FLT_SIZE.h"
521db80798 Jean*0023 #include "FLT.h"
c806179eb4 Alis*0024 
eacecc7041 Jean*0025 C     == routine arguments ==
                0026       _RL myTime
                0027       INTEGER myIter, myThid
c806179eb4 Alis*0028 
bd12238ff3 Jean*0029 C     == shared variables ==
                0030 C-    buffer for sending/receiving variables (E/W are also used for S/N)
                0031 C     (needs to be in common block for multi-threaded)
                0032       INTEGER imax, imax2
eacecc7041 Jean*0033       PARAMETER(imax=9)
                0034       PARAMETER(imax2=imax*max_npart_exch)
c806179eb4 Alis*0035       _RL fltbuf_sendE(imax2,nSx,nSy)
                0036       _RL fltbuf_sendW(imax2,nSx,nSy)
                0037       _RL fltbuf_recvE(imax2,nSx,nSy)
                0038       _RL fltbuf_recvW(imax2,nSx,nSy)
bd12238ff3 Jean*0039       COMMON / FLT_EXCHG_BUFF /
                0040      &   fltbuf_sendE, fltbuf_sendW, fltbuf_recvE, fltbuf_recvW
                0041 
                0042 C     == local variables ==
                0043       INTEGER bi, bj, ic
                0044       INTEGER ip, jp, jl, m, npNew
                0045       INTEGER icountE, icountW, icountN, icountS
                0046       INTEGER deleteList(max_npart_exch*2)
                0047       _RL ilo, ihi, jlo, jhi, iNew, jNew
                0048       CHARACTER*(MAX_LEN_MBUF) msgBuf
7c4c60e70f Jean*0049 #ifdef FLT_WITHOUT_X_PERIODICITY
                0050       LOGICAL wSide, eSide
                0051 #endif /* FLT_WITHOUT_X_PERIODICITY */
                0052 #ifdef FLT_WITHOUT_Y_PERIODICITY
                0053       LOGICAL sSide, nSide
                0054 #endif /* FLT_WITHOUT_Y_PERIODICITY */
                0055       _RL     flt_stopped
c806179eb4 Alis*0056 
eacecc7041 Jean*0057 C     == end of interface ==
c806179eb4 Alis*0058 
7c4c60e70f Jean*0059 C--   set the "end-time" of a stopped float
                0060       flt_stopped = -2.
                0061       flt_stopped = MIN( baseTime, flt_stopped )
                0062 
eacecc7041 Jean*0063 Caw Check if there are eastern/western tiles
121ecfb57a Jean*0064 c     IF ( Nx.NE.sNx ) THEN
                0065 C--   for periodic domain, condition above is wrong ; needs a better test
                0066       IF ( .TRUE. ) THEN
e47631944b Ed H*0067 
c806179eb4 Alis*0068 C--   Choose floats that have to exchanged with eastern and western tiles
                0069 C     and pack to arrays
                0070 
eacecc7041 Jean*0071         DO bj=myByLo(myThid),myByHi(myThid)
                0072          DO bi=myBxLo(myThid),myBxHi(myThid)
                0073 
                0074 C initialize buffers
                0075            DO m=1,imax2
                0076              fltbuf_sendE(m,bi,bj) = 0.
                0077              fltbuf_sendW(m,bi,bj) = 0.
                0078              fltbuf_recvE(m,bi,bj) = 0.
                0079              fltbuf_recvW(m,bi,bj) = 0.
                0080            ENDDO
                0081 
                0082            icountE=0
                0083            icountW=0
382c316761 Jean*0084            jl = 0
eacecc7041 Jean*0085 
d5477ff298 Jean*0086            ilo = 0.5 _d 0
                0087            ihi = 0.5 _d 0 + DFLOAT(sNx)
7c4c60e70f Jean*0088 #ifdef FLT_WITHOUT_X_PERIODICITY
                0089            wSide = myXGlobalLo+bi .LE.2
                0090            eSide = myXGlobalLo+bi*sNx.GT.Nx
                0091 #endif /* FLT_WITHOUT_X_PERIODICITY */
eacecc7041 Jean*0092 
                0093            DO ip=1,npart_tile(bi,bj)
                0094 
7c4c60e70f Jean*0095 #ifdef FLT_WITHOUT_X_PERIODICITY
                0096              IF ( eSide .AND.
                0097      &           (myTime.LE.tend(ip,bi,bj) .OR. tend(ip,bi,bj).EQ.-1.)
                0098      &           .AND. ipart(ip,bi,bj).GE.ihi ) THEN
                0099 C          stop the float:
                0100               tend(ip,bi,bj) = flt_stopped
                0101              ELSEIF ( ipart(ip,bi,bj).GE.ihi ) THEN
                0102 #else /* FLT_WITHOUT_X_PERIODICITY */
d5477ff298 Jean*0103              IF ( ipart(ip,bi,bj).GE.ihi ) THEN
7c4c60e70f Jean*0104 #endif /* FLT_WITHOUT_X_PERIODICITY */
eacecc7041 Jean*0105               icountE=icountE+1
                0106               IF ( icountE.LE.max_npart_exch ) THEN
                0107 
d5477ff298 Jean*0108                ic = (icountE-1)*imax
                0109                iNew = ipart(ip,bi,bj) - DFLOAT(sNx)
eacecc7041 Jean*0110                fltbuf_sendE(ic+1,bi,bj) =   npart(ip,bi,bj)
                0111                fltbuf_sendE(ic+2,bi,bj) =  tstart(ip,bi,bj)
d5477ff298 Jean*0112                fltbuf_sendE(ic+3,bi,bj) =   iNew
                0113                fltbuf_sendE(ic+4,bi,bj) =   jpart(ip,bi,bj)
eacecc7041 Jean*0114                fltbuf_sendE(ic+5,bi,bj) =   kpart(ip,bi,bj)
                0115                fltbuf_sendE(ic+6,bi,bj) =  kfloat(ip,bi,bj)
                0116                fltbuf_sendE(ic+7,bi,bj) =     iup(ip,bi,bj)
                0117                fltbuf_sendE(ic+8,bi,bj) =    itop(ip,bi,bj)
                0118                fltbuf_sendE(ic+9,bi,bj) =    tend(ip,bi,bj)
                0119 
382c316761 Jean*0120 C tag this float to be removed:
                0121                jl = jl + 1
                0122                deleteList(jl) = ip
                0123                npart(ip,bi,bj) = 0.
eacecc7041 Jean*0124 
                0125               ENDIF
                0126              ENDIF
                0127 
7c4c60e70f Jean*0128 #ifdef FLT_WITHOUT_X_PERIODICITY
                0129              IF ( wSide .AND.
                0130      &           (myTime.LE.tend(ip,bi,bj) .OR. tend(ip,bi,bj).EQ.-1.)
                0131      &           .AND. ipart(ip,bi,bj).LT.ilo ) THEN
                0132 C          stop the float:
                0133               tend(ip,bi,bj) = flt_stopped
                0134              ELSEIF ( ipart(ip,bi,bj).LT.ilo ) THEN
                0135 #else /* FLT_WITHOUT_X_PERIODICITY */
d5477ff298 Jean*0136              IF ( ipart(ip,bi,bj).LT.ilo ) THEN
7c4c60e70f Jean*0137 #endif /* FLT_WITHOUT_X_PERIODICITY */
eacecc7041 Jean*0138               icountW=icountW+1
                0139               IF ( icountW.LE.max_npart_exch ) THEN
                0140 
d5477ff298 Jean*0141                ic = (icountW-1)*imax
                0142                iNew = ipart(ip,bi,bj) + DFLOAT(sNx)
eacecc7041 Jean*0143                fltbuf_sendW(ic+1,bi,bj) =   npart(ip,bi,bj)
                0144                fltbuf_sendW(ic+2,bi,bj) =  tstart(ip,bi,bj)
d5477ff298 Jean*0145                fltbuf_sendW(ic+3,bi,bj) =   iNew
                0146                fltbuf_sendW(ic+4,bi,bj) =   jpart(ip,bi,bj)
eacecc7041 Jean*0147                fltbuf_sendW(ic+5,bi,bj) =   kpart(ip,bi,bj)
                0148                fltbuf_sendW(ic+6,bi,bj) =  kfloat(ip,bi,bj)
                0149                fltbuf_sendW(ic+7,bi,bj) =     iup(ip,bi,bj)
                0150                fltbuf_sendW(ic+8,bi,bj) =    itop(ip,bi,bj)
                0151                fltbuf_sendW(ic+9,bi,bj) =    tend(ip,bi,bj)
                0152 
382c316761 Jean*0153 C tag this float to be removed:
                0154                jl = jl + 1
                0155                deleteList(jl) = ip
                0156                npart(ip,bi,bj) = 0.
eacecc7041 Jean*0157 
                0158               ENDIF
                0159              ENDIF
                0160 
                0161            ENDDO
                0162            IF ( icountE.GT.max_npart_exch ) THEN
                0163              WRITE(msgBuf,'(2A,2I4,2(A,I8))') ' FLT_EXCHG:',
                0164      &         ' bi,bj=', bi, bj,
                0165      &         ' icountE=', icountE,
                0166      &         ' > max_npart_exch=', max_npart_exch
                0167              CALL PRINT_ERROR( msgBuf, myThid )
                0168            ENDIF
                0169            IF ( icountW.GT.max_npart_exch ) THEN
                0170              WRITE(msgBuf,'(2A,2I4,2(A,I8))') ' FLT_EXCHG:',
                0171      &         ' bi,bj=', bi, bj,
                0172      &         ' icountW=', icountW,
                0173      &         ' > max_npart_exch=', max_npart_exch
                0174              CALL PRINT_ERROR( msgBuf, myThid )
                0175            ENDIF
                0176            IF ( icountE.GT.max_npart_exch
                0177      &     .OR. icountW.GT.max_npart_exch ) THEN
                0178              STOP 'ABNORMAL END: S/R FLT_EXCHG'
                0179            ENDIF
382c316761 Jean*0180            IF ( (icountE+icountW).GT.0 ) THEN
                0181 C Remove from this tile-list, floats which have been sent to an other tile
                0182              npNew = npart_tile(bi,bj) - (icountE+icountW)
                0183              jl = 0
                0184              DO jp = npNew+1,npart_tile(bi,bj)
                0185               IF ( npart(jp,bi,bj).NE.0. _d 0 ) THEN
                0186                 jl = jl + 1
                0187                 ip = deleteList(jl)
                0188 C        copy: ip <-- jp
                0189                 npart (ip,bi,bj) =  npart (jp,bi,bj)
                0190                 tstart(ip,bi,bj) =  tstart(jp,bi,bj)
d5477ff298 Jean*0191                 ipart (ip,bi,bj) =  ipart (jp,bi,bj)
                0192                 jpart (ip,bi,bj) =  jpart (jp,bi,bj)
382c316761 Jean*0193                 kpart (ip,bi,bj) =  kpart (jp,bi,bj)
                0194                 kfloat(ip,bi,bj) =  kfloat(jp,bi,bj)
                0195                 iup   (ip,bi,bj) =  iup   (jp,bi,bj)
                0196                 itop  (ip,bi,bj) =  itop  (jp,bi,bj)
                0197                 tend  (ip,bi,bj) =  tend  (jp,bi,bj)
                0198               ENDIF
                0199              ENDDO
                0200              npart_tile(bi,bj) = npNew
                0201            ENDIF
c806179eb4 Alis*0202 
e47631944b Ed H*0203          ENDDO
eacecc7041 Jean*0204         ENDDO
c806179eb4 Alis*0205 
121ecfb57a Jean*0206 C--   Send or Put east and west edges.
e09457787a Jean*0207 
                0208 #ifdef DBUG_EXCH_VEC
                0209         WRITE(errorMessageUnit,'(A,I8)') 'FLT_EXCH: 0x', myIter
                0210 #endif
48e4fc2750 Jean*0211         CALL EXCH_SEND_PUT_VEC_X_RL(
121ecfb57a Jean*0212      I                               fltbuf_sendE, fltbuf_sendW,
                0213      O                               fltbuf_recvE, fltbuf_recvW,
eacecc7041 Jean*0214      I                               imax2, myThid )
e09457787a Jean*0215 #ifdef DBUG_EXCH_VEC
                0216         WRITE(errorMessageUnit,'(A,I8)') 'FLT_EXCH: 1x', myIter
                0217 #endif
ef53b829d7 Jean*0218 C--   Receive east/west arrays
48e4fc2750 Jean*0219         CALL EXCH_RECV_GET_VEC_X_RL(
121ecfb57a Jean*0220      U                               fltbuf_recvE, fltbuf_recvW,
eacecc7041 Jean*0221      I                               imax2, myThid )
e09457787a Jean*0222 #ifdef DBUG_EXCH_VEC
                0223         WRITE(errorMessageUnit,'(A,I8)') 'FLT_EXCH: 2x', myIter
                0224 #endif
c806179eb4 Alis*0225 
                0226 C--   Unpack arrays on new tiles
                0227 
eacecc7041 Jean*0228         DO bj=myByLo(myThid),myByHi(myThid)
                0229          DO bi=myBxLo(myThid),myBxHi(myThid)
                0230 
                0231            DO ip=1,max_npart_exch
                0232 
                0233             ic=(ip-1)*imax
                0234             IF ( fltbuf_recvE(ic+1,bi,bj).NE.0. ) THEN
                0235              npart_tile(bi,bj) = npart_tile(bi,bj) + 1
                0236              IF ( npart_tile(bi,bj).LE.max_npart_tile ) THEN
                0237                jp = npart_tile(bi,bj)
                0238                npart( jp,bi,bj) = fltbuf_recvE(ic+1,bi,bj)
                0239                tstart(jp,bi,bj) = fltbuf_recvE(ic+2,bi,bj)
d5477ff298 Jean*0240                ipart( jp,bi,bj) = fltbuf_recvE(ic+3,bi,bj)
                0241                jpart( jp,bi,bj) = fltbuf_recvE(ic+4,bi,bj)
eacecc7041 Jean*0242                kpart( jp,bi,bj) = fltbuf_recvE(ic+5,bi,bj)
                0243                kfloat(jp,bi,bj) = fltbuf_recvE(ic+6,bi,bj)
                0244                iup(   jp,bi,bj) = fltbuf_recvE(ic+7,bi,bj)
                0245                itop(  jp,bi,bj) = fltbuf_recvE(ic+8,bi,bj)
                0246                tend(  jp,bi,bj) = fltbuf_recvE(ic+9,bi,bj)
                0247              ENDIF
                0248             ENDIF
                0249 
                0250            ENDDO
                0251            IF ( npart_tile(bi,bj).GT.max_npart_tile ) THEN
                0252              WRITE(msgBuf,'(2A,2I4,2(A,I8))') 'FLT_EXCHG:+E',
                0253      &         ' bi,bj=', bi, bj,
                0254      &         ' npart_tile=', npart_tile(bi,bj),
                0255      &         ' > max_npart_tile=', max_npart_tile
                0256               CALL PRINT_ERROR( msgBuf, myThid )
                0257               STOP 'ABNORMAL END: S/R FLT_EXCHG'
                0258            ENDIF
                0259 
                0260            DO ip=1,max_npart_exch
                0261 
                0262             ic=(ip-1)*imax
                0263             IF ( fltbuf_recvW(ic+1,bi,bj).NE.0. ) THEN
                0264              npart_tile(bi,bj) = npart_tile(bi,bj) + 1
                0265              IF ( npart_tile(bi,bj).LE.max_npart_tile ) THEN
                0266                jp = npart_tile(bi,bj)
                0267                npart( jp,bi,bj) = fltbuf_recvW(ic+1,bi,bj)
                0268                tstart(jp,bi,bj) = fltbuf_recvW(ic+2,bi,bj)
d5477ff298 Jean*0269                ipart( jp,bi,bj) = fltbuf_recvW(ic+3,bi,bj)
                0270                jpart( jp,bi,bj) = fltbuf_recvW(ic+4,bi,bj)
eacecc7041 Jean*0271                kpart( jp,bi,bj) = fltbuf_recvW(ic+5,bi,bj)
                0272                kfloat(jp,bi,bj) = fltbuf_recvW(ic+6,bi,bj)
                0273                iup(   jp,bi,bj) = fltbuf_recvW(ic+7,bi,bj)
                0274                itop(  jp,bi,bj) = fltbuf_recvW(ic+8,bi,bj)
                0275                tend(  jp,bi,bj) = fltbuf_recvW(ic+9,bi,bj)
                0276              ENDIF
                0277             ENDIF
                0278 
                0279            ENDDO
                0280            IF ( npart_tile(bi,bj).GT.max_npart_tile ) THEN
                0281              WRITE(msgBuf,'(2A,2I4,2(A,I8))') 'FLT_EXCHG:+W',
                0282      &         ' bi,bj=', bi, bj,
                0283      &         ' npart_tile=', npart_tile(bi,bj),
                0284      &         ' > max_npart_tile=', max_npart_tile
                0285               CALL PRINT_ERROR( msgBuf, myThid )
                0286               STOP 'ABNORMAL END: S/R FLT_EXCHG'
                0287            ENDIF
                0288 
e47631944b Ed H*0289          ENDDO
eacecc7041 Jean*0290         ENDDO
e47631944b Ed H*0291 
eacecc7041 Jean*0292 Caw end tile check
                0293       ENDIF
e47631944b Ed H*0294 
                0295 C--   Choose floats that have to exchanged with northern and southern tiles
c806179eb4 Alis*0296 C     and pack to arrays
                0297 
eacecc7041 Jean*0298 Caw Check if there are northern/southern tiles
121ecfb57a Jean*0299 c     IF ( Ny.NE.sNy ) THEN
                0300 C--   for periodic domain, condition above is wrong ; needs a better test
                0301       IF ( .TRUE. ) THEN
eacecc7041 Jean*0302 
                0303         DO bj=myByLo(myThid),myByHi(myThid)
                0304          DO bi=myBxLo(myThid),myBxHi(myThid)
                0305 
                0306 C initialize buffers
                0307 
                0308            DO m=1,imax2
                0309              fltbuf_sendE(m,bi,bj) = 0.
                0310              fltbuf_sendW(m,bi,bj) = 0.
                0311              fltbuf_recvE(m,bi,bj) = 0.
                0312              fltbuf_recvW(m,bi,bj) = 0.
                0313            ENDDO
                0314 
                0315            icountN=0
                0316            icountS=0
382c316761 Jean*0317            jl = 0
eacecc7041 Jean*0318 
d5477ff298 Jean*0319            jlo = 0.5 _d 0
                0320            jhi = 0.5 _d 0 + DFLOAT(sNy)
7c4c60e70f Jean*0321 #ifdef FLT_WITHOUT_Y_PERIODICITY
                0322            sSide = myYGlobalLo+bj .LE.2
                0323            nSide = myYGlobalLo+bj*sNy.GT.Ny
                0324 #endif /* FLT_WITHOUT_Y_PERIODICITY */
eacecc7041 Jean*0325 
                0326            DO ip=1,npart_tile(bi,bj)
                0327 
7c4c60e70f Jean*0328 #ifdef FLT_WITHOUT_Y_PERIODICITY
                0329              IF ( nSide .AND.
                0330      &           (myTime.LE.tend(ip,bi,bj) .OR. tend(ip,bi,bj).EQ.-1.)
                0331      &           .AND. jpart(ip,bi,bj).GE.jhi ) THEN
                0332 C          stop the float:
                0333               tend(ip,bi,bj) = flt_stopped
                0334              ELSEIF ( jpart(ip,bi,bj).GE.jhi ) THEN
                0335 #else /* FLT_WITHOUT_Y_PERIODICITY */
d5477ff298 Jean*0336              IF ( jpart(ip,bi,bj).GE.jhi ) THEN
7c4c60e70f Jean*0337 #endif /* FLT_WITHOUT_Y_PERIODICITY */
eacecc7041 Jean*0338               icountN=icountN+1
                0339               IF ( icountN.LE.max_npart_exch ) THEN
                0340 
d5477ff298 Jean*0341                ic = (icountN-1)*imax
                0342                jNew = jpart(ip,bi,bj) - DFLOAT(sNy)
eacecc7041 Jean*0343                fltbuf_sendE(ic+1,bi,bj) =   npart(ip,bi,bj)
                0344                fltbuf_sendE(ic+2,bi,bj) =  tstart(ip,bi,bj)
d5477ff298 Jean*0345                fltbuf_sendE(ic+3,bi,bj) =   ipart(ip,bi,bj)
                0346                fltbuf_sendE(ic+4,bi,bj) =   jNew
eacecc7041 Jean*0347                fltbuf_sendE(ic+5,bi,bj) =   kpart(ip,bi,bj)
                0348                fltbuf_sendE(ic+6,bi,bj) =  kfloat(ip,bi,bj)
                0349                fltbuf_sendE(ic+7,bi,bj) =     iup(ip,bi,bj)
                0350                fltbuf_sendE(ic+8,bi,bj) =    itop(ip,bi,bj)
                0351                fltbuf_sendE(ic+9,bi,bj) =    tend(ip,bi,bj)
                0352 
382c316761 Jean*0353 C tag this float to be removed:
                0354                jl = jl + 1
                0355                deleteList(jl) = ip
                0356                npart(ip,bi,bj) = 0.
eacecc7041 Jean*0357 
                0358 c             ELSE
                0359 c              WRITE(msgBuf,'(2A,2I4,I6,A,2F17.6))') ' FLT_EXCHG,N:',
                0360 c    &         ' bi,bj,ip=', bi, bj, ip,
d5477ff298 Jean*0361 c    &         ' yp,yHi=', jpart(ip,bi,bj), jhi
eacecc7041 Jean*0362 c              CALL PRINT_ERROR( msgBuf, myThid )
                0363               ENDIF
                0364              ENDIF
                0365 
1a3e6b35f2 Jean*0366 #ifdef FLT_WITHOUT_Y_PERIODICITY
7c4c60e70f Jean*0367              IF ( sSide .AND.
                0368      &           (myTime.LE.tend(ip,bi,bj) .OR. tend(ip,bi,bj).EQ.-1.)
                0369      &           .AND. jpart(ip,bi,bj).LT.jlo ) THEN
                0370 C          stop the float:
                0371               tend(ip,bi,bj) = flt_stopped
                0372              ELSEIF ( jpart(ip,bi,bj).LT.jlo ) THEN
1a3e6b35f2 Jean*0373 #else /* FLT_WITHOUT_Y_PERIODICITY */
d5477ff298 Jean*0374              IF ( jpart(ip,bi,bj).LT.jlo ) THEN
1a3e6b35f2 Jean*0375 #endif /* FLT_WITHOUT_Y_PERIODICITY */
eacecc7041 Jean*0376               icountS=icountS+1
                0377               IF ( icountS.LE.max_npart_exch ) THEN
                0378 
d5477ff298 Jean*0379                ic = (icountS-1)*imax
                0380                jNew = jpart(ip,bi,bj) + DFLOAT(sNy)
eacecc7041 Jean*0381                fltbuf_sendW(ic+1,bi,bj) =   npart(ip,bi,bj)
                0382                fltbuf_sendW(ic+2,bi,bj) =  tstart(ip,bi,bj)
d5477ff298 Jean*0383                fltbuf_sendW(ic+3,bi,bj) =   ipart(ip,bi,bj)
                0384                fltbuf_sendW(ic+4,bi,bj) =   jNew
eacecc7041 Jean*0385                fltbuf_sendW(ic+5,bi,bj) =   kpart(ip,bi,bj)
                0386                fltbuf_sendW(ic+6,bi,bj) =  kfloat(ip,bi,bj)
                0387                fltbuf_sendW(ic+7,bi,bj) =     iup(ip,bi,bj)
                0388                fltbuf_sendW(ic+8,bi,bj) =    itop(ip,bi,bj)
                0389                fltbuf_sendW(ic+9,bi,bj) =    tend(ip,bi,bj)
                0390 
382c316761 Jean*0391 C tag this float to be removed:
                0392                jl = jl + 1
                0393                deleteList(jl) = ip
                0394                npart(ip,bi,bj) = 0.
eacecc7041 Jean*0395 
                0396 c             ELSE
                0397 c              WRITE(msgBuf,'(2A,2I4,I6,A,2F17.6))') ' FLT_EXCHG,S:',
                0398 c    &         ' bi,bj,ip=', bi, bj, ip,
d5477ff298 Jean*0399 c    &         ' yp,yLo=', jpart(ip,bi,bj), jlo
eacecc7041 Jean*0400 c              CALL PRINT_ERROR( msgBuf, myThid )
                0401               ENDIF
                0402              ENDIF
                0403 
                0404            ENDDO
                0405            IF ( icountN.GT.max_npart_exch ) THEN
                0406              WRITE(msgBuf,'(2A,2I4,2(A,I8))') ' FLT_EXCHG:',
                0407      &         ' bi,bj=', bi, bj,
                0408      &         ' icountN=', icountN,
                0409      &         ' > max_npart_exch=', max_npart_exch
                0410              CALL PRINT_ERROR( msgBuf, myThid )
                0411            ENDIF
                0412            IF ( icountS.GT.max_npart_exch ) THEN
                0413              WRITE(msgBuf,'(2A,2I4,2(A,I8))') ' FLT_EXCHG:',
                0414      &         ' bi,bj=', bi, bj,
                0415      &         ' icountS=', icountS,
                0416      &         ' > max_npart_exch=', max_npart_exch
                0417              CALL PRINT_ERROR( msgBuf, myThid )
                0418            ENDIF
                0419            IF ( icountN.GT.max_npart_exch
                0420      &     .OR. icountS.GT.max_npart_exch ) THEN
                0421              STOP 'ABNORMAL END: S/R FLT_EXCHG'
                0422            ENDIF
382c316761 Jean*0423            IF ( (icountN+icountS).GT.0 ) THEN
                0424 C Remove from this tile-list, floats which have been sent to an other tile
                0425              npNew = npart_tile(bi,bj) - (icountN+icountS)
                0426              jl = 0
                0427              DO jp = npNew+1,npart_tile(bi,bj)
                0428               IF ( npart(jp,bi,bj).NE.0. _d 0 ) THEN
                0429                 jl = jl + 1
                0430                 ip = deleteList(jl)
                0431 C        copy: ip <-- jp
                0432                 npart (ip,bi,bj) =  npart (jp,bi,bj)
                0433                 tstart(ip,bi,bj) =  tstart(jp,bi,bj)
d5477ff298 Jean*0434                 ipart (ip,bi,bj) =  ipart (jp,bi,bj)
                0435                 jpart (ip,bi,bj) =  jpart (jp,bi,bj)
382c316761 Jean*0436                 kpart (ip,bi,bj) =  kpart (jp,bi,bj)
                0437                 kfloat(ip,bi,bj) =  kfloat(jp,bi,bj)
                0438                 iup   (ip,bi,bj) =  iup   (jp,bi,bj)
                0439                 itop  (ip,bi,bj) =  itop  (jp,bi,bj)
                0440                 tend  (ip,bi,bj) =  tend  (jp,bi,bj)
                0441               ENDIF
                0442              ENDDO
                0443              npart_tile(bi,bj) = npNew
                0444            ENDIF
eacecc7041 Jean*0445 
e47631944b Ed H*0446          ENDDO
eacecc7041 Jean*0447         ENDDO
c806179eb4 Alis*0448 
121ecfb57a Jean*0449 C     Send or Put north and south arrays.
e09457787a Jean*0450 #ifdef DBUG_EXCH_VEC
                0451         WRITE(errorMessageUnit,'(A,I8)') 'FLT_EXCH: 0y', myIter
                0452 #endif
48e4fc2750 Jean*0453         CALL EXCH_SEND_PUT_VEC_Y_RL(
121ecfb57a Jean*0454      I                               fltbuf_sendE, fltbuf_sendW,
                0455      O                               fltbuf_recvE, fltbuf_recvW,
eacecc7041 Jean*0456      I                               imax2, myThid )
e09457787a Jean*0457 #ifdef DBUG_EXCH_VEC
                0458         WRITE(errorMessageUnit,'(A,I8)') 'FLT_EXCH: 1y', myIter
                0459 #endif
c806179eb4 Alis*0460 C     Receive north and south arrays
48e4fc2750 Jean*0461         CALL EXCH_RECV_GET_VEC_Y_RL(
121ecfb57a Jean*0462      U                               fltbuf_recvE, fltbuf_recvW,
eacecc7041 Jean*0463      I                               imax2, myThid )
e09457787a Jean*0464 #ifdef DBUG_EXCH_VEC
                0465         WRITE(errorMessageUnit,'(A,I8)') 'FLT_EXCH: 2y', myIter
                0466 c       STOP 'FLT_EXCHG: Normal End'
                0467 #endif
c806179eb4 Alis*0468 
                0469 C--   Unpack arrays on new tiles
                0470 
eacecc7041 Jean*0471         DO bj=myByLo(myThid),myByHi(myThid)
                0472          DO bi=myBxLo(myThid),myBxHi(myThid)
                0473 
                0474            DO ip=1,max_npart_exch
                0475 
                0476             ic=(ip-1)*imax
                0477             IF ( fltbuf_recvE(ic+1,bi,bj).NE.0. ) THEN
                0478              npart_tile(bi,bj) = npart_tile(bi,bj) + 1
                0479              IF ( npart_tile(bi,bj).LE.max_npart_tile ) THEN
                0480                jp = npart_tile(bi,bj)
                0481                npart( jp,bi,bj) = fltbuf_recvE(ic+1,bi,bj)
                0482                tstart(jp,bi,bj) = fltbuf_recvE(ic+2,bi,bj)
d5477ff298 Jean*0483                ipart( jp,bi,bj) = fltbuf_recvE(ic+3,bi,bj)
                0484                jpart( jp,bi,bj) = fltbuf_recvE(ic+4,bi,bj)
eacecc7041 Jean*0485                kpart( jp,bi,bj) = fltbuf_recvE(ic+5,bi,bj)
                0486                kfloat(jp,bi,bj) = fltbuf_recvE(ic+6,bi,bj)
                0487                iup(   jp,bi,bj) = fltbuf_recvE(ic+7,bi,bj)
                0488                itop(  jp,bi,bj) = fltbuf_recvE(ic+8,bi,bj)
                0489                tend(  jp,bi,bj) = fltbuf_recvE(ic+9,bi,bj)
                0490              ENDIF
                0491             ENDIF
                0492 
                0493            ENDDO
                0494            IF ( npart_tile(bi,bj).GT.max_npart_tile ) THEN
                0495              WRITE(msgBuf,'(2A,2I4,2(A,I8))') 'FLT_EXCHG:+N',
                0496      &         ' bi,bj=', bi, bj,
                0497      &         ' npart_tile=', npart_tile(bi,bj),
                0498      &         ' > max_npart_tile=', max_npart_tile
                0499               CALL PRINT_ERROR( msgBuf, myThid )
                0500               STOP 'ABNORMAL END: S/R FLT_EXCHG'
                0501            ENDIF
                0502 
                0503            DO ip=1,max_npart_exch
                0504 
                0505             ic=(ip-1)*imax
                0506             IF ( fltbuf_recvW(ic+1,bi,bj).NE.0. ) THEN
                0507              npart_tile(bi,bj) = npart_tile(bi,bj) + 1
                0508              IF ( npart_tile(bi,bj).LE.max_npart_tile ) THEN
                0509                jp = npart_tile(bi,bj)
                0510                npart( jp,bi,bj) = fltbuf_recvW(ic+1,bi,bj)
                0511                tstart(jp,bi,bj) = fltbuf_recvW(ic+2,bi,bj)
d5477ff298 Jean*0512                ipart( jp,bi,bj) = fltbuf_recvW(ic+3,bi,bj)
                0513                jpart( jp,bi,bj) = fltbuf_recvW(ic+4,bi,bj)
eacecc7041 Jean*0514                kpart( jp,bi,bj) = fltbuf_recvW(ic+5,bi,bj)
                0515                kfloat(jp,bi,bj) = fltbuf_recvW(ic+6,bi,bj)
                0516                iup(   jp,bi,bj) = fltbuf_recvW(ic+7,bi,bj)
                0517                itop(  jp,bi,bj) = fltbuf_recvW(ic+8,bi,bj)
                0518                tend(  jp,bi,bj) = fltbuf_recvW(ic+9,bi,bj)
                0519              ENDIF
                0520             ENDIF
                0521 
                0522            ENDDO
                0523            IF ( npart_tile(bi,bj).GT.max_npart_tile ) THEN
                0524              WRITE(msgBuf,'(2A,2I4,2(A,I8))') 'FLT_EXCHG:+S',
                0525      &         ' bi,bj=', bi, bj,
                0526      &         ' npart_tile=', npart_tile(bi,bj),
                0527      &         ' > max_npart_tile=', max_npart_tile
                0528               CALL PRINT_ERROR( msgBuf, myThid )
                0529               STOP 'ABNORMAL END: S/R FLT_EXCHG'
                0530            ENDIF
                0531 
e47631944b Ed H*0532          ENDDO
eacecc7041 Jean*0533         ENDDO
e47631944b Ed H*0534 
eacecc7041 Jean*0535 Caw end tile check
                0536       ENDIF
c806179eb4 Alis*0537 
eacecc7041 Jean*0538       RETURN
                0539       END