C JULIAN DATE ROUTINES C CALLS: C N=JULIAN(YY/MM/DD) C RETURNS JULIAN DATE BASED ON 1/1/80 FOR THAT DATE C C CALL JULASC(N,STRADR) C TAKES JULIAN DATE AND DECODES TO ASCII YY/MM/DD C C N=JULMDY(IYR,IMO,IDA) C RETURNS JULIAN DATE GIVEN SEPARATE Y,M,D C FUNCTION JULIAN(DATST) INTEGER*4 DATST(2),DAT(2) LOGICAL*1 DATSTR(8) LOGICAL*1 YRST(2),MOST(2),DAST(2) EQUIVALENCE(DATSTR(1),DAT(1)) EQUIVALENCE(YRST(1),DATSTR(1)),(MOST(1),DATSTR(4)) EQUIVALENCE(DAST(1),DATSTR(7)) DAT(1)=DATST(1) DAT(2)=DATST(2) IJUL=1 DECODE(2,1,YRST,ERR=2)IYR 1 FORMAT(I2) DECODE(2,1,MOST,ERR=2)IMO DECODE(2,1,DAST,ERR=2)IDA IJUL=JULMDY(IYR,IMO,IDA) 2 CONTINUE JULIAN=IJUL RETURN END FUNCTION JULMDY(IYR,IMO,IDA) INTEGER*2 MLEN(12) DATA MLEN/31,28,31,30,31,30,31,31,30,31,30,31/ C JULIAN DATE FROM Y,M,D C BASE=1/1/81 IJUL=1 IF(IYR.LT.80)GOTO 999 IYR=IYR-81 IF(IMO.LE.0.OR.IMO.GT.12)GOTO 999 IF(IDA.GT.31)GOTO 999 C JUST RETURN ILLEGAL ENTRIES AS 1/1/80 AC=365.25*FLOAT(IYR) IAC=AC C SLIGHTLY CRUDE BUT WORKABLE TREATMENT OF YEARS IJUL=IJUL+IAC C NOW ADD IN MONTHS. IF(IMO.GT.2.AND.MOD(IYR+1,4).EQ.0)IJUL=IJUL+1 C ABOVE ACCOUNTS FOR LEAP YEARS III=IMO-1 IF(III.LE.0)GOTO 22 DO 2 N=1,III 2 IJUL=IJUL+MLEN(N) 22 CONTINUE C NEXT DO DAYS IJUL=IJUL+IDA-1 C JUST ADD IN DAYS. SHOULD BE GOOD ENOUGH. 999 CONTINUE JULMDY=IJUL RETURN END SUBROUTINE JULASC(N,DATST,IYR,IMO,IDA) C CONVERT JULIAN DATE N INTO ASCII STRING STR INTEGER*4 DATST(2),DAT(2) LOGICAL*1 DATSTR(8) LOGICAL*1 YRST(2),MOST(2),DAST(2) EQUIVALENCE(DAT(1),DATSTR(1)) EQUIVALENCE(YRST(1),DATSTR(1)),(MOST(1),DATSTR(4)) EQUIVALENCE(DAST(1),DATSTR(7)) INTEGER*2 MLEN(12) DATA MLEN/31,28,31,30,31,30,31,31,30,31,30,31/ DATSTR(3)='/' DATSTR(6)='/' C FIRST SUBTRACT OFF WHOLE YEARS IYR=N/365 N=N-(365*IYR) C ADJUST FOR LEAP YRS SINCE 1981 IAC=IYR/4 N=N-IAC C NOW SUBTRACT OFF MONTHS AS LONG AS POSSIBLE DO 1 NN=1,12 IMO=NN IF(N.LE.MLEN(NN))GOTO 2 N=N-MLEN(NN) 1 CONTINUE 2 CONTINUE IDA=N IYR=IYR+81 ENCODE(2,3,YRST,ERR=5)IYR 3 FORMAT(I2) ENCODE(2,3,MOST,ERR=5)IMO ENCODE(2,3,DAST,ERR=5)IDA 5 CONTINUE IF(YRST(1).EQ.' ')YRST(1)='0' IF(MOST(1).EQ.' ')MOST(1)='0' IF(DAST(1).EQ.' ')DAST(1)='0' DATST(1)=DAT(1) DATST(2)=DAT(2) C USE INTEGERS SINCE REAL*8 MIGHT OMIT FULL COPY IF C EXPONENT BYTE IS 0, AND CHARS MAY CAUSE NORMALIZATION C PROBLEMS SOMETIMES. RETURN END