pkg/cal/cal_convdate.F

6d54cf9ca1 Ed H*0001 #include "CAL_OPTIONS.h"
a63ed37559 Patr*0002
d0c66b198b Jean*0003       SUBROUTINE CAL_CONVDATE(
a63ed37559 Patr*0004      I                         date,
                0005      O                         yy, mm, dd, ss,
                0006      O                         lp, wd,
d0c66b198b Jean*0007      I                         myThid )
                0008
                0009 C     ==================================================================
                0010 C     SUBROUTINE cal_ConvDate
                0011 C     ==================================================================
                0012 C
                0013 C     o Decompose the first part of a date array.
                0014 C
                0015 C     started: Christian Eckert eckert@mit.edu  30-Jun-1999
                0016 C     changed: Christian Eckert eckert@mit.edu  29-Dec-1999
                0017 C              - restructured the original version in order to have a
                0018 C                better interface to the MITgcmUV.
                0019 C              Christian Eckert eckert@mit.edu  03-Feb-2000
                0020 C              - Introduced new routine and function names, cal_<NAME>,
                0021 C                for verion 0.1.3.
                0022 C              21-Sep-2003: fixed check_sign logic to work with
                0023 C              negative intervals (menemenlis@jpl.nasa.gov)
                0024 C
                0025 C     ==================================================================
                0026 C     SUBROUTINE cal_ConvDate
                0027 C     ==================================================================
                0028
                0029       IMPLICIT NONE
                0030
                0031 C     == global variables ==
                0032 #include "EEPARAMS.h"
a63ed37559 Patr*0033 #include "cal.h"
                0034
d0c66b198b Jean*0035 C     == routine arguments ==
                0036       INTEGER date(4)
89ca39213b Jean*0037       INTEGER yy, mm, dd
                0038       INTEGER ss, lp, wd
d0c66b198b Jean*0039       INTEGER myThid
                0040
                0041 C     == local variables ==
                0042       INTEGER fac
                0043       INTEGER date_1
                0044       INTEGER date_2
                0045       INTEGER ierr
89ca39213b Jean*0046       LOGICAL wrong_sign
d0c66b198b Jean*0047       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0048 C     == end of interface ==
                0049
                0050       IF ( cal_setStatus .LT. 1 ) THEN
                0051         WRITE( msgBuf,'(2A,4I9)') 'CAL_CONVDATE: ',
                0052      &       'date=',date(1),date(2),date(3),date(4)
                0053         CALL PRINT_ERROR( msgBuf, myThid )
                0054         WRITE( msgBuf,'(2A,I2,A)') 'CAL_CONVDATE: ',
                0055      &    'called too early (cal_setStatus=',cal_setStatus,' )'
                0056         CALL PRINT_ERROR( msgBuf, myThid )
                0057         STOP 'ABNORMAL END: S/R CAL_CONVDATE'
                0058       ENDIF
a63ed37559 Patr*0059
d0c66b198b Jean*0060 C     Check the sign of the date.
89ca39213b Jean*0061       fac = 1
                0062       wrong_sign = ( (date(1).lt.0) .and. date(2).gt.0 )
                0063      &        .OR. ( (date(1).gt.0) .and. date(2).lt.0 )
a63ed37559 Patr*0064
89ca39213b Jean*0065       if ( wrong_sign ) then
                0066         ierr = 901
                0067         call cal_PrintError( ierr, myThid )
                0068         stop ' stopped in cal_ConvDate.'
                0069       else
                0070         if ( date(1).lt.0 .OR. date(2).lt.0 ) then
a63ed37559 Patr*0071           date_1 = -date(1)
                0072           date_2 = -date(2)
                0073           fac    = -1
                0074         else
                0075           date_1 = date(1)
                0076           date_2 = date(2)
                0077           fac    = 1
                0078         endif
                0079       endif
                0080
d0c66b198b Jean*0081 C     Decompose the entries.
a63ed37559 Patr*0082       if (date(4) .ne. -1) then
                0083         yy = date_1/10000
                0084         mm = mod(date_1/100,100)
                0085         dd = mod(date_1,100)
                0086       else
                0087         yy = 0
                0088         mm = 0
                0089         dd = date_1
                0090       endif
                0091       ss = mod(date_2,100) +
89ca39213b Jean*0092      &     mod(date_2/100,100)*secondsPerMinute +
                0093      &     date_2/10000*secondsPerHour
a63ed37559 Patr*0094
d0c66b198b Jean*0095 C     Include the sign.
a63ed37559 Patr*0096       yy = fac*yy
                0097       mm = fac*mm
                0098       dd = fac*dd
                0099       ss = fac*ss
                0100
                0101       lp = date(3)
                0102       wd = date(4)
                0103
d0c66b198b Jean*0104       RETURN
                0105       END