File indexing completed on 2018-03-02 18:38:17 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_TIMEPASSED(
a63ed37559 Patr*0004 I initialdate,
0005 I finaldate,
0006 O numdays,
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 IMPLICIT NONE
0029
0030
0031 #include "EEPARAMS.h"
a63ed37559 Patr*0032 #include "cal.h"
0033
d0c66b198b Jean*0034
0035 INTEGER initialdate(4)
0036 INTEGER finaldate(4)
0037 INTEGER numdays(4)
0038 INTEGER myThid
0039
0040
0041 INTEGER cal_IsLeap
0042 EXTERNAL cal_IsLeap
0043
0044
0045 INTEGER yi,yf
0046 INTEGER mi,mf
0047 INTEGER di,df
0048 INTEGER si,sf
0049 INTEGER li,lf
0050 INTEGER wi,wf
0051 INTEGER cdi,cdf
0052 INTEGER csi,csf
0053 INTEGER ndays
0054 INTEGER nsecs
0055 INTEGER hhmmss
0056 INTEGER imon
0057 INTEGER iyr
0058 INTEGER ierr
0059 LOGICAL swap
0060 LOGICAL caldates
0061 LOGICAL nothingtodo
0062 CHARACTER*(MAX_LEN_MBUF) msgBuf
0063
0064
0065
0066 IF ( cal_setStatus .LT. 1 ) THEN
0067 WRITE( msgBuf,'(2A,4I9)') 'CAL_TIMEPASSED: ', 'initialdate=',
0068 & initialdate(1),initialdate(2),initialdate(3),initialdate(4)
0069 CALL PRINT_ERROR( msgBuf, myThid )
0070 WRITE( msgBuf,'(2A,4I9)') 'CAL_TIMEPASSED: ', 'finaldate=',
0071 & finaldate(1),finaldate(2),finaldate(3),finaldate(4)
0072 CALL PRINT_ERROR( msgBuf, myThid )
0073 WRITE( msgBuf,'(2A,I2,A)') 'CAL_TIMEPASSED: ',
0074 & 'called too early (cal_setStatus=',cal_setStatus,' )'
0075 CALL PRINT_ERROR( msgBuf, myThid )
0076 STOP 'ABNORMAL END: S/R CAL_TIMEPASSED'
0077 ENDIF
a63ed37559 Patr*0078
0079 nothingtodo = .false.
0080
d0c66b198b Jean*0081
a63ed37559 Patr*0082 numdays(1) = 0
0083 numdays(2) = 0
0084 numdays(3) = 0
0085 numdays(4) = -1
0086
0087 if ((initialdate(4) .gt. 0) .eqv.
0088 & ( finaldate(4) .gt. 0)) then
0089
0090 caldates = (initialdate(4) .gt. 0) .and.
0091 & ( finaldate(4) .gt. 0)
0092
d0c66b198b Jean*0093
a63ed37559 Patr*0094 if (initialdate(1) .eq. finaldate(1)) then
0095 if (initialdate(2) .eq. finaldate(2)) then
0096 nothingtodo = .true.
0097 else if (initialdate(2) .gt. finaldate(2)) then
0098 swap = .true.
0099 else
0100 swap = .false.
0101 endif
0102 else if (initialdate(1) .gt. finaldate(1)) then
0103 swap = .true.
0104 else
0105 swap = .false.
0106 endif
0107
0108 if (.not. nothingtodo) then
0109
0110 if (swap) then
d0c66b198b Jean*0111 call cal_ConvDate( finaldate,yi,mi,di,si,li,wi,myThid )
0112 call cal_ConvDate( initialdate,yf,mf,df,sf,lf,wf,myThid )
a63ed37559 Patr*0113 else
d0c66b198b Jean*0114 call cal_ConvDate( initialdate,yi,mi,di,si,li,wi,myThid )
0115 call cal_ConvDate( finaldate,yf,mf,df,sf,lf,wf,myThid )
a63ed37559 Patr*0116 endif
0117
d0c66b198b Jean*0118
a63ed37559 Patr*0119 if (.not. caldates) then
0120 ndays = df - di
0121 nsecs = sf - si
0122 if (nsecs .lt. 0) then
0123 nsecs = nsecs + secondsperday
0124 ndays = ndays - 1
0125 endif
0126 ndays = ndays + nsecs/secondsperday
0127 nsecs = mod(nsecs,secondsperday)
0128 else
0129 si = si + (di-1)*secondsperday
0130 sf = sf + (df-1)*secondsperday
0131 cdi = 0
0132 do imon = 1,mod(mi-1,12)
0133 cdi = cdi + ndaymonth(imon,li)
0134 enddo
0135 csi = si
0136 cdf = 0
0137 do imon = 1,mod(mf-1,12)
0138 cdf = cdf + ndaymonth(imon,lf)
0139 enddo
0140 csf = sf
0141
0142 if (yi .eq. yf) then
0143 ndays = (cdf + csf/secondsperday) -
0144 & (cdi + csi/secondsperday)
0145 nsecs = (csf - (csf/secondsperday)*secondsperday) -
0146 & (csi - (csi/secondsperday)*secondsperday)
0147 if (nsecs .lt. 0) then
0148 nsecs = nsecs + secondsperday
0149 ndays = ndays - 1
0150 endif
0151 else
d0c66b198b Jean*0152 ndays = (ndaysnoleap - 1) + cal_IsLeap( yi, myThid ) -
a63ed37559 Patr*0153 & cdi - ndaymonth(mi,li)
0154 do iyr = yi+1,yf-1
0155 ndays = ndays + (ndaysnoleap - 1) +
d0c66b198b Jean*0156 & cal_IsLeap( iyr, myThid )
a63ed37559 Patr*0157 enddo
0158 ndays = ndays + cdf
0159 csi = ndaymonth(mi,li)*secondsperday - csi
0160 nsecs = csi + csf
0161 endif
0162 endif
0163
d0c66b198b Jean*0164
a63ed37559 Patr*0165 numdays(1) = ndays + nsecs/secondsperday
0166 nsecs = mod(nsecs,secondsperday)
0167 hhmmss = nsecs/secondsperminute
0168 numdays(2) = hhmmss/minutesperhour*10000 +
0169 & mod(hhmmss,minutesperhour)*100 +
0170 & mod(nsecs,secondsperminute)
0171 if (swap) then
0172 numdays(1) = -numdays(1)
0173 numdays(2) = -numdays(2)
0174 endif
0175
0176 else
d0c66b198b Jean*0177
a63ed37559 Patr*0178 endif
0179
0180 else
0181
0182 ierr = 501
d0c66b198b Jean*0183 call cal_PrintError( ierr, myThid )
a63ed37559 Patr*0184 stop ' stopped in cal_TimePassed'
0185
0186 endif
0187
d0c66b198b Jean*0188 RETURN
0189 END