Back to home page

MITgcm
 
 

    

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

view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
0a3ae49bfc Jean*0001 #include "FLT_OPTIONS.h"
c806179eb4 Alis*0002 
3992cf11bb Jean*0003 CBOP 0
                0004 C !ROUTINE: FLT_UP
                0005 
                0006 C !INTERFACE:
eacecc7041 Jean*0007       SUBROUTINE FLT_UP (
                0008      I                    myTime, myIter, myThid )
                0009 
3992cf11bb Jean*0010 C     !DESCRIPTION:
                0011 C     *==========================================================*
                0012 C     | SUBROUTINE FLT_UP
                0013 C     | o This routine moves particles vertical from the target
                0014 C     |   depth to the surface and samples the model state over
                0015 C     |   the full water column at horizontal float position
                0016 C     |   every flt_int_prof time steps and writes output.
                0017 C     *==========================================================*
eacecc7041 Jean*0018 
51ec3c32fe Jean*0019 C     !USES:
                0020       IMPLICIT NONE
                0021 C     == global variables ==
c806179eb4 Alis*0022 #include "SIZE.h"
51ec3c32fe Jean*0023 #include "EEPARAMS.h"
c806179eb4 Alis*0024 #include "PARAMS.h"
51ec3c32fe Jean*0025 #include "DYNVARS.h"
730d8469b1 Oliv*0026 #include "FLT_SIZE.h"
c806179eb4 Alis*0027 #include "FLT.h"
3992cf11bb Jean*0028 #include "FLT_BUFF.h"
c806179eb4 Alis*0029 
3992cf11bb Jean*0030 C     !INPUT PARAMETERS:
                0031 C     myTime :: current time in simulation
                0032 C     myIter :: current iteration number
                0033 C     myThid :: my Thread Id number
eacecc7041 Jean*0034       _RL myTime
                0035       INTEGER myIter, myThid
c806179eb4 Alis*0036 
3992cf11bb Jean*0037 C     !FUNCTIONS:
7fc4e95251 Jean*0038       _RL FLT_MAP_K2R
                0039       EXTERNAL FLT_MAP_K2R
51ec3c32fe Jean*0040 
3992cf11bb Jean*0041 C     !LOCAL VARIABLES:
                0042       INTEGER bi, bj, nFlds
                0043       INTEGER ip, k, ii
eacecc7041 Jean*0044       INTEGER imax
7fc4e95251 Jean*0045       PARAMETER (imax=(9+4*Nr))
3992cf11bb Jean*0046       _RL tmp(imax)
d5477ff298 Jean*0047       _RL ix, jy, i0x, j0y, xx, yy, zz
c806179eb4 Alis*0048       _RL uu,vv,tt,ss, pp
55f764277b Jean*0049       _RL npart_read, npart_times
db913584c6 Jean*0050       _RS dummyRS(1)
0ad17d4ed9 Jean*0051       INTEGER fp, ioUnit, irecord
c806179eb4 Alis*0052       CHARACTER*(MAX_LEN_FNAM) fn
3992cf11bb Jean*0053       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0054 CEOP
                0055 
                0056 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0057 
                0058 C--   set number of fields to write
                0059       nFlds = 0
                0060       IF ( flt_selectProfOutp.GE.1 ) nFlds = nFlds + 8
                0061       IF ( flt_selectProfOutp.GE.2 ) nFlds = nFlds + 1 + 4*Nr
                0062 
                0063 C--   check buffer size
                0064       IF ( nFlds.GT.fltBufDim ) THEN
d7e0a84259 Jean*0065          _BEGIN_MASTER(myThid)
3992cf11bb Jean*0066          WRITE(msgBuf,'(3(A,I4))') ' FLT_UP: fltBufDim=', fltBufDim,
                0067      &                             ' too small (<', nFlds, ' )'
                0068          CALL PRINT_ERROR( msgBuf, myThid )
                0069          WRITE(msgBuf,'(2A)')     ' FLT_UP: => increase fltBufDim',
                0070      &                            ' in "FLT_SIZE.h" & recompile'
                0071          CALL PRINT_ERROR( msgBuf, myThid )
d7e0a84259 Jean*0072          _END_MASTER(myThid)
3992cf11bb Jean*0073          CALL ALL_PROC_DIE( myThid )
                0074          STOP 'ABNORMAL END: S/R FLT_UP'
                0075       ENDIF
                0076 
                0077       IF ( myIter.EQ.nIter0 ) RETURN
                0078 
                0079 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0080 C--   Calculate position + other fields at float position and fill up IO-buffer
c806179eb4 Alis*0081 
                0082       DO bj=myByLo(myThid),myByHi(myThid)
51ec3c32fe Jean*0083        DO bi=myBxLo(myThid),myBxHi(myThid)
c806179eb4 Alis*0084 
7fc4e95251 Jean*0085          i0x = DFLOAT( myXGlobalLo-1 + (bi-1)*sNx )
                0086          j0y = DFLOAT( myYGlobalLo-1 + (bj-1)*sNy )
eacecc7041 Jean*0087          DO ip=1,npart_tile(bi,bj)
                0088 
                0089 C     Move float to the surface
7fc4e95251 Jean*0090            IF ( myTime.GE.tstart(ip,bi,bj) .AND.
                0091      &         (tend(ip,bi,bj).EQ.-1..OR.myTime.LE.tend(ip,bi,bj))
                0092      &         .AND.
                0093      &          kpart(ip,bi,bj).EQ.kfloat(ip,bi,bj) .AND.
                0094      &          iup(ip,bi,bj).GT.0.
                0095      &        ) THEN
eacecc7041 Jean*0096 
7fc4e95251 Jean*0097              IF ( MOD(myTime,iup(ip,bi,bj)).EQ.0.)
                0098      &       kpart(ip,bi,bj) = flt_surf
eacecc7041 Jean*0099 
7fc4e95251 Jean*0100            ENDIF
c806179eb4 Alis*0101 
eacecc7041 Jean*0102 C     If float has died move to level 0
7fc4e95251 Jean*0103            IF ( tend(ip,bi,bj).NE.-1..AND.myTime.GT.tend(ip,bi,bj)
                0104      &        ) THEN
                0105              kpart(ip,bi,bj) = 0.
                0106            ENDIF
eacecc7041 Jean*0107 
3992cf11bb Jean*0108            IF ( flt_selectProfOutp.GE.1 ) THEN
d5477ff298 Jean*0109 C     Convert to coordinates
3992cf11bb Jean*0110              ix = ipart(ip,bi,bj)
                0111              jy = jpart(ip,bi,bj)
                0112              CALL FLT_MAP_IJLOCAL2XY( xx, yy,
                0113      I                                ix, jy, bi,bj, myThid )
                0114              zz = FLT_MAP_K2R( kpart(ip,bi,bj),bi,bj,myThid )
                0115 
                0116              tmp(1) = npart(ip,bi,bj)
                0117              tmp(2) = myTime
                0118              tmp(3) = xx
                0119              tmp(4) = yy
                0120              tmp(5) = zz
                0121              tmp(6) = ix + i0x
                0122              tmp(7) = jy + j0y
                0123              tmp(8) = kpart(ip,bi,bj)
                0124            ENDIF
7fc4e95251 Jean*0125 
3992cf11bb Jean*0126            IF ( ( flt_selectProfOutp.GE.2 )    .AND.
                0127      &          ( myTime.GE.tstart(ip,bi,bj) ) .AND.
                0128      &          ( tend(ip,bi,bj).EQ.-1..OR.myTime.LE.tend(ip,bi,bj) )
7fc4e95251 Jean*0129      &        ) THEN
                0130              CALL FLT_BILINEAR2D(ix,jy,pp,etaN,0,bi,bj,myThid)
3992cf11bb Jean*0131              tmp(9) = pp
7fc4e95251 Jean*0132              DO k=1,Nr
                0133                CALL FLT_BILINEAR  (ix,jy,uu,uVel,  k,1,bi,bj,myThid)
                0134                CALL FLT_BILINEAR  (ix,jy,vv,vVel,  k,2,bi,bj,myThid)
                0135                CALL FLT_BILINEAR  (ix,jy,tt,theta, k,0,bi,bj,myThid)
                0136                CALL FLT_BILINEAR  (ix,jy,ss,salt,  k,0,bi,bj,myThid)
3992cf11bb Jean*0137                tmp(9+k     ) = uu
                0138                tmp(9+k+1*Nr) = vv
                0139                tmp(9+k+2*Nr) = tt
                0140                tmp(9+k+3*Nr) = ss
7fc4e95251 Jean*0141              ENDDO
3992cf11bb Jean*0142            ELSEIF ( flt_selectProfOutp.GE.2 ) THEN
                0143              DO ii=9,nFlds
7fc4e95251 Jean*0144                tmp(ii) = flt_nan
                0145              ENDDO
                0146            ENDIF
c806179eb4 Alis*0147 
3992cf11bb Jean*0148            DO ii=1,nFlds
                0149              flt_io_buff(ii,ip,bi,bj) = tmp(ii)
                0150            ENDDO
                0151 
                0152          ENDDO
                0153 
                0154        ENDDO
                0155       ENDDO
                0156 
                0157       IF ( flt_selectProfOutp.LE.0 ) RETURN
                0158 
                0159 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0160 
                0161 C--   Write shared buffer to file
                0162 
                0163       _BARRIER
                0164       _BEGIN_MASTER(myThid)
                0165 
                0166       fn = 'float_profiles'
                0167       fp = writeBinaryPrec
                0168 
                0169       DO bj=1,nSy
                0170        DO bi=1,nSx
                0171 
                0172 C (1) read actual number floats from file (if exists)
                0173          ioUnit = -2
                0174          CALL MDS_READVEC_LOC(  fn, fp, ioUnit, 'RL', nFlds,
                0175      &                          tmp, dummyRS,
                0176      &                          bi, bj, 1, myThid )
                0177          IF ( ioUnit.GT. 0 ) THEN
                0178             npart_read  = tmp(1)
                0179             npart_times = tmp(5)
                0180             ii = NINT(tmp(7))
                0181 C-       for backward compatibility with old profile files:
                0182             IF ( ii.EQ.0 ) ii = 9+4*Nr
                0183             IF ( ii.NE.nFlds ) THEN
                0184               WRITE(msgBuf,'(A,I4,A)')
                0185      &            'FLT_UP: nFlds=', nFlds,' different from'
                0186               CALL PRINT_ERROR( msgBuf, myThid )
                0187               WRITE(msgBuf,'(3A,I4,A)')
                0188      &            'previous file (',fn(1:14),') value =',ii
                0189               CALL PRINT_ERROR( msgBuf, myThid )
d7e0a84259 Jean*0190               CALL ALL_PROC_DIE( 0 )
3992cf11bb Jean*0191               STOP 'ABNORMAL END: S/R FLT_UP'
                0192             ENDIF
                0193 C-       close the read-unit (safer to use a different unit for writing)
                0194             CLOSE( ioUnit )
                0195          ELSE
                0196             npart_read  = 0.
                0197             npart_times = 0.
                0198             tmp(2)      = myTime
                0199          ENDIF
                0200 
                0201 C (2) write new actual number floats and time into file
                0202 C-    the standard routine mds_writevec_loc can be used here
                0203 
                0204 C     total number of records in this file
                0205          tmp(1) = DBLE(npart_tile(bi,bj))+npart_read
                0206 C     first time of writing floats (do not change when written)
                0207 c        tmp(2) = tmp(2)
                0208 C     current time
                0209          tmp(3) = myTime
                0210 C     timestep
                0211          tmp(4) = flt_int_prof
                0212 C     total number of timesteps
                0213          tmp(5) = npart_times + 1.
                0214 C     total number of floats
                0215          tmp(6) = max_npart
                0216 C     total number of fields
                0217          tmp(7) = nFlds
                0218          DO ii=8,nFlds
                0219            tmp(ii) = 0.
                0220          ENDDO
                0221          ioUnit = -1
                0222          CALL MDS_WRITEVEC_LOC( fn, fp, ioUnit, 'RL', nFlds,
                0223      &                          tmp, dummyRS,
                0224      &                          bi, bj, -1, myIter, myThid )
                0225 
                0226          DO ip=1,npart_tile(bi,bj)
eacecc7041 Jean*0227 C (3) write float positions into file
7fc4e95251 Jean*0228            irecord = npart_read+ip+1
                0229            IF ( ip.NE.npart_tile(bi,bj) ) irecord = -irecord
3992cf11bb Jean*0230            CALL MDS_WRITEVEC_LOC( fn, fp, ioUnit, 'RL', nFlds,
                0231      &                            flt_io_buff(1,ip,bi,bj), dummyRS,
                0232      &                            bi, bj, irecord, myIter, myThid )
eacecc7041 Jean*0233          ENDDO
55f764277b Jean*0234          CLOSE( ioUnit )
c806179eb4 Alis*0235 
51ec3c32fe Jean*0236        ENDDO
c806179eb4 Alis*0237       ENDDO
                0238 
3992cf11bb Jean*0239       _END_MASTER(myThid)
                0240       _BARRIER
                0241 
eacecc7041 Jean*0242       RETURN
                0243       END
[ Source navigation ] [ Diff markup ] [ Identifier search ] [ general search ]

This page was automatically generated from https://github.com/MITgcm/MITgcm by the 2.2.1-MITgcm-0.1 LXR engine.

The LXR team
Valid CSS 2.1! Valid HTML 4.01!