File indexing completed on 2018-03-02 18:38:16 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_SUBDATES(
a63ed37559 Patr*0004 I finaldate,
0005 I initialdate,
0006 O diffdate,
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 finaldate(4)
0036 INTEGER initialdate(4)
0037 INTEGER diffdate(4)
0038 INTEGER myThid
0039
0040
0041 INTEGER workdate(4)
0042 INTEGER ierr
0043 CHARACTER*(MAX_LEN_MBUF) msgBuf
0044
0045
0046
0047 IF ( cal_setStatus .LT. 1 ) THEN
0048 WRITE( msgBuf,'(2A,4I9)') 'CAL_SUBDATES: ', 'finaldate=',
0049 & finaldate(1),finaldate(2),finaldate(3),finaldate(4)
0050 CALL PRINT_ERROR( msgBuf, myThid )
0051 WRITE( msgBuf,'(2A,4I9)') 'CAL_SUBDATES: ', 'initialdate=',
0052 & initialdate(1),initialdate(2),initialdate(3),initialdate(4)
0053 CALL PRINT_ERROR( msgBuf, myThid )
0054 WRITE( msgBuf,'(2A,I2,A)') 'CAL_SUBDATES: ',
0055 & 'called too early (cal_setStatus=',cal_setStatus,' )'
0056 CALL PRINT_ERROR( msgBuf, myThid )
0057 STOP 'ABNORMAL END: S/R CAL_SUBDATES'
0058 ENDIF
a63ed37559 Patr*0059
0060 if ((initialdate(4) .gt. 0) .eqv.
0061 & ( finaldate(4) .gt. 0)) then
0062
0063 if (initialdate(4) .eq. -1) then
d0c66b198b Jean*0064
a63ed37559 Patr*0065 workdate(1) = -initialdate(1)
0066 workdate(2) = -initialdate(2)
0067 workdate(3) = 0
0068 workdate(4) = -1
d0c66b198b Jean*0069 call cal_AddTime( finaldate, workdate, diffdate, myThid )
a63ed37559 Patr*0070 else
d0c66b198b Jean*0071
0072 call cal_TimePassed(
0073 & initialdate, finaldate, diffdate, myThid )
a63ed37559 Patr*0074 endif
0075 else
0076
0077 ierr = 801
d0c66b198b Jean*0078 call cal_PrintError( ierr, myThid )
a63ed37559 Patr*0079 stop ' stopped in cal_SubDates.'
0080
0081 endif
0082
d0c66b198b Jean*0083 RETURN
0084 END