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

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

Parent Directory Parent Directory | Revision Log Revision Log

Revision 30 - (hide annotations)
Thu Apr 1 09:07:28 2010 UTC (14 years, 2 months ago) by guez
File size: 30961 byte(s) 
Imported Source files of the external library "IOIPSL_Lionel" into
"libf/IOIPSL".

Split "cray.f90" into "scopy.f90" and "ssum.f90".

Rewrote "leapfrog" in order to have a clearer algorithmic structure.
1 guez 30 MODULE calendar
2     !$Header: /home/ioipsl/CVSROOT/IOIPSL/src/calendar.f90,v 2.0 2004/04/05 14:47:47 adm Exp $
3     !-
4     !---------------------------------------------------------------------
5     !- This is the calendar which going to be used to do all
6     !- calculations on time. Three 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
9     !- - nolap : A 365 day year without leap years.
10     !- The origin for the julian days is in this case 1 Jan 0
11     !- - xxxd : Year of xxx days with month of equal length.
12     !- The origin for the julian days is then also 1 Jan 0
13     !- As one can see it is difficult to go from one calendar to the other.
14     !- All operations involving julian days will be wrong.
15     !- This calendar will lock as soon as possible
16     !- the length of the year and forbid any further modification.
17     !-
18     !- For the non leap-year calendar the method is still brute force.
19     !- We need to find an Integer series which takes care of the length
20     !- of the various month. (Jan)
21     !-
22     !- un_jour : one day in seconds
23     !- un_an : one year in days
24     !---------------------------------------------------------------------
25     USE stringop, ONLY : strlowercase
26     USE errioipsl, ONLY : histerr
27     !-
28     PRIVATE
29     PUBLIC :: ymds2ju,ju2ymds,tlen2itau,isittime,ioconf_calendar, &
30     & ioget_calendar,itau2date,ioget_timestamp, &
31     & ioconf_startdate,itau2ymds,time_diff,time_add
32     !-
33     INTERFACE ioget_calendar
34     MODULE PROCEDURE &
35     & ioget_calendar_real1,ioget_calendar_real2,ioget_calendar_str
36     END INTERFACE
37     !-
38     INTERFACE ioconf_startdate
39     MODULE PROCEDURE &
40     & ioconf_startdate_simple,ioconf_startdate_internal, &
41     & ioconf_startdate_ymds
42     END INTERFACE
43     !-
44     REAL,PARAMETER :: un_jour = 86400.0
45     LOGICAL,SAVE :: lock_startdate = .FALSE.
46     !-
47     CHARACTER(LEN=30),SAVE :: time_stamp='XXXXXXXXXXXXXXXX'
48     !-
49     !- Description of calendar
50     !-
51     CHARACTER(LEN=20),SAVE :: calendar_used="gregorian"
52     LOGICAL,SAVE :: lock_unan = .FALSE.
53     REAL,SAVE :: un_an = 365.2425
54     INTEGER,SAVE :: mon_len(12)=(/31,28,31,30,31,30,31,31,30,31,30,31/)
55     !-
56     !-
57     !-
58     CHARACTER(LEN=3),PARAMETER :: &
59     & cal(12) = (/'JAN','FEB','MAR','APR','MAY','JUN', &
60     & 'JUL','AUG','SEP','OCT','NOV','DEC'/)
61     !-
62     REAL,SAVE :: start_day,start_sec
63    
64     CONTAINS
65    
66     SUBROUTINE ymds2ju (year,month,day,sec,julian)
67    
68     IMPLICIT NONE
69    
70     INTEGER,INTENT(IN) :: year,month,day
71     REAL,INTENT(IN) :: sec
72    
73     REAL,INTENT(OUT) :: julian
74    
75     INTEGER :: julian_day
76     REAL :: julian_sec
77     !---------------------------------------------------------------------
78     CALL ymds2ju_internal (year,month,day,sec,julian_day,julian_sec)
79    
80     julian = julian_day+julian_sec / un_jour
81     !---------------------
82     END SUBROUTINE ymds2ju
83    
84     !===
85    
86     SUBROUTINE ymds2ju_internal (year,month,day,sec,julian_day,julian_sec)
87     !---------------------------------------------------------------------
88     !- Converts year, month, day and seconds into a julian day
89    
90     !- In 1968 in a letter to the editor of Communications of the ACM
91     !- (CACM, volume 11, number 10, October 1968, p.657) Henry F. Fliegel
92     !- and Thomas C. Van Flandern presented such an algorithm.
93    
94     !- See also : http://www.magnet.ch/serendipity/hermetic/cal_stud/jdn.htm
95    
96     !- In the case of the Gregorian calendar we have chosen to use
97     !- the Lilian day numbers. This is the day counter which starts
98     !- on the 15th October 1582.
99     !- This is the day at which Pope Gregory XIII introduced the
100     !- Gregorian calendar.
101     !- Compared to the true Julian calendar, which starts some
102     !- 7980 years ago, the Lilian days are smaler and are dealt with
103     !- easily on 32 bit machines. With the true Julian days you can only
104     !- the fraction of the day in the real part to a precision of
105     !- a 1/4 of a day with 32 bits.
106     !---------------------------------------------------------------------
107     IMPLICIT NONE
108    
109     INTEGER,INTENT(IN) :: year,month,day
110     REAL,INTENT(IN) :: sec
111    
112     INTEGER,INTENT(OUT) :: julian_day
113     REAL,INTENT(OUT) :: julian_sec
114    
115     INTEGER :: jd,m,y,d,ml
116     !---------------------------------------------------------------------
117     lock_unan = .TRUE.
118    
119     m = month
120     y = year
121     d = day
122    
123     !- We deduce the calendar from the length of the year as it
124     !- is faster than an INDEX on the calendar variable.
125    
126     !- Gregorian
127     IF ( (un_an > 365.0).AND.(un_an < 366.0) ) THEN
128     jd = (1461*(y+4800+INT(( m-14 )/12)))/4 &
129     & +(367*(m-2-12*(INT(( m-14 )/12))))/12 &
130     & -(3*((y+4900+INT((m-14)/12))/100))/4 &
131     & +d-32075
132     jd = jd-2299160
133     !- No leap or All leap
134     ELSE IF (ABS(un_an-365.0) <= EPSILON(un_an) .OR. &
135     & ABS(un_an-366.0) <= EPSILON(un_an)) THEN
136     ml = SUM(mon_len(1:m-1))
137     jd = y*INT(un_an)+ml+(d-1)
138     !- Calendar with regular month
139     ELSE
140     ml = INT(un_an)/12
141     jd = y*INT(un_an)+(m-1)*ml+(d-1)
142     ENDIF
143    
144     julian_day = jd
145     julian_sec = sec
146     !------------------------------
147     END SUBROUTINE ymds2ju_internal
148     !-
149     !===
150     !-
151     SUBROUTINE ju2ymds (julian,year,month,day,sec)
152     !---------------------------------------------------------------------
153     IMPLICIT NONE
154    
155     REAL,INTENT(IN) :: julian
156    
157     INTEGER,INTENT(OUT) :: year,month,day
158     REAL,INTENT(OUT) :: sec
159    
160     INTEGER :: julian_day
161     REAL :: julian_sec
162     !---------------------------------------------------------------------
163     julian_day = INT(julian)
164     julian_sec = (julian-julian_day)*un_jour
165    
166     CALL ju2ymds_internal(julian_day,julian_sec,year,month,day,sec)
167     !---------------------
168     END SUBROUTINE ju2ymds
169     !-
170     !===
171     !-
172     SUBROUTINE ju2ymds_internal (julian_day,julian_sec,year,month,day,sec)
173     !---------------------------------------------------------------------
174     !- This subroutine computes from the julian day the year,
175     !- month, day and seconds
176    
177     !- In 1968 in a letter to the editor of Communications of the ACM
178     !- (CACM, volume 11, number 10, October 1968, p.657) Henry F. Fliegel
179     !- and Thomas C. Van Flandern presented such an algorithm.
180    
181     !- See also : http://www.magnet.ch/serendipity/hermetic/cal_stud/jdn.htm
182    
183     !- In the case of the Gregorian calendar we have chosen to use
184     !- the Lilian day numbers. This is the day counter which starts
185     !- on the 15th October 1582. This is the day at which Pope
186     !- Gregory XIII introduced the Gregorian calendar.
187     !- Compared to the true Julian calendar, which starts some 7980
188     !- years ago, the Lilian days are smaler and are dealt with easily
189     !- on 32 bit machines. With the true Julian days you can only the
190     !- fraction of the day in the real part to a precision of a 1/4 of
191     !- a day with 32 bits.
192     !---------------------------------------------------------------------
193     IMPLICIT NONE
194    
195     INTEGER,INTENT(IN) :: julian_day
196     REAL,INTENT(IN) :: julian_sec
197    
198     INTEGER,INTENT(OUT) :: year,month,day
199     REAL,INTENT(OUT) :: sec
200    
201     INTEGER :: l,n,i,jd,j,d,m,y,ml
202     INTEGER :: add_day
203     !---------------------------------------------------------------------
204     lock_unan = .TRUE.
205    
206     jd = julian_day
207     sec = julian_sec
208     IF (sec > un_jour) THEN
209     add_day = INT(sec/un_jour)
210     sec = sec-add_day*un_jour
211     jd = jd+add_day
212     ENDIF
213    
214     !- Gregorian
215     IF ( (un_an > 365.0).AND.(un_an < 366.0) ) THEN
216     jd = jd+2299160
217    
218     l = jd+68569
219     n = (4*l)/146097
220     l = l-(146097*n+3)/4
221     i = (4000*(l+1))/1461001
222     l = l-(1461*i)/4+31
223     j = (80*l)/2447
224     d = l-(2447*j)/80
225     l = j/11
226     m = j+2-(12*l)
227     y = 100*(n-49)+i+l
228     !- No leap or All leap
229     ELSE IF (ABS(un_an-365.0) <= EPSILON(un_an) .OR. &
230     & ABS(un_an-366.0) <= EPSILON(un_an) ) THEN
231     y = jd/INT(un_an)
232     l = jd-y*INT(un_an)
233     m = 1
234     ml = 0
235     DO WHILE (ml+mon_len(m) <= l)
236     ml = ml+mon_len(m)
237     m = m+1
238     ENDDO
239     d = l-ml+1
240     !- others
241     ELSE
242     ml = INT(un_an)/12
243     y = jd/INT(un_an)
244     l = jd-y*INT(un_an)
245     m = (l/ml)+1
246     d = l-(m-1)*ml+1
247     ENDIF
248    
249     day = d
250     month = m
251     year = y
252     !------------------------------
253     END SUBROUTINE ju2ymds_internal
254     !-
255     !===
256     !-
257     SUBROUTINE tlen2itau (input_str,dt,date,itau)
258     !---------------------------------------------------------------------
259     !- This subroutine transforms a sting containing a time length
260     !- into a number of time steps.
261     !- To do this operation the date (in julian days is needed as the
262     !- length of the month varies.
263     !- The following convention is used :
264     !- n : n time steps
265     !- nS : n seconds is transformed into itaus
266     !- nH : n hours
267     !- nD : n days
268     !- nM : n month
269     !- nY : n years
270     !- Combinations are also possible
271     !- nYmD : nyears plus m days !
272     !---------------------------------------------------------------------
273     IMPLICIT NONE
274    
275     CHARACTER(LEN=*),INTENT(IN) :: input_str
276     REAL,INTENT(IN) :: dt,date
277    
278     INTEGER,INTENT(OUT) :: itau
279    
280     INTEGER :: y_pos,m_pos,d_pos,h_pos,s_pos
281     INTEGER :: read_time
282     CHARACTER(LEN=13) :: fmt
283     CHARACTER(LEN=80) :: tmp_str
284    
285     INTEGER :: year,month,day
286     REAL :: sec,date_new,dd,ss
287     !---------------------------------------------------------------------
288     itau = 0
289     CALL ju2ymds (date,year,month,day,sec)
290    
291     y_pos = MAX(INDEX(input_str,'y'),INDEX(input_str,'Y'))
292     m_pos = MAX(INDEX(input_str,'m'),INDEX(input_str,'M'))
293     d_pos = MAX(INDEX(input_str,'d'),INDEX(input_str,'D'))
294     h_pos = MAX(INDEX(input_str,'h'),INDEX(input_str,'H'))
295     s_pos = MAX(INDEX(input_str,'s'),INDEX(input_str,'S'))
296    
297     IF (MAX(y_pos,m_pos,d_pos,s_pos) > 0) THEN
298     tmp_str = input_str
299     DO WHILE ( MAX(y_pos,m_pos,d_pos,s_pos) > 0)
300     !---- WRITE(*,*) tmp_str
301     !---- WRITE(*,*) y_pos,m_pos,d_pos,s_pos
302     IF (y_pos > 0) THEN
303     WRITE(fmt,'("(I",I10.10,")")') y_pos-1
304     READ(tmp_str(1:y_pos-1),fmt) read_time
305     CALL ymds2ju (year+read_time,month,day,sec,date_new)
306     dd = date_new-date
307     ss = INT(dd)*un_jour+dd-INT(dd)
308     itau = itau+NINT(ss/dt)
309     tmp_str = tmp_str(y_pos+1:LEN_TRIM(tmp_str))
310     ELSE IF (m_pos > 0) THEN
311     WRITE(fmt,'("(I",I10.10,")")') m_pos-1
312     READ(tmp_str(1:m_pos-1),fmt) read_time
313     CALL ymds2ju (year,month+read_time,day,sec,date_new)
314     dd = date_new-date
315     ss = INT(dd)*un_jour+ dd-INT(dd)
316     itau = itau+NINT(ss/dt)
317     tmp_str = tmp_str(m_pos+1:LEN_TRIM(tmp_str))
318     ELSE IF (d_pos > 0) THEN
319     WRITE(fmt,'("(I",I10.10,")")') d_pos-1
320     READ(tmp_str(1:d_pos-1),fmt) read_time
321     itau = itau+NINT(read_time*un_jour/dt)
322     tmp_str = tmp_str(d_pos+1:LEN_TRIM(tmp_str))
323     ELSE IF (h_pos > 0) THEN
324     WRITE(fmt,'("(I",I10.10,")")') h_pos-1
325     READ(tmp_str(1:h_pos-1),fmt) read_time
326     itau = itau+NINT(read_time*60.*60./dt)
327     tmp_str = tmp_str(d_pos+1:LEN_TRIM(tmp_str))
328     ELSE IF (s_pos > 0) THEN
329     WRITE(fmt,'("(I",I10.10,")")') s_pos-1
330     READ(tmp_str(1:s_pos-1),fmt) read_time
331     itau = itau+NINT(read_time/dt)
332     tmp_str = tmp_str(s_pos+1:LEN_TRIM(tmp_str))
333     ENDIF
334    
335     y_pos = MAX(INDEX(tmp_str,'y'),INDEX(tmp_str,'Y'))
336     m_pos = MAX(INDEX(tmp_str,'m'),INDEX(tmp_str,'M'))
337     d_pos = MAX(INDEX(tmp_str,'d'),INDEX(tmp_str,'D'))
338     h_pos = MAX(INDEX(tmp_str,'h'),INDEX(tmp_str,'H'))
339     s_pos = MAX(INDEX(tmp_str,'s'),INDEX(tmp_str,'S'))
340     ENDDO
341     ELSE
342     WRITE(fmt,'("(I",I10.10,")")') LEN_TRIM(input_str)
343     READ(input_str(1:LEN_TRIM(input_str)),fmt) itau
344     ENDIF
345     !-----------------------
346     END SUBROUTINE tlen2itau
347     !-
348     !===
349     !-
350     REAL FUNCTION itau2date (itau,date0,deltat)
351     !---------------------------------------------------------------------
352     !- This function transforms itau into a date. The date whith which
353     !- the time axis is going to be labeled
354    
355     !- INPUT
356     !- itau : current time step
357     !- date0 : Date at which itau was equal to 0
358     !- deltat : time step between itau s
359    
360     !- OUTPUT
361     !- itau2date : Date for the given itau
362     !---------------------------------------------------------------------
363     IMPLICIT NONE
364    
365     INTEGER :: itau
366     REAL :: date0,deltat
367     !---------------------------------------------------------------------
368     itau2date = REAL(itau)*deltat/un_jour+date0
369     !---------------------
370     END FUNCTION itau2date
371     !-
372     !===
373     !-
374     SUBROUTINE itau2ymds (itau,deltat,year,month,date,sec)
375     !---------------------------------------------------------------------
376     !- This subroutine transforms itau into a date. The date whith which
377     !- the time axis is going to be labeled
378    
379     !- INPUT
380     !- itau : current time step
381     !- deltat : time step between itau s
382    
383     !- OUTPUT
384     !- year : year
385     !- month : month
386     !- date : date
387     !- sec : seconds since midnight
388     !---------------------------------------------------------------------
389     IMPLICIT NONE
390    
391     INTEGER,INTENT(IN) :: itau
392     REAL,INTENT(IN) :: deltat
393    
394     INTEGER,INTENT(OUT) :: year,month,date
395     REAL,INTENT(OUT) :: sec
396    
397     INTEGER :: julian_day
398     REAL :: julian_sec
399     !---------------------------------------------------------------------
400     julian_day = start_day
401     julian_sec = start_sec+REAL(itau)*deltat
402    
403     CALL ju2ymds_internal (julian_day,julian_sec,year,month,date,sec)
404     !-----------------------
405     END SUBROUTINE itau2ymds
406     !-
407     !===
408     !-
409     SUBROUTINE isittime &
410     & (itau,date0,dt,freq,last_action,last_check,do_action)
411     !---------------------------------------------------------------------
412     !- This subroutine checks the time has come for a given action.
413     !- This is computed from the current time-step(itau).
414     !- Thus we need to have the time delta (dt), the frequency
415     !- of the action (freq) and the last time it was done
416     !- (last_action in units of itau).
417     !- In order to extrapolate when will be the next check we need
418     !- the time step of the last call (last_check).
419    
420     !- The test is done on the following condition :
421     !- the distance from the current time to the time for the next
422     !- action is smaller than the one from the next expected
423     !- check to the next action.
424     !- When the test is done on the time steps simplifactions make
425     !- it more difficult to read in the code.
426     !- For the real time case it is easier to understand !
427     !---------------------------------------------------------------------
428     IMPLICIT NONE
429    
430     INTEGER,INTENT(IN) :: itau
431     REAL,INTENT(IN) :: dt,freq
432     INTEGER,INTENT(IN) :: last_action,last_check
433     REAL,INTENT(IN) :: date0
434    
435     LOGICAL,INTENT(OUT) :: do_action
436    
437     REAL :: dt_action,dt_check
438     REAL :: date_last_act,date_next_check,date_next_act, &
439     & date_now,date_mp1,date_mpf
440     INTEGER :: year,month,monthp1,day,next_check_itau,next_act_itau
441     INTEGER :: yearp,dayp
442     REAL :: sec,secp
443     LOGICAL :: check = .FALSE.
444     !---------------------------------------------------------------------
445     IF (check) THEN
446     WRITE(*,*) &
447     & "isittime 1.0 ",itau,date0,dt,freq,last_action,last_check
448     ENDIF
449    
450     IF (last_check >= 0) THEN
451     dt_action = (itau-last_action)*dt
452     dt_check = (itau-last_check)*dt
453     next_check_itau = itau+(itau-last_check)
454    
455     !-- We are dealing with frequencies in seconds and thus operation
456     !-- can be done on the time steps.
457    
458     IF (freq > 0) THEN
459     IF (ABS(dt_action-freq) <= ABS(dt_action+dt_check-freq)) THEN
460     do_action = .TRUE.
461     ELSE
462     do_action = .FALSE.
463     ENDIF
464    
465     !---- Here we deal with frequencies in month and work on julian days.
466    
467     ELSE
468     date_now = itau2date (itau,date0,dt)
469     date_last_act = itau2date (last_action,date0,dt)
470     CALL ju2ymds (date_last_act,year,month,day,sec)
471     monthp1 = month-freq
472     yearp = year
473    
474     !---- Here we compute what logically should be the next month
475    
476     IF (month >= 13) THEN
477     yearp = year+1
478     monthp1 = monthp1-12
479     ENDIF
480     CALL ymds2ju (year,monthp1,day,sec,date_mpf)
481    
482     !---- But it could be that because of a shorter month or a bad
483     !---- starting date that we end up further than we should be.
484     !---- Thus we compute the first day of the next month.
485     !---- We can not be beyond this date and if we are close
486     !---- then we will take it as it is better.
487    
488     monthp1 = month+ABS(freq)
489     yearp=year
490     IF (monthp1 >= 13) THEN
491     yearp = year+1
492     monthp1 = monthp1 -12
493     ENDIF
494     dayp = 1
495     secp = 0.0
496     CALL ymds2ju (yearp,monthp1,dayp,secp,date_mp1)
497    
498     !---- If date_mp1 is smaller than date_mpf or only less than 4 days
499     !---- larger then we take it. This needed to ensure that short month
500     !---- like February do not mess up the thing !
501    
502     IF (date_mp1-date_mpf < 4.) THEN
503     date_next_act = date_mp1
504     ELSE
505     date_next_act = date_mpf
506     ENDIF
507     date_next_check = itau2date (next_check_itau,date0,dt)
508    
509     !---- Transform the dates into time-steps for the needed precisions.
510    
511     next_act_itau = &
512     & last_action+INT((date_next_act-date_last_act)*(un_jour/dt))
513     !-----
514     IF ( ABS(itau-next_act_itau) &
515     & <= ABS( next_check_itau-next_act_itau)) THEN
516     do_action = .TRUE.
517     IF (check) THEN
518     WRITE(*,*) &
519     & 'ACT-TIME : itau, next_act_itau, next_check_itau : ', &
520     & itau,next_act_itau,next_check_itau
521     CALL ju2ymds (date_now,year,month,day,sec)
522     WRITE(*,*) 'ACT-TIME : y, m, d, s : ',year,month,day,sec
523     WRITE(*,*) &
524     & 'ACT-TIME : date_mp1, date_mpf : ',date_mp1,date_mpf
525     ENDIF
526     ELSE
527     do_action = .FALSE.
528     ENDIF
529     ENDIF
530    
531     IF (check) THEN
532     WRITE(*,*) "isittime 2.0 ", &
533     & date_next_check,date_next_act,ABS(dt_action-freq), &
534     & ABS(dt_action+dt_check-freq),dt_action,dt_check, &
535     & next_check_itau,do_action
536     ENDIF
537     ELSE
538     do_action=.FALSE.
539     ENDIF
540     !----------------------
541     END SUBROUTINE isittime
542     !-
543     !===
544     !-
545     SUBROUTINE ioconf_calendar (str)
546     !---------------------------------------------------------------------
547     !- This routine allows to configure the calendar to be used.
548     !- This operation is only allowed once and the first call to
549     !- ymds2ju or ju2ymsd will lock the current configuration.
550     !- the argument to ioconf_calendar can be any of the following :
551     !- - gregorian : This is the gregorian calendar (default here)
552     !- - noleap : A calendar without leap years = 365 days
553     !- - xxxd : A calendar of xxx days (has to be a modulo of 12)
554     !- with 12 month of equal length
555     !---------------------------------------------------------------------
556     IMPLICIT NONE
557    
558     CHARACTER(LEN=*),INTENT(IN) :: str
559    
560     INTEGER :: leng,ipos
561     CHARACTER(LEN=10) :: str10
562     !---------------------------------------------------------------------
563    
564     ! 1.0 Clean up the sring !
565    
566     CALL strlowercase (str)
567    
568     IF (.NOT.lock_unan) THEN
569     !---
570     lock_unan=.TRUE.
571     !---
572     SELECT CASE(str)
573     CASE('gregorian')
574     calendar_used = 'gregorian'
575     un_an = 365.2425
576     mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/)
577     CASE('standard')
578     calendar_used = 'gregorian'
579     un_an = 365.2425
580     mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/)
581     CASE('proleptic_gregorian')
582     calendar_used = 'gregorian'
583     un_an = 365.2425
584     mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/)
585     CASE('noleap')
586     calendar_used = 'noleap'
587     un_an = 365.0
588     mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/)
589     CASE('365_day')
590     calendar_used = 'noleap'
591     un_an = 365.0
592     mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/)
593     CASE('365d')
594     calendar_used = 'noleap'
595     un_an = 365.0
596     mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/)
597     CASE('all_leap')
598     calendar_used = 'all_leap'
599     un_an = 366.0
600     mon_len(:)=(/31,29,31,30,31,30,31,31,30,31,30,31/)
601     CASE('366_day')
602     calendar_used = 'all_leap'
603     un_an = 366.0
604     mon_len(:)=(/31,29,31,30,31,30,31,31,30,31,30,31/)
605     CASE('366d')
606     calendar_used = 'all_leap'
607     un_an = 366.0
608     mon_len(:)=(/31,29,31,30,31,30,31,31,30,31,30,31/)
609     CASE DEFAULT
610     ipos = INDEX(str,'d')
611     IF (ipos == 4) THEN
612     READ(str(1:3),'(I3)') leng
613     IF ( (MOD(leng,12) == 0).AND.(leng > 1) ) THEN
614     calendar_used = str
615     un_an = leng
616     mon_len(:) = leng
617     ELSE
618     CALL histerr (3,'ioconf_calendar', &
619     & 'The length of the year as to be a modulo of 12', &
620     & 'so that it can be divided into 12 month of equal length', &
621     & str)
622     ENDIF
623     ELSE
624     CALL histerr (3,'ioconf_calendar', &
625     & 'Unrecognized input, please ceck the man pages.',str,' ')
626     ENDIF
627     END SELECT
628     ELSE
629     WRITE(str10,'(f10.4)') un_an
630     CALL histerr (2,'ioconf_calendar', &
631     & 'The calendar was already used or configured. You are not', &
632     & 'allowed to change it again. '// &
633     & 'The following length of year is used :',str10)
634     ENDIF
635     !-----------------------------
636     END SUBROUTINE ioconf_calendar
637     !-
638     !===
639     !-
640     SUBROUTINE ioconf_startdate_simple (julian)
641     !---------------------------------------------------------------------
642     IMPLICIT NONE
643    
644     REAL,INTENT(IN) :: julian
645    
646     INTEGER :: julian_day
647     REAL :: julian_sec
648     !---------------------------------------------------------------------
649     julian_day = INT(julian)
650     julian_sec = (julian-julian_day)*un_jour
651    
652     CALL ioconf_startdate_internal (julian_day,julian_sec)
653     !-------------------------------------
654     END SUBROUTINE ioconf_startdate_simple
655     !-
656     !===
657     !-
658     SUBROUTINE ioconf_startdate_ymds (year,month,day,sec)
659     !---------------------------------------------------------------------
660     IMPLICIT NONE
661    
662     INTEGER,INTENT(IN) :: year,month,day
663     REAL,INTENT(IN) :: sec
664    
665     INTEGER :: julian_day
666     REAL :: julian_sec
667     !---------------------------------------------------------------------
668     CALL ymds2ju_internal (year,month,day,sec,julian_day,julian_sec)
669    
670     CALL ioconf_startdate_internal (julian_day,julian_sec)
671     !-----------------------------------
672     END SUBROUTINE ioconf_startdate_ymds
673     !-
674     !===
675     !-
676     SUBROUTINE ioconf_startdate_internal (julian_day,julian_sec)
677     !---------------------------------------------------------------------
678     ! This subroutine allows to set the startdate for later
679     ! use. It allows the applications to access the date directly from
680     ! the timestep. In order to avoid any problems the start date will
681     ! be locked and can not be changed once set.
682     !---------------------------------------------------------------------
683     IMPLICIT NONE
684    
685     INTEGER,INTENT(IN) :: julian_day
686     REAL,INTENT(IN) :: julian_sec
687    
688     CHARACTER(len=70) :: str70a,str70b
689     !---------------------------------------------------------------------
690     IF (.NOT.lock_startdate) THEN
691     lock_startdate = .TRUE.
692     start_day = julian_day
693     start_sec = julian_sec
694     ELSE
695     WRITE(str70a,'("The date you tried to set : ",f10.4)') &
696     & julian_day,julian_sec/un_jour
697     WRITE(str70b, &
698     & '("The date which was already set in the calendar : ",f10.4)') &
699     & start_day+start_sec/un_jour
700     CALL histerr (2,'ioconf_startdate', &
701     & 'The start date has already been set and you tried to change it', &
702     & str70a,str70b)
703     ENDIF
704    
705     lock_startdate = .TRUE.
706     !---------------------------------------
707     END SUBROUTINE ioconf_startdate_internal
708     !-
709     !===
710     !-
711     SUBROUTINE ioget_calendar_str (str)
712     !---------------------------------------------------------------------
713     !- This subroutine returns the name of the calendar used here.
714     !- Three options exist :
715     !- - gregorian : This is the gregorian calendar (default here)
716     !- - noleap : A calendar without leap years = 365 days
717     !- - xxxd : A calendar of xxx days (has to be a modulo of 12)
718     !- with 12 month of equal length
719    
720     !- This routine will lock the calendar.
721     !- You do not want it to change after your inquiry.
722     !---------------------------------------------------------------------
723     IMPLICIT NONE
724    
725     CHARACTER(LEN=*),INTENT(OUT) :: str
726     !---------------------------------------------------------------------
727     lock_unan = .TRUE.
728    
729     str = calendar_used
730     !--------------------------------
731     END SUBROUTINE ioget_calendar_str
732     !-
733     !===
734     !-
735     SUBROUTINE ioget_calendar_real1 (long_an)
736     !---------------------------------------------------------------------
737     !- This subroutine returns the name of the calendar used here.
738     !- Three options exist :
739     !- - gregorian : This is the gregorian calendar (default here)
740     !- - noleap : A calendar without leap years = 365 days
741     !- - xxxd : A calendar of xxx days (has to be a modulo of 12)
742     !- with 12 month of equal length
743    
744     !- This routine will lock the calendar.
745     !- You do not want it to change after your inquiry.
746     !---------------------------------------------------------------------
747     IMPLICIT NONE
748    
749     REAL,INTENT(OUT) :: long_an
750     !---------------------------------------------------------------------
751     lock_unan = .TRUE.
752    
753     long_an = un_an
754     !----------------------------------
755     END SUBROUTINE ioget_calendar_real1
756     !-
757     !===
758     !-
759     SUBROUTINE ioget_calendar_real2 (long_an,long_jour)
760     !---------------------------------------------------------------------
761     !- This subroutine returns the name of the calendar used here.
762     !- Three options exist :
763     !- - gregorian : This is the gregorian calendar (default here)
764     !- - noleap : A calendar without leap years = 365 days
765     !- - xxxd : A calendar of xxx days (has to be a modulo of 12)
766     !- with 12 month of equal length
767    
768     !- This routine will lock the calendar.
769     !- You do not want it to change after your inquiry.
770     !---------------------------------------------------------------------
771     IMPLICIT NONE
772    
773     REAL,INTENT(OUT) :: long_an,long_jour
774     !---------------------------------------------------------------------
775     lock_unan = .TRUE.
776    
777     long_an = un_an
778     long_jour = un_jour
779     !----------------------------------
780     END SUBROUTINE ioget_calendar_real2
781     !-
782     !===
783     !-
784     SUBROUTINE ioget_timestamp (string)
785     !---------------------------------------------------------------------
786     IMPLICIT NONE
787    
788     CHARACTER(LEN=30),INTENT(OUT) :: string
789    
790     INTEGER :: date_time(8)
791     CHARACTER(LEN=10) :: bigben(3)
792     !---------------------------------------------------------------------
793     IF (INDEX(time_stamp,'XXXXXX') > 0) THEN
794     CALL DATE_AND_TIME (bigben(1),bigben(2),bigben(3),date_time)
795     !---
796     WRITE(time_stamp, &
797     & "(I4.4,'-',A3,'-',I2.2,' ',I2.2,':',I2.2,':',I2.2,' GMT',a5)") &
798     & date_time(1),cal(date_time(2)),date_time(3),date_time(5), &
799     & date_time(6),date_time(7),bigben(3)
800     ENDIF
801    
802     string = time_stamp
803     !-----------------------------
804     END SUBROUTINE ioget_timestamp
805     !-
806     !===
807     !-
808     SUBROUTINE time_add &
809     & (year_s,month_s,day_s,sec_s,sec_increment, &
810     & year_e,month_e,day_e,sec_e)
811     !---------------------------------------------------------------------
812     !- This subroutine allows to increment a date by a number of seconds.
813     !---------------------------------------------------------------------
814     IMPLICIT NONE
815    
816     INTEGER,INTENT(IN) :: year_s,month_s,day_s
817     REAL,INTENT(IN) :: sec_s
818     !!
819     ! Time in seconds to be added to the date
820     !!
821     REAL,INTENT(IN) :: sec_increment
822    
823     INTEGER,INTENT(OUT) :: year_e,month_e,day_e
824     REAL,INTENT(OUT) :: sec_e
825    
826     INTEGER :: julian_day
827     REAL :: julian_sec
828     !---------------------------------------------------------------------
829     CALL ymds2ju_internal &
830     & (year_s,month_s,day_s,sec_s,julian_day,julian_sec)
831    
832     julian_sec = julian_sec+sec_increment
833    
834     CALL ju2ymds_internal &
835     & (julian_day,julian_sec,year_e,month_e,day_e,sec_e)
836     !----------------------
837     END SUBROUTINE time_add
838     !-
839     !===
840     !-
841     SUBROUTINE time_diff &
842     & (year_s,month_s,day_s,sec_s,year_e,month_e,day_e,sec_e,sec_diff)
843     !---------------------------------------------------------------------
844     !- This subroutine allows to determine the number of seconds
845     !- between two dates.
846     !---------------------------------------------------------------------
847     IMPLICIT NONE
848    
849     INTEGER,INTENT(IN) :: year_s,month_s,day_s
850     REAL,INTENT(IN) :: sec_s
851     INTEGER,INTENT(IN) :: year_e,month_e,day_e
852     REAL,INTENT(IN) :: sec_e
853     !!
854     ! Time in seconds between the two dates
855     !!
856     REAL,INTENT(OUT) :: sec_diff
857    
858     INTEGER :: julian_day_s,julian_day_e,day_diff
859     REAL :: julian_sec_s,julian_sec_e
860     !---------------------------------------------------------------------
861     CALL ymds2ju_internal &
862     & (year_s,month_s,day_s,sec_s,julian_day_s,julian_sec_s)
863     CALL ymds2ju_internal &
864     & (year_e,month_e,day_e,sec_e,julian_day_e,julian_sec_e)
865    
866     day_diff = julian_day_e-julian_day_s
867     sec_diff = julian_sec_e-julian_sec_s
868    
869     sec_diff = sec_diff+day_diff*un_jour
870     !-----------------------
871     END SUBROUTINE time_diff
872     !-
873     !===
874     !-
875     END MODULE calendar
  ViewVC Help
Powered by ViewVC 1.1.21