source: branches/2013/dev_rev4119_MERCATOR4_CONFMAN/NEMOGCM/TOOLS/SIREN/src/date.f90 @ 4213

Last change on this file since 4213 was 4213, checked in by cbricaud, 7 years ago

first draft of the CONFIGURATION MANAGER demonstrator

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