pkg/ctrl/ctrl_get_gen_rec.F

7bfe6112e8 Jean*0001 #include "CTRL_OPTIONS.h"
7109a141b2 Patr*0002
                0003       subroutine ctrl_get_gen_rec(
                0004      I                        xx_genstartdate,
                0005      I                        xx_genperiod,
                0006      O                        fac,
                0007      O                        first,
                0008      O                        changed,
                0009      O                        count0,
                0010      O                        count1,
4d72283393 Mart*0011      I                        myTime, myIter, myThid )
7109a141b2 Patr*0012
05e2fb6b68 Jean*0013 C     ==================================================================
                0014 C     SUBROUTINE ctrl_get_gen_rec
                0015 C     ==================================================================
                0016 C
                0017 C     o Get flags, counters, and the linear interpolation factor for a
                0018 C       given control vector contribution.
                0019 C     o New, generic, for new routine ctrl_get_gen
                0020 C
                0021 C     ==================================================================
                0022 C     SUBROUTINE ctrl_get_gen_rec
                0023 C     ==================================================================
7109a141b2 Patr*0024
c7a5c3888a Jean*0025       IMPLICIT NONE
7109a141b2 Patr*0026
05e2fb6b68 Jean*0027 C     == global variables ==
7109a141b2 Patr*0028
                0029 #include "SIZE.h"
594dbca4e4 Jean*0030 #include "EEPARAMS.h"
                0031 #include "PARAMS.h"
5cf4364659 Mart*0032 #include "CTRL_SIZE.h"
4d72283393 Mart*0033 #include "CTRL.h"
dff4940422 Patr*0034 #ifdef ALLOW_CAL
7109a141b2 Patr*0035 # include "cal.h"
                0036 #endif
                0037
05e2fb6b68 Jean*0038 C     == routine arguments ==
7109a141b2 Patr*0039
                0040       integer xx_genstartdate(4)
                0041       _RL     xx_genperiod
                0042       _RL     fac
                0043       logical first
                0044       logical changed
                0045       integer count0
                0046       integer count1
4d72283393 Mart*0047       _RL     myTime
                0048       integer myIter
                0049       integer myThid
7109a141b2 Patr*0050
05e2fb6b68 Jean*0051 C     == local variables ==
7109a141b2 Patr*0052
dff4940422 Patr*0053 #ifdef ALLOW_CAL
7109a141b2 Patr*0054
                0055       integer mydate(4)
                0056       integer previousdate(4)
                0057       integer difftime(4)
                0058
                0059       integer fldcount
                0060       _RL     fldsecs
                0061       integer prevfldcount
                0062       _RL     prevfldsecs
                0063       integer flddate(4)
                0064
                0065       integer fldstartdate(4)
                0066       _RL     fldperiod
                0067
deacece587 Oliv*0068       integer year0
                0069       integer year1
                0070
ab460d1282 Mart*0071 #else
                0072 C     Declarations for code, adapted from external_fields_load,
                0073 C     for simplied default model calendar without exf/cal
03c07845ac Jean*0074       _RL myRelTime, tmpFac
                0075       INTEGER countP
6dfbc266bb Jean*0076 #endif
7109a141b2 Patr*0077
c7a5c3888a Jean*0078       INTEGER shiftRec
                0079       CHARACTER*(MAX_LEN_MBUF) msgBuf
7109a141b2 Patr*0080
05e2fb6b68 Jean*0081 C     == end of interface ==
7109a141b2 Patr*0082
c7a5c3888a Jean*0083       shiftRec = 0
6dfbc266bb Jean*0084 #ifdef ALLOW_CAL
7109a141b2 Patr*0085       fldperiod = 0.
                0086
05e2fb6b68 Jean*0087 C     Map the field parameters.
7109a141b2 Patr*0088
                0089       call cal_CopyDate(
                0090      I     xx_genstartdate,
                0091      O     fldstartdate,
4d72283393 Mart*0092      I     myThid
7109a141b2 Patr*0093      &     )
                0094       fldperiod = xx_genperiod
                0095
79ee6da03d Mart*0096       if ( xx_genperiod .eq. -12. _d 0 ) then
05e2fb6b68 Jean*0097 C     record numbers are assumed 1 to 12 corresponding to
                0098 C     Jan. through Dec.
79ee6da03d Mart*0099        call cal_GetMonthsRec(
                0100      O      fac, first, changed,
deacece587 Oliv*0101      O      count0, count1, year0, year1,
4d72283393 Mart*0102      I      myTime, myIter, myThid
79ee6da03d Mart*0103      &      )
                0104       elseif ( fldperiod .eq. 0. _d 0 ) then
05e2fb6b68 Jean*0105 C     Read field only once in the beginning. Hack: count1=count0 causes
                0106 C     the model to read the first record twice, but since this this is
                0107 C     done only the first time around it is not too much of an overhead.
4d72283393 Mart*0108        first   = ((myTime - modelstart) .lt. 0.5*modelstep)
d2701cc5c1 Mart*0109        changed = .false.
                0110        fac     = 1. _d 0
                0111        count0  = 1
                0112        count1  = count0
                0113       else
05e2fb6b68 Jean*0114 C     fldperiod .ne. 0
                0115 C--   Determine the current date.
4d72283393 Mart*0116        call cal_GetDate( myIter, myTime, mydate, myThid )
7109a141b2 Patr*0117
05e2fb6b68 Jean*0118 C     Determine first record:
c7a5c3888a Jean*0119        call cal_TimePassed( fldstartdate, modelStartDate,
1eed6b0c03 An T*0120      &                      difftime, myThid )
c7a5c3888a Jean*0121        call cal_ToSeconds ( difftime, fldsecs, myThid )
                0122 C     set record-number shift between full ctrl time-serie and
                0123 C     "effective" sub-set (i.e., that covers this simulation)
                0124        shiftRec = int( fldsecs/fldperiod )
cc7fa87b6d Gael*0125
c7a5c3888a Jean*0126 C     Determine the ctrl record just before mycurrentdate.
d2701cc5c1 Mart*0127        call cal_TimePassed( fldstartdate, mydate, difftime,
4d72283393 Mart*0128      &                      myThid )
                0129        call cal_ToSeconds( difftime, fldsecs, myThid )
d2701cc5c1 Mart*0130        fldsecs  = int((fldsecs+0.5)/fldperiod)*fldperiod
                0131        fldcount = int((fldsecs+0.5)/fldperiod) + 1
7109a141b2 Patr*0132
05e2fb6b68 Jean*0133 C     Set switches for reading new records.
c7a5c3888a Jean*0134        first = ((myTime - startTime) .LT. 0.5*deltaTClock)
7109a141b2 Patr*0135
d2701cc5c1 Mart*0136        if ( first) then
7109a141b2 Patr*0137         changed = .false.
d2701cc5c1 Mart*0138        else
4d72283393 Mart*0139         call cal_GetDate( myIter-1, myTime-modelstep,
                0140      &                    previousdate, myThid )
7109a141b2 Patr*0141
                0142         call cal_TimePassed( fldstartdate, previousdate,
4d72283393 Mart*0143      &                       difftime, myThid )
                0144         call cal_ToSeconds( difftime, prevfldsecs, myThid )
7109a141b2 Patr*0145         prevfldsecs  = int((prevfldsecs+0.5)/fldperiod)*fldperiod
                0146         prevfldcount = int((prevfldsecs+0.5)/fldperiod) + 1
                0147
                0148         if (fldcount .ne. prevfldcount) then
d2701cc5c1 Mart*0149          changed = .true.
7109a141b2 Patr*0150         else
d2701cc5c1 Mart*0151          changed = .false.
7109a141b2 Patr*0152         endif
d2701cc5c1 Mart*0153        endif
7109a141b2 Patr*0154
c7a5c3888a Jean*0155        count0 = fldcount - shiftRec
                0156        count1 = count0 + 1
7109a141b2 Patr*0157
4d72283393 Mart*0158        call cal_TimeInterval( fldsecs, 'secs', difftime, myThid )
                0159        call cal_AddTime( fldstartdate, difftime, flddate, myThid )
                0160        call cal_TimePassed( flddate, mydate, difftime, myThid )
                0161        call cal_ToSeconds( difftime, fldsecs, myThid )
7109a141b2 Patr*0162
05e2fb6b68 Jean*0163 C     Weight belonging to irec for linear interpolation purposes.
                0164 C     Note: The weight as chosen here is 1. - fac of the "old"
                0165 C           MITgcm estimation program.
c7a5c3888a Jean*0166        fac = 1. _d 0 - fldsecs/fldperiod
7109a141b2 Patr*0167
05e2fb6b68 Jean*0168 C     fldperiod .ne. 0.
03c07845ac Jean*0169       endif
ab460d1282 Mart*0170 #else /* not ALLOW_CAL */
6dfbc266bb Jean*0171 C     Code, adapted from external_fields_load, for simplied
ab460d1282 Mart*0172 C     default model calendar without exf/cal, but
05e2fb6b68 Jean*0173 C     based on myTime, myIter, deltaTClock, externForcingCycle, and startTime
ab460d1282 Mart*0174
                0175       myRelTime = myTime - startTime
                0176       first = (myRelTime .lt. 0.5*deltaTClock)
6dfbc266bb Jean*0177       if ( xx_genperiod .eq. 0. _d 0
ab460d1282 Mart*0178      &     .or. externForcingCycle .eq. 0. _d 0 ) then
6dfbc266bb Jean*0179 C     control parameter is constant in time and only needs to be updated
ab460d1282 Mart*0180 C     once in the beginning
                0181        changed = .false.
                0182        count0  = 1
                0183        count1  = 1
                0184        fac     = 1. _d 0
                0185       else
03c07845ac Jean*0186
                0187 C--   Now calculate whether it is time to update the forcing arrays
                0188        CALL GET_PERIODIC_INTERVAL(
                0189      O                   countP, count0, count1, tmpFac, fac,
                0190      I                   externForcingCycle, xx_genperiod,
05e2fb6b68 Jean*0191      I                   deltaTClock, myTime, myThid )
03c07845ac Jean*0192
                0193        IF ( count0.NE.countP ) THEN
ab460d1282 Mart*0194         changed = .true.
03c07845ac Jean*0195        ELSE
ab460d1282 Mart*0196         changed = .false.
03c07845ac Jean*0197        ENDIF
                0198        IF ( first ) changed = .false.
ab460d1282 Mart*0199
                0200       endif
                0201
                0202 #endif /* ALLOW_CAL */
                0203
c7a5c3888a Jean*0204       IF ( debugLevel.GE.debLevC ) THEN
05e2fb6b68 Jean*0205 C     Do some printing for the protocol.
4d72283393 Mart*0206       _BEGIN_MASTER( myThid )
c7a5c3888a Jean*0207         WRITE(msgBuf,'(2A,I10,A,1PE21.14)') 'CTRL_GET_GEN_REC:',
                0208      &    ' myIter, myTime =', myIter, ', ', myTime
                0209         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
4d72283393 Mart*0210      &                      SQUEEZE_RIGHT, myThid )
c7a5c3888a Jean*0211         WRITE(msgBuf,'(A,2L3,F21.17,I5)')
                0212      &    '     first, changed, fac, shiftRec:',
                0213      &          first, changed, fac, shiftRec
                0214         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
4d72283393 Mart*0215      &                      SQUEEZE_RIGHT, myThid )
c7a5c3888a Jean*0216         WRITE(msgBuf,'(A,2I5,A,2I5)')
                0217      &    '  in xx_*.effective, count0,1=', count0, count1,
                0218      &    ' ;  in xx_*, rec.#',  count0+shiftRec, count1+shiftRec
                0219         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
4d72283393 Mart*0220      &                      SQUEEZE_RIGHT, myThid )
c7a5c3888a Jean*0221         WRITE(msgBuf,'(A)') ' '
                0222         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
4d72283393 Mart*0223      &                      SQUEEZE_RIGHT, myThid )
                0224       _END_MASTER( myThid )
c7a5c3888a Jean*0225       ENDIF
7109a141b2 Patr*0226
c7a5c3888a Jean*0227       RETURN
                0228       END