File indexing completed on 2018-03-02 18:38:14 UTC
view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
6d54cf9ca1 Ed H*0001 #include "CAL_OPTIONS.h"
a63ed37559 Patr*0002
d0c66b198b Jean*0003 SUBROUTINE CAL_ADDTIME(
a63ed37559 Patr*0004 I date,
0005 I interval,
0006 O added,
d0c66b198b Jean*0007 I myThid )
0008
0009
0010
0011
0012
0013
0014
0015
0016
0017
0018
0019
0020
0021
0022
0023
0024
0025
0026
0027
0028
0029
0030
0031
0032 IMPLICIT NONE
0033
0034
0035 #include "EEPARAMS.h"
a63ed37559 Patr*0036 #include "cal.h"
0037
d0c66b198b Jean*0038
0039 INTEGER date(4)
0040 INTEGER interval(4)
0041 INTEGER added(4)
0042 INTEGER myThid
0043
0044
0045 INTEGER cal_IsLeap
0046 EXTERNAL cal_IsLeap
0047
0048
0049 INTEGER intsecs
0050 INTEGER datesecs
0051 INTEGER nsecs
0052 INTEGER hhmmss
0053 INTEGER yi,mi,di,si,li,wi
0054 INTEGER ndays, ndays_left, days_in_year
0055 INTEGER date_1,date_2
0056 INTEGER intv_1,intv_2
0057 INTEGER fac
0058 INTEGER iday
0059 INTEGER switch
0060 INTEGER ndayssub
0061 INTEGER ierr
0062 CHARACTER*(MAX_LEN_MBUF) msgBuf
0063
0064
0065 IF ( cal_setStatus .LT. 1 ) THEN
0066 WRITE( msgBuf,'(2A,4I9)') 'CAL_ADDTIME: ',
0067 & 'date=',date(1),date(2),date(3),date(4)
0068 CALL PRINT_ERROR( msgBuf, myThid )
0069 WRITE( msgBuf,'(2A,4I9)') 'CAL_ADDTIME: ',
0070 & 'interval=',interval(1),interval(2),interval(3),interval(4)
0071 CALL PRINT_ERROR( msgBuf, myThid )
0072 WRITE( msgBuf,'(2A,I2,A)') 'CAL_ADDTIME: ',
0073 & 'called too early (cal_setStatus=',cal_setStatus,' )'
0074 CALL PRINT_ERROR( msgBuf, myThid )
0075 STOP 'ABNORMAL END: S/R CAL_ADDTIME'
0076 ENDIF
a63ed37559 Patr*0077
c84f6b7c89 Dimi*0078 if (interval(4) .ne. -1) then
0079 ierr = 601
d0c66b198b Jean*0080 call cal_PrintError( ierr, myThid)
c84f6b7c89 Dimi*0081 stop ' stopped in cal_AddTime.'
0082 endif
0083
a63ed37559 Patr*0084 date_1 = 0
0085 date_2 = 0
c84f6b7c89 Dimi*0086 fac = 1
a63ed37559 Patr*0087
c84f6b7c89 Dimi*0088 if (date(4) .eq. -1) then
0089 if (date(1) .ge. 0) then
a63ed37559 Patr*0090 date_1 = date(1)
0091 date_2 = date(2)
0092 intv_1 = interval(1)
0093 intv_2 = interval(2)
c84f6b7c89 Dimi*0094 else
a63ed37559 Patr*0095 if (interval(1) .lt. 0) then
c84f6b7c89 Dimi*0096 date_1 = -date(1)
0097 date_2 = -date(2)
0098 intv_1 = -interval(1)
0099 intv_2 = -interval(2)
0100 fac = -1
a63ed37559 Patr*0101 else
c84f6b7c89 Dimi*0102 date_1 = interval(1)
0103 date_2 = interval(2)
0104 intv_1 = date(1)
0105 intv_2 = date(2)
0106 fac = 1
a63ed37559 Patr*0107 endif
c84f6b7c89 Dimi*0108 endif
0109 else
0110 if (interval(1) .ge. 0) then
a63ed37559 Patr*0111 intv_1 = interval(1)
0112 intv_2 = interval(2)
c84f6b7c89 Dimi*0113 else
a63ed37559 Patr*0114 intv_1 = -interval(1)
0115 intv_2 = -interval(2)
0116 fac = -1
c84f6b7c89 Dimi*0117 endif
0118 endif
0119
d0c66b198b Jean*0120 intsecs = fac*(intv_2/10000*secondsperhour +
c84f6b7c89 Dimi*0121 & (mod(intv_2/100,100)*secondsperminute +
0122 & mod(intv_2,100)))
0123
0124 if (date(4) .eq. -1) then
d0c66b198b Jean*0125 datesecs = date_2/10000*secondsperhour +
c84f6b7c89 Dimi*0126 & mod(date_2/100,100)*secondsperminute +
0127 & mod(date_2,100)
0128 date_1 = date_1 + intv_1
0129 nsecs = datesecs + intsecs
0130 if ((date_1 .gt. 0) .and.
a63ed37559 Patr*0131 & (nsecs .lt. 0)) then
0132 date_1 = date_1 - 1
0133 nsecs = nsecs + secondsperday
c84f6b7c89 Dimi*0134 endif
0135 nsecs = fac*nsecs
0136 yi = 0
0137 mi = 0
0138 di = fac*date_1
0139 li = 0
0140 wi = -1
0141 else
d0c66b198b Jean*0142 call cal_ConvDate( date,yi,mi,di,si,li,wi,myThid )
c84f6b7c89 Dimi*0143 if ((interval(1) .ge. 0) .and.
a63ed37559 Patr*0144 & (interval(2) .ge. 0)) then
0145 nsecs = si + intsecs
c84f6b7c89 Dimi*0146 ndays = interval(1)+nsecs/secondsperday
a63ed37559 Patr*0147 nsecs = mod(nsecs,secondsperday)
d0c66b198b Jean*0148
0149
0150
c84f6b7c89 Dimi*0151
0152
0153
0154
0155
0156
0157
0158
0159
d0c66b198b Jean*0160
c84f6b7c89 Dimi*0161
0162
d0c66b198b Jean*0163
c84f6b7c89 Dimi*0164 ndays_left=ndays
e50a7d3fbe Patr*0165
d0c66b198b Jean*0166
e50a7d3fbe Patr*0167 if ( usingGregorianCalendar ) then
0168 if ( mi.eq.2 .and. di.eq.29 .and. ndays_left.gt.1 ) then
0169 mi = 3
0170 di = 1
0171 ndays_left = ndays_left - 1
0172 endif
c84f6b7c89 Dimi*0173 endif
0174
d0c66b198b Jean*0175
e50a7d3fbe Patr*0176 days_in_year=ndaysnoleap
d0c66b198b Jean*0177 if ((mi.gt.2.and.cal_IsLeap(yi+1,myThid).eq.2).or.
0178 & (mi.le.2.and.cal_IsLeap(yi,myThid).eq.2) )
e50a7d3fbe Patr*0179 & days_in_year=ndaysleap
c84f6b7c89 Dimi*0180 do while (ndays_left .ge. days_in_year)
0181 ndays_left = ndays_left - days_in_year
0182 yi = yi + 1
e50a7d3fbe Patr*0183 days_in_year=ndaysnoleap
d0c66b198b Jean*0184 if ((mi.gt.2.and.cal_IsLeap(yi+1,myThid).eq.2).or.
0185 & (mi.le.2.and.cal_IsLeap(yi,myThid).eq.2) )
e50a7d3fbe Patr*0186 & days_in_year=ndaysleap
c84f6b7c89 Dimi*0187 enddo
d0c66b198b Jean*0188 li = cal_IsLeap( yi, myThid )
c84f6b7c89 Dimi*0189
d0c66b198b Jean*0190
c84f6b7c89 Dimi*0191 do iday = 1,ndays_left
0192 di = di + 1
0193 if (di .gt. ndaymonth(mi,li)) then
0194 di = 1
0195 mi = mi + 1
0196 endif
0197 switch = (mi-1)/nmonthyear
0198 yi = yi + switch
0199 mi = mod(mi-1,nmonthyear)+1
d0c66b198b Jean*0200 if (switch .eq. 1) li = cal_IsLeap( yi, myThid )
a63ed37559 Patr*0201 enddo
c84f6b7c89 Dimi*0202 wi = mod(wi+ndays-1,7)+1
0203
0204 else
a63ed37559 Patr*0205 nsecs = si + intsecs
0206 if (nsecs .ge. 0) then
c84f6b7c89 Dimi*0207 ndayssub = intv_1
a63ed37559 Patr*0208 else
c84f6b7c89 Dimi*0209 nsecs = nsecs + secondsperday
0210 ndayssub = intv_1 + 1
a63ed37559 Patr*0211 endif
0212 do iday = 1,ndayssub
c84f6b7c89 Dimi*0213 di = di - 1
0214 if (di .eq. 0) then
0215 mi = mod(mi+10,nmonthyear)+1
0216 switch = mi/nmonthyear
0217 yi = yi - switch
d0c66b198b Jean*0218 if (switch .eq. 1) li = cal_IsLeap( yi, myThid )
c84f6b7c89 Dimi*0219 di = ndaymonth(mi,li)
0220 endif
a63ed37559 Patr*0221 enddo
0222 wi = mod(wi+6-mod(ndayssub,7),7)+1
c84f6b7c89 Dimi*0223 endif
a63ed37559 Patr*0224 endif
0225
d0c66b198b Jean*0226
c84f6b7c89 Dimi*0227 added(1) = yi*10000 + mi*100 + di
0228 hhmmss = nsecs/secondsperminute
0229 added(2) = hhmmss/minutesperhour*10000 +
0230 & (mod(fac*hhmmss,minutesperhour)*100 +
0231 & mod(fac*nsecs,secondsperminute))*fac
0232 added(3) = li
0233 added(4) = wi
0234
d0c66b198b Jean*0235 RETURN
0236 END