C $Header: /u/gcmpack/MITgcm/pkg/ctrl/ctrl_get_gen_rec.F,v 1.15 2012/08/10 19:38:57 jmc Exp $ C $Name: $ #include "CTRL_OPTIONS.h" subroutine CTRL_GET_GEN_REC( I xx_genstartdate, I xx_genperiod, O fac, O first, O changed, O count0, O count1, I mytime, I myiter, I mythid & ) c ================================================================== c SUBROUTINE ctrl_get_gen_rec c ================================================================== c c o Get flags, counters, and the linear interpolation factor for a c given control vector contribution. c o New, generic, for new routine ctrl_get_gen c c ================================================================== c SUBROUTINE ctrl_get_gen_rec c ================================================================== implicit none c == global variables == #include "EEPARAMS.h" #include "SIZE.h" #include "ctrl.h" #ifdef ALLOW_CAL # include "cal.h" #endif #include "PARAMS.h" c == routine arguments == integer xx_genstartdate(4) _RL xx_genperiod _RL fac logical first logical changed integer count0 integer count1 _RL mytime integer myiter integer mythid c == local variables == #ifdef ALLOW_CAL integer mydate(4) integer previousdate(4) integer difftime(4) integer fldcount _RL fldsecs integer prevfldcount _RL prevfldsecs integer flddate(4) integer fldstartdate(4) _RL fldperiod integer startrec logical lArgErr #else C Declarations for code, adapted from external_fields_load, C for simplied default model calendar without exf/cal _RL myRelTime, tmpFac INTEGER countP #endif #ifdef ECCO_VERBOSE character*(max_len_mbuf) msgbuf #endif c == end of interface == #ifdef ALLOW_CAL lArgErr = .true. fldperiod = 0. c Map the field parameters. call CAL_COPYDATE( I xx_genstartdate, O fldstartdate, I mythid & ) fldperiod = xx_genperiod lArgErr = .false. c-- Check the field argument. if ( lArgErr ) then print*,' The subroutine *ctrl_get_gen_rec* has been called' print*,' with an illegal field specification.' stop ' ... stopped in ctrl_get_gen_rec.' endif if ( xx_genperiod .eq. -12. _d 0 ) then c record numbers are assumed 1 to 12 corresponding to c Jan. through Dec. call CAL_GETMONTHSREC( O fac, first, changed, O count0, count1, I mytime, myiter, mythid & ) elseif ( fldperiod .eq. 0. _d 0 ) then c Read field only once in the beginning. Hack: count1=count0 causes c the model to read the first record twice, but since this this is c done only the first time around it is not too much of an overhead. first = ((mytime - modelstart) .lt. 0.5*modelstep) changed = .false. fac = 1. _d 0 count0 = 1 count1 = count0 else c fldperiod .ne. 0 c-- Determine the current date. call CAL_GETDATE( myiter, mytime, mydate, mythid ) c Determine first record: call CAL_TIMEPASSED( fldstartdate, modelstartdate, & difftime, mythid ) call CAL_TOSECONDS ( difftime, fldsecs, mythid ) startrec = int((modelstart + startTime - fldsecs)/ & fldperiod) + 1 c Determine the flux record just before mycurrentdate. call CAL_TIMEPASSED( fldstartdate, mydate, difftime, & mythid ) call CAL_TOSECONDS( difftime, fldsecs, mythid ) fldsecs = int((fldsecs+0.5)/fldperiod)*fldperiod fldcount = int((fldsecs+0.5)/fldperiod) + 1 c Set switches for reading new records. first = ((mytime - modelstart) .lt. 0.5*modelstep) if ( first) then changed = .false. else call CAL_GETDATE( myiter-1, mytime-modelstep, & previousdate, mythid ) call CAL_TIMEPASSED( fldstartdate, previousdate, & difftime, mythid ) call CAL_TOSECONDS( difftime, prevfldsecs, mythid ) prevfldsecs = int((prevfldsecs+0.5)/fldperiod)*fldperiod prevfldcount = int((prevfldsecs+0.5)/fldperiod) + 1 if (fldcount .ne. prevfldcount) then changed = .true. else changed = .false. endif endif c count0 = fldcount c count1 = fldcount + 1 count0 = fldcount - startrec + 1 count1 = fldcount - startrec + 2 call CAL_TIMEINTERVAL( fldsecs, 'secs', difftime, mythid ) call CAL_ADDTIME( fldstartdate, difftime, flddate, mythid ) call CAL_TIMEPASSED( flddate, mydate, difftime, mythid ) call CAL_TOSECONDS( difftime, fldsecs, mythid ) c Weight belonging to irec for linear interpolation purposes. c Note: The weight as chosen here is 1. - fac of the "old" c MITgcm estimation program. fac = 1. - fldsecs/fldperiod c fldperiod .ne. 0. endif #else /* not ALLOW_CAL */ C Code, adapted from external_fields_load, for simplied C default model calendar without exf/cal, but C based on myTime, myIter, deltaTclock, externForcingCycle, and startTime myRelTime = myTime - startTime first = (myRelTime .lt. 0.5*deltaTClock) if ( xx_genperiod .eq. 0. _d 0 & .or. externForcingCycle .eq. 0. _d 0 ) then C control parameter is constant in time and only needs to be updated C once in the beginning changed = .false. count0 = 1 count1 = 1 fac = 1. _d 0 else C-- Now calculate whether it is time to update the forcing arrays CALL GET_PERIODIC_INTERVAL( O countP, count0, count1, tmpFac, fac, I externForcingCycle, xx_genperiod, I deltaTclock, myTime, myThid ) IF ( count0.NE.countP ) THEN changed = .true. ELSE changed = .false. ENDIF IF ( first ) changed = .false. endif #endif /* ALLOW_CAL */ #ifdef ECCO_VERBOSE c Do some printing for the protocol. _BEGIN_MASTER( mythid ) write(msgbuf,'(a)') ' ' call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT , mythid) write(msgbuf,'(a,2x,l2,2x,l2,2x,D15.8)') & ' first, changed, fac:', & first, changed, fac call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT , mythid) write(msgbuf,'(a,i4,i4)') & ' count0, count1:', & count0, count1 call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT , mythid) write(msgbuf,'(a)') ' ' call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT , mythid) _END_MASTER( mythid ) #endif return end