C $Header: /u/gcmpack/MITgcm/pkg/flt/flt_up.F,v 1.13 2012/03/30 18:25:03 jmc Exp $
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
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