C-----------------------------------------------------------------------------
      SUBROUTINE GLORENZ
C-----------------------------------------------------------------------------
C 13 Mar 2008 - Corrected length in common block /PCONST/
C 10 Mar 2008 - corrected length errors in blank common
C-----------------------------------------------------------------------------
C     TERRAIN MODEL USING LORENZIAN SHAPED HORIZONTAL SURFACE LOCATED AT
C     ARBITRARY GEOGRAPHICAL LOCATION.                                  
      implicit double precision (a-h,o-z)
      COMMON/PCONST/CREF,RGAS,GAMMA      
     1 ,MO2,MN2,MO,MN,MH2O,MO3                        ! 9 Mar 2007 ! 13 Mar 2008
      DOUBLE PRECISION MO2,MN2,MO,MN,MH2O,MO3                      ! 13 Mar 2008
      COMMON/MCONST/PI,PIT2,PID2,DEGS,RAD,ALN10
C     COMMON DECK "B9" INSERTED HERE           
      INTEGER GMX,GNTBL,GITBL,GFRMTBL,IDSG(20) 
      COMMON/B9/GMX,GNTBL(10),GITBL(10),GFRMTBL(10),GGP(113)
      EQUIVALENCE (GGP,IDSG),(ANG,GGP(11))                  
      COMMON//R,TH,PH,KR,KTH,KPH,RKVARS(14),TPULSE,CSTEP,DRDT(20)
      double precision kr,kth,kph                                  ! 10 Mar 2008
C     COMMON DECK "GG" INSERTED HERE  
      DOUBLE PRECISION MODG
      COMMON/GG/MODG(4)
      COMMON/GG/G,PGR,PGRR,PGRTH,PGRPH   
      COMMON/GG/PGTH,PGPH,PGTHTH,PGPHPH,PGTHPH,GSELECT,GTIME  
C     COMMON DECK "B10" INSERTED HERE
      COMMON/WW/ dum(10), MAXW,W(1000)
      EQUIVALENCE (EARTHR,W(1))
C     TOPOGRAPHY   300-324
      EQUIVALENCE (GCZAMP,W(303)),(GCLAMZ,W(304))
      EQUIVALENCE (GCTHDL,W(305)),(GCBASE,W(306))
      INTEGER GPX    ,GQTBL(10),GLTBL(10),GIRMTBL(10) 
      DATA GPX/1/       
      DATA GQTBL/1,11,8*0/
      DATA GLTBL/1,9*0/   
      DATA GIRMTBL/1,9*0/ 
C
      ENTRY SETTOP
      GMX=GPX     
      CALL IMOVE(GNTBL,GQTBL,10)
      CALL IMOVE(GITBL,GLTBL,10)
      CALL IMOVE(GFRMTBL,GIRMTBL,10)
      CALL SETPTP                   
      RETURN      
C
      ENTRY ITOPOG
      IF(W(300) .NE. 4.) THEN
           PRINT*,' Model check number mismatch: '
           STOP ' W(300) should be 4 if you are using model GLORENZ.'
      ENDIF

      MODG(1)=8HGLORENZ   
      MODG(2)= w(302)
      GCTH0=PID2-GCLAMZ 
      GCINV=1.d0/GCTHDL 
      CALL IPTOPOG      
      RETURN            
C
      ENTRY TOPOG 
      CALL CLEAR(PGRR,8)  
      ETA=(TH-GCTH0)*GCINV
      ETA2=ETA*ETA        
      GBINOM=1.d0/(1.d0 + ETA2)
      Z=GCZAMP*GBINOM    
      G=R-EARTHR-Z-GCBASE
      PGR=1.d0           
      GBINOMB=GBINOM*GCINV
      PGTH=2.d0*Z*ETA*GBINOMB
      PGTHTH=2.d0*Z*GBINOMB*GBINOMB*(1.d0-3.d0*ETA2)
      RETURN   
      END      
