pkg/ctrl/ctrl_get_gen_rec.F

7bfe6112e8 Jean*0001 #include "CTRL_OPTIONS.h"
7109a141b2 Patr*0002
6fc9daf8e1 Jean*0003       SUBROUTINE CTRL_GET_GEN_REC(
7109a141b2 Patr*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 #include "SIZE.h"
594dbca4e4 Jean*0029 #include "EEPARAMS.h"
                0030 #include "PARAMS.h"
5cf4364659 Mart*0031 #include "CTRL_SIZE.h"
4d72283393 Mart*0032 #include "CTRL.h"
dff4940422 Patr*0033 #ifdef ALLOW_CAL
7109a141b2 Patr*0034 # include "cal.h"
                0035 #endif
                0036
05e2fb6b68 Jean*0037 C     == routine arguments ==
6fc9daf8e1 Jean*0038       INTEGER xx_genstartdate(4)
7109a141b2 Patr*0039       _RL     xx_genperiod
                0040       _RL     fac
6fc9daf8e1 Jean*0041       LOGICAL first
                0042       LOGICAL changed
                0043       INTEGER count0
                0044       INTEGER count1
4d72283393 Mart*0045       _RL     myTime
6fc9daf8e1 Jean*0046       INTEGER myIter
                0047       INTEGER myThid
7109a141b2 Patr*0048
05e2fb6b68 Jean*0049 C     == local variables ==
dff4940422 Patr*0050 #ifdef ALLOW_CAL
6fc9daf8e1 Jean*0051       INTEGER mydate(4)
                0052       INTEGER previousdate(4)
                0053       INTEGER difftime(4)
7109a141b2 Patr*0054
6fc9daf8e1 Jean*0055       INTEGER fldcount
7109a141b2 Patr*0056       _RL     fldsecs
6fc9daf8e1 Jean*0057       INTEGER prevfldcount
7109a141b2 Patr*0058       _RL     prevfldsecs
6fc9daf8e1 Jean*0059       INTEGER flddate(4)
7109a141b2 Patr*0060
6fc9daf8e1 Jean*0061       INTEGER fldstartdate(4)
7109a141b2 Patr*0062       _RL     fldperiod
                0063
6fc9daf8e1 Jean*0064       INTEGER year0
                0065       INTEGER year1
                0066 #endif /* ALLOW_CAL */
deacece587 Oliv*0067
ab460d1282 Mart*0068 C     Declarations for code, adapted from external_fields_load,
                0069 C     for simplied default model calendar without exf/cal
03c07845ac Jean*0070       _RL myRelTime, tmpFac
                0071       INTEGER countP
7109a141b2 Patr*0072
c7a5c3888a Jean*0073       INTEGER shiftRec
                0074       CHARACTER*(MAX_LEN_MBUF) msgBuf
7109a141b2 Patr*0075
05e2fb6b68 Jean*0076 C     == end of interface ==
7109a141b2 Patr*0077
c7a5c3888a Jean*0078       shiftRec = 0
6fc9daf8e1 Jean*0079       IF ( useCAL ) THEN
6dfbc266bb Jean*0080 #ifdef ALLOW_CAL
7109a141b2 Patr*0081       fldperiod = 0.
                0082
05e2fb6b68 Jean*0083 C     Map the field parameters.
7109a141b2 Patr*0084
6fc9daf8e1 Jean*0085       CALL cal_CopyDate(
7109a141b2 Patr*0086      I     xx_genstartdate,
                0087      O     fldstartdate,
4d72283393 Mart*0088      I     myThid
7109a141b2 Patr*0089      &     )
                0090       fldperiod = xx_genperiod
                0091
6fc9daf8e1 Jean*0092       IF ( xx_genperiod .EQ. -12. _d 0 ) THEN
05e2fb6b68 Jean*0093 C     record numbers are assumed 1 to 12 corresponding to
                0094 C     Jan. through Dec.
6fc9daf8e1 Jean*0095        CALL cal_GetMonthsRec(
79ee6da03d Mart*0096      O      fac, first, changed,
deacece587 Oliv*0097      O      count0, count1, year0, year1,
4d72283393 Mart*0098      I      myTime, myIter, myThid
79ee6da03d Mart*0099      &      )
6fc9daf8e1 Jean*0100       ELSEIF ( fldperiod .EQ. 0. _d 0 ) THEN
05e2fb6b68 Jean*0101 C     Read field only once in the beginning. Hack: count1=count0 causes
                0102 C     the model to read the first record twice, but since this this is
                0103 C     done only the first time around it is not too much of an overhead.
6fc9daf8e1 Jean*0104        first   = ((myTime - modelstart) .LT. 0.5*modelstep)
d2701cc5c1 Mart*0105        changed = .false.
                0106        fac     = 1. _d 0
                0107        count0  = 1
                0108        count1  = count0
6fc9daf8e1 Jean*0109       ELSE
                0110 C     fldperiod .NE. 0
05e2fb6b68 Jean*0111 C--   Determine the current date.
6fc9daf8e1 Jean*0112        CALL cal_GetDate( myIter, myTime, mydate, myThid )
7109a141b2 Patr*0113
05e2fb6b68 Jean*0114 C     Determine first record:
6fc9daf8e1 Jean*0115        CALL cal_TimePassed( fldstartdate, modelStartDate,
1eed6b0c03 An T*0116      &                      difftime, myThid )
6fc9daf8e1 Jean*0117        CALL cal_ToSeconds ( difftime, fldsecs, myThid )
c7a5c3888a Jean*0118 C     set record-number shift between full ctrl time-serie and
                0119 C     "effective" sub-set (i.e., that covers this simulation)
                0120        shiftRec = int( fldsecs/fldperiod )
cc7fa87b6d Gael*0121
c7a5c3888a Jean*0122 C     Determine the ctrl record just before mycurrentdate.
6fc9daf8e1 Jean*0123        CALL cal_TimePassed( fldstartdate, mydate, difftime,
4d72283393 Mart*0124      &                      myThid )
6fc9daf8e1 Jean*0125        CALL cal_ToSeconds( difftime, fldsecs, myThid )
d2701cc5c1 Mart*0126        fldsecs  = int((fldsecs+0.5)/fldperiod)*fldperiod
                0127        fldcount = int((fldsecs+0.5)/fldperiod) + 1
7109a141b2 Patr*0128
05e2fb6b68 Jean*0129 C     Set switches for reading new records.
c7a5c3888a Jean*0130        first = ((myTime - startTime) .LT. 0.5*deltaTClock)
7109a141b2 Patr*0131
6fc9daf8e1 Jean*0132        IF ( first) THEN
7109a141b2 Patr*0133         changed = .false.
6fc9daf8e1 Jean*0134        ELSE
                0135         CALL cal_GetDate( myIter-1, myTime-modelstep,
4d72283393 Mart*0136      &                    previousdate, myThid )
7109a141b2 Patr*0137
6fc9daf8e1 Jean*0138         CALL cal_TimePassed( fldstartdate, previousdate,
4d72283393 Mart*0139      &                       difftime, myThid )
6fc9daf8e1 Jean*0140         CALL cal_ToSeconds( difftime, prevfldsecs, myThid )
7109a141b2 Patr*0141         prevfldsecs  = int((prevfldsecs+0.5)/fldperiod)*fldperiod
                0142         prevfldcount = int((prevfldsecs+0.5)/fldperiod) + 1
                0143
6fc9daf8e1 Jean*0144         IF (fldcount .NE. prevfldcount) THEN
d2701cc5c1 Mart*0145          changed = .true.
6fc9daf8e1 Jean*0146         ELSE
d2701cc5c1 Mart*0147          changed = .false.
6fc9daf8e1 Jean*0148         ENDIF
                0149        ENDIF
7109a141b2 Patr*0150
c7a5c3888a Jean*0151        count0 = fldcount - shiftRec
                0152        count1 = count0 + 1
7109a141b2 Patr*0153
6fc9daf8e1 Jean*0154        CALL cal_TimeInterval( fldsecs, 'secs', difftime, myThid )
                0155        CALL cal_AddTime( fldstartdate, difftime, flddate, myThid )
                0156        CALL cal_TimePassed( flddate, mydate, difftime, myThid )
                0157        CALL cal_ToSeconds( difftime, fldsecs, myThid )
7109a141b2 Patr*0158
05e2fb6b68 Jean*0159 C     Weight belonging to irec for linear interpolation purposes.
                0160 C     Note: The weight as chosen here is 1. - fac of the "old"
                0161 C           MITgcm estimation program.
c7a5c3888a Jean*0162        fac = 1. _d 0 - fldsecs/fldperiod
7109a141b2 Patr*0163
6fc9daf8e1 Jean*0164 C     fldperiod .NE. 0.
                0165       ENDIF
                0166 #endif /* ALLOW_CAL */
                0167       ELSE
                0168 C-    case useCAL=F
                0169
6dfbc266bb Jean*0170 C     Code, adapted from external_fields_load, for simplied
ab460d1282 Mart*0171 C     default model calendar without exf/cal, but
05e2fb6b68 Jean*0172 C     based on myTime, myIter, deltaTClock, externForcingCycle, and startTime
ab460d1282 Mart*0173
                0174       myRelTime = myTime - startTime
6fc9daf8e1 Jean*0175       first = (myRelTime .LT. 0.5*deltaTClock)
                0176       IF ( xx_genperiod .EQ. 0. _d 0
                0177      &     .OR. externForcingCycle .EQ. 0. _d 0 ) THEN
6dfbc266bb Jean*0178 C     control parameter is constant in time and only needs to be updated
ab460d1282 Mart*0179 C     once in the beginning
                0180        changed = .false.
                0181        count0  = 1
                0182        count1  = 1
                0183        fac     = 1. _d 0
6fc9daf8e1 Jean*0184       ELSE
03c07845ac Jean*0185
                0186 C--   Now calculate whether it is time to update the forcing arrays
                0187        CALL GET_PERIODIC_INTERVAL(
                0188      O                   countP, count0, count1, tmpFac, fac,
                0189      I                   externForcingCycle, xx_genperiod,
05e2fb6b68 Jean*0190      I                   deltaTClock, myTime, myThid )
03c07845ac Jean*0191
                0192        IF ( count0.NE.countP ) THEN
ab460d1282 Mart*0193         changed = .true.
03c07845ac Jean*0194        ELSE
ab460d1282 Mart*0195         changed = .false.
03c07845ac Jean*0196        ENDIF
                0197        IF ( first ) changed = .false.
ab460d1282 Mart*0198
6fc9daf8e1 Jean*0199       ENDIF
ab460d1282 Mart*0200
6fc9daf8e1 Jean*0201 C-    end if/else useCAL
                0202       ENDIF
ab460d1282 Mart*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