source: lmdz_wrf/trunk/WRFV3/lmdz/IOIPSL/calendar.f90

MODULE calendar
!-
!$Id: calendar.f90 1519 2011-08-01 09:34:10Z mmaipsl $
!-
! This software is governed by the CeCILL license
! See IOIPSL/IOIPSL_License_CeCILL.txt
!---------------------------------------------------------------------
!- This is the calendar which going to be used to do all
!- calculations on time. Three types of calendars are possible :
!-
!-  - gregorian :
!-      The normal calendar. The time origin for the
!-      julian day in this case is 24 Nov -4713
!-      (other names : 'standard','proleptic_gregorian')
!-  - noleap :
!-      A 365 day year without leap years.
!-      The origin for the julian days is in this case 1 Jan 0
!-      (other names : '365_day','365d')
!-  - all_leap :
!-      A 366 day year with leap years.
!-      The origin for the julian days is in this case ????
!-      (other names : '366_day','366d'
!-  - julian :
!-      same as gregorian, but with all leap century years
!-  - xxxd :
!-      Year of xxx days with month of equal length.
!-      The origin for the julian days is then also 1 Jan 0
!-
!- As one can see it is difficult to go from one calendar to the other.
!- All operations involving julian days will be wrong.
!- This calendar will lock as soon as possible
!- the length of the year and forbid any further modification.
!-
!- For the non leap-year calendar the method is still brute force.
!- We need to find an Integer series which takes care of the length
!- of the various month. (Jan)
!-
!-   one_day  : one day in seconds
!-   one_year : one year in days
!---------------------------------------------------------------------
  USE stringop,ONLY  : strlowercase
  USE errioipsl,ONLY : ipslerr, ipsldbg, ipslout
!-
  PRIVATE
  PUBLIC :: ymds2ju,ju2ymds,tlen2itau,isittime,ioconf_calendar, &
 &          ioget_calendar,ioget_mon_len,ioget_year_len,itau2date, &
 &          ioget_timestamp,ioconf_startdate,itau2ymds, &
 &          time_diff,time_add,lock_calendar
!-
  INTERFACE ioget_calendar
    MODULE PROCEDURE &
 &    ioget_calendar_real1,ioget_calendar_real2,ioget_calendar_str
  END INTERFACE
!-
  INTERFACE ioconf_startdate
     MODULE PROCEDURE &
 &    ioconf_startdate_simple,ioconf_startdate_internal, &
 &    ioconf_startdate_ymds
  END INTERFACE
!-
  REAL,PARAMETER :: one_day = 86400.0
  LOGICAL,SAVE :: lock_startdate = .FALSE.
!-
  CHARACTER(LEN=30),SAVE :: time_stamp='XXXXXXXXXXXXXXXX'
!-
!- Description of calendar
!-
  CHARACTER(LEN=20),SAVE :: calendar_used="gregorian"
  LOGICAL,SAVE :: lock_one_year = .FALSE.
  REAL,SAVE :: one_year = 365.2425
  INTEGER,SAVE :: mon_len(12)=(/31,28,31,30,31,30,31,31,30,31,30,31/)
!-
  CHARACTER(LEN=3),PARAMETER :: &
 &  cal(12) = (/'JAN','FEB','MAR','APR','MAY','JUN', &
 &              'JUL','AUG','SEP','OCT','NOV','DEC'/)
!-
  REAL,SAVE :: start_day,start_sec
!-
CONTAINS
!-
!===
!-
SUBROUTINE lock_calendar (new_status,old_status)
!!--------------------------------------------------------------------
!! The "lock_calendar" routine
!! allows to lock or unlock the calendar,
!! and to know the current status of the calendar.
!! Be careful !
!!
!! SUBROUTINE lock_calendar (new_status,old_status)
!!
!! Optional INPUT argument
!!
!! (L) new_status : new status of the calendar
!!
!! Optional OUTPUT argument
!!
!! (L) old_status : current status of the calendar
!!--------------------------------------------------------------------
  IMPLICIT NONE
!-
  LOGICAL,OPTIONAL,INTENT(IN)  :: new_status
  LOGICAL,OPTIONAL,INTENT(OUT) :: old_status
!---------------------------------------------------------------------
  IF (PRESENT(old_status)) THEN
    old_status = lock_one_year
  ENDIF
  IF (PRESENT(new_status)) THEN
    lock_one_year = new_status
  ENDIF
!---------------------------
END SUBROUTINE lock_calendar
!-
!===
!-
SUBROUTINE ymds2ju (year,month,day,sec,julian)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER,INTENT(IN) :: year,month,day
  REAL,INTENT(IN)    :: sec
!-
  REAL,INTENT(OUT) :: julian
!-
  INTEGER :: julian_day
  REAL    :: julian_sec
!---------------------------------------------------------------------
  CALL ymds2ju_internal (year,month,day,sec,julian_day,julian_sec)
!-
  julian = julian_day+julian_sec/one_day
!---------------------
END SUBROUTINE ymds2ju
!-
!===
!-
SUBROUTINE ymds2ju_internal (year,month,day,sec,julian_day,julian_sec)
!---------------------------------------------------------------------
!- Converts year, month, day and seconds into a julian day
!-
!- In 1968 in a letter to the editor of Communications of the ACM
!- (CACM, volume 11, number 10, October 1968, p.657) Henry F. Fliegel
!- and Thomas C. Van Flandern presented such an algorithm.
!-
!- See also : http://www.magnet.ch/serendipity/hermetic/cal_stud/jdn.htm
!-
!- In the case of the Gregorian calendar we have chosen to use
!- the Lilian day numbers. This is the day counter which starts
!- on the 15th October 1582.
!- This is the day at which Pope Gregory XIII introduced the
!- Gregorian calendar.
!- Compared to the true Julian calendar, which starts some
!- 7980 years ago, the Lilian days are smaler and are dealt with
!- easily on 32 bit machines. With the true Julian days you can only
!- the fraction of the day in the real part to a precision of
!- a 1/4 of a day with 32 bits.
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER,INTENT(IN) :: year,month,day
  REAL,INTENT(IN)    :: sec
!-
  INTEGER,INTENT(OUT) :: julian_day
  REAL,INTENT(OUT)    :: julian_sec
!-
  INTEGER :: jd,m,y,d,ml
!---------------------------------------------------------------------
  lock_one_year = .TRUE.
!-
  m = month
  y = year
  d = day
!-
!- We deduce the calendar from the length of the year as it
!- is faster than an INDEX on the calendar variable.
!-
  IF ( (one_year > 365.0).AND.(one_year < 366.0) ) THEN
!-- "Gregorian"
    jd = (1461*(y+4800+INT((m-14)/12)))/4 &
 &      +(367*(m-2-12*(INT((m-14)/12))))/12 &
 &      -(3*((y+4900+INT((m-14)/12))/100))/4 &
 &      +d-32075
    jd = jd-2299160
  ELSE IF (    (ABS(one_year-365.0) <= EPSILON(one_year))  &
 &         .OR.(ABS(one_year-366.0) <= EPSILON(one_year)) ) THEN
!-- "No leap" or "All leap"
    ml = SUM(mon_len(1:m-1))
    jd = y*NINT(one_year)+ml+(d-1)
  ELSE
!-- Calendar with regular month
    ml = NINT(one_year/12.)
    jd = y*NINT(one_year)+(m-1)*ml+(d-1)
  ENDIF
!-
  julian_day = jd
  julian_sec = sec
!------------------------------
END SUBROUTINE ymds2ju_internal
!-
!===
!-
SUBROUTINE ju2ymds (julian,year,month,day,sec)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  REAL,INTENT(IN) :: julian
!-
  INTEGER,INTENT(OUT) :: year,month,day
  REAL,INTENT(OUT)    :: sec
!-
  INTEGER :: julian_day
  REAL    :: julian_sec
!---------------------------------------------------------------------
  julian_day = INT(julian)
  julian_sec = (julian-julian_day)*one_day
!-
  CALL ju2ymds_internal(julian_day,julian_sec,year,month,day,sec)
!---------------------
END SUBROUTINE ju2ymds
!-
!===
!-
SUBROUTINE ju2ymds_internal (julian_day,julian_sec,year,month,day,sec)
!---------------------------------------------------------------------
!- This subroutine computes from the julian day the year,
!- month, day and seconds
!-
!- In 1968 in a letter to the editor of Communications of the ACM
!- (CACM, volume 11, number 10, October 1968, p.657) Henry F. Fliegel
!- and Thomas C. Van Flandern presented such an algorithm.
!-
!- See also : http://www.magnet.ch/serendipity/hermetic/cal_stud/jdn.htm
!-
!- In the case of the Gregorian calendar we have chosen to use
!- the Lilian day numbers. This is the day counter which starts
!- on the 15th October 1582. This is the day at which Pope
!- Gregory XIII introduced the Gregorian calendar.
!- Compared to the true Julian calendar, which starts some 7980
!- years ago, the Lilian days are smaler and are dealt with easily
!- on 32 bit machines. With the true Julian days you can only the
!- fraction of the day in the real part to a precision of a 1/4 of
!- a day with 32 bits.
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER,INTENT(IN) :: julian_day
  REAL,INTENT(IN)    :: julian_sec
!-
  INTEGER,INTENT(OUT) :: year,month,day
  REAL,INTENT(OUT)    :: sec
!-
  INTEGER :: l,n,i,jd,j,d,m,y,ml
  INTEGER :: add_day
  REAL :: eps_day
!---------------------------------------------------------------------
  eps_day = SPACING(one_day)
  lock_one_year = .TRUE.
!-
  jd = julian_day
  sec = julian_sec
  IF (sec > (one_day-eps_day)) THEN
    add_day = INT(sec/one_day)
    sec = sec-add_day*one_day
    jd = jd+add_day
  ENDIF
  IF (sec < -eps_day) THEN
    sec = sec+one_day
    jd = jd-1
  ENDIF
!-
  IF ( (one_year > 365.0).AND.(one_year < 366.0) ) THEN
!-- Gregorian
    jd = jd+2299160
!-
    l = jd+68569
    n = (4*l)/146097
    l = l-(146097*n+3)/4
    i = (4000*(l+1))/1461001
    l = l-(1461*i)/4+31
    j = (80*l)/2447
    d = l-(2447*j)/80
    l = j/11
    m = j+2-(12*l)
    y = 100*(n-49)+i+l
  ELSE IF (    (ABS(one_year-365.0) <= EPSILON(one_year)) &
 &         .OR.(ABS(one_year-366.0) <= EPSILON(one_year)) ) THEN
!-- No leap or All leap
    y = jd/NINT(one_year)
    l = jd-y*NINT(one_year)
    m = 1
    ml = 0
    DO WHILE (ml+mon_len(m) <= l)
      ml = ml+mon_len(m)
      m = m+1
    ENDDO
    d = l-ml+1
  ELSE
!-- others
    ml = NINT(one_year/12.)
    y = jd/NINT(one_year)
    l = jd-y*NINT(one_year)
    m = (l/ml)+1
    d = l-(m-1)*ml+1
  ENDIF
!-
  day = d
  month = m
  year = y
!------------------------------
END SUBROUTINE ju2ymds_internal
!-
!===
!-
SUBROUTINE tlen2itau (input_str,dt,date,itau)
!---------------------------------------------------------------------
!- This subroutine transforms a string containing a time length
!- into a number of time steps.
!- To do this operation the date (in julian days is needed as the
!- length of the month varies.
!- The following convention is used :
!-   n   : n time steps
!-   nS  : n seconds is transformed into itaus
!-   nH  : n hours
!-   nD  : n days
!-   nM  : n month
!-   nY  : n years
!- Combinations are also possible
!-   nYmD : nyears plus m days !
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=*),INTENT(IN) :: input_str
  REAL,INTENT(IN)             :: dt,date
!-
  INTEGER,INTENT(OUT)         :: itau
!-
  INTEGER           :: y_pos,m_pos,d_pos,h_pos,s_pos
  INTEGER           :: read_time
  CHARACTER(LEN=13) :: fmt
  CHARACTER(LEN=80) :: tmp_str
!-
  INTEGER :: year,month,day
  REAL    :: sec,date_new,dd,ss
!---------------------------------------------------------------------
  itau = 0
  CALL ju2ymds (date,year,month,day,sec)
!-
  y_pos = MAX(INDEX(input_str,'y'),INDEX(input_str,'Y'))
  m_pos = MAX(INDEX(input_str,'m'),INDEX(input_str,'M'))
  d_pos = MAX(INDEX(input_str,'d'),INDEX(input_str,'D'))
  h_pos = MAX(INDEX(input_str,'h'),INDEX(input_str,'H'))
  s_pos = MAX(INDEX(input_str,'s'),INDEX(input_str,'S'))
!-
  IF (MAX(y_pos,m_pos,d_pos,s_pos) > 0) THEN
    tmp_str = input_str
    DO WHILE ( MAX(y_pos,m_pos,d_pos,s_pos) > 0)
!---- WRITE(ipslout,*) tmp_str
!---- WRITE(ipslout,*) y_pos,m_pos,d_pos,s_pos
      IF (y_pos > 0) THEN
        WRITE(fmt,'("(I",I10.10,")")') y_pos-1
        READ(tmp_str(1:y_pos-1),fmt) read_time
        CALL ymds2ju (year+read_time,month,day,sec,date_new)
        dd = date_new-date
        ss = INT(dd)*one_day+dd-INT(dd)
        itau = itau+NINT(ss/dt)
        tmp_str = tmp_str(y_pos+1:LEN_TRIM(tmp_str))
      ELSE IF (m_pos > 0) THEN
        WRITE(fmt,'("(I",I10.10,")")') m_pos-1
        READ(tmp_str(1:m_pos-1),fmt) read_time
        CALL ymds2ju (year,month+read_time,day,sec,date_new)
        dd = date_new-date
        ss = INT(dd)*one_day+dd-INT(dd)
        itau = itau+NINT(ss/dt)
        tmp_str = tmp_str(m_pos+1:LEN_TRIM(tmp_str))
      ELSE IF (d_pos > 0) THEN
        WRITE(fmt,'("(I",I10.10,")")') d_pos-1
        READ(tmp_str(1:d_pos-1),fmt) read_time
        itau = itau+NINT(read_time*one_day/dt)
        tmp_str = tmp_str(d_pos+1:LEN_TRIM(tmp_str))
      ELSE IF (h_pos > 0) THEN
        WRITE(fmt,'("(I",I10.10,")")') h_pos-1
        READ(tmp_str(1:h_pos-1),fmt) read_time
        itau = itau+NINT(read_time*60.*60./dt)
        tmp_str = tmp_str(d_pos+1:LEN_TRIM(tmp_str))
      ELSE IF  (s_pos > 0) THEN
        WRITE(fmt,'("(I",I10.10,")")') s_pos-1
        READ(tmp_str(1:s_pos-1),fmt) read_time
        itau = itau+NINT(read_time/dt)
        tmp_str = tmp_str(s_pos+1:LEN_TRIM(tmp_str))
      ENDIF
!-
      y_pos = MAX(INDEX(tmp_str,'y'),INDEX(tmp_str,'Y'))
      m_pos = MAX(INDEX(tmp_str,'m'),INDEX(tmp_str,'M'))
      d_pos = MAX(INDEX(tmp_str,'d'),INDEX(tmp_str,'D'))
      h_pos = MAX(INDEX(tmp_str,'h'),INDEX(tmp_str,'H'))
      s_pos = MAX(INDEX(tmp_str,'s'),INDEX(tmp_str,'S'))
    ENDDO
  ELSE
    WRITE(fmt,'("(I",I10.10,")")') LEN_TRIM(input_str)
    READ(input_str(1:LEN_TRIM(input_str)),fmt) itau
  ENDIF
!-----------------------
END SUBROUTINE tlen2itau
!-
!===
!-
REAL FUNCTION itau2date (itau,date0,deltat)
!---------------------------------------------------------------------
!- This function transforms itau into a date. The date with which
!- the time axis is going to be labeled
!-
!- INPUT
!-   itau   : current time step
!-   date0  : Date at which itau was equal to 0
!-   deltat : time step between itau s
!-
!- OUTPUT
!-   itau2date : Date for the given itau
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER  :: itau
  REAL     :: date0,deltat
!---------------------------------------------------------------------
  itau2date = REAL(itau)*deltat/one_day+date0
!---------------------
END FUNCTION itau2date
!-
!===
!-
SUBROUTINE itau2ymds (itau,deltat,year,month,day,sec)
!---------------------------------------------------------------------
!- This subroutine transforms itau into a date. The date with which
!- the time axis is going to be labeled
!-
!- INPUT
!-   itau   : current time step
!-   deltat : time step between itau s
!-
!- OUTPUT
!-   year  : year
!-   month : month
!-   day   : day
!-   sec   : seconds since midnight
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER,INTENT(IN) :: itau
  REAL,INTENT(IN)    :: deltat
!-
  INTEGER,INTENT(OUT) :: year,month,day
  REAL,INTENT(OUT)    :: sec
!-
  INTEGER :: julian_day
  REAL    :: julian_sec
!---------------------------------------------------------------------
  IF (.NOT.lock_startdate) THEN
    CALL ipslerr (2,'itau2ymds', &
 &   'You try to call this function, itau2ymds, but you didn''t', &
 &   ' call ioconf_startdate to initialize date0 in calendar.', &
 &   ' Please call ioconf_startdate before itau2ymds.')
  ENDIF
  julian_day = start_day
  julian_sec = start_sec+REAL(itau)*deltat
  CALL ju2ymds_internal (julian_day,julian_sec,year,month,day,sec)
!-----------------------
END SUBROUTINE itau2ymds
!-
!===
!-
REAL FUNCTION dtchdate (itau,date0,old_dt,new_dt)
!---------------------------------------------------------------------
!- This function changes the date so that the simulation can
!- continue with the same itau but a different dt.
!-
!- INPUT
!-   itau   : current time step
!-   date0  : Date at which itau was equal to 0
!-   old_dt : Old time step between itaus
!-   new_dt : New time step between itaus
!-
!- OUTPUT
!-   dtchdate : Date for the given itau
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER,INTENT(IN) :: itau
  REAL,INTENT(IN)    :: date0,old_dt,new_dt
!-
  REAL :: rtime
!---------------------------------------------------------------------
  rtime = itau2date (itau,date0,old_dt)
  dtchdate = rtime-REAL(itau)*new_dt/one_day
!--------------------
END FUNCTION dtchdate
!-
!===
!-
SUBROUTINE isittime &
 &  (itau,date0,dt,freq,last_action,last_check,do_action)
!---------------------------------------------------------------------
!- This subroutine checks the time as come for a given action.
!- This is computed from the current time-step(itau).
!- Thus we need to have the time delta (dt), the frequency
!- of the action (freq) and the last time it was done
!- (last_action in units of itau).
!- In order to extrapolate when will be the next check we need
!- the time step of the last call (last_check).
!-
!- The test is done on the following condition :
!- the distance from the current time to the time for the next
!- action is smaller than the one from the next expected
!- check to the next action.
!- When the test is done on the time steps simplifications make
!- it more difficult to read in the code.
!- For the real time case it is easier to understand !
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER,INTENT(IN) :: itau
  REAL,INTENT(IN)    :: dt,freq
  INTEGER,INTENT(IN) :: last_action,last_check
  REAL,INTENT(IN)    :: date0
!-
  LOGICAL,INTENT(OUT)  :: do_action
!-
  REAL :: dt_action,dt_check
  REAL :: date_last_act,date_next_check,date_next_act, &
 &        date_now,date_mp1,date_mpf
  INTEGER :: year,month,monthp1,day,next_check_itau,next_act_itau
  INTEGER :: yearp,dayp
  REAL :: sec,secp
  LOGICAL :: l_dbg
!---------------------------------------------------------------------
  CALL ipsldbg (old_status=l_dbg)
!---------------------------------------------------------------------
  IF (l_dbg) THEN
    WRITE(ipslout,*) &
 &    "isittime 1.0 ",itau,date0,dt,freq,last_action,last_check
  ENDIF
!-
  IF (last_check >= 0) THEN
    dt_action = (itau-last_action)*dt
    dt_check = (itau-last_check)*dt
    next_check_itau = itau+(itau-last_check)
!-
!-- We are dealing with frequencies in seconds and thus operation
!-- can be done on the time steps.
!-
    IF (freq > 0) THEN
      IF (ABS(dt_action-freq) <= ABS(dt_action+dt_check-freq)) THEN
        do_action = .TRUE.
      ELSE
        do_action = .FALSE.
      ENDIF
!-
!---- Here we deal with frequencies in month and work on julian days.
!-
    ELSE
      date_now = itau2date (itau,date0,dt)
      date_last_act = itau2date (last_action,date0,dt)
      CALL ju2ymds (date_last_act,year,month,day,sec)
      monthp1 = month-freq
      yearp = year
!-
!---- Here we compute what logically should be the next month
!-
      IF (month >= 13) THEN
        yearp = year+1
        monthp1 = monthp1-12
      ENDIF
      CALL ymds2ju (year,monthp1,day,sec,date_mpf)
!-
!---- But it could be that because of a shorter month or a bad
!---- starting date that we end up further than we should be.
!---- Thus we compute the first day of the next month.
!---- We can not be beyond this date and if we are close
!---- then we will take it as it is better.
!-
      monthp1 = month+ABS(freq)
      yearp=year
      IF (monthp1 >= 13) THEN
        yearp = year+1
        monthp1 = monthp1 -12
      ENDIF
      dayp = 1
      secp = 0.0
      CALL ymds2ju (yearp,monthp1,dayp,secp,date_mp1)
!-
!---- If date_mp1 is smaller than date_mpf or only less than 4 days
!---- larger then we take it. This needed to ensure that short month
!---- like February do not mess up the thing !
!-
      IF (date_mp1-date_mpf < 4.) THEN
        date_next_act = date_mp1
      ELSE
        date_next_act = date_mpf
      ENDIF
      date_next_check = itau2date (next_check_itau,date0,dt)
!-
!---- Transform the dates into time-steps for the needed precisions.
!-
      next_act_itau = &
 &      last_action+INT((date_next_act-date_last_act)*(one_day/dt))
!-----
      IF (   ABS(itau-next_act_itau) &
 &        <= ABS( next_check_itau-next_act_itau)) THEN
        do_action = .TRUE.
        IF (l_dbg) THEN
          WRITE(ipslout,*) &
 &         'ACT-TIME : itau, next_act_itau, next_check_itau : ', &
 &         itau,next_act_itau,next_check_itau
          CALL ju2ymds (date_now,year,month,day,sec)
          WRITE(ipslout,*) 'ACT-TIME : y, m, d, s : ',year,month,day,sec
          WRITE(ipslout,*) &
 &         'ACT-TIME : date_mp1, date_mpf : ',date_mp1,date_mpf
        ENDIF
      ELSE
        do_action = .FALSE.
      ENDIF
    ENDIF
!-
    IF (l_dbg) THEN
      WRITE(ipslout,*) "isittime 2.0 ", &
 &     date_next_check,date_next_act,ABS(dt_action-freq), &
 &     ABS(dt_action+dt_check-freq),dt_action,dt_check, &
 &     next_check_itau,do_action
    ENDIF
  ELSE
    do_action=.FALSE.
  ENDIF
!----------------------
END SUBROUTINE isittime
!-
!===
!-
SUBROUTINE ioconf_calendar (str)
!---------------------------------------------------------------------
!- This routine allows to configure the calendar to be used.
!- This operation is only allowed once and the first call to
!- ymds2ju or ju2ymsd will lock the current configuration.
!- the argument to ioconf_calendar can be any of the following :
!-  - gregorian : This is the gregorian calendar (default here)
!-  - noleap    : A calendar without leap years = 365 days
!-  - xxxd      : A calendar of xxx days (has to be a modulo of 12)
!-                with 12 month of equal length
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=*),INTENT(IN) :: str
!-
  INTEGER :: leng,ipos
  CHARACTER(LEN=20) :: str_w
!---------------------------------------------------------------------
!-
! Clean up the string !
!-
  str_w = str
  CALL strlowercase (str_w)
!-
  IF (.NOT.lock_one_year) THEN
!---
    lock_one_year=.TRUE.
!---
    SELECT CASE(TRIM(str_w))
    CASE('gregorian','standard','proleptic_gregorian')
      calendar_used = 'gregorian'
      one_year = 365.2425
      mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/)
    CASE('noleap','365_day','365d')
      calendar_used = 'noleap'
      one_year = 365.0
      mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/)
    CASE('all_leap','366_day','366d')
      calendar_used = 'all_leap'
      one_year = 366.0
      mon_len(:)=(/31,29,31,30,31,30,31,31,30,31,30,31/)
    CASE('360_day','360d')
      calendar_used = '360d'
      one_year = 360.0
      mon_len(:)=(/30,30,30,30,30,30,30,30,30,30,30,30/)
    CASE('julian')
      calendar_used = 'julian'
      one_year = 365.25
      mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/)
    CASE DEFAULT
      ipos = INDEX(str_w,'d')
      IF (ipos == 4) THEN
        READ(str_w(1:3),'(I3)') leng
        IF ( (MOD(leng,12) == 0).AND.(leng > 1) ) THEN
          calendar_used = str_w
          one_year = leng
          mon_len(:) = leng/12
        ELSE
          CALL ipslerr (3,'ioconf_calendar', &
 &         'The length of the year as to be a modulo of 12', &
 &         'so that it can be divided into 12 month of equal length', &
 &         TRIM(str_w))
        ENDIF
      ELSE
        CALL ipslerr (3,'ioconf_calendar', &
 &       'Unrecognized input, please check the man pages.', &
 &       TRIM(str_w),' ')
      ENDIF
    END SELECT
  ELSE IF (TRIM(str_w) /= TRIM(calendar_used)) THEN
    WRITE(str_w,'(f10.4)') one_year
    CALL ipslerr (2,'ioconf_calendar', &
 &   'The calendar was already used or configured to : '// &
 &    TRIM(calendar_used)//'.', &
 &   'You are not allowed to change it to : '//TRIM(str)//'.', &
 &   'The following length of year is used : '//TRIM(ADJUSTL(str_w)))
  ENDIF
!-----------------------------
END SUBROUTINE ioconf_calendar
!-
!===
!-
SUBROUTINE ioconf_startdate_simple (julian)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  REAL,INTENT(IN) :: julian
!-
  INTEGER :: julian_day
  REAL    :: julian_sec
!---------------------------------------------------------------------
  julian_day = INT(julian)
  julian_sec = (julian-julian_day)*one_day
!-
  CALL ioconf_startdate_internal (julian_day,julian_sec)
!-------------------------------------
END SUBROUTINE ioconf_startdate_simple
!-
!===
!-
SUBROUTINE ioconf_startdate_ymds (year,month,day,sec)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER,INTENT(IN) :: year,month,day
  REAL,INTENT(IN)    :: sec
!-
  INTEGER :: julian_day
  REAL    :: julian_sec
!---------------------------------------------------------------------
  CALL ymds2ju_internal (year,month,day,sec,julian_day,julian_sec)
!-
  CALL ioconf_startdate_internal (julian_day,julian_sec)
!-----------------------------------
END SUBROUTINE ioconf_startdate_ymds
!-
!===
!-
SUBROUTINE ioconf_startdate_internal (julian_day,julian_sec)
!---------------------------------------------------------------------
! This subroutine allows to set the startdate for later
! use. It allows the applications to access the date directly from
! the timestep. In order to avoid any problems the start date will
! be locked and can not be changed once set.
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER,INTENT(IN)  :: julian_day
  REAL,INTENT(IN)     :: julian_sec
!-
  CHARACTER(len=70) :: str70a,str70b
!---------------------------------------------------------------------
  IF (.NOT.lock_startdate) THEN
    start_day = julian_day
    start_sec = julian_sec
    lock_startdate = .TRUE.
  ELSE
    WRITE(str70a,'("The date you tried to set : ",f10.4)') &
 &   julian_day,julian_sec/one_day
    WRITE(str70b, &
 &   '("The date which was already set in the calendar : ",f10.4)') &
 &   start_day+start_sec/one_day
    CALL ipslerr (2,'ioconf_startdate', &
 &   'The start date has already been set and you tried to change it', &
 &   str70a,str70b)
  ENDIF
!---------------------------------------
END SUBROUTINE ioconf_startdate_internal
!-
!===
!-
SUBROUTINE ioget_calendar_str (str)
!---------------------------------------------------------------------
!- This subroutine returns the name of the calendar used here.
!- Three options exist :
!-  - gregorian : This is the gregorian calendar (default here)
!-  - noleap    : A calendar without leap years = 365 days
!-  - xxxd      : A calendar of xxx days (has to be a modulo of 12)
!-                with 12 month of equal length
!-
!- This routine will lock the calendar.
!- You do not want it to change after your inquiry.
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=*),INTENT(OUT) :: str
!---------------------------------------------------------------------
  lock_one_year = .TRUE.
!-
  str = calendar_used
!--------------------------------
END SUBROUTINE ioget_calendar_str
!-
!===
!-
SUBROUTINE ioget_calendar_real1 (long_year)
!---------------------------------------------------------------------
!- This subroutine returns the name of the calendar used here.
!- Three options exist :
!-  - gregorian : This is the gregorian calendar (default here)
!-  - noleap    : A calendar without leap years = 365 days
!-  - xxxd      : A calendar of xxx days (has to be a modulo of 12)
!-                with 12 month of equal length
!-
!- This routine will lock the calendar.
!- You do not want it to change after your inquiry.
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  REAL,INTENT(OUT) :: long_year
!---------------------------------------------------------------------
  long_year = one_year
  lock_one_year = .TRUE.
!----------------------------------
END SUBROUTINE ioget_calendar_real1
!-
!===
!-
SUBROUTINE ioget_calendar_real2 (long_year,long_day)
!---------------------------------------------------------------------
!- This subroutine returns the name of the calendar used here.
!- Three options exist :
!-  - gregorian : This is the gregorian calendar (default here)
!-  - noleap    : A calendar without leap years = 365 days
!-  - xxxd      : A calendar of xxx days (has to be a modulo of 12)
!-                with 12 month of equal length
!-
!- This routine will lock the calendar.
!- You do not want it to change after your inquiry.
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  REAL,INTENT(OUT) :: long_year,long_day
!---------------------------------------------------------------------
  long_year = one_year
  long_day  = one_day
  lock_one_year = .TRUE.
!----------------------------------
END SUBROUTINE ioget_calendar_real2
!-
!===
!-
INTEGER FUNCTION ioget_mon_len (year,month)
!!--------------------------------------------------------------------
!! The "ioget_mon_len" function returns
!! the number of days in a "month" of a "year",
!! in the current calendar.
!!
!! INTEGER FUNCTION ioget_mon_len (year,month)
!!
!! INPUT
!!
!! (I) year  : year
!! (I) month : month in the year (1 --> 12)
!!
!! OUTPUT
!!
!! (I) ioget_mon_len : number of days in the month
!!--------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER,INTENT(IN) :: year,month
!-
  INTEGER :: ml
!---------------------------------------------------------------------
  IF ( (month >= 1).AND.(month <= 12) ) THEN
    IF ( (one_year > 365.0).AND.(one_year < 366.0) ) THEN
!---- "Gregorian" or "Julian"
      ml = mon_len(month)
      IF (month == 2) THEN
        IF (ABS(one_year-365.2425) <= EPSILON(one_year) ) THEN
!-------- "Gregorian"
          IF (    ((MOD(year,4) == 0).AND.(MOD(year,100) /= 0)) &
              .OR.(MOD(year,400) == 0) ) THEN
            ml = ml+1
          ENDIF
        ELSE
!-------- "Julian"
          IF (MOD(year,4) == 0) THEN
            ml = ml+1
          ENDIF
        ENDIF
      ENDIF
      ioget_mon_len = ml
    ELSE
!---- "No leap" or "All leap" or "Calendar with regular month"
      ioget_mon_len = mon_len(month)
    ENDIF
  ELSE
    CALL ipslerr (3,'ioget_mon_len', &
 &    'The number of the month','must be between','1 and 12')
  ENDIF
!-------------------------
END FUNCTION ioget_mon_len
!-
!===
!-
INTEGER FUNCTION ioget_year_len (year)
!!--------------------------------------------------------------------
!! The "ioget_year_len" function returns
!! the number of days in "year", in the current calendar.
!!
!! INTEGER FUNCTION ioget_year_len (year)
!!
!! INPUT
!!
!! (I) year  : year
!!
!! OUTPUT
!!
!! (I) ioget_year_len : number of days in the year
!!--------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER,INTENT(IN) :: year
!-
  INTEGER :: yl
!---------------------------------------------------------------------
  SELECT CASE(TRIM(calendar_used))
  CASE('gregorian')
    yl = 365
    IF (    ((MOD(year,4) == 0).AND.(MOD(year,100) /= 0)) &
        .OR.(MOD(year,400) == 0) ) THEN
      yl = yl+1
    ENDIF
  CASE('julian')
    yl = 365
    IF (MOD(year,4) == 0) THEN
      yl = yl+1
    ENDIF
  CASE DEFAULT
    yl = NINT(one_year)
  END SELECT
  ioget_year_len = yl
!--------------------------
END FUNCTION ioget_year_len
!-
!===
!-
SUBROUTINE ioget_timestamp (string)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=30),INTENT(OUT) :: string
!-
  INTEGER :: date_time(8)
  CHARACTER(LEN=10) :: bigben(3)
!---------------------------------------------------------------------
  IF (INDEX(time_stamp,'XXXXXX') > 0) THEN
    CALL DATE_AND_TIME (bigben(1),bigben(2),bigben(3),date_time)
!---
    WRITE(time_stamp, &
 &   "(I4.4,'-',A3,'-',I2.2,' ',I2.2,':',I2.2,':',I2.2,' GMT',a5)") &
 &   date_time(1),cal(date_time(2)),date_time(3),date_time(5), &
 &   date_time(6),date_time(7),bigben(3)
  ENDIF
!-
  string = time_stamp
!-----------------------------
END SUBROUTINE ioget_timestamp
!-
!===
!-
SUBROUTINE time_add &
 &  (year_s,month_s,day_s,sec_s,sec_increment, &
 &   year_e,month_e,day_e,sec_e)
!---------------------------------------------------------------------
!- This subroutine allows to increment a date by a number of seconds.
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER,INTENT(IN) :: year_s,month_s,day_s
  REAL,INTENT(IN)    :: sec_s
!-
! Time in seconds to be added to the date
!-
  REAL,INTENT(IN)    :: sec_increment
!-
  INTEGER,INTENT(OUT) :: year_e,month_e,day_e
  REAL,INTENT(OUT)    :: sec_e
!-
  INTEGER :: julian_day
  REAL    :: julian_sec
!---------------------------------------------------------------------
  CALL ymds2ju_internal &
 &  (year_s,month_s,day_s,sec_s,julian_day,julian_sec)
!-
  julian_sec = julian_sec+sec_increment
!-
  CALL ju2ymds_internal &
 &  (julian_day,julian_sec,year_e,month_e,day_e,sec_e)
!----------------------
END SUBROUTINE time_add
!-
!===
!-
SUBROUTINE time_diff &
 &  (year_s,month_s,day_s,sec_s,year_e,month_e,day_e,sec_e,sec_diff)
!---------------------------------------------------------------------
!- This subroutine allows to determine the number of seconds
!- between two dates.
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER,INTENT(IN) :: year_s,month_s,day_s
  REAL,INTENT(IN)    :: sec_s
  INTEGER,INTENT(IN) :: year_e,month_e,day_e
  REAL,INTENT(IN)    :: sec_e
!-
! Time in seconds between the two dates
!-
  REAL,INTENT(OUT)    :: sec_diff
!-
  INTEGER :: julian_day_s,julian_day_e,day_diff
  REAL    :: julian_sec_s,julian_sec_e
!---------------------------------------------------------------------
  CALL ymds2ju_internal &
 &  (year_s,month_s,day_s,sec_s,julian_day_s,julian_sec_s)
  CALL ymds2ju_internal &
 &  (year_e,month_e,day_e,sec_e,julian_day_e,julian_sec_e)
!-
  day_diff = julian_day_e-julian_day_s
  sec_diff = julian_sec_e-julian_sec_s
!-
  sec_diff = sec_diff+day_diff*one_day
!-----------------------
END SUBROUTINE time_diff
!-
!===
!-
END MODULE calendar