3DRWALK/source/gdate.for

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