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 SUBROUTINE WKDY(JULLO,JULHI,NDAYS) C GIVEN START AND END JULIAN DATE, FIGURE OUT HOW MANY WEEK DAYS C THERE ARE BETWEEN THEM. JL=JULLO JH=JULHI IF(JL.LE.JH)GOTO 10 JL=JULHI JH=JULLO 10 CONTINUE IDL=(JH-JL)/7 C GET NUMBER OF WEEKS BETWEEN DAYS, 5 WORKDAYS PER WHOLE WEEK. IWDY=IDL*5 C ADD 3 SO THAT MODULO OF SUNDAY IS 0, NOT WED. IDOR=JH-JL-7*(IDL) IF(IDOR.NE.0)IDOR=5 C IDOR IS ORIGINAL # DAYS DIFFERENCE, CORRECTED FOR WHOLE C WEEKS ALREADY ALLOWED. LD=JL+3 LD=MOD(LD,7) LH=JH+3 LH=MOD(LH,7) C NOW HAVE DAY OF WEEK START,END. FIND WORK DAYS THAT WEEK (M-F ONLY) IKLU=0 IK2=1 IF(LD.LT.1)IK2=0 IF(LD.LT.1)LD=1 IF(LD.GT.5)LD=5 C FOR HIGH END OF RANGE IF THE END DATE IS SUNDAY SUBTRACT ONE DAY C FROM THE DAYS SO WE OMIT THE MONDAY FROM THE RANGE... IF(LH.LT.1)IKLU=IK2 IF(LH.LT.1)LH=1 IF(LH.GT.5)LH=5 C LH = DAY ENDED ON, LD=START DAY, FORCED INTO WORK WEEK. IF (LH.GT.LD)IWDY=IWDY+LH-LD-IKLU IF (LH.LE.LD)IWDY=IWDY+IDOR-(LD-LH)-IKLU C GIVES DAYS BETWEEN 2 DATES JUST LIKE JULIAN DATE SUBTRACTION FOR C CALENDAR DATES. NDAYS=IWDY RETURN END SUBROUTINE WRKINT(JULLO,NWDY,JULHI) C GETS JULLO = START DATE AND NWDY = NO. WORKDAYS (M-F) TO ADD AND C FINDS JULHI = END JULIAN DATE, CONSTRAINED TO BE IN MONDAY TO C FRIDAY RANGE. C MUST ADD 3 BECAUSE THAT'S THE BIAS OF OUR JULIAN DATE BASE. IDJL=MOD(JULLO+3,7) C IDJL = DAY CODE OF START DATE NWWK=NWDY/5 JL=JULLO IF(IDJL.LT.1)JL=JL+1 IF(IDJL.GT.5)JL=JL+2 C BUMP START INTERVAL... NWDD=NWDY-5*NWWK JL=JL+NWWK*7+NWDD IDJL=MOD(JL+3,7) IF(IDJL.LT.1)JL=JL+1 IF(IDJL.GT.5)JL=JL+2 C FORCE OUTPUT DATE TO BE WITHIN WORKWEEK JULHI=JL RETURN END