C $Header$
C $Name$

#include "FLT_OPTIONS.h"

CBOP 0
C !ROUTINE: FLT_UP

C !INTERFACE:
      SUBROUTINE FLT_UP (
     I                    myTime, myIter, myThid )

C     !DESCRIPTION:
C     *==========================================================*
C     | SUBROUTINE FLT_UP
C     | o This routine moves particles vertical from the target
C     |   depth to the surface and samples the model state over
C     |   the full water column at horizontal float position
C     |   every flt_int_prof time steps and writes output.
C     *==========================================================*

C     !USES:
      IMPLICIT NONE
C     == global variables ==
#include "SIZE.h"
#include "EEPARAMS.h"
#include "PARAMS.h"
#include "DYNVARS.h"
#include "FLT_SIZE.h"
#include "FLT.h"
#include "FLT_BUFF.h"

C     !INPUT PARAMETERS:
C     myTime :: current time in simulation
C     myIter :: current iteration number
C     myThid :: my Thread Id number
      _RL myTime
      INTEGER myIter, myThid

C     !FUNCTIONS:
      _RL FLT_MAP_K2R
      EXTERNAL FLT_MAP_K2R

C     !LOCAL VARIABLES:
      INTEGER bi, bj, nFlds
      INTEGER ip, k, ii
      INTEGER imax
      PARAMETER (imax=(9+4*Nr))
      _RL tmp(imax)
      _RL ix, jy, i0x, j0y, xx, yy, zz
      _RL uu,vv,tt,ss, pp
      _RL npart_read, npart_times
      _RS dummyRS(1)
      INTEGER fp, ioUnit, irecord
      CHARACTER*(MAX_LEN_FNAM) fn
      CHARACTER*(MAX_LEN_MBUF) msgBuf
CEOP

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

C--   set number of fields to write
      nFlds = 0
      IF ( flt_selectProfOutp.GE.1 ) nFlds = nFlds + 8
      IF ( flt_selectProfOutp.GE.2 ) nFlds = nFlds + 1 + 4*Nr

C--   check buffer size
      IF ( nFlds.GT.fltBufDim ) THEN
         _BEGIN_MASTER(myThid)
         WRITE(msgBuf,'(3(A,I4))') ' FLT_UP: fltBufDim=', fltBufDim,
     &                             ' too small (<', nFlds, ' )'
         CALL PRINT_ERROR( msgBuf, myThid )
         WRITE(msgBuf,'(2A)')     ' FLT_UP: => increase fltBufDim',
     &                            ' in "FLT_SIZE.h" & recompile'
         CALL PRINT_ERROR( msgBuf, myThid )
         _END_MASTER(myThid)
         CALL ALL_PROC_DIE( myThid )
         STOP 'ABNORMAL END: S/R FLT_UP'
      ENDIF

      IF ( myIter.EQ.nIter0 ) RETURN

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
C--   Calculate position + other fields at float position and fill up IO-buffer

      DO bj=myByLo(myThid),myByHi(myThid)
       DO bi=myBxLo(myThid),myBxHi(myThid)

         i0x = DFLOAT( myXGlobalLo-1 + (bi-1)*sNx )
         j0y = DFLOAT( myYGlobalLo-1 + (bj-1)*sNy )
         DO ip=1,npart_tile(bi,bj)

C     Move float to the surface
           IF ( myTime.GE.tstart(ip,bi,bj) .AND.
     &         (tend(ip,bi,bj).EQ.-1..OR.myTime.LE.tend(ip,bi,bj))
     &         .AND.
     &          kpart(ip,bi,bj).EQ.kfloat(ip,bi,bj) .AND.
     &          iup(ip,bi,bj).GT.0.
     &        ) THEN

             IF ( MOD(myTime,iup(ip,bi,bj)).EQ.0.)
     &       kpart(ip,bi,bj) = flt_surf

           ENDIF

C     If float has died move to level 0
           IF ( tend(ip,bi,bj).NE.-1..AND.myTime.GT.tend(ip,bi,bj)
     &        ) THEN
             kpart(ip,bi,bj) = 0.
           ENDIF

           IF ( flt_selectProfOutp.GE.1 ) THEN
C     Convert to coordinates
             ix = ipart(ip,bi,bj)
             jy = jpart(ip,bi,bj)
             CALL FLT_MAP_IJLOCAL2XY( xx, yy,
     I                                ix, jy, bi,bj, myThid )
             zz = FLT_MAP_K2R( kpart(ip,bi,bj),bi,bj,myThid )

             tmp(1) = npart(ip,bi,bj)
             tmp(2) = myTime
             tmp(3) = xx
             tmp(4) = yy
             tmp(5) = zz
             tmp(6) = ix + i0x
             tmp(7) = jy + j0y
             tmp(8) = kpart(ip,bi,bj)
           ENDIF

           IF ( ( flt_selectProfOutp.GE.2 )    .AND.
     &          ( myTime.GE.tstart(ip,bi,bj) ) .AND.
     &          ( tend(ip,bi,bj).EQ.-1..OR.myTime.LE.tend(ip,bi,bj) )
     &        ) THEN
             CALL FLT_BILINEAR2D(ix,jy,pp,etaN,0,bi,bj,myThid)
             tmp(9) = pp
             DO k=1,Nr
               CALL FLT_BILINEAR  (ix,jy,uu,uVel,  k,1,bi,bj,myThid)
               CALL FLT_BILINEAR  (ix,jy,vv,vVel,  k,2,bi,bj,myThid)
               CALL FLT_BILINEAR  (ix,jy,tt,theta, k,0,bi,bj,myThid)
               CALL FLT_BILINEAR  (ix,jy,ss,salt,  k,0,bi,bj,myThid)
               tmp(9+k     ) = uu
               tmp(9+k+1*Nr) = vv
               tmp(9+k+2*Nr) = tt
               tmp(9+k+3*Nr) = ss
             ENDDO
           ELSEIF ( flt_selectProfOutp.GE.2 ) THEN
             DO ii=9,nFlds
               tmp(ii) = flt_nan
             ENDDO
           ENDIF

           DO ii=1,nFlds
             flt_io_buff(ii,ip,bi,bj) = tmp(ii)
           ENDDO

         ENDDO

       ENDDO
      ENDDO

      IF ( flt_selectProfOutp.LE.0 ) RETURN

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

C--   Write shared buffer to file

      _BARRIER
      _BEGIN_MASTER(myThid)

      fn = 'float_profiles'
      fp = writeBinaryPrec

      DO bj=1,nSy
       DO bi=1,nSx

C (1) read actual number floats from file (if exists)
         ioUnit = -2
         CALL MDS_READVEC_LOC(  fn, fp, ioUnit, 'RL', nFlds,
     &                          tmp, dummyRS,
     &                          bi, bj, 1, myThid )
         IF ( ioUnit.GT. 0 ) THEN
            npart_read  = tmp(1)
            npart_times = tmp(5)
            ii = NINT(tmp(7))
C-       for backward compatibility with old profile files:
            IF ( ii.EQ.0 ) ii = 9+4*Nr
            IF ( ii.NE.nFlds ) THEN
              WRITE(msgBuf,'(A,I4,A)')
     &            'FLT_UP: nFlds=', nFlds,' different from'
              CALL PRINT_ERROR( msgBuf, myThid )
              WRITE(msgBuf,'(3A,I4,A)')
     &            'previous file (',fn(1:14),') value =',ii
              CALL PRINT_ERROR( msgBuf, myThid )
              CALL ALL_PROC_DIE( 0 )
              STOP 'ABNORMAL END: S/R FLT_UP'
            ENDIF
C-       close the read-unit (safer to use a different unit for writing)
            CLOSE( ioUnit )
         ELSE
            npart_read  = 0.
            npart_times = 0.
            tmp(2)      = myTime
         ENDIF

C (2) write new actual number floats and time into file
C-    the standard routine mds_writevec_loc can be used here

C     total number of records in this file
         tmp(1) = DBLE(npart_tile(bi,bj))+npart_read
C     first time of writing floats (do not change when written)
c        tmp(2) = tmp(2)
C     current time
         tmp(3) = myTime
C     timestep
         tmp(4) = flt_int_prof
C     total number of timesteps
         tmp(5) = npart_times + 1.
C     total number of floats
         tmp(6) = max_npart
C     total number of fields
         tmp(7) = nFlds
         DO ii=8,nFlds
           tmp(ii) = 0.
         ENDDO
         ioUnit = -1
         CALL MDS_WRITEVEC_LOC( fn, fp, ioUnit, 'RL', nFlds,
     &                          tmp, dummyRS,
     &                          bi, bj, -1, myIter, myThid )

         DO ip=1,npart_tile(bi,bj)
C (3) write float positions into file
           irecord = npart_read+ip+1
           IF ( ip.NE.npart_tile(bi,bj) ) irecord = -irecord
           CALL MDS_WRITEVEC_LOC( fn, fp, ioUnit, 'RL', nFlds,
     &                            flt_io_buff(1,ip,bi,bj), dummyRS,
     &                            bi, bj, irecord, myIter, myThid )
         ENDDO
         CLOSE( ioUnit )

       ENDDO
      ENDDO

      _END_MASTER(myThid)
      _BARRIER

      RETURN
      END
