pkg/cal/cal_isleap.F

6d54cf9ca1 Ed H*0001 #include "CAL_OPTIONS.h"
a63ed37559 Patr*0002
d0c66b198b Jean*0003       INTEGER FUNCTION CAL_ISLEAP(
a63ed37559 Patr*0004      I                             year,
d0c66b198b Jean*0005      I                             myThid )
a63ed37559 Patr*0006
d0c66b198b Jean*0007 C     ==================================================================
                0008 C     FUNCTION cal_IsLeap
                0009 C     ==================================================================
                0010 C
                0011 C     o In case the Gregorian calendar is used determine whether the
                0012 C       given year is a leap year or not.
                0013 C
                0014 C     started: Christian Eckert eckert@mit.edu  30-Jun-1999
                0015 C     changed: Christian Eckert eckert@mit.edu  29-Dec-1999
                0016 C              - restructured the original version in order to have a
                0017 C                better interface to the MITgcmUV.
                0018 C              Christian Eckert eckert@mit.edu  03-Feb-2000
                0019 C              - Introduced new routine and function names, cal_<NAME>,
                0020 C                for verion 0.1.3.
                0021 C
                0022 C     ==================================================================
                0023 C     FUNCTION cal_IsLeap
                0024 C     ==================================================================
a63ed37559 Patr*0025
d0c66b198b Jean*0026       IMPLICIT NONE
a63ed37559 Patr*0027
d0c66b198b Jean*0028 C     == global variables ==
                0029 #include "EEPARAMS.h"
a63ed37559 Patr*0030 #include "cal.h"
                0031
d0c66b198b Jean*0032 C     == routine arguments ==
                0033       INTEGER year
                0034       INTEGER myThid
a63ed37559 Patr*0035
d0c66b198b Jean*0036 C     == local variables ==
                0037       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0038 C     == end of interface ==
a63ed37559 Patr*0039
d0c66b198b Jean*0040       IF ( cal_setStatus .LT. 1 ) THEN
                0041         WRITE( msgBuf,'(A,2(A,I9))')  'CAL_ISLEAP: ',
                0042      &          'year=', year
                0043         CALL PRINT_ERROR( msgBuf, myThid )
                0044         WRITE( msgBuf,'(2A,I2,A)') 'CAL_ISLEAP: ',
                0045      &    'called too early (cal_setStatus=',cal_setStatus,' )'
                0046         CALL PRINT_ERROR( msgBuf, myThid )
                0047         STOP 'ABNORMAL END: FUNCTION CAL_ISLEAP'
                0048       ENDIF
a63ed37559 Patr*0049
                0050       if ( usingGregorianCalendar ) then
                0051         if ( mod(year,4) .ne. 0 ) then
                0052           cal_IsLeap = 1
                0053         else
                0054           cal_IsLeap = 2
                0055           if ( (mod(year,100) .eq. 0)  .and.
                0056      &         (mod(year,400) .ne. 0) ) then
                0057             cal_IsLeap = 1
                0058           endif
                0059         endif
                0060       else if ( usingJulianCalendar ) then
                0061         if ( mod(year,4) .ne. 0 ) then
                0062           cal_IsLeap = 1
                0063         else
                0064           cal_IsLeap = 2
                0065         endif
                0066       else
                0067        cal_IsLeap = 1
                0068       endif
                0069
d0c66b198b Jean*0070       RETURN
                0071       END