New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
date.f90 in utils/tools/SIREN/src – NEMO

source: utils/tools/SIREN/src/date.f90 @ 12080

Last change on this file since 12080 was 12080, checked in by jpaul, 4 years ago

update nemo trunk
File size: 38.2 KB
Line 
1!----------------------------------------------------------------------
2! NEMO system team, System and Interface for oceanic RElocable Nesting
3!----------------------------------------------------------------------
4!
5! DESCRIPTION:
6!> @brief This module provide the calculation of Julian dates, and
7!> do many manipulations with dates.
8!>
9!> @details
10!> Actually we use Modified Julian Dates, with 
11!> 17 Nov 1858 at 00:00:00 as origin.<br/>
12!>
13!>   define type TDATE:<br/>
14!> @code
15!>   TYPE(TDATE) :: tl_date1
16!> @endcode
17!>   default date is 17 Nov 1858 at 00:00:00<br/>
18!>
19!>   to intialise date : <br/>
20!>   - from date of the day at 12:00:00 :
21!> @code
22!> tl_date1=date_today()
23!> @endcode
24!>   - from date and time of the day    :
25!> @code
26!> tl_date1=date_now()
27!> @endcode
28!>   - from julian day                  :
29!> @code
30!> tl_date1=date_init(dd_jd)
31!> @endcode
32!>      - dd_jd julian day (double precision)
33!>   - from number of second since julian day origin   :
34!> @code
35!> tl_date1=date_init(kd_nsec)
36!> @endcode
37!>      - kd_nsec number of second (integer 8)
38!>   - from year month day              :
39!> @code
40!> tl_date1=date_init(2012,12,10)
41!> @endcode
42!>   - from string character formatted date  :
43!> @code
44!> tl_date1=date_init(cd_fmtdate)
45!> @endcode
46!>      - cd_fmtdate date in format YYYY-MM-DD hh:mm:ss
47!>
48!>   to print date in format YYYY-MM-DD hh:mm:ss<br/>
49!>   CHARACTER(LEN=lc) :: cl_date<br/>
50!> @code
51!>   cl_date=date_print(tl_date1)
52!>   PRINT *, TRIM(cl_date)
53!> @endcode
54!>   
55!>   to print date in another format (only year, month, day):
56!> @code
57!>   cl_date=date_print(tl_date1, cd_fmt)
58!>   PRINT *, TRIM(cl_date)
59!> @endcode
60!>       - cd_fmt ouput format (ex: cd_fmt="('y',i0.4,'m',i0.2,'d',i0.2)" )
61!>
62!>   to print day of the week:<br/>
63!> @code
64!>   PRINT *,"dow ", tl_date1\%i_dow
65!> @endcode
66!>   to print last day of the month:<br/>
67!> @code
68!>   PRINT *,"last day ", tl_date1\%i_lday
69!> @endcode
70!>
71!>   to know if year is a leap year:<br/>
72!> @code
73!>   ll_isleap=date_leapyear(tl_date1)
74!> @endcode
75!>    - ll_isleap is logical
76!>
77!>   to compute number of days between two dates:<br/>
78!> @code
79!>   tl_date2=date_init(2010,12,10)
80!>   dl_diff=tl_date1-tl_date2
81!> @endcode
82!>    - dl_diff is the number of days between date1 and date2 (double precision)
83!>
84!>   to add or substract nday to a date:<br/>
85!> @code
86!>   tl_date2=tl_date1+2.
87!>   tl_date2=tl_date1-2.6
88!> @endcode
89!>    - number of day (double precision)
90!>
91!>   to print julian day:<br/>
92!> @code
93!>   PRINT *," julian day",tl_date1\%r_jd
94!> @endcode
95!>
96!>   to print CNES julian day (origin 1950-01-01 00:00:00)<br/>
97!> @code
98!>   PRINT *," CNES julian day",tl_date1\%r_jc
99!> @endcode
100!>
101!>   to create pseudo julian day with origin date_now:<br/>
102!> @code
103!>   tl_date1=date_init(2012,12,10,td_dateo=date_now())
104!> @endcode
105!>   @note you erase CNES julian day when doing so<br/>
106!>
107!>   to print julian day in seconds:<br/>
108!> @code
109!>   PRINT *, tl_date1\%k_jdsec
110!> @endcode
111!>   to print CNES or new julian day in seconds:<br/>
112!> @code
113!>   PRINT *, tl_date1\%k_jcsec
114!> @endcode
115!>
116!> @author J.Paul
117!>
118!> @date November, 2013 - Initial Version
119!
120!> @note This module is based on Perderabo's date calculator (ksh)
121!> @note Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
122!>
123!> @todo
124!> - see calendar.f90 and select Gregorian, NoLeap, or D360 calendar
125!----------------------------------------------------------------------
126MODULE date
127
128   USE global                          ! global variable
129   USE kind                            ! F90 kind parameter
130   USE fct                             ! basic useful function
131   USE logger                          ! log file manager
132
133   IMPLICIT NONE
134   ! NOTE_avoid_public_variables_if_possible
135
136   ! type and variable
137   PUBLIC :: TDATE              !< date structure
138
139   PRIVATE :: cm_fmtdate        !< date and time format
140   PRIVATE :: im_secbyday       !< number of second by day
141
142   ! function and subroutine
143   PUBLIC :: date_today         !< return the date of the day at 12:00:00
144   PUBLIC :: date_now           !< return the date and time
145   PUBLIC :: date_time          !< return the date and time in milliseconds
146   PUBLIC :: date_init          !< initialized date structure form julian day or year month day
147   PUBLIC :: date_print         !< print the date with format YYYY-MM-DD hh:mm:ss
148   PUBLIC :: date_leapyear      !< check if year is a leap year
149   PUBLIC :: OPERATOR(-)        !< substract two dates or n days to a date
150   PUBLIC :: OPERATOR(+)        !< add n days to a date
151
152   PRIVATE :: date__init_fmtdate ! initialized date structure from character YYYY-MM-DD hh:mm:ss
153   PRIVATE :: date__init_jd      ! initialized date structure from julian day
154   PRIVATE :: date__init_nsec    ! initialized date structure from number of second since origin of julian day
155   PRIVATE :: date__init_ymd     ! initialized date structure from year month day
156   PRIVATE :: date__addnday      ! add nday to a date
157   PRIVATE :: date__subnday      ! substract nday to a date
158   PRIVATE :: date__diffdate     ! compute number of days between two dates
159   PRIVATE :: date__lastday      ! compute last day of the month
160   PRIVATE :: date__ymd2jd       ! compute julian day from year month day
161   PRIVATE :: date__jd2ymd       ! compute year month day from julian day
162   PRIVATE :: date__jc2jd        ! compute julian day from pseudo julian day
163   PRIVATE :: date__jd2jc        ! compute pseudo julian day with new date origin
164   PRIVATE :: date__jd2dow       ! compute the day of week from julian day
165   PRIVATE :: date__hms2jd       ! compute fraction of a day from hour, minute, second
166   PRIVATE :: date__jd2hms       ! compute hour, minute, second from julian fraction
167   PRIVATE :: date__check        ! check date in date structure
168   PRIVATE :: date__adjust       ! adjust date
169   PRIVATE :: date__jd2sec       ! convert julian day in seconds since julian day origin
170   PRIVATE :: date__sec2jd       ! convert seconds since julian day origin in julian day
171
172   TYPE TDATE !< date structure
173      INTEGER(i4) :: i_year  = 1858   !< year
174      INTEGER(i4) :: i_month = 11     !< month
175      INTEGER(i4) :: i_day   = 17     !< day
176      INTEGER(i4) :: i_hour  = 0      !< hour
177      INTEGER(i4) :: i_min   = 0      !< min
178      INTEGER(i4) :: i_sec   = 0      !< sec
179      INTEGER(i4) :: i_dow   = 0      !< day of week
180      INTEGER(i4) :: i_lday  = 0      !< last day of the month
181      REAL(dp)    :: d_jd = 0         !< julian day (origin : 1858/11/17 00:00:00)
182      REAL(dp)    :: d_jc = 0         !< CNES julian day or pseudo julian day with new date origin   
183      INTEGER(i8) :: k_jdsec  = 0     !< number of seconds since julian day origin
184      INTEGER(i8) :: k_jcsec  = 0     !< number of seconds since CNES or pseudo julian day origin
185   END TYPE TDATE   
186
187   !  module variable   
188   CHARACTER(LEN=lc), PARAMETER :: cm_fmtdate = &  !< date and time format
189   &  "(i0.4,'-',i0.2,'-',i0.2,1x,i0.2,':',i0.2,':',i0.2)"
190
191   INTEGER(i4), PARAMETER :: im_secbyday = 86400    !< number of second by day   
192
193   INTERFACE date_init
194      MODULE PROCEDURE date__init_jd    ! initialized date structure from julian day
195      MODULE PROCEDURE date__init_nsec  ! initialized date structure from number of second since origin of julian day
196      MODULE PROCEDURE date__init_ymd   ! initialized date structure from year month day
197      MODULE PROCEDURE date__init_fmtdate   ! initialized date structure from character YYYY-MM-DD hh:mm:ss
198   END INTERFACE date_init
199
200   INTERFACE OPERATOR(+)
201      MODULE PROCEDURE date__addnday   ! add nday to a date
202   END INTERFACE
203
204   INTERFACE OPERATOR(-)
205      MODULE PROCEDURE date__subnday   ! substract nday to a date
206      MODULE PROCEDURE date__diffdate  ! compute number of day between two dates
207   END INTERFACE
208
209CONTAINS
210   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
211   FUNCTION date_print(td_date, cd_fmt) &
212         & RESULT (cf_date)
213   !-------------------------------------------------------------------
214   !> @brief This function print the date and time with
215   !> format YYYY/MM/DD hh:mm:ss.
216   !> @details
217   !> Optionally, you could specify output format. However it will be
218   !> only apply to year, month, day.
219   !>
220   !> @author J.Paul
221   !> @date November, 2013 - Initial Version
222   !>
223   !> @param[in] td_date   date strutcutre
224   !> @param[in] cd_fmt    ouput format (only for year,month,day)
225   !> @return date in format YYYY-MM-DD hh:mm:ss
226   !-------------------------------------------------------------------
227
228      IMPLICIT NONE
229
230      ! Argument   
231      TYPE(TDATE)     , INTENT(IN) :: td_date
232      CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_fmt
233
234      ! function
235      CHARACTER(LEN=lc)            :: cf_date 
236      !----------------------------------------------------------------
237
238      IF( PRESENT(cd_fmt) )THEN
239         WRITE(cf_date,TRIM(cd_fmt)) &
240            &    td_date%i_year,td_date%i_month,td_date%i_day
241      ELSE
242         WRITE(cf_date,cm_fmtdate) &
243            &    td_date%i_year,td_date%i_month,td_date%i_day, &
244            &    td_date%i_hour,td_date%i_min,td_date%i_sec
245      ENDIF
246
247   END FUNCTION date_print
248   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
249   FUNCTION date_leapyear(td_date) &
250         & RESULT (lf_leap)
251   !-------------------------------------------------------------------
252   !> @brief This function check if year is a leap year.
253   !>
254   !> @author J.Paul
255   !> @date November, 2013 - Initial Version
256   !>
257   !> @param[in] td_date   date strutcutre
258   !> @return true if year is leap year
259   !-------------------------------------------------------------------
260
261      IMPLICIT NONE
262
263      ! Argument   
264      TYPE(TDATE), INTENT(IN) :: td_date
265
266      ! function
267      LOGICAL                 :: lf_leap
268      !----------------------------------------------------------------
269
270      lf_leap=.false.
271      IF( (MOD(td_date%i_year,100_i4)==0) )THEN
272         IF( (MOD(td_date%i_year,400_i4)==0) )THEN
273            lf_leap=.true.
274         ENDIF
275      ELSE
276         IF( (MOD(td_date%i_year,4_i4)==0) )THEN
277            lf_leap=.true.
278         ENDIF
279      ENDIF
280
281   END FUNCTION date_leapyear
282   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
283   FUNCTION date_now() &
284         & RESULT (tf_date)
285   !-------------------------------------------------------------------
286   !> @brief This function return the current date and time.
287   !>
288   !> @author J.Paul
289   !> @date November, 2013 - Initial Version
290   !>
291   !> @return current date and time in a date structure
292   !-------------------------------------------------------------------
293
294      IMPLICIT NONE
295
296      ! function
297      TYPE(TDATE) :: tf_date
298
299      ! local variable
300      INTEGER(sp), DIMENSION(8) :: il_values
301      !----------------------------------------------------------------
302
303      CALL DATE_AND_TIME( values= il_values)
304
305      tf_date=date_init( il_values(1), il_values(2), il_values(3), &
306         &               il_values(5), il_values(6), il_values(7) )
307
308   END FUNCTION date_now
309   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
310   SUBROUTINE date_time()
311   !-------------------------------------------------------------------
312   !> @brief This subroutine print the current date and time in milliseconds.
313   !>
314   !> @author J.Paul
315   !> @date August, 2017 - Initial Version
316   !-------------------------------------------------------------------
317
318      IMPLICIT NONE
319
320      ! local variable
321      INTEGER(sp), DIMENSION(8) :: il_values
322      CHARACTER(LEN=lc)         :: cl_fmtdate = &  !< date and time format
323      &  "(i0.4,'-',i0.2,'-',i0.2,1x,i0.2,':',i0.2,':',i0.2'.',i0.3)"     
324      !----------------------------------------------------------------
325
326      CALL DATE_AND_TIME( values= il_values)
327
328      WRITE(*,cl_fmtdate) il_values(1),il_values(2),il_values(3),il_values(5),il_values(6),il_values(7),il_values(8)
329
330   END SUBROUTINE date_time
331   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
332   FUNCTION date_today() &
333         & RESULT (tf_date)
334   !-------------------------------------------------------------------
335   !> @brief This function return the date of the day at 12:00:00.
336   !>
337   !> @author J.Paul
338   !> @date November, 2013 - Initial Version
339   !>
340   !> @return date of the day at 12:00:00 in a date structure
341   !-------------------------------------------------------------------
342
343      IMPLICIT NONE
344     
345      ! function
346      TYPE(TDATE) :: tf_date
347
348      ! local variable
349      INTEGER(sp), DIMENSION(8) :: il_values
350      !----------------------------------------------------------------
351
352      CALL DATE_AND_TIME( values= il_values)
353
354      tf_date=date_init( il_values(1), il_values(2), il_values(3), 12_i4 )
355
356   END FUNCTION date_today
357   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
358   FUNCTION date__init_fmtdate(cd_datetime, td_dateo) &
359         & RESULT (tf_date)
360   !-------------------------------------------------------------------
361   !> @brief This function initialized date structure from a character
362   !> date with format YYYY-MM-DD hh:mm:ss.<br/>
363   !> @details
364   !> Optionaly create pseudo julian day with new origin.<br/>
365   !> julian day origin is 17 Nov 1858 at 00:00:00
366   !>
367   !> @author J.Paul
368   !> @date November, 2013 - Initial Version
369   !> @date April, 2019
370   !> - check time units CF convention, raise error if not
371   !>
372   !> @param[in] cd_date   date in format YYYY-MM-DD hh:mm:ss
373   !> @param[in] td_dateo  new date origin for pseudo julian day
374   !> @return date structure
375   !-------------------------------------------------------------------
376
377      IMPLICIT NONE
378
379      ! Argument   
380      CHARACTER(LEN=*), INTENT(IN)  :: cd_datetime
381      TYPE(TDATE),      INTENT(IN), OPTIONAL :: td_dateo
382
383      ! function
384      TYPE(TDATE)                   :: tf_date
385
386      ! local variable
387      CHARACTER(LEN=lc) :: cl_datetime
388      CHARACTER(LEN=lc) :: cl_date
389      CHARACTER(LEN=lc) :: cl_time
390      CHARACTER(LEN=lc) :: cl_year
391      CHARACTER(LEN=lc) :: cl_month
392      CHARACTER(LEN=lc) :: cl_day
393      CHARACTER(LEN=lc) :: cl_hour
394      CHARACTER(LEN=lc) :: cl_min
395      CHARACTER(LEN=lc) :: cl_sec
396      CHARACTER(LEN=lc) :: cl_msg
397
398      INTEGER(i4)       :: il_year
399      INTEGER(i4)       :: il_month
400      INTEGER(i4)       :: il_day
401      INTEGER(i4)       :: il_hour
402      INTEGER(i4)       :: il_min
403      INTEGER(i4)       :: il_sec
404      !----------------------------------------------------------------
405
406      cl_datetime=TRIM(ADJUSTL(cd_datetime))
407
408      cl_date=fct_split(cl_datetime,1,' ')
409      cl_time=fct_split(cl_datetime,2,' ')
410
411      cl_year = fct_split(cl_date,1,'-')
412      READ(cl_year,*) il_year
413      cl_month= fct_split(cl_date,2,'-')
414      READ(cl_month, *) il_month
415      cl_day  = fct_split(cl_date,3,'-')
416      READ(cl_day, *) il_day
417      cl_hour = fct_split(cl_time,1,':')
418      IF( TRIM(cl_hour) /= '' )THEN
419         READ(cl_hour, *) il_hour
420      ELSE
421         WRITE(cl_msg,*) "time units not conform to CF conventions"
422         CALL logger_error(cl_msg)
423         il_hour=0
424      ENDIf
425      cl_min  = fct_split(cl_time,2,':')
426      IF( TRIM(cl_min) /= '' )THEN
427         READ(cl_min, *) il_min
428      ELSE
429         WRITE(cl_msg,*) "time units not conform to CF conventions"
430         CALL logger_error(cl_msg)
431         il_min=0
432      ENDIf
433      cl_sec  = fct_split(cl_time,3,':')
434      IF( TRIM(cl_sec) /= '' )THEN
435         READ(cl_sec, *) il_sec
436      ELSE
437         WRITE(cl_msg,*) "time units not conform to CF conventions"
438         CALL logger_error(cl_msg)
439         il_sec=0
440      ENDIf
441
442      tf_date = date_init( il_year, il_month, il_day, il_hour, &
443         &                 il_min, il_sec, td_dateo=td_dateo )
444
445   END FUNCTION date__init_fmtdate
446   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
447   FUNCTION date__init_jd(dd_jd, td_dateo) &
448         & RESULT (tf_date)
449   !-------------------------------------------------------------------
450   !> @brief This function initialized date structure from julian day.<br/>
451   !> @details
452   !> Optionaly create pseudo julian day with new origin.<br/>
453   !> julian day origin is 17 Nov 1858 at 00:00:00
454   !>
455   !> @author J.Paul
456   !> @date November, 2013 - Initial Version
457   !>
458   !> @param[in] dd_jd     julian day
459   !> @param[in] td_dateo  new date origin for pseudo julian day
460   !>
461   !> @return date structure of julian day
462   !-------------------------------------------------------------------
463
464      IMPLICIT NONE
465
466      !Argument
467      REAL(dp),    INTENT(IN)  :: dd_jd
468      TYPE(TDATE), INTENT(IN), OPTIONAL :: td_dateo
469
470      ! function
471      TYPE(TDATE)              :: tf_date
472      !----------------------------------------------------------------
473      IF( PRESENT(td_dateo) )THEN
474         CALL date__check(td_dateo)
475
476         ! pseudo julian day with origin dateo
477         tf_date%d_jc=dd_jd
478         tf_date%k_jcsec=date__jd2sec(dd_jd)
479
480         ! convert to truly julian day
481         CALL date__jc2jd(tf_date, td_dateo)
482      ELSE
483         tf_date%d_jd=dd_jd
484         tf_date%k_jdsec=date__jd2sec(dd_jd)
485
486         ! compute CNES julian day
487         CALL date__jd2jc(tf_date)
488      ENDIF
489
490      ! check input data
491      CALL date__check(tf_date)
492
493      ! compute year month day hour min sec
494      CALL date__jd2ymd(tf_date)
495
496      ! compute day of the wekk
497      CALL date__jd2dow(tf_date)
498
499      !compute last day of the month
500      tf_date%i_lday=date__lastday(tf_date)
501
502   END FUNCTION date__init_jd
503   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
504   FUNCTION date__init_nsec(kd_nsec, td_dateo) &
505         & RESULT (tf_date)
506   !-------------------------------------------------------------------
507   !> @brief This function initialized date structure from number of
508   !> second since julian day origin.<br/>
509   !> @details
510   !> Optionaly create pseudo julian day with new origin.
511   !>
512   !> @author J.Paul
513   !> @date November, 2013 - Initial Version
514   !>
515   !> @param[in] kd_nsec   number of second since julian day origin
516   !> @param[in] td_dateo  new date origin for pseudo julian day
517   !>
518   !> @return date structure of julian day
519   !-------------------------------------------------------------------
520
521      IMPLICIT NONE
522
523      !Argument
524      INTEGER(i8), INTENT(IN)  :: kd_nsec
525      TYPE(TDATE), INTENT(IN), OPTIONAL :: td_dateo
526
527      ! function
528      TYPE(TDATE)              :: tf_date
529      !----------------------------------------------------------------
530      IF( PRESENT(td_dateo) )THEN
531         tf_date=date_init( date__sec2jd(kd_nsec), td_dateo )
532      ELSE
533         tf_date=date_init( date__sec2jd(kd_nsec) )
534      ENDIF
535
536   END FUNCTION date__init_nsec
537   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
538   FUNCTION date__init_ymd(id_year, id_month, id_day, &
539         &                 id_hour, id_min, id_sec,   &
540         &                 td_dateo) &
541         & RESULT (tf_date)
542   !-------------------------------------------------------------------
543   !> @brief This function initialized date structure form year month day
544   !> and optionnaly hour min sec.<br/>
545   !> @details
546   !> Optionaly create pseudo julian day with new origin.
547   !>
548   !> @author J.Paul
549   !> @date November, 2013 - Initial Version
550   !>
551   !> @param[in] id_year
552   !> @param[in] id_month
553   !> @param[in] id_day
554   !> @param[in] id_hour
555   !> @param[in] id_min
556   !> @param[in] id_sec
557   !> @param[in] td_dateo  new date origin for pseudo julian day
558   !>
559   !> @return date structure of year month day
560   !-------------------------------------------------------------------
561
562      IMPLICIT NONE
563
564      !Argument
565      INTEGER(i4), INTENT(IN) :: id_year
566      INTEGER(i4), INTENT(IN) :: id_month
567      INTEGER(i4), INTENT(IN) :: id_day
568      INTEGER(i4), INTENT(IN), OPTIONAL :: id_hour
569      INTEGER(i4), INTENT(IN), OPTIONAL :: id_min
570      INTEGER(i4), INTENT(IN), OPTIONAL :: id_sec
571      TYPE(TDATE), INTENT(IN), OPTIONAL :: td_dateo
572
573      ! function
574      TYPE(TDATE)              :: tf_date
575      !----------------------------------------------------------------
576      tf_date%i_year=id_year
577      tf_date%i_month=id_month
578      tf_date%i_day=id_day
579      IF( PRESENT(id_hour) )THEN
580         tf_date%i_hour=id_hour
581      ENDIF
582      IF( PRESENT(id_min) )THEN
583         tf_date%i_min=id_min
584      ENDIF   
585      IF( PRESENT(id_sec) )THEN   
586         tf_date%i_sec=id_sec
587      ENDIF   
588      ! check input data
589      CALL date__check(tf_date)
590
591      ! compute julian day
592      CALL date__ymd2jd(tf_date)
593
594      IF( PRESENT(td_dateo) )THEN
595         CALL date__check(td_dateo)
596         ! compute julian day with origin dateo
597         CALL date__jd2jc(tf_date, td_dateo)         
598      ELSE
599         ! compute CNES julian day
600         CALL date__jd2jc(tf_date)
601      ENDIF     
602
603      ! compute day of the week
604      CALL date__jd2dow(tf_date)
605
606      !compute last day of the month
607      tf_date%i_lday=date__lastday(tf_date)
608
609   END FUNCTION date__init_ymd
610   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
611   FUNCTION date__diffdate(td_date1, td_date2) &
612         & RESULT (df_diff)
613   !-------------------------------------------------------------------
614   !> @brief This function compute number of day between two dates:
615   !> nday= date1 - date2
616   !>
617   !> @author J.Paul
618   !> @date November, 2013 - Initial Version
619   !>
620   !> @param[in] td_date1  first date strutcutre
621   !> @param[in] td_date2  second date strutcutre
622   !> @return nday
623   !-------------------------------------------------------------------
624
625      IMPLICIT NONE
626       
627      !Argument
628      TYPE(TDATE), INTENT(IN) :: td_date1
629      TYPE(TDATE), INTENT(IN) :: td_date2
630
631      ! function
632      REAL(dp)                :: df_diff
633      !----------------------------------------------------------------
634
635      ! check year month day hour min sec
636      CALL date__check(td_date1)   
637      CALL date__check(td_date2)   
638
639      df_diff = td_date1%d_jd - td_date2%d_jd
640
641   END FUNCTION date__diffdate
642   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
643   FUNCTION date__subnday(td_date, dd_nday) &
644         & RESULT (tf_date)
645   !-------------------------------------------------------------------
646   !> @brief This function substract nday to a date:
647   !> date2 = date1 - nday
648   !>
649   !> @author J.Paul
650   !> @date November, 2013 - Initial Version
651   !>
652   !> @param[in] td_date   date strutcutre
653   !> @param[in] dd_nday   number of day
654   !> @return date strutcutre of date - nday
655   !-------------------------------------------------------------------
656
657      IMPLICIT NONE
658
659      ! Argument
660      TYPE(TDATE), INTENT(IN) :: td_date
661      REAL(dp),    INTENT(IN) :: dd_nday
662
663      ! function
664      TYPE(TDATE)             :: tf_date
665      !----------------------------------------------------------------
666
667      ! check year month day hour min sec
668      CALL date__check(td_date)   
669
670      tf_date=date__init_jd(td_date%d_jd-dd_nday)
671
672   END FUNCTION date__subnday
673   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
674   FUNCTION date__addnday(td_date, dd_nday) &
675         & RESULT (tf_date)
676   !-------------------------------------------------------------------
677   !> @brief This function add nday to a date:
678   !> date2 = date1 + nday
679   !>
680   !> @author J.Paul
681   !> @date November, 2013 - Initial Version
682   !>
683   !> @param[in] td_date   date strutcutre
684   !> @param[in] dd_nday   number of day
685   !> @return date strutcutre of date + nday
686   !-------------------------------------------------------------------
687
688      IMPLICIT NONE
689
690      ! Argument
691      TYPE(TDATE), INTENT(IN) :: td_date
692      REAL(dp),    INTENT(IN) :: dd_nday
693
694      ! function
695      TYPE(TDATE)             :: tf_date
696      !----------------------------------------------------------------
697
698      ! check year month day hour min sec
699      CALL date__check(td_date)   
700
701      tf_date=date__init_jd(td_date%d_jd+dd_nday)
702
703   END FUNCTION date__addnday
704   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
705   FUNCTION date__lastday(td_date) &
706         & RESULT (if_lday)
707   !-------------------------------------------------------------------
708   !> @brief This subroutine compute last day of the month
709   !>
710   !> @author J.Paul
711   !> @date November, 2013 - Initial Version
712   !>
713   !> @param[in] td_date   date strutcutre
714   !> @return last day of the month
715   !-------------------------------------------------------------------
716
717      IMPLICIT NONE
718
719      ! Argument   
720      TYPE(TDATE), INTENT(IN) :: td_date
721
722      ! function
723      INTEGER(i4) :: if_lday
724
725      ! local variable
726      INTEGER, DIMENSION(12), PARAMETER :: il_lastdaytab = &
727      &        (/31,28,31,30,31,30,31,31,30,31,30,31/)
728      !----------------------------------------------------------------
729
730      ! general case
731      IF( td_date%i_month /= 2 )THEN
732         if_lday=il_lastdaytab(td_date%i_month)
733      ELSE
734         IF( date_leapyear(td_date) )THEN
735            if_lday=29
736         ELSE
737            if_lday=il_lastdaytab(td_date%i_month)
738         ENDIF
739      ENDIF
740
741   END FUNCTION date__lastday
742   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
743   SUBROUTINE date__ymd2jd(td_date)
744   !-------------------------------------------------------------------
745   !> @brief This subroutine compute julian day from year month day , and fill
746   !> input date strutcutre.
747   !>
748   !> @author J.Paul
749   !> @date November, 2013 - Initial Version
750   !>
751   !> @param[inout] td_date   date strutcutre
752   !-------------------------------------------------------------------
753
754      IMPLICIT NONE
755
756      ! Argument   
757      TYPE(TDATE), INTENT(INOUT) :: td_date
758
759      ! local variable
760      REAL(dp) :: dl_standard_jd
761      REAL(dp) :: dl_frac
762      !----------------------------------------------------------------
763
764      dl_standard_jd= td_date%i_day - 32075                               & 
765          & + 1461 * (td_date%i_year + 4800 - (14 - td_date%i_month)/12)/4  &
766          & + 367 * (td_date%i_month - 2 + (14 - td_date%i_month)/12*12)/12 &
767          & - 3 * ((td_date%i_year + 4900 - (14 - td_date%i_month)/12)/100)/4
768     
769      td_date%d_jd = dl_standard_jd-2400001 ! origin : 17 nov 1858 h00m00s00
770
771      ! compute fraction of day
772      dl_frac=date__hms2jd(td_date)
773
774      td_date%d_jd = td_date%d_jd + dl_frac
775
776      td_date%k_jdsec = date__jd2sec( td_date%d_jd ) 
777
778   END SUBROUTINE date__ymd2jd
779   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
780   SUBROUTINE date__jd2ymd(td_date)
781   !-------------------------------------------------------------------
782   !> @brief This subroutine compute year month day from julian day, and fill
783   !> input date strutcutre.
784   !>
785   !> @author J.Paul
786   !> @date November, 2013 - Initial Version
787   !>
788   !> @param[inout] td_date   date strutcutre
789   !-------------------------------------------------------------------
790
791      IMPLICIT NONE
792
793      ! Argument   
794      TYPE(TDATE), INTENT(INOUT) :: td_date
795
796      ! local variable
797      INTEGER(i4) :: il_standard_jd
798      INTEGER(i4) :: il_temp1
799      INTEGER(i4) :: il_temp2
800      !----------------------------------------------------------------
801
802      ! check year month day hour min sec
803      CALL date__check(td_date)   
804
805      il_standard_jd=INT( td_date%d_jd+2400001, i4 )
806
807      il_temp1=il_standard_jd + 68569
808      il_temp2=4*il_temp1/146097
809      il_temp1=il_temp1 - (146097 * il_temp2 + 3) / 4
810      td_date%i_year  = 4000 * (il_temp1 + 1) / 1461001
811      il_temp1 = il_temp1 - 1461 * td_date%i_year/4 + 31
812      td_date%i_month = 80 * il_temp1 / 2447
813      td_date%i_day   = il_temp1 - 2447 * td_date%i_month / 80
814      il_temp1 = td_date%i_month / 11
815      td_date%i_month = td_date%i_month + 2 - 12 * il_temp1
816      td_date%i_year  = 100 * (il_temp2 - 49) + td_date%i_year + il_temp1
817
818      ! compute hour, minute, second from julian fraction
819      CALL date__jd2hms(td_date)
820
821      ! adjust date
822      CALL date__adjust(td_date)
823
824   END SUBROUTINE date__jd2ymd
825   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
826   SUBROUTINE date__jc2jd(td_date, td_dateo)
827   !-------------------------------------------------------------------
828   !> @brief This subroutine compute julian day from pseudo julian day
829   !> with new date origin, and fill input date strutcutre.
830   !>
831   !> @author J.Paul
832   !> @date November, 2013 - Initial Version
833   !>
834   !> @param[inout] td_date   date
835   !> @param[in]    td_dateo  new date origin for pseudo julian day
836   !-------------------------------------------------------------------
837
838      IMPLICIT NONE
839
840      ! Argument   
841      TYPE(TDATE), INTENT(INOUT) :: td_date
842      TYPE(TDATE), INTENT(IN) :: td_dateo
843
844      ! local variable
845      TYPE(TDATE) :: tl_date
846      REAL(dp)    :: dl_nday
847      !----------------------------------------------------------------
848      ! origin julian day
849      tl_date=date_init(1858,11,17)
850
851      dl_nday=td_dateo-tl_date
852
853      ! compute julian day
854      td_date%d_jd = td_date%d_jc + dl_nday
855      ! compute number of second since julian day origin
856      td_date%k_jdsec = date__jd2sec(td_date%d_jd)
857
858   END SUBROUTINE date__jc2jd
859   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
860   SUBROUTINE date__jd2jc(td_date, td_dateo)
861   !-------------------------------------------------------------------
862   !> @brief This subroutine compute pseudo julian day with new date origin, and
863   !> fill input date structure.<br/>
864   !>  default new origin is CNES julian day origin: 1950-01-01 00:00:00
865   !>
866   !> @author J.Paul
867   !> @date November, 2013 - Initial Version
868   !>
869   !> @param[inout] td_date   date
870   !> @param[in] td_dateo     new origin date
871   !-------------------------------------------------------------------
872
873      IMPLICIT NONE
874
875      ! Argument   
876      TYPE(TDATE), INTENT(INOUT) :: td_date
877      TYPE(TDATE), INTENT(IN),   OPTIONAL :: td_dateo
878
879      ! local variable
880      TYPE(TDATE) :: tl_dateo
881      !----------------------------------------------------------------
882      IF( PRESENT(td_dateo) )THEN
883         td_date%d_jc=td_date%d_jd-td_dateo%d_jd
884      ELSE
885         ! CNES julian day origin
886         tl_dateo%i_year = 1950
887         tl_dateo%i_month = 1
888         tl_dateo%i_day = 1
889
890         CALL date__ymd2jd(tl_dateo)
891
892         td_date%d_jc = td_date%d_jd-tl_dateo%d_jd
893      ENDIF
894
895      td_date%k_jcsec = date__jd2sec(td_date%d_jc)
896
897   END SUBROUTINE date__jd2jc
898   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
899   SUBROUTINE date__jd2dow(td_date)
900   !-------------------------------------------------------------------
901   !> @brief This subroutine compute the day of week from julian day, and fill
902   !> input date structure.<br/>
903   !>  days   : Sunday Monday Tuesday Wednesday Thursday Friday Saturday<br/>
904   !>  numday : 0      1      2       3         4        5      6<br/>
905   !>
906   !> @author J.Paul
907   !> @date November, 2013 - Initial Version
908   !>
909   !> @param[inout] td_date   date strutcutre
910   !-------------------------------------------------------------------
911
912      IMPLICIT NONE
913
914      ! Argument   
915      TYPE(TDATE), INTENT(INOUT) :: td_date
916      !----------------------------------------------------------------
917
918      td_date%i_dow=MOD((INT(AINT(td_date%d_jd))+3),7)
919
920   END SUBROUTINE date__jd2dow
921   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
922   FUNCTION date__hms2jd(td_date) &
923         & RESULT (df_frac)
924   !-------------------------------------------------------------------
925   !> @brief This function compute fraction of a day from
926   !> hour, minute, second.
927   !>
928   !> @author J.Paul
929   !> @date November, 2013 - Initial Version
930   !>
931   !> @param[in] td_date   date strutcutre
932   !> @return fraction of the day
933   !-------------------------------------------------------------------
934
935      IMPLICIT NONE
936
937      ! Argument   
938      TYPE(TDATE), INTENT(IN) :: td_date
939
940      ! function
941      REAL(dp)                :: df_frac
942      !----------------------------------------------------------------
943
944      !  compute real seconds
945      df_frac = REAL( td_date%i_sec, dp )
946      !  compute real minutes
947      df_frac = REAL( td_date%i_min, dp ) + df_frac/60.0
948      !  compute real hours
949      df_frac = REAL( td_date%i_hour, dp ) + df_frac/60.0
950      !  julian fraction of a day
951      df_frac = df_frac/24.0
952
953   END FUNCTION date__hms2jd
954   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
955   SUBROUTINE date__jd2hms(td_date)
956   !-------------------------------------------------------------------
957   !> @brief This subroutine compute hour, minute, second from julian
958   !> fraction, and fill date structure.
959   !>
960   !> @author J.Paul
961   !> @date November, 2013 - Initial Version
962   !>
963   !> @param[inout] td_date   date strutcutre
964   !-------------------------------------------------------------------
965
966      IMPLICIT NONE
967
968      ! Argument   
969      TYPE(TDATE), INTENT(INOUT) :: td_date
970
971      !local variable
972      REAL(dp) :: dl_fract
973      !----------------------------------------------------------------
974
975      dl_fract=(td_date%d_jd)-AINT(td_date%d_jd)
976      !  compute hour
977      td_date%i_hour = INT( dl_fract * 24.0, i4 )
978      dl_fract = ( dl_fract - REAL( td_date%i_hour, dp ) / 24.0) * 24.0
979      !  compute minute
980      td_date%i_min = INT( dl_fract * 60.0, i4 )
981      dl_fract = ( dl_fract - REAL( td_date%i_min, dp ) / 60.0) * 60.0
982      !  compute second
983      td_date%i_sec = NINT( dl_fract * 60.0, i4 )
984
985   END SUBROUTINE date__jd2hms
986   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
987   SUBROUTINE date__check(td_date)
988   !-------------------------------------------------------------------
989   !> @brief This subroutine check date express in date structure
990   !>
991   !> @author J.Paul
992   !> @date November, 2013 - Initial Version
993   !>
994   !> @param[in] td_date   date strutcutre
995   !-------------------------------------------------------------------
996     
997      IMPLICIT NONE
998
999      ! Argument   
1000      TYPE(TDATE), INTENT(IN) :: td_date
1001
1002      ! local variable
1003      INTEGER(i4)       :: il_lastday
1004      INTEGER(i4)       :: il_status
1005      CHARACTER(LEN=lc) :: cl_msg
1006      !----------------------------------------------------------------
1007
1008      ! init
1009      il_status=0
1010
1011      ! check year
1012      IF( td_date%i_year < 1858_i4 .OR. td_date%i_year > 39999_i4 )THEN
1013         il_status=il_status+1
1014         WRITE(cl_msg,*) "year ",td_date%i_year," out of range"
1015         CALL logger_error(cl_msg)
1016      ENDIF
1017      ! check month
1018      IF( td_date%i_month < 1_i4 .OR. td_date%i_month > 12_i4 )THEN
1019         il_status=il_status+1
1020         WRITE(cl_msg,*) "month ",td_date%i_month," out of range"
1021         CALL logger_error(cl_msg)
1022      ENDIF
1023      ! check day
1024      il_lastday=date__lastday(td_date)
1025      IF( td_date%i_day < 1_i4 .OR. td_date%i_day > il_lastday )THEN
1026         il_status=il_status+1
1027         WRITE(cl_msg,*) "day ",td_date%i_day," out of range"
1028         CALL logger_error(cl_msg)
1029      ENDIF
1030      ! check hour
1031      IF( td_date%i_hour < 0_i4 .OR. td_date%i_hour > 23_i4 )THEN
1032         il_status=il_status+1
1033         WRITE(cl_msg,*) "hour ",td_date%i_hour," out of range"
1034         CALL logger_error(cl_msg)
1035      ENDIF
1036      ! check minutes
1037      IF( td_date%i_min < 0_i4 .OR. td_date%i_min > 59_i4 )THEN
1038         il_status=il_status+1
1039         WRITE(cl_msg,*) "minutes ",td_date%i_min," out of range"
1040         CALL logger_error(cl_msg)
1041      ENDIF   
1042      ! check seconds
1043      IF( td_date%i_sec < 0_i4 .OR. td_date%i_sec > 59_i4 )THEN
1044         il_status=il_status+1
1045         WRITE(cl_msg,*) "seconds ",td_date%i_sec," out of range"
1046         CALL logger_error(cl_msg)
1047      ENDIF
1048
1049      ! check julian day
1050      IF( td_date%d_jd < 0_sp .OR. td_date%d_jd > 782028_sp )THEN
1051         il_status=il_status+1
1052         WRITE(cl_msg,*) "julian day ",td_date%d_jd," out of range"
1053         CALL logger_error(cl_msg)
1054      ENDIF
1055
1056      IF( il_status/= 0 )THEN
1057         WRITE(cl_msg,*) " date error"
1058         CALL logger_fatal(cl_msg)
1059      ENDIF
1060
1061   END SUBROUTINE date__check
1062   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1063   SUBROUTINE date__adjust(td_date)
1064   !-------------------------------------------------------------------
1065   !> @brief This subroutine adjust date (correct hour, minutes, and seconds
1066   !> value if need be)
1067   !>
1068   !> @author J.Paul
1069   !> @date November, 2013 - Initial Version
1070   !>
1071   !> @param[inout] td_date   date strutcutre
1072   !-------------------------------------------------------------------
1073
1074      IMPLICIT NONE
1075
1076      ! Argument   
1077      TYPE(TDATE), INTENT(INOUT) :: td_date
1078      !----------------------------------------------------------------
1079
1080      IF( td_date%i_sec == 60 )THEN
1081         td_date%i_sec=0
1082         td_date%i_min=td_date%i_min+1
1083      ENDIF
1084     
1085      IF( td_date%i_min == 60 )THEN
1086         td_date%i_min=0
1087         td_date%i_hour=td_date%i_hour+1
1088      ENDIF
1089
1090      IF( td_date%i_hour == 24 )THEN
1091         td_date%i_hour=0
1092         td_date=date__addnday(td_date,1._dp)
1093      ENDIF
1094
1095   END SUBROUTINE date__adjust
1096   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1097   FUNCTION date__jd2sec(dd_jul) &
1098         & RESULT (if_sec)
1099   !-------------------------------------------------------------------
1100   !> @brief This function convert julian day in seconds
1101   !> since julian day origin.
1102   !> @author J.Paul
1103   !> @date November, 2013 - Initial Version
1104   !>
1105   !> @param[in] td_date   date strutcutre
1106   !> @return number of seconds since julian day origin
1107   !-------------------------------------------------------------------
1108
1109      IMPLICIT NONE
1110
1111      ! Argument   
1112      REAL(dp), INTENT(IN) :: dd_jul
1113
1114      ! function
1115      INTEGER(i8)          :: if_sec
1116      !----------------------------------------------------------------
1117
1118      if_sec = NINT( dd_jul * im_secbyday, i8 )
1119
1120   END FUNCTION date__jd2sec
1121   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1122   FUNCTION date__sec2jd(kd_nsec) &
1123         & RESULT (df_sec)
1124   !-------------------------------------------------------------------
1125   !> @brief This function convert seconds since julian day origin in
1126   !> julian day.
1127   !> @author J.Paul
1128   !> @date November, 2013 - Initial Version
1129   !>
1130   !> @param[in] kd_nsec   number of second since julian day origin
1131   !> @return julian day
1132   !-------------------------------------------------------------------
1133
1134      IMPLICIT NONE
1135
1136      ! Argument   
1137      INTEGER(i8), INTENT(IN) :: kd_nsec
1138
1139      ! function
1140      REAL(dp)                :: df_sec
1141      !----------------------------------------------------------------
1142
1143      df_sec = REAL( REAL( kd_nsec , dp ) / im_secbyday, dp )
1144
1145   END FUNCTION date__sec2jd
1146   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1147END MODULE date
1148
Note: See TracBrowser for help on using the repository browser.