You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
210 lines
6.0 KiB
Fortran
210 lines
6.0 KiB
Fortran
C
|
|
C ANALYST : D.GORHAM
|
|
C INDEX NO. : UT 95.00
|
|
C TITLE : EXTENDED GREGORIAN DATE SUBROUTINE FROM YEAR 1/1/1
|
|
C DATE : 08/03/82
|
|
C REV.01 : 19-SEP-83 BY DJG: MODIFIED FOR VAX
|
|
C
|
|
C THIS SUBROUTINE IS ADAPTED BY DJG FROM THAT IN HP COMMUNICATOR
|
|
C 1981 VOL. 5 ISSUE 3 WITH INTEGER*4 TYPE BEING CHANGED TO REAL
|
|
C PLUS ASSOCIATED CHANGES.
|
|
C
|
|
C PARAMETER LIST :
|
|
C OPT = 1 TO CONVERT CALENDAR DATE TO EXTENDED GREGORIAN DATE (EGD)
|
|
C = 2 TO CONVERT EXTENDED GREGORIAN DATE (EGD) TO CALENDAR DATE
|
|
C MON = MONTH (1-12)
|
|
C DAY = DAY OF MONTH
|
|
C YEAR= CALENDAR YEAR EG. 1982
|
|
C DWK = DAY OF WEEK (1=SUNDAY, 7=SATURDAY)
|
|
C DYR = DAY OF YEAR
|
|
C DMON= DAYS IN MONTH
|
|
C EGD = EXTENDED GREGORIAN DATE SINCE 1/1/1
|
|
C IER = 0 FOR NO ERRORS
|
|
C 1 IF ERRORS DETECTED
|
|
C LU = 0 FOR NO ERROR MESSAGE PRINTOUT
|
|
C = N FOR DISPLAY OF ERROR MESSAGE ON LOGICAL UNIT 'N'
|
|
C
|
|
C TITLE TRUE GEORGIAN DATE ROUTINE ISS. 2 801126 R.A.G. (MWR)
|
|
C
|
|
SUBROUTINE GDATE (OPT,MON,DAY,YEAR,DWK,DYR,DMON,EGD,IER,LU)
|
|
C
|
|
C GREGORIAN DATE ROUTINE 801126
|
|
C
|
|
IMPLICIT INTEGER*4 (A-Z)
|
|
C
|
|
C
|
|
C --------------------------------------------------------------
|
|
C
|
|
C REVISION LIST
|
|
C
|
|
C --DATE-- ---BY--- --DESCRIPTION--
|
|
C
|
|
C 19/03/80 R.A.G. -ORIGINAL ISSUE
|
|
C 26/11/80 R.A.G. -CONVERTED REAL NUMBERS TO DOUBLE INTEGER AND
|
|
C ADDED DAY OF THE WEEK, DAY OF THE YEAR (JULIAN
|
|
C DATE), AND NUMBER OF DAYS IN THE MONTH.
|
|
C
|
|
C ---------------------------------------------------------------
|
|
C
|
|
C
|
|
INTEGER*4 M(12)
|
|
C
|
|
LOGICAL LYEAR
|
|
C
|
|
DATA M/31,28,31,30,31,30,31,31,30,31,30,31/
|
|
C
|
|
C INITIALIZE SOME VARIABLES
|
|
C
|
|
M(2)=28
|
|
DYR=0
|
|
IER=0
|
|
C
|
|
C CHECK FOR OPTION
|
|
C 1=CALLER SUPPLIES DAY MONTH YEAR
|
|
C >1=CALLER SUPPLIES EXTENDED GREGORIAN DATE
|
|
C
|
|
IF (OPT.GT.1) GO TO 120
|
|
C
|
|
C THIS SECTION CONVERTS TO A GREGORIAN DATE
|
|
C
|
|
C TEST ARGUMENTS FOR VALIDITY
|
|
C
|
|
IF (MON.LT.1.OR.MON.GT.12.OR.DAY.LT.1.OR.DAY.GT.31.
|
|
1 OR.YEAR.LT.1) THEN
|
|
cdrc TYPE 5000
|
|
PRINT 5000
|
|
5000 FORMAT(' **GDATE ERROR')
|
|
cdrc TYPE '(A,I6)',' MONTH =',MON
|
|
cdrc TYPE '(A,I6)',' DAY =',DAY
|
|
cdrc TYPE '(A,I6)',' YEAR =',YEAR
|
|
PRINT '(A,I6)',' MONTH =',MON
|
|
PRINT '(A,I6)',' DAY =',DAY
|
|
PRINT '(A,I6)',' YEAR =',YEAR
|
|
IER=1
|
|
GO TO 180
|
|
END IF
|
|
C
|
|
IF (LYEAR(YEAR)) M(2)=29
|
|
C
|
|
IF (DAY.GT.M(MON)) THEN
|
|
cdrc TYPE 5000
|
|
cdrc TYPE '(A,I6)',' DAY =',DAY
|
|
PRINT 5000
|
|
PRINT '(A,I6)',' DAY =',DAY
|
|
IER=2
|
|
GO TO 180
|
|
END IF
|
|
C
|
|
C CALCULATE GREG. DATE TO 1ST OF REQUESTED YEAR
|
|
C
|
|
Y=YEAR-1
|
|
EGD=GDATS(Y)
|
|
C
|
|
C CALCULATE TO CURRENT GREGORIAN DATE
|
|
C
|
|
J=MON-1
|
|
IF (J.EQ.0) GO TO 110
|
|
DO 100 I=1,J
|
|
DYR=DYR+M(I)
|
|
100 CONTINUE
|
|
EGD=EGD+DYR
|
|
110 EGD=EGD+DAY
|
|
DYR=DYR+DAY
|
|
GO TO 170
|
|
C
|
|
C THIS SECTION CONVERTS FROM A GREGORIAN DATE
|
|
C
|
|
120 IF (EGD.LT.1) THEN
|
|
IER=3
|
|
cdrc TYPE 5000
|
|
cdrc TYPE '(A,I6)',' EGD =',EGD
|
|
PRINT 5000
|
|
PRINT '(A,I6)',' EGD =',EGD
|
|
GO TO 180
|
|
END IF
|
|
C
|
|
C CALCULATE CURRENT DATE (DD/MM/YYYY)
|
|
C
|
|
YEAR=(EGD/366)-1
|
|
130 YEAR=YEAR+1
|
|
EEGD=GDATS(YEAR)
|
|
IF (EGD-EEGD-368) 140,140,130
|
|
140 YEAR=YEAR+1
|
|
DYR=EGD-EEGD
|
|
C
|
|
IF (LYEAR(YEAR)) M(2)=29
|
|
C
|
|
DO 150 MON=1,12
|
|
EEGD=EEGD+M(MON)
|
|
IF (EGD.LE.EEGD) GO TO 160
|
|
150 CONTINUE
|
|
M(2)=28
|
|
GO TO 140
|
|
C
|
|
C CALCULATE THE REMAINING ARGUMENTS
|
|
C
|
|
160 DAY=EGD+M(MON)-EEGD
|
|
170 DMON=M(MON)
|
|
DWK=MOD(EGD,7)+1
|
|
RETURN
|
|
C
|
|
180 RETURN
|
|
END
|
|
C
|
|
C
|
|
C TITLE FUNCTION LYEAR(LEAP YEAR) ISS. 1 801126 R.A.G. (MWR)
|
|
FUNCTION LYEAR(YEAR)
|
|
C
|
|
IMPLICIT INTEGER*4 (A-Z)
|
|
C
|
|
C THIS FUNCTION WILL TEST A GIVEN YEAR AND RETURN A TRUE/FALSE
|
|
C INDICATION
|
|
C
|
|
C --------------------------------------------------------------
|
|
C
|
|
C REVISION LIST
|
|
C
|
|
C --DATE-- ---BY--- --DESCRIPTION--
|
|
C
|
|
C 26/11/80 R.A.G. -ORIGINAL ISSUE
|
|
C
|
|
C --------------------------------------------------------------
|
|
C
|
|
LYEAR=0
|
|
IF (MOD(YEAR,4).EQ.0.AND.MOD(YEAR,100).NE.0.OR.
|
|
& MOD(YEAR,400).EQ.0) LYEAR= -1
|
|
RETURN
|
|
END
|
|
C TITLE FUNCTION GDATS(GDATE) ISS. 1 801126 R.A.G. (MWR)
|
|
FUNCTION GDATS(YEAR)
|
|
C
|
|
C
|
|
IMPLICIT INTEGER*4 (A-Z)
|
|
|
|
C
|
|
C
|
|
C THIS FUNCTION IS PART OF THE GDATE SUBROUTINE, AND RETURNS A
|
|
C GREGORIAN DATE TO THE 1ST OF THE YEAR BASED ON THAT YEAR
|
|
C
|
|
C -----------------------------------------------------------------
|
|
C
|
|
C REVISION LIST
|
|
C
|
|
C --DATE-- ---BY--- --DESCRIPTION
|
|
C
|
|
C 26/11/80 R.A.G. -ORIGINAL ISSUE
|
|
C
|
|
C --------------------------------------------------------------------
|
|
C
|
|
C **NOTE**
|
|
C
|
|
C GDATS MUST BE DECLARED AS AN INTEGER*4 FUNCTION!!!!!!!
|
|
C
|
|
CON=365
|
|
GDATS=CON*YEAR
|
|
GDATS=GDATS+(24*(YEAR/100))
|
|
GDATS=GDATS+(YEAR/400)
|
|
GDATS=GDATS+(MOD(YEAR,100)/4)
|
|
RETURN
|
|
END
|