/[MITgcm]/MITgcm/pkg/cal/cal_checkdate.F
ViewVC logotype

Diff of /MITgcm/pkg/cal/cal_checkdate.F

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

revision 1.5 by jmc, Sat Apr 7 16:20:07 2012 UTC revision 1.6 by jmc, Sun Apr 8 19:31:46 2012 UTC
# Line 43  C     == routine arguments == Line 43  C     == routine arguments ==
43    
44  C     == local variables ==  C     == local variables ==
45  C     msgBuf     :: Informational/error message buffer  C     msgBuf     :: Informational/error message buffer
46        INTEGER yy,mm,dd        INTEGER yy, mm, dd
47        INTEGER nsecs        INTEGER nsecs
48        INTEGER lp,wd        INTEGER lp,wd
49          INTEGER hh, mn, ss
50        INTEGER hhmmss        INTEGER hhmmss
51        INTEGER yymmdd        LOGICAL wrong_sign
       INTEGER fac  
       LOGICAL check_sign  
52        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
53  C     == end of interface ==  C     == end of interface ==
54    
55        valid  = .true.        valid  = .true.
       hhmmss = 0  
56        calerr = 0        calerr = 0
57        fac    = 1  c     wrong_sign = date(1)*date(2).lt.0
58    C     product above might go over integer*4 limit; better to check each one:
59          wrong_sign = ( (date(1).LT.0) .AND. date(2).GT.0 )
60         &        .OR. ( (date(1).GT.0) .AND. date(2).LT.0 )
61    
62          IF ( wrong_sign ) THEN
63    C         cal_CheckDate: Signs of first two components unequal
64              calerr = 1803
65    C         invalid sign is fatal (since we need to check for valid month)
66              valid = .FALSE.
67          ELSEIF ( cal_setStatus .LT. 1 ) THEN
68              WRITE( msgBuf,'(2A,4I9)')  'CAL_CHECKDATE:',
69         &      ' date=',date(1),date(2),date(3),date(4)
70              CALL PRINT_ERROR( msgBuf, myThid )
71              WRITE( msgBuf,'(2A,I2,A)') 'CAL_CHECKDATE:',
72         &      ' called too early (cal_setStatus=',cal_setStatus,' )'
73              CALL PRINT_ERROR( msgBuf, myThid )
74    c         valid = .FALSE.
75    
76        check_sign = ( (date(1).lt.0) .and. date(2).gt.0 )        ELSEIF ( date(4).LE.0 ) THEN
77       &        .OR. ( (date(1).gt.0) .and. date(2).lt.0 )  C--   date without weekday (date(4)= -1) and no LeapYear index (date(3)= 0)
78    
79        if (date(4) .le. 0) then          IF ( date(4).NE.-1 ) THEN
80          if (date(4) .ne. -1) then  C         cal_CheckDate: Last component of array not valid
81            calerr = 1801            calerr = 1801
82          else          ELSEIF ( date(3).NE.0 ) THEN
83            if (date(3) .ne. 0) then  C         cal_CheckDate: Third component of interval array not 0
84              calerr = 1802            calerr = 1802
85            else          ENDIF
86              if ( check_sign ) then  
87                calerr = 1803        ELSE
88              ELSEIF ( cal_setStatus .LT. 1 ) THEN  C--   normal date with weekday (date(4)> 0) and LeapYear index (date(3)> 0)
89                WRITE( msgBuf,'(2A,4I9)')  'CAL_CHECKDATE: ',  
90       &          'date=',date(1),date(2),date(3),date(4)          CALL CAL_CONVDATE( date, yy, mm, dd, nsecs, lp, wd, myThid )
91                CALL PRINT_ERROR( msgBuf, myThid )          IF ( mm.EQ.0 .OR. ABS(mm).GT.nMonthYear ) THEN
92                WRITE( msgBuf,'(2A,I2,A)') 'CAL_CHECKDATE: ',            WRITE( msgBuf,'(2A,I10)') 'CAL_CHECKDATE:',
93       &          'called too early (cal_setStatus=',cal_setStatus,' )'       &      ' Invalid month in date(1)=', date(1)
94                CALL PRINT_ERROR( msgBuf, myThid )            CALL PRINT_ERROR( msgBuf, myThid )
95              else  C       invalid month is fatal (used as index in nDayMonth array)
96                call cal_ConvDate(date,yy,mm,dd,nsecs,lp,wd,myThid)            valid = .FALSE.
97                if (nsecs .lt. 0) fac = -1          ELSEIF ( wd.LT.1 .OR. wd.GT.7 ) THEN
98                hhmmss  = fac*nsecs/secondsperminute  C         cal_CheckDate: Weekday indentifier not correct
               hhmmss  = hhmmss/minutesperhour*10000 +  
      &                  mod(hhmmss,minutesperhour)*100 +  
      &                  mod(fac*nsecs,secondsperminute)  
               hhmmss  = fac*hhmmss  
               if (date(2) .ne. hhmmss) then  
                 calerr = 1804  
               endif  
             endif  
           endif  
         endif  
       else  
         if (date(4) .gt. 8) then  
99            calerr = 1805            calerr = 1805
100          else  C       invalid weekday is not safe (index in dayOfWeek, but just to print)
101            if ((date(3) .ne. 1) .and.          ELSEIF ( lp.NE.1 .AND. lp.NE.2 ) then
102       &        (date(3) .ne. 2)) then  C         cal_CheckDate: Leap year identifier not correct
103              calerr = 1806            calerr = 1806
104            else  C       invalid leap-year index is fatal (used as index in nDayMonth array)
105              if ( check_sign ) then            valid = .FALSE.
106                calerr = 1803          ELSEIF ( dd.EQ.0 .OR. ABS(dd).GT.nMaxDayMonth ) THEN
107              else  C-note: can refine above using Nb of days of the corresponding month:
108                call cal_ConvDate( date,yy,mm,dd,nsecs,lp,wd,myThid )  c       ELSEIF ( dd.EQ.0 .OR. ABS(dd).GT.nDayMonth(mm,lp) ) THEN
109                if (date(1) .lt. refdate(1)) then            WRITE( msgBuf,'(2A,I10)') 'CAL_CHECKDATE:',
110                  calerr = 1807       &      ' Invalid day in date(1)=', date(1)
111                ELSEIF ( cal_setStatus .LT. 1 ) THEN            CALL PRINT_ERROR( msgBuf, myThid )
112                  WRITE( msgBuf,'(2A,4I9)')  'CAL_CHECKDATE: ',          ELSEIF ( date(1).LT.refDate(1) ) THEN
113       &           'date=',date(1),date(2),date(3),date(4)  C         cal_CheckDate: Calendar date before predef. reference date
114                  CALL PRINT_ERROR( msgBuf, myThid )            calerr = 1807
115                  WRITE( msgBuf,'(2A,I2,A)') 'CAL_CHECKDATE: ',          ENDIF
116       &           'called too early (cal_setStatus=',cal_setStatus,' )'  
117                  CALL PRINT_ERROR( msgBuf, myThid )        ENDIF
118                else  
119                  hhmmss  = nsecs/secondsperminute        IF ( valid .AND. cal_setStatus.GE.1 ) THEN
120                  hhmmss  = hhmmss/minutesperhour*10000 +  C--   check 2nd component (hhmmss=date(2)) and print warning
121       &                    mod(hhmmss,minutesperhour)*100 +          hhmmss  = ABS(date(2))
122       &                    mod(nsecs,secondsperminute)          hh = hhmmss/10000
123                  if (date(2) .ne. hhmmss) then          mn = MOD(hhmmss/100,100)
124                    calerr = 1804          ss = MOD(hhmmss,100)
125                  endif          IF ( ss.GE.secondsPerMinute ) THEN
126                endif            WRITE( msgBuf,'(2A,I10)') '** WARNING ** CAL_CHECKDATE:',
127                yymmdd  = yy*10000 + mm*100 + dd       &      ' Invalid Seconds in date(2)=', date(2)
128                if (date(1) .ne. yymmdd) then            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
129                  calerr = 1808       &                        SQUEEZE_RIGHT, myThid )
130                endif          ENDIF
131              endif          IF ( mn.GE.minutesPerHour ) THEN
132            endif            WRITE( msgBuf,'(2A,I10)') '** WARNING ** CAL_CHECKDATE:',
133          endif       &      ' Invalid Minutes in date(2)=', date(2)
134        endif            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
135         &                        SQUEEZE_RIGHT, myThid )
136        if (calerr .ne. 0) valid = .FALSE.          ENDIF
137            IF ( hh.GE.hoursPerDay ) THEN
138              WRITE( msgBuf,'(2A,I10)') '** WARNING ** CAL_CHECKDATE:',
139         &      ' Invalid  Hours  in date(2)=', date(2)
140              CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
141         &                        SQUEEZE_RIGHT, myThid )
142            ENDIF
143          ENDIF
144    
145        RETURN        RETURN
146        END        END
Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6
  ViewVC Help
Powered by ViewVC 1.1.22