
C-----------------------------------------------------------------------------
      SUBROUTINE AWCWL
C-----------------------------------------------------------------------------
C     DISPERSION RELATION FOR ACOUSTIC WAVES WITH CURRENT, WITH LOSSES
C     COMMON DECK "RKAM" INSERTED HERE
      implicit double precision (a-h,o-z)
      REAL*8 KR,KTH,KPH
      COMMON//R,TH,PH,KR,KTH,KPH,RKVARS(14),TPULSE,CSTEP,DRDT(20)
C     COMMON DECK "CC" INSERTED HERE
      real*8 MODC
      COMMON/CC/MODC(4),CS,PCST,PCSR,PCSTH,PCSPH
C     COMMON DECK "CONST" INSERTED HERE 
      COMMON/PCONST/CREF,RGAS,GAMMA
      COMMON/MCONST/PI,PIT2,PID2,DEGS,RAD,ALN10
C     COMMON DECK "RK" INSERTED HERE
C     DEFINE SIZE REQUIRED FOR RAY STATE SAVE ARRAY  
      PARAMETER (LRKAMS=87+2*100,NXRKMS=12+LRKAMS,MXEQPT=21)
      PARAMETER (NRKSAV=NXRKMS+MXEQPT-1)
      COMMON /RK/ NEQS,STEP,MODE,E1MAX,E1MIN,E2MAX,E2MIN,FACT,RSTART
C     COMMON DECK "RINREAL" INSERTED HERE
      LOGICAL SPACE
      REAL*8 LPOLAR,LPOLRI,KPHK,KPHKI,KAY2,KAY2I 
      CHARACTER DISPM*6,modrin*64
      COMMON/RINPL/DISPM 
      COMMON /RIN/ MODRIN,RAYNAME(2,3),TYPE(3),SPACE
      COMMON/RIN/OMEGMIN,OMEGMAX,KAY2,KAY2I,
     1              H,HI,PHT,PHTI,PHR,PHRI,PHTH,PHTHI,PHPH,PHPHI
     2, PHOW,PHOWI,PHKR,PHKRI,PHKTH,PHKTI, PHKPH,PHKPI 
     3 ,KPHK,KPHKI,POLAR,POLARI,LPOLAR,LPOLRI,SGN 
C     COMMON DECK "UU" INSERTED HERE 
      real*8 MODU
      COMMON/UU/MODU(4)
     1  ,V  ,PVT  ,PVR  ,PVTH  ,PVPH  
     2  ,VR ,PVRT ,PVRR ,PVRTH ,PVRPH 
     3  ,VTH,PVTHT,PVTHR,PVTHTH,PVTHPH
     4  ,VPH,PVPHT,PVPHR,PVPHTH,PVPHPH
      common/ww/maxw,w(1000)
      REAL*8 KS,KV
      REAL*8 KVECT(24)
      EQUIVALENCE(KVECT,KAY2),(ow,w(6)) 
      REAL*8  TBPE( 3),modl
      CHARACTER DLSPM*5 
      COMMON/LL/MODL(4),APH,APHPT,APHPR,APHPTH,APHPPH 
      DATA DLSPM/'AWCWL'/
      DATA TBPE/3*1H3 / 
C
C
      ENTRY SETDSP  
	modrin = 'ACOUSTIC WAVE --- WITH CURRENT --- WITH LOSSES'
      DISPM=DLSPM 
      CALL RMOVE(TYPE,TBPE, 3) 
      CALL SETSPD
      CALL SETWND
      CALL SETRCV
      CALL SETTOP
      CALL SETSUR
      CALL SETABS
      RETURN     
C 
      ENTRY IDISPER
      CALL ISPEED
      CALL IWINDR
      CALL IRECVR
      CALL ITOPOG
      CALL ISURFAC
      CALL IABSRP
      RETURN
C
      ENTRY DISPER
      SPACE=.FALSE.
      KS=KR*KR+KTH*KTH+KPH*KPH
C     WIND VELOCITY 
      CALL WINDR
      KV=KR*VR+KTH*VTH+KPH*VPH
      VLS=KV*KV/KS
C     SOUND SPEED
      CALL SPEED
      OWS=OW*OW
      KAY2=OWS/(dSQRT(CS)+KV/dSQRT(KS))**2  
      OWI=OW-KV
      H=OWI*OWI - CS*KS
      POWIT=-KR*PVRT - KTH*PVTHT - KPH*PVPHT 
      PHT=2.d0*OWI*POWIT - KS*PCST 
      POWIR=-KR*PVRR - KTH*PVTHR - KPH*PVPHR 
      PHR=2.d0*OWI*POWIR - KS*PCSR
      POWITH=-KR*PVRTH - KTH*PVTHTH - KPH*PVPHTH
      PHTH=2.d0*OWI*POWITH - KS*PCSTH
      POWIPH=-KR*PVRPH - KTH*PVTHPH - KPH*PVPHPH  
      PHPH=2.d0*OWI*POWIPH - KS*PCSPH
      PHOW=2.d0*OWI
      PHKR=-2.d0*(OWI*VR + CS*KR)   
      PHKTH=-2.d0*(OWI*VTH + CS*KTH)
      PHKPH=-2.d0*(OWI*VPH + CS*KPH)
      KPHK=-2.d0*(OWI*KV + CS*KS)   
      CALL ABSRP
      GMS=GAMMA-1.d0
      KAY2I=-dSQRT(KAY2)*APH
      RETURN 
      END 


C-----------------------------------------------------------------------------
      SUBROUTINE VVORTX3  
C-----------------------------------------------------------------------------
C     WIND VELOCITY MODEL 
C     VERTICAL VORTEX WIND PERTURBATION WITH VISCOUS CORE AND
C     MULTIPLIES VELOCITY FIELD BY A GUASSIAN HEIGHT PROFILE.
      implicit double precision (a-h,o-z)
      COMMON/PCONST/CREF,RGAS,GAMMA       
      COMMON/MCONST/PI,PIT2,PID2,DEGS,RAD,ALN10
      COMMON//R,TH,PH,KR,KTH,KPH,RKVARS(14),TPULSE,CSTEP,DRDT(20)  
      real*8 MODU                         
      COMMON/UU/MODU(4)                   
     1  ,V  ,PVT  ,PVR  ,PVTH  ,PVPH      
     2  ,VR ,PVRT ,PVRR ,PVRTH ,PVRPH     
     3  ,VTH,PVTHT,PVTHR,PVTHTH,PVTHPH    
     4  ,VPH,PVPHT,PVPHR,PVPHTH,PVPHPH    
      COMMON/WW/MAXW,W(1000) 
      REAL*8 MAXSTP,MAXERR,INTYP,LLAT,LLON  
      EQUIVALENCE (EARTHR,W(1))
C     WIND        100-124      
      EQUIVALENCE (W(100),UMODEL),(W(101),UFORM),(W(102),UID)           
       EQUIVALENCE (U0,W(103)),(R0,W(104)),(TH0,W(105)),(PH0,W(106))    
       EQUIVALENCE (HWIDTH,W(107)),(HVMAX,W(108))           
C     COMMON DECK "B1" INSERTED HERE                        
      INTEGER UMX,UNTBL,UITBL,UFRMTBL,IDSU(20)              
      COMMON/B1/UMX,UNTBL(10),UITBL(10),UFRMTBL(10),UGP(10) 
      EQUIVALENCE (UGP,IDSU)                                
      INTEGER UPX    ,UQTBL(10),ULTBL(10),UIRMTBL(10)       
      DATA RECOGU/9.0/                                      
      DATA UPX/1/                                           
      DATA UQTBL/1,11,8*0/    
      DATA ULTBL/1,9*0/       
      DATA UIRMTBL/1,9*0/     
C                             
      ENTRY SETWND            
      UMX=UPX                 
      CALL IMOVE(UNTBL,UQTBL,10)     
      CALL IMOVE(UITBL,ULTBL,10)     
      CALL IMOVE(UFRMTBL,UIRMTBL,10) 
      CALL SETPWN                    
      RETURN                         
C                                    
      ENTRY IWINDR                   
      IF( idint(RECOGU) .NE.  idint(UMODEL))   
     1    CALL RERROR('SPEED  ','WRNG MODEL',RECOGU)
      MODU(1)=8HVVORTX3  
      MODU(2)=UID        
       DENOM=0.d0        
       IF(HWIDTH.NE.0.d0) DENOM=1.d0/HWIDTH/HWIDTH
      CALL IPWINDR                                
      RETURN         
C                    
       ENTRY WINDR   
      CALL CLEAR(V,20)
      DR=R-EARTHR-HVMAX
       DTH = TH - (PID2-TH0)
       DPH = PH - PH0       
       RAD2 = EARTHR * dSQRT(DTH * DTH + DPH * DPH)  
       A = 1.397d0     
       B = - 1.26d0    
      EXPO=RAD2/R0     
      EXPO=B*EXPO*EXPO 
      EXB=0.d0         
       IF(EXPO .GT. -675.d0) EXB = dEXP(EXPO)   
      FX=1.d0-EXB                               
       DUM = A * EARTHR * U0 * R0 / RAD2/rad2   
      FZ=dEXP(-DR*DR*DENOM)                     
      DFDZ=-2.d0*DR*DENOM                       
      DUM=FZ*DUM                                
       DUX = FX / RAD2 + RAD2 * B * EXB / R0 * * 2
       VTH = - DUM * FX * DPH
       VPH = DUM * FX * DTH  
      V=dSQRT(VTH*VTH + VPH*VPH)
       DUM2=2.d0*DUM*EARTHR*EARTHR
       PVTHTH = DUM2 * DTH * DPH / RAD2 * DUX  
       PVPHPH = - PVTHTH     
       PVTHPH = DPH*dph * DUM2 / RAD2 * DUX -DUM*FX 
       PVPHTH = - DTH*dth* DUM2 / RAD2* DUX + DUM*FX
      PVTH=(VTH*PVTHTH + VPH*PVPHTH)/V              
      PVPH=(VTH*PVTHPH + VPH*PVPHPH)/V              
      PVTHR=VTH*DFDZ                                
      PVPHR=VPH*DFDZ                                
      PVR=(VTH*PVTHR+VPH*PVPHR)/V                   
      CALL PWINDR                                   
       RETURN                                       
       END                                          
                                                    

C-----------------------------------------------------------------------------
      SUBROUTINE NPCURR   
C-----------------------------------------------------------------------------
C     DO-NOTHING CURRENT PERTURBATION MODEL   
C     COMMON DECK "UU" INSERTED HERE     
      implicit double precision (a-h,o-z)
      real*8 MODU                        
      common/ww/maxw,w(1000)
      COMMON/UU/MODU(4)     
     1  ,V  ,PVT  ,PVR  ,PVTH  ,PVPH     
     2  ,VR ,PVRT ,PVRR ,PVRTH ,PVRPH    
     3  ,VTH,PVTHT,PVTHR,PVTHTH,PVTHPH   
     4  ,VPH,PVPHT,PVPHR,PVPHTH,PVPHPH   
C     DELTA WIND        125-149          
      EQUIVALENCE (W(125),DUMODEL),(W(126),DUFORM),(W(127),DUID)
      INTEGER DUMX,DUNTBL,DUITBL,DUFRMTB,IDSDU(20)              
      COMMON/B2/DUMX,DUNTBL(10),DUITBL(10),DUFRMTB(10),DUGP(10) 
      EQUIVALENCE (DUGP,IDSDU)                                  
      INTEGER DXMX    ,DXNTBL(10),DXITBL(10),DXFRMTB(10)        
      DATA RECOGDU/0.0/      
      DATA DXMX/1/           
      DATA DXNTBL/1,11,8*0/  
      DATA DXITBL/1,9*0/     
      DATA DXFRMTB/1,9*0/    
C                            
      ENTRY SETPWN           
      DUMX=DXMX              
      CALL IMOVE(DUNTBL,DXNTBL,10)  
      CALL IMOVE(DUITBL,DXITBL,10)  
      CALL IMOVE(DUFRMTB,DXFRMTB,10)
      RETURN                        
C                                   
      ENTRY IPWINDR                 
      IF( idint(RECOGDU) .NE. idint(DUMODEL))   
     1    CALL RERROR('DWINDR ','WRNG MODEL',RECOGDU)
      MODU(3)=8HNPCURR      
      MODU(4)=DUID          
      RETURN                
C                           
      ENTRY PWINDR          
      RETURN                
      END                   
                            
 
C-----------------------------------------------------------------------------
      SUBROUTINE CTANH
C-----------------------------------------------------------------------------
C     SPEED PROFILE REPRESENTED BY A SEQUENCE OF LINEAR SEGMENTS   
C     SMOOTHLY JOINED BY HYPERBOLIC FUNCTIONS. PARAMETERS ARE INPUT
C     AS TABULAR DATA WITH SLOPES COMPUTED FROM SPEED DATA.        
C     REFERENCE SPEED C0 IS READ FROM TABULAR DATA.                
      implicit double precision (a-h,o-z)
      COMMON//R,TH,PH,KR,KTH,KPH,RKVARS(14),TPULSE,CSTEP,DRDT(20)
C     COMMON DECK "CC" INSERTED HERE
      real*8 MODC
      INTEGER CPX,CQTBL(10),CLTBL(10),CIRMTBL(10)  
      COMMON/CC/MODC(4),CS,PCST,PCSR,PCSTH,PCSPH    
      COMMON/WW/MAXW,W(1000) 
C     SOUND SPEED 150-174 
      EQUIVALENCE (W(150),CMODEL),(W(151),CFORM),(W(152),CID)
      EQUIVALENCE (W(153),REFC),(earthr,w(1))                                         CWW30120
      INTEGER CMX,CNTBL,CITBL,CFRMTBL,IDSC(20) 
      COMMON/B3/CMX,CNTBL(10),CITBL(10),CFRMTBL(10),CGP(512)
      EQUIVALENCE (CGP,IDSC),(ANC,CGP(11))
C.......The changes from the Cyber version indicated in lower case 
C.......below enlarge the data arrays to accommodate 100 profile points.
      real*8 co(100), tm(99), z(99), dl(99)
      EQUIVALENCE (Z0,CGP(12)),(CO,cgp(112))
      EQUIVALENCE (Z,CGP(13)),(TM,cgp(113)),(DL,cgp(213))
      data cqtbl/1,11,312,7*0/
      data cltbl/1,100,8*0/   
      DATA CIRMTBL/1,2,8*0/  
      DATA RECOGC,N/7.0,0/
      DATA AQC/0.0/ 
      DATA CPX/2/   
C%      COSH (X) = (dEXP (X) + 1.d0 / (dEXP (X))) / 2.d0 ! not needed
C
      ENTRY SETSPD  
      ANC=AQC       
      CMX=CPX       
      CALL IMOVE(CNTBL,CQTBL,10)  
      CALL IMOVE(CITBL,CLTBL,10) 
      CALL IMOVE(CFRMTBL,CIRMTBL,10)
      CALL SETPSP
      RETURN     
C
      ENTRY ISPEED
C     IF HAD PREVIOUS CALL BUT NOTHING THIS TIME, EXIT NOW
C     RETAINING PREVIOUS TABULAR DATA COUNT
      CALL IPSPEED 
      IF(N.GT.0 .AND. ANC.EQ.0.d0) RETURN 
      IF( idint(RECOGC) .NE.  idint(CMODEL))
     1    CALL RERROR('SPEED   ','WRNG MODEL',RECOGC)
      MODC(1)=8HCTANH 
      MODC(2)=CID
      N=(ANC+1)/3 - 2
      avl=float(n)   
      IF(N.LE.0)     
     1    CALL RERROR('CTANH','BAD N VALUE',     avl)
      ANC=0.d0
C     CONVERT 'CGP' ARRAY INPUT(OVERLAYS 'C' ARRAY) TO 'C' ARRAY 
      C0=CO(1) 
      TIM1=C0  
      ZIM1=Z0  
      NP1=N+1  
      DO 10 I=1,NP1
         TI=TM(I)  
         ZI=Z(I)   
         CO(I)=(TI-TIM1)/(ZI-ZIM1)  
         TIM1=TI 
10       ZIM1=ZI 
      RETURN 
C 
      ENTRY SPEED 
      H = R - EARTHR
      SUM = 0.d0
C     LOOP TO SUM OVER ALL COEFFICIENTS 
C     USE SPECIAL FUNCTION 'ALCOSH' WHICH ALLOWS FOR LARGE ARGUMENTS.
      DO 1 I = 1, N
   1  SUM = SUM + DL(I) * (CO(I + 1) - CO(I)) / 2.d0 *(ALCOSH((H - Z
     1(I)) / DL(I)) - ALCOSH((Z(I)-Z0) / DL(I)))
      C = C0 + SUM + (CO(1) + CO(N + 1)) * (H - Z0) * 0.5d0
      SUM = 0.d0
      DO 2 I = 1, N
   2  SUM = SUM + (CO(I + 1) - CO(I)) / 2.d0*(1.d0+dTANH((H - Z(I)) /DL
     1 (I)))
      CS=C*C
      PCST=0.d0
      PCSR = 2.d0*C*(CO(1) + SUM)    
      PCSTH=0.d0 
      PCSPH=0.d0 
      CALL PSPEED
      RETURN 
      END 
                                                                                
 
C-----------------------------------------------------------------------------
      SUBROUTINE CBLOB2
C-----------------------------------------------------------------------------
C     SOUND SPEED PERTURBATION MODEL
C     MULTIPLICATIVE PERTURBATION WITH EXPONENTIALLY DECAYING
C     EFFECT IN ALL THREE DIRECTIONS. GIVE LATITUDE 
C     INSTEAD OF CO-LATITUDE.
      implicit double precision (a-h,o-z)
      COMMON/PCONST/CREF,RGAS,GAMMA 
      COMMON/MCONST/PI,PIT2,PID2,DEGS,RAD,ALN10
      COMMON//R,TH,PH,KR,KTH,KPH,RKVARS(14),TPULSE,CSTEP,DRDT(20)
C     COMMON DECK "B4" INSERTED HERE 
      INTEGER DCMX,DCNTBL,DCITBL,DCFRMTB,IDSDC(20)
      COMMON/B4/DCMX,DCNTBL(10),DCITBL(10),DCFRMTB(10),DCGP(10)
      EQUIVALENCE (DCGP,IDSDC) 
C     COMMON DECK "CC" INSERTED HERE 
      real*8 MODC
      COMMON/CC/MODC(4),CS,PCST,PCSR,PCSTH,PCSPH
      COMMON/WW/MAXW,W(1000) 
      REAL*8 MAXSTP,MAXERR,INTYP,LLAT,LLON 
      EQUIVALENCE (EARTHR,W(1))
C     DELTA SOUND SPEED 175-199
      EQUIVALENCE (W(175),DCMODEL),(W(176),DCFORM),(W(177),DCID)
      EQUIVALENCE (C0,W(178)), (Z0,W(179)),(CBTH0,W(180))
      EQUIVALENCE (PH0,W(181)),(WZ,W(182)),(WTH,W(183)),(WPH,W(184))
      INTEGER DFMX    ,DFNTBL(10),DFITBL(10),DFFRMTB(10)
      DATA RECOGDC/2.0/
      DATA DFMX/1/
      DATA DFNTBL/1,11,8*0/
      DATA DFITBL/1,9*0/
      DATA DFFRMTB/1,9*0/
C
      ENTRY SETPSP
      DCMX=DFMX 
      CALL IMOVE(DCNTBL,DFNTBL,10)
      CALL IMOVE(DCITBL,DFITBL,10)
      CALL IMOVE(DCFRMTB,DFFRMTB,10)
      RETURN
C
      ENTRY IPSPEED
      IF( idint(RECOGDC) .NE.  idint(DCMODEL))
     1    CALL RERROR('DSPEED ','WRNG MODEL',RECOGDC)
      MODC(3)=8HCBLOB2
      MODC(4)=DCID
      FWZ=0.d0
      FWTH=0.d0
      FWPH=0.d0
      TH0= PID2-CBTH0
      IF(WZ.NE.0.d0) FWZ=2.d0/WZ/WZ
      IF(WTH.NE.0.d0) FWTH=2.d0/WTH/WTH
      IF(WPH.NE.0.d0) FWPH=2.d0/WPH/WPH
      RETURN
C
      ENTRY PSPEED
      IF(C0.EQ.0.0) RETURN
      DZ=R-EARTHR-Z0
      DTH=TH-TH0
      DPH=PH-PH0
      DEXPO=0.0 
      EXPO=-0.5*(DZ*DZ*FWZ+DTH*DTH*FWTH+DPH*DPH*FWPH)
      IF(EXPO .GT. -200.d0) DEXPO=C0*dEXP(EXPO)
      DEL=1.d0+DEXPO 
      PCSR=PCSR*DEL-CS*DEXPO*FWZ*DZ 
      PCSTH=PCSTH*DEL-CS*DEXPO*FWTH*DTH
      PCSPH=PCSPH*DEL-CS*DEXPO*FWPH*DPH
      CS=CS*DEL
      RETURN
      END 
    
 
C-----------------------------------------------------------------------------
      SUBROUTINE GLORENZ
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      
      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)
C     COMMON DECK "GG" INSERTED HERE  
      real*8 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/MAXW,W(1000) 
      EQUIVALENCE (EARTHR,W(1))
C     TOPOGRAPHY   300-324
      EQUIVALENCE (W(300),GMODEL),(W(301),GFORM),(W(302),GID)
      EQUIVALENCE (GCZAMP,W(303)),(GCLAMZ,W(304))
      EQUIVALENCE (GCTHDL,W(305)),(GCBASE,W(306))
      INTEGER GPX    ,GQTBL(10),GLTBL(10),GIRMTBL(10) 
      DATA RECOGG/4.0/  
      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( idint(RECOGG) .NE.  idint(GMODEL)) 
     1    CALL RERROR('GROUND ','WRNG MODEL',RECOGG)
      MODG(1)=8HGLORENZ   
      MODG(2)=GID       
      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      
                                                                                
 
C-----------------------------------------------------------------------------
      SUBROUTINE NPBOTM
C-----------------------------------------------------------------------------
C    DO-NOTHING BOTTOM PERTURBATION MODEL  
C     COMMON DECK "GG" INSERTED HERE       
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      real*8 MODG                        
      COMMON/GG/MODG(4)                  
      COMMON/GG/G,PGR,PGRR,PGRTH,PGRPH   
      COMMON/GG/PGTH,PGPH,PGTHTH,PGPHPH,PGTHPH,GSELECT,GTIME 
      COMMON/WW/MAXW,W(1000) 
      EQUIVALENCE (EARTHR,W(1))
C     DELTA TOPOGRAPHY   325-349
      EQUIVALENCE (W(325),GUMODEL),(W(326),GUFORM),(W(327),GUID)
C     COMMON DECK "B10" INSERTED HERE                           
      INTEGER DGMX,DGNTBL,DGITBL,DGFRMTB,IDSDG(20)              
      COMMON/B10/DGMX,DGNTBL(10),DGITBL(10),DGFRMTB(10),DGGP(10)
      EQUIVALENCE (DGGP,IDSDG)                                  
      INTEGER DJMX    ,DJNTBL(10),DJITBL(10),DJFRMTB(10)        
      DATA DJMX/1/          
      DATA DJNTBL/1,11,8*0/ 
      DATA DJITBL/1,9*0/    
      DATA DJFRMTB/1,9*0/   
C                           
      ENTRY SETPTP          
      DGMX=DJMX             
      CALL IMOVE(DGNTBL,DJNTBL,10)  
      CALL IMOVE(DGITBL,DJITBL,10)  
      CALL IMOVE(DGFRMTB,DJFRMTB,10)
      RETURN                        
C                                   
      ENTRY IPTOPOG                 
      MODG(3)=8HNPBOTM              
      MODG(4)=GUID                  
      ENTRY PTOPOG                  
      END                           
                                    
 
C-----------------------------------------------------------------------------
      SUBROUTINE SLLOSS   
C-----------------------------------------------------------------------------
C     SLLOSS BACKGROUND ABSORPTION FORMULA    
      implicit double precision (a-h,o-z)
      EQUIVALENCE (W(500),AMODEL),(W(501),AFORM),(W(502),AID)  
      EQUIVALENCE (W(503),ACOEF),(W(504),BCOEF),(W(505),OMEG1) 
      EQUIVALENCE (W(506),OMEG2),(w(6),ow)                     
C     COMMON DECK "LL" INSERTED HERE                           
      real*8 MODL                                              
      common/ww/maxw,w(1000)
      COMMON/LL/MODL(4),APH,APHPT,APHPR,APHPTH,APHPPH 
C     COMMON DECK "CB17" INSERTED HERE                
      INTEGER VMX,VNTBL,VITBL,VFRMTBL,IDSV(10)        
      COMMON/B17/VMX,VNTBL(10),VITBL(10),VFRMTBL(10),VGP(53)
      EQUIVALENCE (VGP,IDSV),(ANV,VGP(11))                  
      INTEGER VPX    ,VQTBL(10),VLTBL(10),VIRMTBL(10)       
      DATA VPX/1/         
      DATA VQTBL/1,11,8*0/
      DATA VLTBL/1,9*0/   
      DATA VIRMTBL/1,9*0/ 
      DATA RECOGA/1.0/    
C                         
      ENTRY SETABS        
      VMX=VPX                       
      CALL IMOVE(VNTBL,VQTBL,10)    
      CALL IMOVE(VITBL,VLTBL,10)    
      CALL IMOVE(VFRMTBL,VIRMTBL,10)
      CALL SETPAB                   
      RETURN                        
C                                   
      ENTRY IABSRP                  
      IF( idint(RECOGA) .NE.  idint(AMODEL))
     1    CALL RERROR('ABSRP ','WRNG MODEL',RECOGA)
      MODL(1)=8HSLLOSS                             
      MODL(2)=AID                                  
      CALL IPABSRP                                 
      RETURN                                       
C                                                  
      ENTRY ABSRP                                  
      OWS=OW*OW                                    
      APH=ACOEF*(OW/OMEG1)*(ow/omeg1)+ BCOEF*OWS/(OMEG2*omeg2+OWS) 
      CALL PABSRP       
      END               
                        
 
C-----------------------------------------------------------------------------
      SUBROUTINE NPABSR 
C-----------------------------------------------------------------------------
C     DO-NOTHING ABSORPTION PERTURBATION MODEL  
      implicit double precision (a-h,o-z)
C     COMMON DECK "LL" INSERTED HERE     
      real*8 MODL                        
      COMMON/LL/MODL(4),APH,APHPT,APHPR,APHPTH,APHPPH
C     COMMON DECK "CB18" INSERTED HERE               
      INTEGER DVMX,DVNTBL,DVITBL,DVFRMTB,IDSDV(10)   
      COMMON/B18/DVMX,DVNTBL(10),DVITBL(10),DVFRMTB(10),DVGP(11)
      EQUIVALENCE (DVGP,IDSDV),(ANDV,DVGP(11))    
      INTEGER DYMX    ,DYNTBL(10),DYITBL(10),DYFRMTB(10)  
      DATA DYMX/1/          
      DATA DYNTBL/1,11,8*0/ 
      DATA DYITBL/1,9*0/    
      DATA DYFRMTB/1,9*0/   
      DATA RECOGDA/0.0/     
C                           
      ENTRY SETPAB          
      DVMX=DYMX             
      CALL IMOVE(DVNTBL,DYNTBL,10)  
      CALL IMOVE(DVITBL,DYITBL,10)  
      CALL IMOVE(DVFRMTB,DYFRMTB,10)
      RETURN                        
C                                   
      ENTRY IPABSRP                 
      IF( idint(RECOGDA) .NE.  idint(DAMODEL))    
     1    CALL RERROR('DABSRP ','WRNG MODEL',RECOGDA)
      MODL(3)=8HNPABSR 
      MODL(4)=DAID     
      RETURN           
C                      
      ENTRY PABSRP     
      RETURN           
      END              
                                                                                
 
C-----------------------------------------------------------------------------
      SUBROUTINE RHORIZ
C-----------------------------------------------------------------------------
C     RECEIVER MODEL USING FIXED OFFSET TO EARTHR'S SURFACE
C     COMMON DECK "RR" INSERTED HERE     
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      real*8 MODREC                      
      COMMON/RR/ MODREC(4)               
      COMMON/RR/F,PFR,PFRR,PFRTH,PFRPH   
      COMMON/RR/PFTH,PFPH,PFTHTH,PFPHPH,PFTHPH,FSELECT,FTIME
C     COMMON DECK "WW" INSERTED HERE                        
      COMMON/WW/MAXW,W(1000) 
C     RECEIVER HEIGHT   275-299
      EQUIVALENCE (W(275),RMODEL),(W(276),RFORM),(W(277),RID) 
      COMMON//R,TH,PH,KR,KTH,KPH,RKVARS(14),TPULSE,CSTEP,DRDT(20)
C     COMMON DECK "B8" INSERTED HERE                 
      INTEGER RMX,RNTBL,RITBL,RFRMTBL,IDSR(20)       
      COMMON/B8/RMX,RNTBL(10),RITBL(10),RFRMTBL(10),RGP(10) 
      EQUIVALENCE (RGP,IDSR)                
      INTEGER RPX    ,RQTBL(10),RLTBL(10),RIRMTBL(10)   
      DATA RECORR/1.0/         
      DATA RPX/1/              
      DATA RQTBL/1,11,8*0/     
      DATA RLTBL/1,9*0/        
      DATA RIRMTBL/1,9*0/      
C
      ENTRY SETRCV     
      RMX=RPX          
      CALL IMOVE(RNTBL,RQTBL,10)         
      CALL IMOVE(RITBL,RLTBL,10)         
      CALL IMOVE(RFRMTBL,RIRMTBL,10)     
      RETURN                             
C                                        
      ENTRY IRECVR                       
      IF( idint(RECORR) .NE. idint(RMODEL))
     1    CALL RERROR('RECEIVR','WRNG MODEL',RECORR) 
      MODREC(1)=8HRHORIZ  
      MODREC(2)=RID       
      RETURN              
C                         
      ENTRY RECEVER       
      F=R-W(1)-W(20)      
      PFR=1.d0            
      CALL CLEAR(PFRR,8)  
      END                 
                          
 
C-----------------------------------------------------------------------------
      SUBROUTINE SHORIZ
C-----------------------------------------------------------------------------
C     SURFACE MODEL USING FIXED OFFSET TO EARTHR'S SURFACE.
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON//R,TH,PH,KR,KTH,KPH,RKVARS(14),TPULSE,CSTEP,DRDT(20)
C     COMMON DECK "SS" INSERTED HERE                             
      real*8 MODSURF                                             
      common/ww/maxw,w(1000)
      COMMON/SS/ MODSURF(4) 
      COMMON/SS/U,PUR,PURR,PURTH,PURPH   
      COMMON/SS/PUTH,PUPH,PUTHTH,PUPHPH,PUTHPH,USELECT,UTIME
      EQUIVALENCE (EARTHR,W(1))
C     ATMOSPHERIC SURFACE TOPOGRAPHY   350-374   
      EQUIVALENCE (W(350),SMODEL),(W(351),SFORM),(W(352),SID)  
      EQUIVALENCE (W(353),SHEIGHT)                             
C     COMMON DECK "CB11" INSERTED HERE                         
      INTEGER SMX,SNTBL,SITBL,SFRMTBL,IDSS(10)                 
      COMMON/B11/SMX,SNTBL(10),SITBL(10),SFRMTBL(10),SGP(11)   
      EQUIVALENCE (SGP,IDSS),(ANS,SGP(11))                     
      INTEGER SPX    ,SQTBL(10),SLTBL(10),SIRMTBL(10)          
      DATA RECOSS/1.0/     
      DATA SPX/1/          
      DATA SQTBL/1,11,8*0/ 
      DATA SLTBL/1,9*0/    
      DATA SIRMTBL/1,9*0/  
C                     
      ENTRY SETSUR    
      SMX=SPX         
      CALL IMOVE(SNTBL,SQTBL,10) 
      CALL IMOVE(SITBL,SLTBL,10) 
      CALL IMOVE(SFRMTBL,SIRMTBL,10)
      CALL SETPSR  
      RETURN       
C                  
      ENTRY ISURFAC
      IF( idint(RECOSS) .NE. idint(SMODEL)) 
     1   CALL RERROR('SURFACE','WRNG MODEL', RECOSS)     
      MODSURF(1)=8HSHORIZ                     
      MODSURF(2)=SID                          
C     CALL THE PERTURBATION INITIALIZATION    
      CALL IPSURF                             
      RETURN                                  
C                                             
      ENTRY SURFACE                           
      U=-(R-EARTHR-SHEIGHT)                   
      PUR=-1.d0                               
      CALL CLEAR(PURR,8)                      
C     CALL THE PERTURBATION                   
      CALL PSURFCE                            
      END                                     
                                              
                                              
 
C-----------------------------------------------------------------------------
      SUBROUTINE NPSURF  
C-----------------------------------------------------------------------------
C     DO-NOTHING SURFACE PERTURBATION MODEL  
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      real*8 MODSURF                     
      common/ww/maxw,w(1000)
      COMMON/SS/ MODSURF(4) 
      COMMON/SS/U,PUR,PURR,PURTH,PURPH          
      COMMON/SS/PUTH,PUPH,PUTHTH,PUPHPH,PUTHPH,USELECT,UTIME
      INTEGER DSMX,DSNTBL,DSITBL,DSFRMTB,IDSDS(10)          
      COMMON/B12/DSMX,DSNTBL(10),DSITBL(10),DSFRMTB(10),DSGP(11)
      EQUIVALENCE (W(350),SMODEL),(W(351),SFORM),(W(352),SID)
      EQUIVALENCE (DSGP,IDSDS),(ANDS,DSGP(11))               
      INTEGER DVMX    ,DVNTBL(10),DVITBL(10),DVFRMTB(10)     
      DATA RECOGSU/0.0/     
      DATA DVMX/1/          
      DATA DVNTBL/1,11,8*0/ 
      DATA DVITBL/1,9*0/    
      DATA DVFRMTB/1,9*0/   
C                           
      ENTRY SETPSR          
      DSMX=DVMX                           
      CALL IMOVE(DSNTBL,DVNTBL,10)        
      CALL IMOVE(DSITBL,DVITBL,10)        
      CALL IMOVE(DSFRMTB,DVFRMTB,10)      
      RETURN                              
C
      ENTRY IPSURF    
      IF(RECOGSU .NE. SUMODEL)  
     1    CALL RERROR('DSURF ','WRNG MODEL',RECOGSU) 
      MODSURF(3)=8HNPSURF   
      MODSURF(4)=SUID      
      RETURN               
C                         
      ENTRY PSURFCE       
      RETURN              
      END                 
                                                                                
 