/[lmdze]/trunk/libf/IOIPSL/calendar.f90
ViewVC logotype

Diff of /trunk/libf/IOIPSL/calendar.f90

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 61 by guez, Thu Dec 2 17:11:04 2010 UTC revision 62 by guez, Thu Jul 26 14:37:37 2012 UTC
# Line 2  MODULE calendar Line 2  MODULE calendar
2    
3    ! From IOIPSL/src/calendar.f90, version 2.0 2004/04/05 14:47:47    ! From IOIPSL/src/calendar.f90, version 2.0 2004/04/05 14:47:47
4    
5    !- This is the calendar used to do all calculations on time. Three    ! This is the calendar used to do all calculations on time. Three
6    !- types of calendars are possible :    ! types of calendars are possible:
7    !-  - gregorian : The normal calendar. The time origin for the  
8    !-                julian day in this case is 24 Nov -4713    ! - Gregorian:
9    !-  - nolap : A 365 day year without leap years.    ! The normal calendar. The time origin for the julian day in this
10    !-            The origin for the julian days is in this case 1 Jan 0    ! case is 24 Nov -4713.
11    !-  - xxxd : Year of xxx days with month of equal length.  
12    !-           The origin for the julian days is then also 1 Jan 0    ! - No leap:
13    !- As one can see it is difficult to go from one calendar to the other.    ! A 365 day year without leap years. The origin for the julian days
14    !- All operations involving julian days will be wrong.    ! is in this case 1 Jan 0.
15    !- This calendar will lock as soon as possible  
16    !- the length of the year and  forbid any further modification.    ! - xxxd:
17    !-    ! Year of xxx days with months of equal length. The origin for the
18    !- For the non leap-year calendar the method is still brute force.    ! julian days is then also 1 Jan 0.
19    !- We need to find an Integer series which takes care of the length  
20    !- of the various month. (Jan)    ! As one can see it is difficult to go from one calendar to the
21    !-    ! other. All operations involving julian days will be wrong. This
22    !-   un_jour : one day in seconds    ! calendar will lock as soon as possible the length of the year and
23    !-   un_an   : one year in days    ! forbid any further modification.
24    
25    USE strlowercase_m, ONLY : strlowercase    ! For the non leap-year calendar the method is still brute force.
26    USE errioipsl, ONLY : histerr    ! We need to find an integer series which takes care of the length
27    !-    ! of the various month. (Jan)
28    
29      USE strlowercase_m, ONLY: strlowercase
30      USE errioipsl, ONLY: histerr
31    
32      IMPLICIT NONE
33    
34    PRIVATE    PRIVATE
35    PUBLIC :: ymds2ju,ju2ymds,isittime,ioconf_calendar, &    PUBLIC ymds2ju, ju2ymds, isittime, ioconf_calendar, itau2date, lock_unan, &
36         ioget_calendar,itau2date, ioconf_startdate         calendar_used, un_an, un_jour
37    !-  
38    INTERFACE ioget_calendar    REAL, PARAMETER:: un_jour = 86400. ! one day in seconds
39       MODULE PROCEDURE &    LOGICAL:: lock_startdate = .FALSE.
40            &    ioget_calendar_real1,ioget_calendar_real2,ioget_calendar_str  
41    END INTERFACE    CHARACTER(LEN=30):: time_stamp = 'XXXXXXXXXXXXXXXX'
42    !-  
43    REAL,PARAMETER :: un_jour = 86400.0    ! Description of calendar
44    LOGICAL,SAVE :: lock_startdate = .FALSE.  
45    !-    CHARACTER(LEN=20):: calendar_used = "gregorian"
46    CHARACTER(LEN=30),SAVE :: time_stamp='XXXXXXXXXXXXXXXX'    LOGICAL:: lock_unan = .FALSE.
47    !-    REAL:: un_an = 365.2425 ! one year in days
48    !- Description of calendar    INTEGER:: mon_len(12) = (/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/)
49    !-  
50    CHARACTER(LEN=20),SAVE :: calendar_used="gregorian"    CHARACTER(LEN=3), PARAMETER:: cal(12) = (/'JAN', 'FEB', 'MAR', 'APR', &
51    LOGICAL,SAVE :: lock_unan = .FALSE.         'MAY', 'JUN', 'JUL', 'AUG', 'SEP', 'OCT', 'NOV', 'DEC'/)
52    REAL,SAVE :: un_an = 365.2425  
53    INTEGER,SAVE :: mon_len(12)=(/31,28,31,30,31,30,31,31,30,31,30,31/)    REAL, SAVE:: start_day, start_sec
   !-  
   !-  
   !-  
   CHARACTER(LEN=3),PARAMETER :: &  
        &  cal(12) = (/'JAN','FEB','MAR','APR','MAY','JUN', &  
        &              'JUL','AUG','SEP','OCT','NOV','DEC'/)  
   !-  
   REAL,SAVE :: start_day,start_sec  
54    
55  CONTAINS  CONTAINS
56    
57    SUBROUTINE ymds2ju (year,month,day,sec,julian)    SUBROUTINE ymds2ju (year, month, day, sec, julian)
58    
59        INTEGER, INTENT(IN):: year, month, day
60        REAL, INTENT(IN):: sec
61        REAL, INTENT(OUT):: julian
62    
63      IMPLICIT NONE      INTEGER:: julian_day
64        REAL:: julian_sec
65    
66      INTEGER,INTENT(IN) :: year,month,day      !--------------------------------------------------------------------
     REAL,INTENT(IN)    :: sec  
     REAL,INTENT(OUT) :: julian  
   
     INTEGER :: julian_day  
     REAL    :: julian_sec  
     !---------------------------------------------------------------------  
     CALL ymds2ju_internal (year,month,day,sec,julian_day,julian_sec)  
67    
68        CALL ymds2ju_internal(year, month, day, sec, julian_day, julian_sec)
69      julian = julian_day + julian_sec / un_jour      julian = julian_day + julian_sec / un_jour
70      !---------------------  
71    END SUBROUTINE ymds2ju    END SUBROUTINE ymds2ju
72    
73    !===    !===
74    
75    SUBROUTINE ymds2ju_internal (year,month,day,sec,julian_day,julian_sec)    SUBROUTINE ymds2ju_internal (year, month, day, sec, julian_day, julian_sec)
76      !---------------------------------------------------------------------  
77      !- Converts year, month, day and seconds into a julian day      ! Converts year, month, day and seconds into a julian day
78    
79      !- In 1968 in a letter to the editor of Communications of the ACM      ! In 1968 in a letter to the editor of Communications of the ACM
80      !- (CACM, volume 11, number 10, October 1968, p.657) Henry F. Fliegel      ! (CACM, volume 11, number 10, October 1968, p.657) Henry F. Fliegel
81      !- and Thomas C. Van Flandern presented such an algorithm.      ! and Thomas C. Van Flandern presented such an algorithm.
82    
83      !- See also : http://www.magnet.ch/serendipity/hermetic/cal_stud/jdn.htm      ! See also: http://www.magnet.ch/serendipity/hermetic/cal_stud/jdn.htm
84    
85      !- In the case of the Gregorian calendar we have chosen to use      ! In the case of the Gregorian calendar we have chosen to use
86      !- the Lilian day numbers. This is the day counter which starts      ! the Lilian day numbers. This is the day counter which starts
87      !- on the 15th October 1582.      ! on the 15th October 1582.
88      !- This is the day at which Pope Gregory XIII introduced the      ! This is the day at which Pope Gregory XIII introduced the
89      !- Gregorian calendar.      ! Gregorian calendar.
90      !- Compared to the true Julian calendar, which starts some      ! Compared to the true Julian calendar, which starts some
91      !- 7980 years ago, the Lilian days are smaler and are dealt with      ! 7980 years ago, the Lilian days are smaler and are dealt with
92      !- easily on 32 bit machines. With the true Julian days you can only      ! easily on 32 bit machines. With the true Julian days you can only
93      !- the fraction of the day in the real part to a precision of      ! the fraction of the day in the real part to a precision of
94      !- a 1/4 of a day with 32 bits.      ! a 1/4 of a day with 32 bits.
     !---------------------------------------------------------------------  
     IMPLICIT NONE  
95    
96      INTEGER,INTENT(IN) :: year,month,day      INTEGER, INTENT(IN):: year, month, day
97      REAL,INTENT(IN)    :: sec      REAL, INTENT(IN):: sec
98    
99      INTEGER,INTENT(OUT) :: julian_day      INTEGER, INTENT(OUT):: julian_day
100      REAL,INTENT(OUT)    :: julian_sec      REAL, INTENT(OUT):: julian_sec
101    
102      INTEGER :: jd,m,y,d,ml      INTEGER:: jd, m, y, d, ml
103      !---------------------------------------------------------------------      !--------------------------------------------------------------------
104      lock_unan = .TRUE.      lock_unan = .TRUE.
105    
106      m = month      m = month
107      y = year      y = year
108      d = day      d = day
109    
110      !- We deduce the calendar from the length of the year as it      ! We deduce the calendar from the length of the year as it
111      !- is faster than an INDEX on the calendar variable.      ! is faster than an INDEX on the calendar variable.
112    
113      !- Gregorian      ! Gregorian
114      IF ( (un_an > 365.0).AND.(un_an < 366.0) ) THEN      IF ( (un_an > 365.0).AND.(un_an < 366.0) ) THEN
115         jd = (1461*(y+4800+INT(( m-14 )/12)))/4 &         jd = (1461*(y+4800+INT(( m-14 )/12)))/4 &
116              &      +(367*(m-2-12*(INT(( m-14 )/12))))/12 &              &      +(367*(m-2-12*(INT(( m-14 )/12))))/12 &
117              &      -(3*((y+4900+INT((m-14)/12))/100))/4 &              &      -(3*((y+4900+INT((m-14)/12))/100))/4 &
118              &      +d-32075              &      +d-32075
119         jd = jd-2299160         jd = jd-2299160
120         !- No leap or All leap         ! No leap or All leap
121      ELSE IF (ABS(un_an-365.0) <= EPSILON(un_an) .OR. &      ELSE IF (ABS(un_an-365.0) <= EPSILON(un_an) .OR. &
122           &   ABS(un_an-366.0) <= EPSILON(un_an)) THEN           &   ABS(un_an-366.0) <= EPSILON(un_an)) THEN
123         ml = SUM(mon_len(1:m-1))         ml = SUM(mon_len(1:m-1))
124         jd = y*INT(un_an)+ml+(d-1)         jd = y*INT(un_an)+ml+(d-1)
125         !- Calendar with regular month         ! Calendar with regular month
126      ELSE      ELSE
127         ml = INT(un_an)/12         ml = INT(un_an)/12
128         jd = y*INT(un_an)+(m-1)*ml+(d-1)         jd = y*INT(un_an)+(m-1)*ml+(d-1)
# Line 135  CONTAINS Line 130  CONTAINS
130    
131      julian_day = jd      julian_day = jd
132      julian_sec = sec      julian_sec = sec
133      !------------------------------  
134    END SUBROUTINE ymds2ju_internal    END SUBROUTINE ymds2ju_internal
135    !-  
136    !===    !===
137    !-  
138    SUBROUTINE ju2ymds (julian,year,month,day,sec)    SUBROUTINE ju2ymds (julian, year, month, day, sec)
139      !---------------------------------------------------------------------  
140      IMPLICIT NONE      REAL, INTENT(IN):: julian
141    
142      REAL,INTENT(IN) :: julian      INTEGER, INTENT(OUT):: year, month, day
143        REAL, INTENT(OUT):: sec
144      INTEGER,INTENT(OUT) :: year,month,day  
145      REAL,INTENT(OUT)    :: sec      INTEGER:: julian_day
146        REAL:: julian_sec
147      INTEGER :: julian_day      !--------------------------------------------------------------------
     REAL    :: julian_sec  
     !---------------------------------------------------------------------  
148      julian_day = INT(julian)      julian_day = INT(julian)
149      julian_sec = (julian-julian_day)*un_jour      julian_sec = (julian-julian_day)*un_jour
150    
151      CALL ju2ymds_internal(julian_day,julian_sec,year,month,day,sec)      CALL ju2ymds_internal(julian_day, julian_sec, year, month, day, sec)
152      !---------------------  
153    END SUBROUTINE ju2ymds    END SUBROUTINE ju2ymds
154    !-  
155    !===    !===
156    !-  
157    SUBROUTINE ju2ymds_internal (julian_day,julian_sec,year,month,day,sec)    SUBROUTINE ju2ymds_internal (julian_day, julian_sec, year, month, day, sec)
158      !---------------------------------------------------------------------  
159      !- This subroutine computes from the julian day the year,      ! This subroutine computes from the julian day the year,
160      !- month, day and seconds      ! month, day and seconds
161    
162      !- In 1968 in a letter to the editor of Communications of the ACM      ! In 1968 in a letter to the editor of Communications of the ACM
163      !- (CACM, volume 11, number 10, October 1968, p.657) Henry F. Fliegel      ! (CACM, volume 11, number 10, October 1968, p.657) Henry F. Fliegel
164      !- and Thomas C. Van Flandern presented such an algorithm.      ! and Thomas C. Van Flandern presented such an algorithm.
165    
166      !- See also : http://www.magnet.ch/serendipity/hermetic/cal_stud/jdn.htm      ! See also: http://www.magnet.ch/serendipity/hermetic/cal_stud/jdn.htm
167    
168      !- In the case of the Gregorian calendar we have chosen to use      ! In the case of the Gregorian calendar we have chosen to use
169      !- the Lilian day numbers. This is the day counter which starts      ! the Lilian day numbers. This is the day counter which starts
170      !- on the 15th October 1582. This is the day at which Pope      ! on the 15th October 1582. This is the day at which Pope
171      !- Gregory XIII introduced the Gregorian calendar.      ! Gregory XIII introduced the Gregorian calendar.
172      !- Compared to the true Julian calendar, which starts some 7980      ! Compared to the true Julian calendar, which starts some 7980
173      !- years ago, the Lilian days are smaler and are dealt with easily      ! years ago, the Lilian days are smaler and are dealt with easily
174      !- on 32 bit machines. With the true Julian days you can only the      ! on 32 bit machines. With the true Julian days you can only the
175      !- fraction of the day in the real part to a precision of a 1/4 of      ! fraction of the day in the real part to a precision of a 1/4 of
176      !- a day with 32 bits.      ! a day with 32 bits.
177      !---------------------------------------------------------------------  
178      IMPLICIT NONE      INTEGER, INTENT(IN):: julian_day
179        REAL, INTENT(IN):: julian_sec
180      INTEGER,INTENT(IN) :: julian_day  
181      REAL,INTENT(IN)    :: julian_sec      INTEGER, INTENT(OUT):: year, month, day
182        REAL, INTENT(OUT):: sec
183      INTEGER,INTENT(OUT) :: year,month,day  
184      REAL,INTENT(OUT)    :: sec      INTEGER:: l, n, i, jd, j, d, m, y, ml
185        INTEGER:: add_day
186      INTEGER :: l,n,i,jd,j,d,m,y,ml      !--------------------------------------------------------------------
     INTEGER :: add_day  
     !---------------------------------------------------------------------  
187      lock_unan = .TRUE.      lock_unan = .TRUE.
188    
189      jd = julian_day      jd = julian_day
# Line 203  CONTAINS Line 194  CONTAINS
194         jd = jd+add_day         jd = jd+add_day
195      ENDIF      ENDIF
196    
197      !- Gregorian      ! Gregorian
198      IF ( (un_an > 365.0).AND.(un_an < 366.0) ) THEN      IF ( (un_an > 365.0).AND.(un_an < 366.0) ) THEN
199         jd = jd+2299160         jd = jd+2299160
200        
# Line 217  CONTAINS Line 208  CONTAINS
208         l = j/11         l = j/11
209         m = j+2-(12*l)         m = j+2-(12*l)
210         y = 100*(n-49)+i+l         y = 100*(n-49)+i+l
211         !- No leap or All leap         ! No leap or All leap
212      ELSE IF (ABS(un_an-365.0) <= EPSILON(un_an) .OR. &      ELSE IF (ABS(un_an-365.0) <= EPSILON(un_an) .OR. &
213           &   ABS(un_an-366.0) <= EPSILON(un_an) ) THEN           &   ABS(un_an-366.0) <= EPSILON(un_an) ) THEN
214         y = jd/INT(un_an)         y = jd/INT(un_an)
# Line 229  CONTAINS Line 220  CONTAINS
220            m = m+1            m = m+1
221         ENDDO         ENDDO
222         d = l-ml+1         d = l-ml+1
223         !- others         ! others
224      ELSE      ELSE
225         ml = INT(un_an)/12         ml = INT(un_an)/12
226         y = jd/INT(un_an)         y = jd/INT(un_an)
# Line 241  CONTAINS Line 232  CONTAINS
232      day = d      day = d
233      month = m      month = m
234      year = y      year = y
235      !------------------------------  
236    END SUBROUTINE ju2ymds_internal    END SUBROUTINE ju2ymds_internal
237    !-  
238    !===    !===
239    !-  
240    REAL FUNCTION itau2date (itau,date0,deltat)    REAL FUNCTION itau2date (itau, date0, deltat)
241      !---------------------------------------------------------------------  
242      !- This function transforms itau into a date. The date whith which      ! This function transforms itau into a date. The date whith which
243      !- the time axis is going to be labeled      ! the time axis is going to be labeled
244    
245      !- INPUT      ! INPUT
246      !-   itau   : current time step      !   itau: current time step
247      !-   date0  : Date at which itau was equal to 0      !   date0: Date at which itau was equal to 0
248      !-   deltat : time step between itau s      !   deltat: time step between itau s
249    
250      !- OUTPUT      ! OUTPUT
251      !-   itau2date : Date for the given itau      !   itau2date: Date for the given itau
252      !---------------------------------------------------------------------  
253      IMPLICIT NONE      INTEGER:: itau
254        REAL:: date0, deltat
255      INTEGER  :: itau      !--------------------------------------------------------------------
     REAL     :: date0,deltat  
     !---------------------------------------------------------------------  
256      itau2date = REAL(itau)*deltat/un_jour+date0      itau2date = REAL(itau)*deltat/un_jour+date0
257      !---------------------  
258    END FUNCTION itau2date    END FUNCTION itau2date
259    !-  
260    !===    !===
261    !-  
262    SUBROUTINE isittime &    SUBROUTINE isittime &
263         &  (itau,date0,dt,freq,last_action,last_check,do_action)         &  (itau, date0, dt, freq, last_action, last_check, do_action)
264      !---------------------------------------------------------------------  
265      !- This subroutine checks the time has come for a given action.      ! This subroutine checks the time has come for a given action.
266      !- This is computed from the current time-step(itau).      ! This is computed from the current time-step(itau).
267      !- Thus we need to have the time delta (dt), the frequency      ! Thus we need to have the time delta (dt), the frequency
268      !- of the action (freq) and the last time it was done      ! of the action (freq) and the last time it was done
269      !- (last_action in units of itau).      ! (last_action in units of itau).
270      !- In order to extrapolate when will be the next check we need      ! In order to extrapolate when will be the next check we need
271      !- the time step of the last call (last_check).      ! the time step of the last call (last_check).
272    
273      !- The test is done on the following condition :      ! The test is done on the following condition:
274      !- the distance from the current time to the time for the next      ! the distance from the current time to the time for the next
275      !- action is smaller than the one from the next expected      ! action is smaller than the one from the next expected
276      !- check to the next action.      ! check to the next action.
277      !- When the test is done on the time steps simplifactions make      ! When the test is done on the time steps simplifactions make
278      !- it more difficult to read in the code.      ! it more difficult to read in the code.
279      !- For the real time case it is easier to understand !      ! For the real time case it is easier to understand !
280      !---------------------------------------------------------------------  
281      IMPLICIT NONE      INTEGER, INTENT(IN):: itau
282        REAL, INTENT(IN):: dt, freq
283      INTEGER,INTENT(IN) :: itau      INTEGER, INTENT(IN):: last_action, last_check
284      REAL,INTENT(IN)    :: dt,freq      REAL, INTENT(IN):: date0
285      INTEGER,INTENT(IN) :: last_action,last_check  
286      REAL,INTENT(IN)    :: date0      LOGICAL, INTENT(OUT):: do_action
287    
288      LOGICAL,INTENT(OUT)  :: do_action      REAL:: dt_action, dt_check
289        REAL:: date_last_act, date_next_check, date_next_act, &
290      REAL :: dt_action,dt_check           &        date_now, date_mp1, date_mpf
291      REAL :: date_last_act,date_next_check,date_next_act, &      INTEGER:: year, month, monthp1, day, next_check_itau, next_act_itau
292           &        date_now,date_mp1,date_mpf      INTEGER:: yearp, dayp
293      INTEGER :: year,month,monthp1,day,next_check_itau,next_act_itau      REAL:: sec, secp
294      INTEGER :: yearp,dayp      LOGICAL:: check = .FALSE.
295      REAL :: sec,secp      !--------------------------------------------------------------------
     LOGICAL :: check = .FALSE.  
     !---------------------------------------------------------------------  
296      IF (check) THEN      IF (check) THEN
297         WRITE(*,*) &         WRITE(*, *) &
298              &    "isittime 1.0 ",itau,date0,dt,freq,last_action,last_check              &    "isittime 1.0 ", itau, date0, dt, freq, last_action, last_check
299      ENDIF      ENDIF
300    
301      IF (last_check >= 0) THEN      IF (last_check >= 0) THEN
# Line 316  CONTAINS Line 303  CONTAINS
303         dt_check = (itau-last_check)*dt         dt_check = (itau-last_check)*dt
304         next_check_itau = itau+(itau-last_check)         next_check_itau = itau+(itau-last_check)
305        
306         !-- We are dealing with frequencies in seconds and thus operation         !- We are dealing with frequencies in seconds and thus operation
307         !-- can be done on the time steps.         !- can be done on the time steps.
308        
309         IF (freq > 0) THEN         IF (freq > 0) THEN
310            IF (ABS(dt_action-freq) <= ABS(dt_action+dt_check-freq)) THEN            IF (ABS(dt_action-freq) <= ABS(dt_action+dt_check-freq)) THEN
# Line 326  CONTAINS Line 313  CONTAINS
313               do_action = .FALSE.               do_action = .FALSE.
314            ENDIF            ENDIF
315                
316            !---- Here we deal with frequencies in month and work on julian days.            !--- Here we deal with frequencies in month and work on julian days.
317                
318         ELSE         ELSE
319            date_now = itau2date (itau,date0,dt)            date_now = itau2date (itau, date0, dt)
320            date_last_act = itau2date (last_action,date0,dt)            date_last_act = itau2date (last_action, date0, dt)
321            CALL ju2ymds (date_last_act,year,month,day,sec)            CALL ju2ymds (date_last_act, year, month, day, sec)
322            monthp1 = month - freq            monthp1 = month - freq
323            yearp = year            yearp = year
324                
325            !---- Here we compute what logically should be the next month            !--- Here we compute what logically should be the next month
326                
327            IF (month >= 13) THEN            IF (month >= 13) THEN
328               yearp = year+1               yearp = year+1
329               monthp1 = monthp1-12               monthp1 = monthp1-12
330            ENDIF            ENDIF
331            CALL ymds2ju (year,monthp1,day,sec,date_mpf)            CALL ymds2ju (year, monthp1, day, sec, date_mpf)
332                
333            !---- But it could be that because of a shorter month or a bad            !--- But it could be that because of a shorter month or a bad
334            !---- starting date that we end up further than we should be.            !--- starting date that we end up further than we should be.
335            !---- Thus we compute the first day of the next month.            !--- Thus we compute the first day of the next month.
336            !---- We can not be beyond this date and if we are close            !--- We can not be beyond this date and if we are close
337            !---- then we will take it as it is better.            !--- then we will take it as it is better.
338                
339            monthp1 = month+ABS(freq)            monthp1 = month+ABS(freq)
340            yearp=year            yearp=year
# Line 357  CONTAINS Line 344  CONTAINS
344            ENDIF            ENDIF
345            dayp = 1            dayp = 1
346            secp = 0.0            secp = 0.0
347            CALL ymds2ju (yearp,monthp1,dayp,secp,date_mp1)            CALL ymds2ju (yearp, monthp1, dayp, secp, date_mp1)
348                
349            !---- If date_mp1 is smaller than date_mpf or only less than 4 days            !--- If date_mp1 is smaller than date_mpf or only less than 4 days
350            !---- larger then we take it. This needed to ensure that short month            !--- larger then we take it. This needed to ensure that short month
351            !---- like February do not mess up the thing !            !--- like February do not mess up the thing !
352                
353            IF (date_mp1-date_mpf < 4.) THEN            IF (date_mp1-date_mpf < 4.) THEN
354               date_next_act = date_mp1               date_next_act = date_mp1
355            ELSE            ELSE
356               date_next_act = date_mpf               date_next_act = date_mpf
357            ENDIF            ENDIF
358            date_next_check = itau2date (next_check_itau,date0,dt)            date_next_check = itau2date (next_check_itau, date0, dt)
359                
360            !---- Transform the dates into time-steps for the needed precisions.            !--- Transform the dates into time-steps for the needed precisions.
361                
362            next_act_itau = &            next_act_itau = &
363                 &      last_action+INT((date_next_act-date_last_act)*(un_jour/dt))                 &      last_action+INT((date_next_act-date_last_act)*(un_jour/dt))
364            !-----  
365            IF (   ABS(itau-next_act_itau) &            IF (   ABS(itau-next_act_itau) &
366                 &        <= ABS( next_check_itau-next_act_itau)) THEN                 &        <= ABS( next_check_itau-next_act_itau)) THEN
367               do_action = .TRUE.               do_action = .TRUE.
368               IF (check) THEN               IF (check) THEN
369                  WRITE(*,*) &                  WRITE(*, *) &
370                       &         'ACT-TIME : itau, next_act_itau, next_check_itau : ', &                       &         'ACT-TIME: itau, next_act_itau, next_check_itau: ', &
371                       &         itau,next_act_itau,next_check_itau                       &         itau, next_act_itau, next_check_itau
372                  CALL ju2ymds (date_now,year,month,day,sec)                  CALL ju2ymds (date_now, year, month, day, sec)
373                  WRITE(*,*) 'ACT-TIME : y, m, d, s : ',year,month,day,sec                  WRITE(*, *) 'ACT-TIME: y, m, d, s: ', year, month, day, sec
374                  WRITE(*,*) &                  WRITE(*, *) &
375                       &         'ACT-TIME : date_mp1, date_mpf : ',date_mp1,date_mpf                       &         'ACT-TIME: date_mp1, date_mpf: ', date_mp1, date_mpf
376               ENDIF               ENDIF
377            ELSE            ELSE
378               do_action = .FALSE.               do_action = .FALSE.
# Line 393  CONTAINS Line 380  CONTAINS
380         ENDIF         ENDIF
381        
382         IF (check) THEN         IF (check) THEN
383            WRITE(*,*) "isittime 2.0 ", &            WRITE(*, *) "isittime 2.0 ", &
384                 &     date_next_check,date_next_act,ABS(dt_action-freq), &                 &     date_next_check, date_next_act, ABS(dt_action-freq), &
385                 &     ABS(dt_action+dt_check-freq),dt_action,dt_check, &                 &     ABS(dt_action+dt_check-freq), dt_action, dt_check, &
386                 &     next_check_itau,do_action                 &     next_check_itau, do_action
387         ENDIF         ENDIF
388      ELSE      ELSE
389         do_action=.FALSE.         do_action=.FALSE.
390      ENDIF      ENDIF
391      !----------------------  
392    END SUBROUTINE isittime    END SUBROUTINE isittime
393    !-  
394    !===    !===
395    !-  
396    SUBROUTINE ioconf_calendar (str)    SUBROUTINE ioconf_calendar (str)
397      !---------------------------------------------------------------------  
398      !- This routine allows to configure the calendar to be used.      ! This routine allows to configure the calendar to be used.
399      !- This operation is only allowed once and the first call to      ! This operation is only allowed once and the first call to
400      !- ymds2ju or ju2ymsd will lock the current configuration.      ! ymds2ju or ju2ymsd will lock the current configuration.
401      !- the argument to ioconf_calendar can be any of the following :      ! the argument to ioconf_calendar can be any of the following:
402      !-  - gregorian : This is the gregorian calendar (default here)      !  - gregorian: This is the gregorian calendar (default here)
403      !-  - noleap    : A calendar without leap years = 365 days      !  - noleap: A calendar without leap years = 365 days
404      !-  - xxxd      : A calendar of xxx days (has to be a modulo of 12)      !  - xxxd: A calendar of xxx days (has to be a modulo of 12)
405      !-                with 12 month of equal length      !                with 12 month of equal length
406      !---------------------------------------------------------------------  
407      IMPLICIT NONE      CHARACTER(LEN=*), INTENT(IN):: str
408    
409      CHARACTER(LEN=*),INTENT(IN) :: str      INTEGER:: leng, ipos
410        CHARACTER(LEN=10):: str10
411      INTEGER :: leng,ipos      !--------------------------------------------------------------------
     CHARACTER(LEN=10) :: str10  
     !---------------------------------------------------------------------  
412    
413      ! 1.0 Clean up the sring !      ! 1.0 Clean up the sring !
414    
415      CALL strlowercase (str)      CALL strlowercase (str)
416    
417      IF (.NOT.lock_unan) THEN      IF (.NOT.lock_unan) THEN
418         !---  
419         lock_unan=.TRUE.         lock_unan=.TRUE.
420         !---  
421         SELECT CASE(str)         SELECT CASE(str)
422         CASE('gregorian')         CASE('gregorian')
423            calendar_used = 'gregorian'            calendar_used = 'gregorian'
424            un_an = 365.2425            un_an = 365.2425
425            mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/)            mon_len(:)=(/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/)
426         CASE('standard')         CASE('standard')
427            calendar_used = 'gregorian'            calendar_used = 'gregorian'
428            un_an = 365.2425            un_an = 365.2425
429            mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/)            mon_len(:)=(/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/)
430         CASE('proleptic_gregorian')         CASE('proleptic_gregorian')
431            calendar_used = 'gregorian'            calendar_used = 'gregorian'
432            un_an = 365.2425            un_an = 365.2425
433            mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/)            mon_len(:)=(/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/)
434         CASE('noleap')         CASE('noleap')
435            calendar_used = 'noleap'            calendar_used = 'noleap'
436            un_an = 365.0            un_an = 365.0
437            mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/)            mon_len(:)=(/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/)
438         CASE('365_day')         CASE('365_day')
439            calendar_used = 'noleap'            calendar_used = 'noleap'
440            un_an = 365.0            un_an = 365.0
441            mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/)            mon_len(:)=(/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/)
442         CASE('365d')         CASE('365d')
443            calendar_used = 'noleap'            calendar_used = 'noleap'
444            un_an = 365.0            un_an = 365.0
445            mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/)            mon_len(:)=(/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/)
446         CASE('all_leap')         CASE('all_leap')
447            calendar_used = 'all_leap'            calendar_used = 'all_leap'
448            un_an = 366.0            un_an = 366.0
449            mon_len(:)=(/31,29,31,30,31,30,31,31,30,31,30,31/)            mon_len(:)=(/31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/)
450         CASE('366_day')         CASE('366_day')
451            calendar_used = 'all_leap'            calendar_used = 'all_leap'
452            un_an = 366.0            un_an = 366.0
453            mon_len(:)=(/31,29,31,30,31,30,31,31,30,31,30,31/)            mon_len(:)=(/31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/)
454         CASE('366d')         CASE('366d')
455            calendar_used = 'all_leap'            calendar_used = 'all_leap'
456            un_an = 366.0            un_an = 366.0
457            mon_len(:)=(/31,29,31,30,31,30,31,31,30,31,30,31/)            mon_len(:)=(/31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/)
458         CASE DEFAULT         CASE DEFAULT
459            ipos = INDEX(str,'d')            ipos = INDEX(str, 'd')
460            IF (ipos == 4) THEN            IF (ipos == 4) THEN
461               READ(str(1:3),'(I3)') leng               READ(str(1:3), '(I3)') leng
462               IF ( (MOD(leng,12) == 0).AND.(leng > 1) ) THEN               IF ( (MOD(leng, 12) == 0).AND.(leng > 1) ) THEN
463                  calendar_used = str                  calendar_used = str
464                  un_an = leng                  un_an = leng
465                  mon_len(:) = leng                  mon_len(:) = leng
466               ELSE               ELSE
467                  CALL histerr (3,'ioconf_calendar', &                  CALL histerr (3, 'ioconf_calendar', &
468                       &         'The length of the year as to be a modulo of 12', &                       &         'The length of the year as to be a modulo of 12', &
469                       &         'so that it can be divided into 12 month of equal length', &                       &         'so that it can be divided into 12 month of equal length', &
470                       &         str)                       &         str)
471               ENDIF               ENDIF
472            ELSE            ELSE
473               CALL histerr (3,'ioconf_calendar', &               CALL histerr (3, 'ioconf_calendar', &
474                    &       'Unrecognized input, please ceck the man pages.',str,' ')                    &       'Unrecognized input, please ceck the man pages.', str, ' ')
475            ENDIF            ENDIF
476         END SELECT         END SELECT
477      ELSE      ELSE
478         WRITE(str10,'(f10.4)') un_an         WRITE(str10, '(f10.4)') un_an
479         CALL histerr (2,'ioconf_calendar', &         CALL histerr (2, 'ioconf_calendar', &
480              &   'The calendar was already used or configured. You are not', &              &   'The calendar was already used or configured. You are not', &
481              &   'allowed to change it again. '// &              &   'allowed to change it again. '// &
482              &   'The following length of year is used :',str10)              &   'The following length of year is used:', str10)
483      ENDIF      ENDIF
     !-----------------------------  
   END SUBROUTINE ioconf_calendar  
   !-  
   !===  
   !-  
   SUBROUTINE ioget_calendar_str (str)  
     !---------------------------------------------------------------------  
     !- This subroutine returns the name of the calendar used here.  
     !- Three options exist :  
     !-  - gregorian : This is the gregorian calendar (default here)  
     !-  - noleap    : A calendar without leap years = 365 days  
     !-  - xxxd      : A calendar of xxx days (has to be a modulo of 12)  
     !-                with 12 month of equal length  
   
     !- This routine will lock the calendar.  
     !- You do not want it to change after your inquiry.  
     !---------------------------------------------------------------------  
     IMPLICIT NONE  
   
     CHARACTER(LEN=*),INTENT(OUT) :: str  
     !---------------------------------------------------------------------  
     lock_unan = .TRUE.  
484    
485      str = calendar_used    END SUBROUTINE ioconf_calendar
     !--------------------------------  
   END SUBROUTINE ioget_calendar_str  
   !-  
   !===  
   !-  
   SUBROUTINE ioget_calendar_real1 (long_an)  
     !---------------------------------------------------------------------  
     !- This subroutine returns the name of the calendar used here.  
     !- Three options exist :  
     !-  - gregorian : This is the gregorian calendar (default here)  
     !-  - noleap    : A calendar without leap years = 365 days  
     !-  - xxxd      : A calendar of xxx days (has to be a modulo of 12)  
     !-                with 12 month of equal length  
   
     !- This routine will lock the calendar.  
     !- You do not want it to change after your inquiry.  
     !---------------------------------------------------------------------  
     IMPLICIT NONE  
   
     REAL,INTENT(OUT) :: long_an  
     !---------------------------------------------------------------------  
     lock_unan = .TRUE.  
   
     long_an = un_an  
     !----------------------------------  
   END SUBROUTINE ioget_calendar_real1  
   !-  
   !===  
   !-  
   SUBROUTINE ioget_calendar_real2 (long_an,long_jour)  
     !---------------------------------------------------------------------  
     !- This subroutine returns the name of the calendar used here.  
     !- Three options exist :  
     !-  - gregorian : This is the gregorian calendar (default here)  
     !-  - noleap    : A calendar without leap years = 365 days  
     !-  - xxxd      : A calendar of xxx days (has to be a modulo of 12)  
     !-                with 12 month of equal length  
   
     !- This routine will lock the calendar.  
     !- You do not want it to change after your inquiry.  
     !---------------------------------------------------------------------  
     IMPLICIT NONE  
   
     REAL,INTENT(OUT) :: long_an,long_jour  
     !---------------------------------------------------------------------  
     lock_unan = .TRUE.  
   
     long_an = un_an  
     long_jour = un_jour  
     !----------------------------------  
   END SUBROUTINE ioget_calendar_real2  
486    
487  END MODULE calendar  END MODULE calendar
Legend:
Removed from v.61  
changed lines
  Added in v.62
  ViewVC Help
Powered by ViewVC 1.1.21