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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 31 by guez, Thu Apr 1 09:07:28 2010 UTC revision 32 by guez, Tue Apr 6 17:52:58 2010 UTC
# Line 22  MODULE calendar Line 22  MODULE calendar
22    !-   un_jour : one day in seconds    !-   un_jour : one day in seconds
23    !-   un_an   : one year in days    !-   un_an   : one year in days
24    !---------------------------------------------------------------------    !---------------------------------------------------------------------
25    USE stringop, ONLY : strlowercase    USE strlowercase_m, ONLY : strlowercase
26    USE errioipsl, ONLY : histerr    USE errioipsl, ONLY : histerr
27    !-    !-
28    PRIVATE    PRIVATE
29    PUBLIC :: ymds2ju,ju2ymds,tlen2itau,isittime,ioconf_calendar, &    PUBLIC :: ymds2ju,ju2ymds,isittime,ioconf_calendar, &
30         &          ioget_calendar,itau2date,ioget_timestamp, &         ioget_calendar,itau2date, ioconf_startdate
        &          ioconf_startdate,itau2ymds,time_diff,time_add  
31    !-    !-
32    INTERFACE ioget_calendar    INTERFACE ioget_calendar
33       MODULE PROCEDURE &       MODULE PROCEDURE &
34            &    ioget_calendar_real1,ioget_calendar_real2,ioget_calendar_str            &    ioget_calendar_real1,ioget_calendar_real2,ioget_calendar_str
35    END INTERFACE    END INTERFACE
36    !-    !-
   INTERFACE ioconf_startdate  
      MODULE PROCEDURE &  
           &    ioconf_startdate_simple,ioconf_startdate_internal, &  
           &    ioconf_startdate_ymds  
   END INTERFACE  
   !-  
37    REAL,PARAMETER :: un_jour = 86400.0    REAL,PARAMETER :: un_jour = 86400.0
38    LOGICAL,SAVE :: lock_startdate = .FALSE.    LOGICAL,SAVE :: lock_startdate = .FALSE.
39    !-    !-
# Line 254  CONTAINS Line 247  CONTAINS
247    !-    !-
248    !===    !===
249    !-    !-
   SUBROUTINE tlen2itau (input_str,dt,date,itau)  
     !---------------------------------------------------------------------  
     !- This subroutine transforms a sting 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(*,*) tmp_str  
           !---- WRITE(*,*) 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)*un_jour+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)*un_jour+ 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*un_jour/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  
   !-  
   !===  
   !-  
250    REAL FUNCTION itau2date (itau,date0,deltat)    REAL FUNCTION itau2date (itau,date0,deltat)
251      !---------------------------------------------------------------------      !---------------------------------------------------------------------
252      !- This function transforms itau into a date. The date whith which      !- This function transforms itau into a date. The date whith which
# Line 371  CONTAINS Line 271  CONTAINS
271    !-    !-
272    !===    !===
273    !-    !-
   SUBROUTINE itau2ymds (itau,deltat,year,month,date,sec)  
     !---------------------------------------------------------------------  
     !- This subroutine transforms itau into a date. The date whith 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  
     !-   date : date  
     !-   sec  : seconds since midnight  
     !---------------------------------------------------------------------  
     IMPLICIT NONE  
   
     INTEGER,INTENT(IN) :: itau  
     REAL,INTENT(IN)    :: deltat  
   
     INTEGER,INTENT(OUT) :: year,month,date  
     REAL,INTENT(OUT)    :: sec  
   
     INTEGER :: julian_day  
     REAL    :: julian_sec  
     !---------------------------------------------------------------------  
     julian_day = start_day  
     julian_sec = start_sec+REAL(itau)*deltat  
   
     CALL ju2ymds_internal (julian_day,julian_sec,year,month,date,sec)  
     !-----------------------  
   END SUBROUTINE itau2ymds  
   !-  
   !===  
   !-  
274    SUBROUTINE isittime &    SUBROUTINE isittime &
275         &  (itau,date0,dt,freq,last_action,last_check,do_action)         &  (itau,date0,dt,freq,last_action,last_check,do_action)
276      !---------------------------------------------------------------------      !---------------------------------------------------------------------
# Line 637  CONTAINS Line 502  CONTAINS
502    !-    !-
503    !===    !===
504    !-    !-
   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)*un_jour  
   
     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  
        lock_startdate = .TRUE.  
        start_day = julian_day  
        start_sec = julian_sec  
     ELSE  
        WRITE(str70a,'("The date you tried to set : ",f10.4)') &  
             &   julian_day,julian_sec/un_jour  
        WRITE(str70b, &  
             &   '("The date which was already set in the calendar : ",f10.4)') &  
             &   start_day+start_sec/un_jour  
        CALL histerr (2,'ioconf_startdate', &  
             &   'The start date has already been set and you tried to change it', &  
             &   str70a,str70b)  
     ENDIF  
   
     lock_startdate = .TRUE.  
     !---------------------------------------  
   END SUBROUTINE ioconf_startdate_internal  
   !-  
   !===  
   !-  
505    SUBROUTINE ioget_calendar_str (str)    SUBROUTINE ioget_calendar_str (str)
506      !---------------------------------------------------------------------      !---------------------------------------------------------------------
507      !- This subroutine returns the name of the calendar used here.      !- This subroutine returns the name of the calendar used here.
# Line 778  CONTAINS Line 572  CONTAINS
572      long_jour = un_jour      long_jour = un_jour
573      !----------------------------------      !----------------------------------
574    END SUBROUTINE ioget_calendar_real2    END SUBROUTINE ioget_calendar_real2
   !-  
   !===  
   !-  
   SUBROUTINE ioget_timestamp (string)  
     !---------------------------------------------------------------------  
     IMPLICIT NONE  
575    
     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*un_jour  
     !-----------------------  
   END SUBROUTINE time_diff  
   !-  
   !===  
   !-  
576  END MODULE calendar  END MODULE calendar
Legend:
Removed from v.31  
changed lines
  Added in v.32
  ViewVC Help
Powered by ViewVC 1.1.21