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_utils.F90 in branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/TOOLS/OBSTOOLS/src – NEMO

source: branches/2014/dev_r4650_UKMO7_STARTHOUR/NEMOGCM/TOOLS/OBSTOOLS/src/date_utils.F90 @ 5985

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

Reinstate keywords before upgrading to head of trunk

  • Property svn:keywords set to Id
File size: 11.6 KB
Line 
1MODULE date_utils
2
3   USE toolspar_kind
4   IMPLICIT NONE
5
6CONTAINS
7
8   SUBROUTINE add_date(initial_date,hours,final_date)
9
10      ! Add a number of hours to initial_date and return it in final_date
11
12      IMPLICIT NONE
13
14
15      !! Arguments
16      INTEGER,INTENT(in) :: initial_date ! Initial date (YYYYMMDDHH)
17      INTEGER,INTENT(in) :: hours        ! Number of hours to add
18      INTEGER,INTENT(out) :: final_date  ! Final date (YYYYMMDDHH)
19
20      !! Local variables
21
22      INTEGER :: isec,imin,ihours,iyear,imon,iday ! temporary results
23      REAL(dp):: juld
24
25      CALL split_date(initial_date,iyear,imon,iday,ihours)
26
27      CALL greg2jul(0,0,ihours,iday,imon,iyear,juld)
28
29      juld=juld+REAL(hours)/24.0
30
31      CALL jul2greg(isec,imin,ihours,iday,imon,iyear,juld)
32
33      final_date=iyear*1000000+imon*10000+iday*100+ihours
34
35   END SUBROUTINE add_date
36
37
38   SUBROUTINE add_days_to_date(initial_date,days,final_date)
39
40      ! Add a number of days to initial_date and return it in final_date
41
42      IMPLICIT NONE
43
44
45      !! Arguments
46      INTEGER,INTENT(in) :: initial_date ! Initial date (YYYYMMDD)
47      INTEGER,INTENT(in) :: days         ! Number of days to add
48      INTEGER,INTENT(out) :: final_date  ! Final date (YYYYMMDD)
49
50      !! Local variables
51
52      INTEGER :: isec,imin,ihours,iyear,imon,iday ! temporary results
53      REAL(dp):: juld
54
55      ! Account for lack of hours in date format (initial_date*100)
56      CALL split_date(initial_date*100,iyear,imon,iday,ihours)
57
58      CALL greg2jul(0,0,ihours,iday,imon,iyear,juld)
59
60      juld=juld+REAL(days)
61
62      CALL jul2greg(isec,imin,ihours,iday,imon,iyear,juld)
63
64      final_date=(iyear*1000000+imon*10000+iday*100+ihours)/100
65
66   END SUBROUTINE add_days_to_date
67
68
69   SUBROUTINE split_date(iyyyymmddhh,iyyyy,imm,idd,ihh)
70
71      ! Splits a date in YYYYMMDDHH format into iyyyy, imm, idd, ihh
72
73      IMPLICIT NONE
74      INTEGER,INTENT(in) :: iyyyymmddhh
75      INTEGER,INTENT(out) :: iyyyy,imm,idd,ihh
76
77      iyyyy=iyyyymmddhh/1000000
78      imm=iyyyymmddhh/10000-iyyyy*100
79      idd=iyyyymmddhh/100-(iyyyy*10000+imm*100)
80      ihh=MOD(iyyyymmddhh,100)
81
82   END SUBROUTINE split_date
83
84   SUBROUTINE jul2greg( ksec, kminut, khour, kday, kmonth, kyear, &
85      &                           prelday )
86
87      IMPLICIT NONE
88      !!-----------------------------------------------------------------------
89      !!
90      !!                     ***  ROUTINE jul2greg  ***
91      !!
92      !! ** Purpose : Take the relative time in days and re-express in terms of
93      !!              seconds, minutes, hours, days, month, year.
94      !!
95      !! ** Method  : Reference date : 19500101
96      !!
97      !! ** Action  :
98      !!
99      !! History
100      !!      ! 06-04  (A. Vidard) Original
101      !!      ! 06-05  (A. Vidard) Reformatted and refdate     
102      !!      ! 06-10  (A. Weaver) Cleanup
103      !!-----------------------------------------------------------------------
104
105      ! * Arguments
106      INTEGER, INTENT(OUT) :: &
107         & ksec,   &
108         & kminut, &
109         & khour,  &
110         & kday,   &
111         & kmonth, &
112         & kyear
113      REAL(KIND=dp), INTENT(IN) :: &
114         & prelday
115
116      !! * Local declarations
117      INTEGER, PARAMETER :: &
118         & jpgreg = 2299161, &
119         & jporef = 2433283, &
120         & jparef = 2415021
121      INTEGER :: &
122         & ijulian, &
123         & ij1,     &
124         & ija,     &
125         & ijb,     &
126         & ijc,     &
127         & ijd,     &
128         & ije,     &
129         & isec,    &
130         & imin,    &
131         & ihou,    &
132         & iday,    &
133         & imon,    &
134         & iyea,    &
135         & iref
136      REAL(KIND=wp) :: &
137         & zday, &
138         & zref
139
140      ! Main computation
141      iref = jporef 
142
143      zday = prelday
144      ksec = NINT( 86400. * MOD( zday, 1.0_wp ) )
145
146      IF ( ksec < 0. ) ksec = 86400. + ksec
147
148      khour  = ksec / 3600
149      kminut = ( ksec - 3600 * khour ) / 60
150      ksec   = MOD( ksec , 60 )
151
152      ijulian = iref + INT( zday )
153      IF ( zday < 0. ) ijulian = ijulian - 1
154
155      ! If input date after 10/15/1582 :
156      IF ( ijulian >= jpgreg ) THEN
157         ij1 = INT( ( DBLE( ijulian - 1867216 ) - 0.25 ) / 36524.25 )
158         ija = ijulian + 1 + ij1 - INT( ( 0.25 * ij1 ) )
159      ELSE
160         ija = ijulian
161      ENDIF
162
163      ijb = ija + 1524
164      ijc = INT( 6680. + ( DBLE ( ijb - 2439870 ) - 122.1 ) / 365.25 )
165      ijd = 365 * ijc + INT( 0.25 * ijc )
166      ije = INT( ( ijb - ijd ) / 30.6001 )
167      kday = ijb - ijd - INT( 30.6001 * ije )
168      kmonth = ije - 1
169      IF ( kmonth > 12 ) kmonth = kmonth - 12
170      kyear = ijc - 4715
171      IF ( kmonth > 2 ) kyear = kyear - 1
172      IF ( kyear <= 0 ) kyear = kyear - 1
173
174   END SUBROUTINE jul2greg
175
176   SUBROUTINE greg2jul( ksec, kmin, khour, kday, kmonth, kyear, pjulian )
177
178      IMPLICIT NONE
179      !!-----------------------------------------------------------------------
180      !!
181      !!                     ***  ROUTINE greg2jul  ***
182      !!
183      !! ** Purpose : Produce the time relative to the current date and time.
184      !!
185      !! ** Method  : The units are days, so hours and minutes transform to
186      !!              fractions of a day.
187      !!
188      !!              Reference date : 19500101
189      !! ** Action  :
190      !!
191      !! History :
192      !!      ! 06-04  (A. Vidard) Original
193      !!      ! 06-04  (A. Vidard) Reformatted
194      !!      ! 06-10  (A. Weaver) Cleanup
195      !!-----------------------------------------------------------------------
196
197      ! * Arguments
198      INTEGER, INTENT(IN) :: &
199         & ksec,   &
200         & kmin,   &
201         & khour,  & 
202         & kday,   &
203         & kmonth, & 
204         & kyear
205      REAL(KIND=dp), INTENT(OUT) :: &
206         & pjulian
207
208      !! * Local declarations
209      INTEGER, PARAMETER :: &
210         & jpgreg = 15 + 31 * ( 10 + 12 * 1582 ), &  ! Gregorian calendar introduction date
211         & jpjref = 2433283                          ! Julian reference date: 19500101
212      INTEGER :: &
213         & ija,     &
214         & ijy,     &
215         & ijm,     &
216         & ijultmp, &
217         & ijyear
218
219      ! Main computation
220      ijyear = kyear
221      IF ( ijyear < 0 ) ijyear = ijyear + 1
222      IF ( kmonth > 2 ) THEN
223         ijy = ijyear
224         ijm = kmonth + 1
225      ELSE
226         ijy = ijyear  - 1
227         ijm = kmonth + 13
228      ENDIF
229      ijultmp = INT( 365.25 * ijy ) + INT( 30.6001 * ijm ) + kday + 1720995
230      IF ( kday + 31 * ( kmonth + 12 * ijyear ) >= jpgreg ) THEN
231         ija = INT( 0.01 * ijy )
232         ijultmp = ijultmp + 2 - ija + INT( 0.25 * ija )
233      ENDIF
234      pjulian = ( ijultmp - jpjref ) + ( ( 60 * khour + kmin ) * 60 + ksec ) / 86400.
235
236   END SUBROUTINE greg2jul
237
238
239   SUBROUTINE addseconds(iyear,imon,iday,ihour,imin,isec,iaddsec)
240
241      ! Add iaddsecs to the date and return the new date (in place)
242
243      !! Arguments
244
245      INTEGER,intent(inout) :: iyear,imon,iday,ihour,imin,isec,iaddsec
246
247      !! Local variables
248
249      INTEGER :: itotsec,idays,isecs
250      INTEGER :: mday(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) 
251
252      itotsec=iaddsec+ihour*3600*imin*60+isec
253
254      IF (itotsec<0) THEN
255         WRITE(*,*)'Negative itotsec in addseconds'
256         WRITE(*,*)'This does not work'
257         RETURN
258      ENDIF
259
260      ihour=0
261      imin=0
262      isec=0
263
264      idays=itotsec/86400
265      isecs=itotsec-idays*86400
266      iday=iday+idays
267
268      ! Compute the date
269      DO
270         ! Leap year
271         mday(2)=28
272         IF (MOD(iyear,4).EQ.0) mday(2)=29
273         IF (MOD(iyear,100).EQ.0) mday(2)=28
274         IF (MOD(iyear,400).EQ.0) mday(2)=29
275         IF (MOD(iyear,4000).EQ.0) mday(2)=28
276
277         IF (iday.GT.mday(imon))THEN
278            iday=iday-mday(imon)
279            imon=imon+1
280            IF(imon.GT.12)THEN
281               imon=1
282               iyear=iyear+1
283            ENDIF
284         ELSE
285            EXIT
286         ENDIF
287
288      ENDDO
289
290      ! Set the time
291      ihour=isecs/3600
292      imin=isecs/60-ihour*60
293      isec=isecs-ihour*3600-imin*60
294
295   END SUBROUTINE addseconds
296
297   INTEGER FUNCTION nextdate(idate)
298
299      ! Return next date.
300      ! Date format is assumed to be YYYYMMDD
301
302      IMPLICIT NONE
303
304      !! Arguments
305
306      INTEGER :: idate ! Initial date
307
308      !! Local variables
309
310      INTEGER :: year,day,mon
311      INTEGER :: mday(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/)
312
313
314      day=MOD(idate,100)
315      mon=MOD((idate-day)/100,100)
316      year=idate/10000
317
318      mday(2)=28
319      IF (MOD(year,4).EQ.0) mday(2)=29
320      IF (MOD(year,100).EQ.0) mday(2)=28
321      IF (MOD(year,400).EQ.0) mday(2)= 29
322      IF (MOD(year,4000).EQ.0) mday(2) = 28
323
324      day=day+1
325      IF (day.GT.mday(mon))THEN
326         day=1
327         mon=mon+1
328         IF(mon.GT.12)THEN
329            mon=1
330            year=year+1
331         ENDIF
332      ENDIF
333      nextdate=year*10000+mon*100+day
334      RETURN
335
336   END FUNCTION nextdate
337
338   INTEGER FUNCTION prevdate(idate)
339
340      ! Return previous date.
341      ! Date format is assumed to be YYYYMMDD
342
343      IMPLICIT NONE
344
345      !! Arguments
346
347      INTEGER :: idate ! Initial date
348
349      !! Local variables
350
351      INTEGER :: year,day,mon
352      INTEGER :: mday(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/)
353
354
355      day=MOD(idate,100)
356      mon=MOD((idate-day)/100,100)
357      year=idate/10000
358
359      mday(2)=28
360      IF (MOD(year,4).EQ.0) mday(2)=29
361      IF (MOD(year,100).EQ.0) mday(2)=28
362      IF (MOD(year,400).EQ.0) mday(2)= 29
363      IF (MOD(year,4000).EQ.0) mday(2) = 28
364
365      day=day-1
366      IF (day.LT.1)THEN
367         mon=mon-1
368         IF(mon.LT.1)THEN
369            mon=12
370            year=year-1
371         ENDIF
372         day=mday(mon)
373      ENDIF
374      prevdate=year*10000+mon*100+day
375      RETURN
376
377   END FUNCTION prevdate
378
379   INTEGER FUNCTION diffdate(idate1,idate2)
380
381      ! Compute difference in days between dates
382      ! Assumes YYYYMMDD format for dates
383
384      IMPLICIT NONE
385
386      !! Argument
387
388      INTEGER :: idate1,idate2    ! Dates to be diffed.
389
390      !! Local variables
391
392      INTEGER :: itdate1,itdate2
393      INTEGER :: it
394
395      itdate1=MIN(idate1,idate2)
396      itdate2=MAX(idate1,idate2)
397
398      IF (itdate1==itdate2) THEN
399         diffdate=0
400         RETURN
401      ENDIF
402      diffdate=0
403      it=itdate1
404      DO
405         it=nextdate(it)
406         diffdate=diffdate+1
407         IF (it==itdate2) EXIT
408      ENDDO
409      RETURN
410
411   END FUNCTION diffdate
412
413   INTEGER FUNCTION difftime(itime1,itime2)
414
415      ! Compute difference in minutes between times
416      ! Assumes HHMM or HMM or MM or M format for dates
417      !
418      ! ORDER MATTERS - itime1 is ealier time
419      ! Result is an integer number of minutes
420
421      IMPLICIT NONE
422      INTEGER, INTENT(IN) :: itime1,itime2    ! Times to be diffed.
423      INTEGER :: imin1, imin2, ihr1, ihr2
424
425      ihr1 = (itime1/100)
426      ihr2 = (itime2/100)
427     
428      imin1 = (itime1 - ihr1*100) + (60 * ihr1)
429      imin2 = (itime2 - ihr2*100) + (60 * ihr2)
430     
431      ! Assume that itime2 is later, so wrap around midnight if necessary.
432      IF (imin2 < imin1) THEN
433         imin2 = imin2 + 24*60
434      END IF
435     
436      difftime = imin2 - imin1
437     
438   END FUNCTION difftime
439
440
441   INTEGER FUNCTION add_mins_to_time(itime1, imin_add)
442
443      ! Add number of minutes onto given time
444      ! Assumes time in HHMM or HMM or MM or M format
445      !
446      ! Result is in HHMM format
447
448      IMPLICIT NONE
449      INTEGER, INTENT(IN) :: itime1,imin_add
450      INTEGER :: imin1, ihr1, imin2, ihr2
451
452      ihr1 = (itime1/100)
453     
454      ! itime1 in minutes from previous midnight
455      imin1 = (itime1 - ihr1*100) + (60 * ihr1)
456     
457      imin1 = imin1 + imin_add
458     
459      ! Add 1day if time went nagative
460      IF (imin1 < 0) THEN
461         imin1 = imin1 + 24*60
462      END IF
463     
464      ! Turn number of minutes back into HHMM
465      ihr2 = imin1/60
466      imin2 = imin1 - ihr2*60
467
468      DO
469         IF (ihr2<0) THEN
470            ihr2 = ihr2 + 24
471         ELSE IF (ihr2>=24) THEN
472            ihr2 = ihr2 - 24
473         END IF
474         IF ((ihr2>=0).OR.(ihr2<24)) EXIT
475      END DO
476
477      add_mins_to_time = ihr2*100 + imin2
478   
479   END FUNCTION add_mins_to_time
480
481
482END MODULE date_utils
Note: See TracBrowser for help on using the repository browser.