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 branches/UKMO/icebergs_restart_single_file/NEMOGCM/TOOLS/SIREN/src – NEMO

source: branches/UKMO/icebergs_restart_single_file/NEMOGCM/TOOLS/SIREN/src/date.f90 @ 6019

Last change on this file since 6019 was 6019, checked in by timgraham, 8 years ago

Reinstated svn keywords before upgrading to head of trunk

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