source: lmdz_wrf/trunk/WRFV3/share/module_date_time.F @ 831

Last change on this file since 831 was 1, checked in by lfita, 10 years ago
  • -- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 31.4 KB
Line 
1!WRF:MODEL_LAYER:UTIL
2!
3MODULE module_date_time
4
5  USE module_wrf_error
6  USE module_configure
7  USE module_model_constants
8
9  CHARACTER* 24 ::   start_date = '                        '
10  CHARACTER* 24 ::   current_date
11  INTEGER , PARAMETER :: len_current_date  = 24
12  REAL , PRIVATE :: xtime
13
14!  1.  geth_idts (ndate, odate, idts)
15!  Get the time period between two dates.
16
17!  2. geth_newdate ( ndate, odate, idts)
18!  Get the new date based on the old date and a time difference.
19
20!  3. split_date_char ( date , century_year , month , day , hour , minute , second , ten_thousandth)
21!  Given the date, return the integer components.
22
23CONTAINS
24
25!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
26
27   SUBROUTINE get_julgmt(date_str,julyr,julday,gmt)
28     IMPLICIT NONE
29! Arguments
30     CHARACTER (LEN=24) , INTENT(IN) :: date_str
31     INTEGER, INTENT(OUT  ) :: julyr
32     INTEGER, INTENT(OUT  ) :: julday
33     REAL   , INTENT(OUT  ) :: gmt
34! Local
35     INTEGER :: ny , nm , nd , nh , ni , ns , nt
36     INTEGER :: my1, my2, my3, monss
37     INTEGER, DIMENSION(12) :: mmd
38     DATA MMD/31,28,31,30,31,30,31,31,30,31,30,31/
39     CALL split_date_char ( date_str , ny , nm , nd , nh , ni , ns , nt )
40#ifdef PLANET
41     GMT=nh+FLOAT(ni)/60.+(FLOAT(ns)+FLOAT(nt)/1.e6)/3600.
42     JULDAY=nd
43     JULYR=ny
44#else
45     GMT=nh+FLOAT(ni)/60.+FLOAT(ns)/3600.
46     MY1=MOD(ny,4)
47     MY2=MOD(ny,100)
48     MY3=MOD(ny,400)
49     IF(MY1.EQ.0.AND.MY2.NE.0.OR.MY3.EQ.0)MMD(2)=29
50     JULDAY=nd
51     JULYR=ny
52     DO MONSS=1,nm-1
53       JULDAY=JULDAY+MMD(MONSS)
54     ENDDO
55#endif
56   END SUBROUTINE get_julgmt
57
58
59   SUBROUTINE geth_julgmt(julyr,julday, gmt)
60     IMPLICIT NONE
61! Arguments
62     INTEGER, INTENT(OUT  ) :: julyr
63     INTEGER, INTENT(OUT  ) :: julday
64     REAL   , INTENT(OUT  ) :: gmt
65! Local
66     INTEGER :: ny , nm , nd , nh , ni , ns , nt
67     INTEGER :: my1, my2, my3, monss
68     INTEGER, DIMENSION(12) :: mmd
69     DATA MMD/31,28,31,30,31,30,31,31,30,31,30,31/
70     CALL split_date_char ( current_date , ny , nm , nd , nh , ni , ns , nt )
71#ifdef PLANET
72     GMT=nh+FLOAT(ni)/60.+(FLOAT(ns)+FLOAT(nt)/1.e6)/3600.
73     JULDAY=nd
74     JULYR=ny
75#else
76     GMT=nh+FLOAT(ni)/60.+FLOAT(ns)/3600.
77     MY1=MOD(ny,4)
78     MY2=MOD(ny,100)
79     MY3=MOD(ny,400)
80     IF(MY1.EQ.0.AND.MY2.NE.0.OR.MY3.EQ.0)MMD(2)=29
81     JULDAY=nd
82     JULYR=ny
83     DO MONSS=1,nm-1
84       JULDAY=JULDAY+MMD(MONSS)
85     ENDDO
86#endif
87   END SUBROUTINE geth_julgmt
88
89   SUBROUTINE calc_current_date (id, time)
90! This subroutines calculates current_date and xtime
91   IMPLICIT NONE
92! Arguments
93   INTEGER, INTENT(IN   ) :: id ! grid id
94   REAL, INTENT(IN   ) :: time ! time in seconds since start time
95! Local
96   INTEGER :: julyr, julday, idt
97   CHARACTER*19  new_date
98   CHARACTER*24  base_date
99   CHARACTER*128 mess
100   REAL :: gmt
101
102    xtime = time/60.
103    CALL nl_get_gmt (id, gmt)
104    CALL nl_get_julyr (id, julyr)
105    CALL nl_get_julday (id, julday)
106    idt        = 86400*(julday-1)+nint(3600*gmt)
107    write (mess,*) 'calc_current_date called: time = ',time,' idt = ',idt
108    CALL wrf_debug(300,TRIM(mess))
109    write (mess,*) 'calc_current_date called: gmt  = ',gmt
110    CALL wrf_debug(300,TRIM(mess))
111    write (mess,*) 'calc_current_date called: julyr  = ',julyr
112    CALL wrf_debug(300,TRIM(mess))
113    write (mess,*) 'calc_current_date called: julday = ',julday
114    CALL wrf_debug(300,TRIM(mess))
115#ifdef PLANET
116    base_date  = '0000-00001_00:00:00.0000'
117#else
118    base_date  = '0000-01-01_00:00:00.0000'
119#endif
120    write(base_date(1:4),'(I4.4)')julyr
121    CALL geth_newdate (start_date(1:19), base_date(1:19), idt)
122    CALL geth_newdate (new_date, start_date(1:19), nint(time))
123    write (current_date(1:24),fmt=340)new_date
124    340 format(a19, '.0000')
125    write (mess,*) current_date,gmt,julday,julyr,'=current_date,gmt,julday,julyr: calc_current_date'
126    CALL wrf_debug(300,TRIM(mess))
127   END SUBROUTINE calc_current_date
128
129!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
130
131   SUBROUTINE geth_idts (ndate, odate, idts)
132   
133      IMPLICIT NONE
134     
135      !  From 2 input mdates ('YYYY-MM-DD HH:MM:SS.ffff'),
136      !                   or ('YYYY-DDDDD HH:MM:SS.ffff'),
137      !  compute the time difference.
138     
139      !  on entry     -  ndate  -  the new hdate.
140      !                  odate  -  the old hdate.
141     
142      !  on exit      -  idts    -  the change in time in seconds.
143     
144      CHARACTER (LEN=*) , INTENT(INOUT) :: ndate, odate
145      INTEGER           , INTENT(OUT)   :: idts
146     
147      !  Local Variables
148     
149      !  yrnew    -  indicates the year associated with "ndate"
150      !  yrold    -  indicates the year associated with "odate"
151      !  monew    -  indicates the month associated with "ndate"
152      !  moold    -  indicates the month associated with "odate"
153      !  dynew    -  indicates the day associated with "ndate"
154      !  dyold    -  indicates the day associated with "odate"
155      !  hrnew    -  indicates the hour associated with "ndate"
156      !  hrold    -  indicates the hour associated with "odate"
157      !  minew    -  indicates the minute associated with "ndate"
158      !  miold    -  indicates the minute associated with "odate"
159      !  scnew    -  indicates the second associated with "ndate"
160      !  scold    -  indicates the second associated with "odate"
161      !  i        -  loop counter
162      !  mday     -  a list assigning the number of days in each month
163     
164      CHARACTER (LEN=24) :: tdate
165      INTEGER :: olen, nlen
166      INTEGER :: yrnew, monew, dynew, hrnew, minew, scnew
167      INTEGER :: yrold, moold, dyold, hrold, miold, scold
168      INTEGER :: mday(12), i, newdys, olddys
169      LOGICAL :: npass, opass
170      INTEGER :: isign
171     
172      IF (odate.GT.ndate) THEN
173         isign = -1
174         tdate=ndate
175         ndate=odate
176         odate=tdate
177      ELSE
178         isign = 1
179      END IF
180     
181      !  Assign the number of days in a months
182     
183      mday( 1) = 31
184      mday( 2) = 28
185      mday( 3) = 31
186      mday( 4) = 30
187      mday( 5) = 31
188      mday( 6) = 30
189      mday( 7) = 31
190      mday( 8) = 31
191      mday( 9) = 30
192      mday(10) = 31
193      mday(11) = 30
194      mday(12) = 31
195     
196      !  Break down old hdate into parts
197     
198      hrold = 0
199      miold = 0
200      scold = 0
201      olen = LEN(odate)
202     
203      READ(odate(1:4),  '(I4)') yrold
204#ifdef PLANET
205      READ(odate(6:10), '(I5)') dyold
206      moold=0.
207#else
208      READ(odate(6:7),  '(I2)') moold
209      READ(odate(9:10), '(I2)') dyold
210#endif
211      IF (olen.GE.13) THEN
212         READ(odate(12:13),'(I2)') hrold
213         IF (olen.GE.16) THEN
214            READ(odate(15:16),'(I2)') miold
215            IF (olen.GE.19) THEN
216               READ(odate(18:19),'(I2)') scold
217            END IF
218         END IF
219      END IF
220     
221      !  Break down new hdate into parts
222     
223      hrnew = 0
224      minew = 0
225      scnew = 0
226      nlen = LEN(ndate)
227     
228      READ(ndate(1:4),  '(I4)') yrnew
229#ifdef PLANET
230      READ(ndate(6:10), '(I5)') dynew
231      monew=0.
232#else
233      READ(ndate(6:7),  '(I2)') monew
234      READ(ndate(9:10), '(I2)') dynew
235#endif
236      IF (nlen.GE.13) THEN
237         READ(ndate(12:13),'(I2)') hrnew
238         IF (nlen.GE.16) THEN
239            READ(ndate(15:16),'(I2)') minew
240            IF (nlen.GE.19) THEN
241               READ(ndate(18:19),'(I2)') scnew
242            END IF
243         END IF
244      END IF
245     
246      !  Check that the dates make sense.
247     
248      npass = .true.
249      opass = .true.
250     
251#ifdef PLANET
252      !  Check that the day of NDATE makes sense.
253     
254      IF ((dynew > PLANET_YEAR).or.(dynew < 1)) THEN
255         PRINT*, 'GETH_IDTS:  Day of NDATE = ', dynew
256         npass = .false.
257      END IF
258
259      !  Check that the day of ODATE makes sense.
260
261      IF ((dyold > PLANET_YEAR).or.(dyold < 1)) THEN
262         PRINT*, 'GETH_IDTS:  Day of ODATE = ', dyold
263         opass = .false.
264      END IF
265
266#else
267      !  Check that the month of NDATE makes sense.
268     
269      IF ((monew.GT.12).or.(monew.LT.1)) THEN
270         PRINT*, 'GETH_IDTS:  Month of NDATE = ', monew
271         npass = .false.
272      END IF
273     
274      !  Check that the month of ODATE makes sense.
275     
276      IF ((moold.GT.12).or.(moold.LT.1)) THEN
277         PRINT*, 'GETH_IDTS:  Month of ODATE = ', moold
278         opass = .false.
279      END IF
280     
281      !  Check that the day of NDATE makes sense.
282     
283      IF (monew.ne.2) THEN
284      ! ...... For all months but February
285         IF ((dynew.GT.mday(monew)).or.(dynew.LT.1)) THEN
286            PRINT*, 'GETH_IDTS:  Day of NDATE = ', dynew
287            npass = .false.
288         END IF
289      ELSE IF (monew.eq.2) THEN
290      ! ...... For February
291         IF ((dynew.GT.nfeb(yrnew)).OR.(dynew.LT.1)) THEN
292            PRINT*, 'GETH_IDTS:  Day of NDATE = ', dynew
293            npass = .false.
294         END IF
295      END IF
296     
297      !  Check that the day of ODATE makes sense.
298     
299      IF (moold.ne.2) THEN
300      ! ...... For all months but February
301         IF ((dyold.GT.mday(moold)).or.(dyold.LT.1)) THEN
302            PRINT*, 'GETH_IDTS:  Day of ODATE = ', dyold
303            opass = .false.
304         END IF
305      ELSE IF (moold.eq.2) THEN
306      ! ....... For February
307         IF ((dyold.GT.nfeb(yrold)).or.(dyold.LT.1)) THEN
308            PRINT*, 'GETH_IDTS:  Day of ODATE = ', dyold
309            opass = .false.
310         END IF
311      END IF
312#endif
313      !  Check that the hour of NDATE makes sense.
314     
315      IF ((hrnew.GT.23).or.(hrnew.LT.0)) THEN
316         PRINT*, 'GETH_IDTS:  Hour of NDATE = ', hrnew
317         npass = .false.
318      END IF
319     
320      !  Check that the hour of ODATE makes sense.
321     
322      IF ((hrold.GT.23).or.(hrold.LT.0)) THEN
323         PRINT*, 'GETH_IDTS:  Hour of ODATE = ', hrold
324         opass = .false.
325      END IF
326     
327      !  Check that the minute of NDATE makes sense.
328     
329      IF ((minew.GT.59).or.(minew.LT.0)) THEN
330         PRINT*, 'GETH_IDTS:  Minute of NDATE = ', minew
331         npass = .false.
332      END IF
333     
334      !  Check that the minute of ODATE makes sense.
335     
336      IF ((miold.GT.59).or.(miold.LT.0)) THEN
337         PRINT*, 'GETH_IDTS:  Minute of ODATE = ', miold
338         opass = .false.
339      END IF
340     
341      !  Check that the second of NDATE makes sense.
342     
343      IF ((scnew.GT.59).or.(scnew.LT.0)) THEN
344         PRINT*, 'GETH_IDTS:  SECOND of NDATE = ', scnew
345         npass = .false.
346      END IF
347     
348      !  Check that the second of ODATE makes sense.
349     
350      IF ((scold.GT.59).or.(scold.LT.0)) THEN
351         PRINT*, 'GETH_IDTS:  Second of ODATE = ', scold
352         opass = .false.
353      END IF
354     
355      IF (.not. npass) THEN
356         WRITE( wrf_err_message , * ) 'module_date_time: geth_idts: Bad NDATE: ', ndate(1:nlen)
357         CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
358      END IF
359     
360      IF (.not. opass) THEN
361         WRITE( wrf_err_message , * ) 'module_date_time: geth_idts: Bad ODATE: ', odate(1:olen)
362         CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
363      END IF
364     
365      !  Date Checks are completed.  Continue.
366     
367      !  Compute number of days from 1 January ODATE, 00:00:00 until ndate
368      !  Compute number of hours from 1 January ODATE, 00:00:00 until ndate
369      !  Compute number of minutes from 1 January ODATE, 00:00:00 until ndate
370     
371      newdys = 0
372#ifdef PLANET
373      DO i = yrold, yrnew - 1
374         newdys = newdys + PLANET_YEAR
375      END DO
376#else
377      DO i = yrold, yrnew - 1
378         newdys = newdys + (365 + (nfeb(i)-28))
379      END DO
380     
381      IF (monew .GT. 1) THEN
382         mday(2) = nfeb(yrnew)
383         DO i = 1, monew - 1
384            newdys = newdys + mday(i)
385         END DO
386         mday(2) = 28
387      END IF
388#endif
389     
390      newdys = newdys + dynew-1
391     
392      !  Compute number of hours from 1 January ODATE, 00:00:00 until odate
393      !  Compute number of minutes from 1 January ODATE, 00:00:00 until odate
394     
395      olddys = 0
396     
397#ifndef PLANET
398      IF (moold .GT. 1) THEN
399         mday(2) = nfeb(yrold)
400         DO i = 1, moold - 1
401            olddys = olddys + mday(i)
402         END DO
403         mday(2) = 28
404      END IF
405#endif
406     
407      olddys = olddys + dyold-1
408     
409      !  Determine the time difference in seconds
410     
411      idts = (newdys - olddys) * 86400
412      idts = idts + (hrnew - hrold) * 3600
413      idts = idts + (minew - miold) * 60
414      idts = idts + (scnew - scold)
415     
416      IF (isign .eq. -1) THEN
417         tdate=ndate
418         ndate=odate
419         odate=tdate
420         idts = idts * isign
421      END IF
422   
423   END SUBROUTINE geth_idts
424
425!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
426
427   SUBROUTINE geth_newdate (ndate, odate, idt)
428   
429      IMPLICIT NONE
430     
431      !  From old date ('YYYY-MM-DD HH:MM:SS.ffff') and
432      !            [or ('YYYY-DDDDD HH:MM:SS.ffff')]
433      !  delta-time, compute the new date.
434   
435      !  on entry     -  odate  -  the old hdate.
436      !                  idt    -  the change in time
437   
438      !  on exit      -  ndate  -  the new hdate.
439     
440      INTEGER , INTENT(IN)           :: idt
441      CHARACTER (LEN=*) , INTENT(OUT) :: ndate
442      CHARACTER (LEN=*) , INTENT(IN)  :: odate
443     
444       
445      !  Local Variables
446       
447      !  yrold    -  indicates the year associated with "odate"
448      !  moold    -  indicates the month associated with "odate"
449      !  dyold    -  indicates the day associated with "odate"
450      !  hrold    -  indicates the hour associated with "odate"
451      !  miold    -  indicates the minute associated with "odate"
452      !  scold    -  indicates the second associated with "odate"
453       
454      !  yrnew    -  indicates the year associated with "ndate"
455      !  monew    -  indicates the month associated with "ndate"
456      !  dynew    -  indicates the day associated with "ndate"
457      !  hrnew    -  indicates the hour associated with "ndate"
458      !  minew    -  indicates the minute associated with "ndate"
459      !  scnew    -  indicates the second associated with "ndate"
460       
461      !  mday     -  a list assigning the number of days in each month
462     
463      !  i        -  loop counter
464      !  nday     -  the integer number of days represented by "idt"
465      !  nhour    -  the integer number of hours in "idt" after taking out
466      !              all the whole days
467      !  nmin     -  the integer number of minutes in "idt" after taking out
468      !              all the whole days and whole hours.
469      !  nsec     -  the integer number of minutes in "idt" after taking out
470      !              all the whole days, whole hours, and whole minutes.
471       
472      INTEGER :: nlen, olen
473      INTEGER :: yrnew, monew, dynew, hrnew, minew, scnew, frnew
474      INTEGER :: yrold, moold, dyold, hrold, miold, scold, frold
475      INTEGER :: mday(12), nday, nhour, nmin, nsec, nfrac, i, ifrc
476      LOGICAL :: opass
477      CHARACTER (LEN=10) :: hfrc
478      CHARACTER (LEN=1) :: sp
479      ! INTEGER, EXTERNAL :: nfeb  ! in the same module now
480     
481      !  Assign the number of days in a months
482     
483      mday( 1) = 31
484      mday( 2) = 28
485      mday( 3) = 31
486      mday( 4) = 30
487      mday( 5) = 31
488      mday( 6) = 30
489      mday( 7) = 31
490      mday( 8) = 31
491      mday( 9) = 30
492      mday(10) = 31
493      mday(11) = 30
494      mday(12) = 31
495     
496      !  Break down old hdate into parts
497     
498      hrold = 0
499      miold = 0
500      scold = 0
501      frold = 0
502      olen = LEN(odate)
503      IF (olen.GE.11) THEN
504         sp = odate(11:11)
505      else
506         sp = ' '
507      END IF
508     
509      !  Use internal READ statements to convert the CHARACTER string
510      !  date into INTEGER components.
511   
512      READ(odate(1:4),  '(I4)') yrold
513#ifdef PLANET
514      READ(odate(6:10), '(I5)') dyold
515      moold=0.
516#else
517      READ(odate(6:7),  '(I2)') moold
518      READ(odate(9:10), '(I2)') dyold
519#endif
520      IF (olen.GE.13) THEN
521         READ(odate(12:13),'(I2)') hrold
522         IF (olen.GE.16) THEN
523            READ(odate(15:16),'(I2)') miold
524            IF (olen.GE.19) THEN
525               READ(odate(18:19),'(I2)') scold
526               IF (olen.GT.20) THEN
527                  READ(odate(21:olen),'(I2)') frold
528               END IF
529            END IF
530         END IF
531      END IF
532     
533      !  Set the number of days in February for that year.
534     
535      mday(2) = nfeb(yrold)
536     
537      !  Check that ODATE makes sense.
538     
539      opass = .TRUE.
540     
541#ifdef PLANET
542      !  Check that the day of ODATE makes sense.
543      IF ((dyold.GT.PLANET_YEAR).or.(dyold.LT.1)) THEN
544         WRITE(*,*) 'GETH_NEWDATE:  Day of ODATE = ', dyold
545         opass = .FALSE.
546      END IF
547#else
548      !  Check that the month of ODATE makes sense.
549     
550      IF ((moold.GT.12).or.(moold.LT.1)) THEN
551         WRITE(*,*) 'GETH_NEWDATE:  Month of ODATE = ', moold
552         opass = .FALSE.
553      END IF
554     
555      !  Check that the day of ODATE makes sense.
556     
557      IF ((dyold.GT.mday(moold)).or.(dyold.LT.1)) THEN
558         WRITE(*,*) 'GETH_NEWDATE:  Day of ODATE = ', dyold
559         opass = .FALSE.
560      END IF
561#endif
562      !  Check that the hour of ODATE makes sense.
563     
564      IF ((hrold.GT.23).or.(hrold.LT.0)) THEN
565         WRITE(*,*) 'GETH_NEWDATE:  Hour of ODATE = ', hrold
566         opass = .FALSE.
567      END IF
568     
569      !  Check that the minute of ODATE makes sense.
570     
571      IF ((miold.GT.59).or.(miold.LT.0)) THEN
572         WRITE(*,*) 'GETH_NEWDATE:  Minute of ODATE = ', miold
573         opass = .FALSE.
574      END IF
575     
576      !  Check that the second of ODATE makes sense.
577     
578      IF ((scold.GT.59).or.(scold.LT.0)) THEN
579         WRITE(*,*) 'GETH_NEWDATE:  Second of ODATE = ', scold
580         opass = .FALSE.
581      END IF
582     
583      !  Check that the fractional part  of ODATE makes sense.
584     
585     
586      IF (.not.opass) THEN
587         WRITE( wrf_err_message , * ) 'module_date_time: GETH_NEWDATE: Bad ODATE: ', odate(1:olen), olen
588         CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
589      END IF
590     
591      !  Date Checks are completed.  Continue.
592     
593     
594      !  Compute the number of days, hours, minutes, and seconds in idt
595     
596      IF (olen.GT.20) THEN !idt should be in fractions of seconds
597         ifrc = olen-20
598         ifrc = 10**ifrc
599         nday   = ABS(idt)/(86400*ifrc)
600         nhour  = MOD(ABS(idt),86400*ifrc)/(3600*ifrc)
601         nmin   = MOD(ABS(idt),3600*ifrc)/(60*ifrc)
602         nsec   = MOD(ABS(idt),60*ifrc)/(ifrc)
603         nfrac = MOD(ABS(idt), ifrc)
604      ELSE IF (olen.eq.19) THEN  !idt should be in seconds
605         ifrc = 1
606         nday   = ABS(idt)/86400 ! Integer number of days in delta-time
607         nhour  = MOD(ABS(idt),86400)/3600
608         nmin   = MOD(ABS(idt),3600)/60
609         nsec   = MOD(ABS(idt),60)
610         nfrac  = 0
611      ELSE IF (olen.eq.16) THEN !idt should be in minutes
612         ifrc = 1
613         nday   = ABS(idt)/1440 ! Integer number of days in delta-time
614         nhour  = MOD(ABS(idt),1440)/60
615         nmin   = MOD(ABS(idt),60)
616         nsec   = 0
617         nfrac  = 0
618      ELSE IF (olen.eq.13) THEN !idt should be in hours
619         ifrc = 1
620         nday   = ABS(idt)/24 ! Integer number of days in delta-time
621         nhour  = MOD(ABS(idt),24)
622         nmin   = 0
623         nsec   = 0
624         nfrac  = 0
625      ELSE IF (olen.eq.10) THEN !idt should be in days
626         ifrc = 1
627         nday   = ABS(idt)/24 ! Integer number of days in delta-time
628         nhour  = 0
629         nmin   = 0
630         nsec   = 0
631         nfrac  = 0
632      ELSE
633         WRITE( wrf_err_message , * ) 'module_date_time: GETH_NEWDATE: Strange length for ODATE: ',olen
634         CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
635      END IF
636     
637      IF (idt.GE.0) THEN
638     
639         frnew = frold + nfrac
640         IF (frnew.GE.ifrc) THEN
641            frnew = frnew - ifrc
642            nsec = nsec + 1
643         END IF
644     
645         scnew = scold + nsec
646         IF (scnew .GE. 60) THEN
647            scnew = scnew - 60
648            nmin  = nmin + 1
649         END IF
650     
651         minew = miold + nmin
652         IF (minew .GE. 60) THEN
653            minew = minew - 60
654            nhour  = nhour + 1
655         END IF
656     
657         hrnew = hrold + nhour
658         IF (hrnew .GE. 24) THEN
659            hrnew = hrnew - 24
660            nday  = nday + 1
661         END IF
662     
663         dynew = dyold
664         monew = moold
665         yrnew = yrold
666         DO i = 1, nday
667            dynew = dynew + 1
668#ifdef PLANET
669            IF (dynew .GT. PLANET_YEAR) THEN
670               dynew = dynew - PLANET_YEAR
671               yrnew = yrnew + 1
672            END IF
673#else
674            IF (dynew.GT.mday(monew)) THEN
675               dynew = dynew - mday(monew)
676               monew = monew + 1
677               IF (monew .GT. 12) THEN
678                  monew = 1
679                  yrnew = yrnew + 1
680                  ! If the year changes, recompute the number of days in February
681                  mday(2) = nfeb(yrnew)
682               END IF
683            END IF
684#endif
685         END DO
686     
687      ELSE IF (idt.LT.0) THEN
688     
689         frnew = frold - nfrac
690         IF (frnew .LT. 0) THEN
691            frnew = frnew + ifrc
692            nsec = nsec - 1
693         END IF
694     
695         scnew = scold - nsec
696         IF (scnew .LT. 00) THEN
697            scnew = scnew + 60
698            nmin  = nmin + 1
699         END IF
700     
701         minew = miold - nmin
702         IF (minew .LT. 00) THEN
703            minew = minew + 60
704            nhour  = nhour + 1
705         END IF
706     
707         hrnew = hrold - nhour
708         IF (hrnew .LT. 00) THEN
709            hrnew = hrnew + 24
710            nday  = nday + 1
711         END IF
712     
713         dynew = dyold
714         monew = moold
715         yrnew = yrold
716         DO i = 1, nday
717            dynew = dynew - 1
718#ifdef PLANET
719            IF (dynew.eq.0) THEN
720               dynew = PLANET_YEAR
721               yrnew = yrnew - 1
722            END IF
723#else
724            IF (dynew.eq.0) THEN
725               monew = monew - 1
726               IF (monew.eq.0) THEN
727                  monew = 12
728                  yrnew = yrnew - 1
729                  ! If the year changes, recompute the number of days in February
730                  mday(2) = nfeb(yrnew)
731               END IF
732               dynew = mday(monew)
733            END IF
734#endif
735         END DO
736      END IF
737     
738      !  Now construct the new mdate
739     
740      nlen = LEN(ndate)
741     
742#ifdef PLANET
743      IF (nlen.GT.20) THEN
744         WRITE(ndate(1:19),19) yrnew, dynew, hrnew, minew, scnew
745         WRITE(hfrc,'(I10)') frnew+1000000000
746         ndate = ndate(1:19)//'.'//hfrc(31-nlen:10)
747     
748      ELSE IF (nlen.eq.19.or.nlen.eq.20) THEN
749         WRITE(ndate(1:19),19) yrnew, dynew, hrnew, minew, scnew
750      19   format(I4.4,'-',I5.5,'_',I2.2,':',I2.2,':',I2.2)
751         IF (nlen.eq.20) ndate = ndate(1:19)//'.'
752     
753      ELSE IF (nlen.eq.16) THEN
754         WRITE(ndate,16) yrnew, dynew, hrnew, minew
755      16   format(I4.4,'-',I5.5,'_',I2.2,':',I2.2)
756     
757      ELSE IF (nlen.eq.13) THEN
758         WRITE(ndate,13) yrnew, dynew, hrnew
759      13   format(I4.4,'-',I5.5,'_',I2.2)
760     
761      ELSE IF (nlen.eq.10) THEN
762         WRITE(ndate,10) yrnew, dynew
763      10   format(I4.4,'-',I5.5)
764     
765      END IF
766     
767      IF (olen.GE.11) ndate(11:11) = sp
768#else
769      IF (nlen.GT.20) THEN
770         WRITE(ndate(1:19),19) yrnew, monew, dynew, hrnew, minew, scnew
771         WRITE(hfrc,'(I10)') frnew+1000000000
772         ndate = ndate(1:19)//'.'//hfrc(31-nlen:10)
773     
774      ELSE IF (nlen.eq.19.or.nlen.eq.20) THEN
775         WRITE(ndate(1:19),19) yrnew, monew, dynew, hrnew, minew, scnew
776      19   format(I4,'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2,':',I2.2)
777         IF (nlen.eq.20) ndate = ndate(1:19)//'.'
778     
779      ELSE IF (nlen.eq.16) THEN
780         WRITE(ndate,16) yrnew, monew, dynew, hrnew, minew
781      16   format(I4,'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2)
782     
783      ELSE IF (nlen.eq.13) THEN
784         WRITE(ndate,13) yrnew, monew, dynew, hrnew
785      13   format(I4,'-',I2.2,'-',I2.2,'_',I2.2)
786     
787      ELSE IF (nlen.eq.10) THEN
788         WRITE(ndate,10) yrnew, monew, dynew
789      10   format(I4,'-',I2.2,'-',I2.2)
790     
791      END IF
792     
793      IF (olen.GE.11) ndate(11:11) = sp
794#endif
795   END SUBROUTINE geth_newdate
796
797!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
798
799   FUNCTION nfeb ( year ) RESULT (num_days)
800   
801      ! Compute the number of days in February for the given year
802   
803      IMPLICIT NONE
804   
805      INTEGER :: year
806      INTEGER :: num_days
807   
808#ifdef NO_LEAP_CALENDAR
809      num_days = 28 ! By default, February has 28 days ...
810#else
811      num_days = 28 ! By default, February has 28 days ...
812      IF (MOD(year,4).eq.0) THEN 
813         num_days = 29  ! But every four years, it has 29 days ...
814         IF (MOD(year,100).eq.0) THEN
815            num_days = 28  ! Except every 100 years, when it has 28 days ...
816            IF (MOD(year,400).eq.0) THEN
817               num_days = 29  ! Except every 400 years, when it has 29 days.
818            END IF
819         END IF
820      END IF
821#endif
822   
823   END FUNCTION nfeb
824
825!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
826   SUBROUTINE split_date_char ( date , century_year , month , day , hour , minute , second , ten_thousandth)
827     
828      IMPLICIT NONE
829   
830      !  Input data.
831   
832      CHARACTER(LEN=24) , INTENT(IN) :: date
833   
834      !  Output data.
835   
836      INTEGER , INTENT(OUT) :: century_year , month , day , hour , minute , second , ten_thousandth
837     
838      READ(date,FMT='(    I4)') century_year
839#ifdef PLANET
840      month = 0
841      READ(date,FMT='( 5X,I5)') day
842#else
843      READ(date,FMT='( 5X,I2)') month
844      READ(date,FMT='( 8X,I2)') day
845#endif
846      READ(date,FMT='(11X,I2)') hour
847      READ(date,FMT='(14X,I2)') minute
848      READ(date,FMT='(17X,I2)') second
849      READ(date,FMT='(20X,I4)') ten_thousandth
850   
851   END SUBROUTINE split_date_char
852
853   SUBROUTINE init_module_date_time
854   END SUBROUTINE init_module_date_time
855
856END MODULE module_date_time
857
858
859   ! TBH:  NOTE: 
860   ! TBH:  Linkers whine if these routines are placed inside the module.  Not
861   ! TBH:  sure if these should live here or inside an external package.  They
862   ! TBH:  have dependencies both on WRF (for the format of the WRF date-time
863   ! TBH:  strings) and on the time manager.  Currently, the format of the WRF
864   ! TBH:  date-time strings is a slight variant on ISO 8601 (ISO is
865   ! TBH:  "YYYY-MM-DDThh:mm:ss" while WRF is "YYYY-MM-DD_hh:mm:ss").  If we
866   ! TBH:  change the WRF format to match the standard, then we remove the
867   ! TBH:  WRF dependence... 
868
869   ! Converts WRF date-time string into an WRFU_Time object. 
870   ! The format of the WRF date-time strings is a slight variant on ISO 8601:
871   ! ISO is "YYYY-MM-DDThh:mm:ss" while WRF is "YYYY-MM-DD_hh:mm:ss". 
872   SUBROUTINE wrf_atotime ( str, time )
873      USE module_utility
874      CHARACTER (LEN=*), INTENT(INOUT) :: str
875      TYPE(WRFU_Time),   INTENT(OUT) :: time
876      INTEGER yr, mm, dd, h, m, s, ms
877      INTEGER rc
878      IF ( LEN( str ) .GE. 20 ) THEN
879        IF ( str(20:20) .EQ. '.' ) THEN
880#ifdef PLANET
881          READ(str,'(I4.4,1x,I5.5,1x,I2.2,1x,I2.2,1x,I2.2,1x,I4.4)') yr,dd,h,m,s,ms
882          mm = 1
883#else
884          READ(str,34) yr,mm,dd,h,m,s,ms
885#endif
886          !  last four digits are ten-thousandths of a sec, convert to ms
887          ms=nint(real(ms)/10)
888        ELSE
889#ifdef PLANET
890          READ(str,'(I4.4,1x,I5.5,1x,I2.2,1x,I2.2,1x,I2.2)') yr,dd,h,m,s
891          mm = 1
892#else
893          READ(str,33) yr,mm,dd,h,m,s
894#endif
895          ms = 0
896        ENDIF
897      ELSE
898#ifdef PLANET
899        READ(str,'(I4.4,1x,I5.5,1x,I2.2,1x,I2.2,1x,I2.2)') yr,dd,h,m,s
900        mm = 1
901#else
902        READ(str,33) yr,mm,dd,h,m,s
903#endif
904        ms = 0
905      ENDIF
906      CALL WRFU_TimeSet( time, YY=yr, MM=mm, DD=dd, H=h, M=m, S=s, MS=ms, rc=rc )
907      CALL wrf_check_error( WRFU_SUCCESS, rc, &
908                            'WRFU_TimeSet() in wrf_atotime() FAILED', &
909                            __FILE__ , &
910                            __LINE__  )
91133 FORMAT (I4.4,1x,I2.2,1x,I2.2,1x,I2.2,1x,I2.2,1x,I2.2)
91234 FORMAT (I4.4,1x,I2.2,1x,I2.2,1x,I2.2,1x,I2.2,1x,I2.2,1x,I4.4)
913      RETURN
914   END SUBROUTINE wrf_atotime
915
916   ! Converts an WRFU_Time object into a WRF date-time string. 
917   ! The format of the WRF date-time strings is a slight variant on ISO 8601:
918   ! ISO is "YYYY-MM-DDThh:mm:ss" while WRF is "YYYY-MM-DD_hh:mm:ss". 
919   SUBROUTINE wrf_timetoa ( time, str )
920      USE module_utility, ONLY : WRFU_Time, WRFU_TimeGet, WRFU_SUCCESS
921      IMPLICIT NONE
922      TYPE(WRFU_Time),   INTENT(INOUT) :: time
923      CHARACTER (LEN=*), INTENT(OUT) :: str
924      INTEGER strlen, rc
925      CHARACTER (LEN=256) :: mess, tmpstr
926      ! Assertion
927      IF ( LEN(str) < 19 ) THEN
928        CALL wrf_error_fatal( 'wrf_timetoa:  str is too short' )
929      ENDIF
930      tmpstr = ''
931      CALL WRFU_TimeGet( time, timeString=tmpstr, rc=rc )
932      WRITE(mess,*)'WRFU_TimeGet() returns ',rc,' in wrf_timetoa() FAILED: timeString >',TRIM(tmpstr),'<'
933      CALL wrf_check_error( WRFU_SUCCESS, rc, &
934                            mess, &
935                            __FILE__ , &
936                            __LINE__  )
937      ! change ISO 8601 'T' to WRF '_' and hack off fraction if str is not
938      ! big enough to hold it
939      strlen = MIN( LEN(str), LEN_TRIM(tmpstr) )
940      str = ''
941      str(1:strlen) = tmpstr(1:strlen)
942      str(11:11) = '_'
943      WRITE (mess,*) 'DEBUG wrf_timetoa():  returning with str = [',TRIM(str),']'
944      CALL wrf_debug ( 150 , TRIM(mess) )
945      RETURN
946   END SUBROUTINE wrf_timetoa
947
948   ! Converts an WRFU_TimeInterval object into a time-interval string. 
949   SUBROUTINE wrf_timeinttoa ( timeinterval, str )
950      USE module_utility
951      IMPLICIT NONE
952      TYPE(WRFU_TimeInterval),   INTENT(INOUT) :: timeinterval
953      CHARACTER (LEN=*), INTENT(OUT) :: str
954      INTEGER rc
955      CHARACTER (LEN=256) :: mess
956      CALL WRFU_TimeIntervalGet( timeinterval, timeString=str, rc=rc )
957      CALL wrf_check_error( WRFU_SUCCESS, rc, &
958                            'WRFU_TimeIntervalGet() in wrf_timeinttoa() FAILED', &
959                            __FILE__ , &
960                            __LINE__  )
961      WRITE (mess,*) 'DEBUG wrf_timeinttoa():  returning with str = [',TRIM(str),']'
962      CALL wrf_debug ( 150 , TRIM(mess) )
963      RETURN
964   END SUBROUTINE wrf_timeinttoa
965
966
967
968   ! Debug routine to print key clock information. 
969   ! Every printed line begins with pre_str. 
970   SUBROUTINE wrf_clockprint ( level, clock, pre_str )
971      USE module_utility
972      INTEGER,           INTENT( IN) :: level
973      TYPE(WRFU_Clock),  INTENT( IN) :: clock
974      CHARACTER (LEN=*), INTENT( IN) :: pre_str
975      INTEGER rc
976      INTEGER :: debug_level
977      TYPE(WRFU_Time) :: currTime, startTime, stopTime
978      TYPE(WRFU_TimeInterval) :: timeStep
979      CHARACTER (LEN=64) :: currTime_str, startTime_str, stopTime_str
980      CHARACTER (LEN=64) :: timeStep_str
981      CHARACTER (LEN=256) :: mess
982      CALL get_wrf_debug_level( debug_level )
983      IF ( level .LE. debug_level ) THEN
984        CALL WRFU_ClockGet( clock, CurrTime=currTime, StartTime=startTime, &
985                                   StopTime=stopTime, TimeStep=timeStep, rc=rc )
986        CALL wrf_check_error( WRFU_SUCCESS, rc, &
987                              'wrf_clockprint:  WRFU_ClockGet() FAILED', &
988                              __FILE__ , &
989                              __LINE__  )
990        CALL wrf_timetoa( currTime, currTime_str )
991        CALL wrf_timetoa( startTime, startTime_str )
992        CALL wrf_timetoa( stopTime, stopTime_str )
993        CALL wrf_timeinttoa( timeStep, timeStep_str )
994        WRITE (mess,*) TRIM(pre_str),'  clock start time = ',TRIM(startTime_str)
995        CALL wrf_message(TRIM(mess))
996        WRITE (mess,*) TRIM(pre_str),'  clock current time = ',TRIM(currTime_str)
997        CALL wrf_message(TRIM(mess))
998        WRITE (mess,*) TRIM(pre_str),'  clock stop time = ',TRIM(stopTime_str)
999        CALL wrf_message(TRIM(mess))
1000        WRITE (mess,*) TRIM(pre_str),'  clock time step = ',TRIM(timeStep_str)
1001        CALL wrf_message(TRIM(mess))
1002      ENDIF
1003      RETURN
1004   END SUBROUTINE wrf_clockprint
1005
Note: See TracBrowser for help on using the repository browser.