      SUBROUTINE AWWWL                                                  AWWWL  8

c

      implicit real*8 (a-h,o-z)

c

C     DISPERSION RELATION FOR ACOUSTIC WAVES WITH WIND, WITH LOSSES     AWWWL  9

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL*8 KR,KTH,KPH                                                 RKAMCOM4

      COMMON//R,TH,PH,KR,KTH,KPH,RKVARS(14),TPULSE,CSTEP,DRDT(20)       RKAMCOM5

C     COMMON DECK "CC" INSERTED HERE                                    CCC    2

      real*8 modc

c     REAL MODC                                                         CCC    4

      COMMON/CC/MODC(4),CS,PCST,PCSR,PCSTH,PCSPH                        CCC    5

C     COMMON DECK "CONST" INSERTED HERE                                 CCONST 2

      COMMON/PCONST/CREF,RGAS,GAMMA                                     CCONST 4

      COMMON/MCONST/PI,PIT2,PID2,DEGS,RAD,ALN10                         CCONST 5

C     COMMON DECK "RK" INSERTED HERE                                    CRK    2

C     DEFINE SIZE REQUIRED FOR RAY STATE SAVE ARRAY                     CRK    4

      PARAMETER (LRKAMS=87+2*100,NXRKMS=12+LRKAMS,MXEQPT=21)            CRK    5

      PARAMETER (NRKSAV=NXRKMS+MXEQPT-1)                                CRK    6

      COMMON /RK/ NEQS,STEP,MODE,E1MAX,E1MIN,E2MAX,E2MIN,FACT,RSTART    CRK    7

C     COMMON DECK "RINREAL" INSERTED HERE                               CRINREA2

      LOGICAL SPACE                                                     CRINREA4

      REAL*8 LPOLAR,LPOLRI,KPHK,KPHKI,KAY2,KAY2I                        CRINREA5

      CHARACTER DISPM*6                                                 CRINREA6

      COMMON/RINPL/DISPM                                                CRINREA7

      real*8 modrin

      COMMON /RIN/ MODRIN(8),RAYNAME(2,3),TYPE(3),SPACE                 CRINREA8

      COMMON/RIN/OMEGMIN,OMEGMAX,KAY2,KAY2I,                            CRINREA9

     1              H,HI,PHT,PHTI,PHR,PHRI,PHTH,PHTHI,PHPH,PHPHI        CRINRE10

     2, PHOW,PHOWI,PHKR,PHKRI,PHKTH,PHKTI, PHKPH,PHKPI                  CRINRE11

     3 ,KPHK,KPHKI,POLAR,POLARI,LPOLAR,LPOLRI,SGN                       CRINRE12

C     COMMON DECK "UU" INSERTED HERE                                    CUU    2

      real*8 modu 

c     REAL MODU                                                         CUU    4

      COMMON/UU/MODU(4)                                                 CUU    5

     1  ,V  ,PVT  ,PVR  ,PVTH  ,PVPH                                    CUU    6

     2  ,VR ,PVRT ,PVRR ,PVRTH ,PVRPH                                   CUU    7

     3  ,VTH,PVTHT,PVTHR,PVTHTH,PVTHPH                                  CUU    8

     4  ,VPH,PVPHT,PVPHR,PVPHTH,PVPHPH                                  CUU    9

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      PARAMETER (NWARSZ=1000)                                           CWW1   3

      real*8 id

      COMMON/WW/ID(10),MAXW,W(NWARSZ)                                   CWW1   4

      REAL*8 MAXSTP,MAXERR,INTYP,LLAT,LLON                              CWW2   2

      EQUIVALENCE (EARTHR,W(1)),(RAY,W(2)),(XMTRH,W(3)),(TLAT,W(4)),    CWW2   3

     1 (TLON,W(5)),(OW,W(6)),(FBEG,W(7)),(FEND,W(8)),(FSTEP,W(9)),      CWW2   4

     2 (AZ1,W(10)),(AZBEG,W(11)),(AZEND,W(12)),(AZSTEP,W(13)),          CWW2   5

     3 (BETA,W(14)),(ELBEG,W(15)),(ELEND,W(16)),(ELSTEP,W(17)),         CWW2   6

     8 (RCVRH,W(20)),                                                   CWW2   7

     4 (ONLY,W(21)),(HOP,W(22)),(MAXSTP,W(23)),(PLAT,W(24)),(PLON,W(25))CWW2   8

     5,(HMAX,W(26)),(RAYFNC,W(29)),(EXTINC,W(33)),                      CWW2   9

     6 (HMIN,W(27)),(RGMAX,W(28)),                                      CWW2  10

     8 (INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),                     CWW2  11

     6 (STEP1,W(44)),(STPMAX,W(45)),(STPMIN,W(46)),(FACTR,W(47)),       CWW2  12

     7 (SKIP,W(71)),(RAYSET,W(72)),(PRTSRP,W(74)),(HITLET,W(75))        CWW2  13

     9 ,(BINRAY,W(76)),(PAGLN,W(77)),(PLT,W(81)),(PFACTR,W(82)),        CWW2  14

     1 (LLAT,W(83)),(LLON,W(84)),(RLAT,W(85)),(RLON,W(86))              CWW2  15

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89)),(TICV,W(96))                   CWW2  16

      REAL*8 MMODEL,MFORM,MID                                           CWW3   2

C                                                                       CWW3   3

C     WIND        100-124                                               CWW3   4

      EQUIVALENCE (W(100),UMODEL),(W(101),UFORM),(W(102),UID)           CWW3   5

C                                                                       CWW3   6

C     DELTA WIND        125-149                                         CWW3   7

      EQUIVALENCE (W(125),DUMODEL),(W(126),DUFORM),(W(127),DUID)        CWW3   8

C                                                                       CWW3   9

C     SOUND SPEED 150-174                                               CWW3  10

      EQUIVALENCE (W(150),CMODEL),(W(151),CFORM),(W(152),CID)           CWW3  11

      EQUIVALENCE (W(153),REFC)                                         CWW3  12

C                                                                       CWW3  13

C     DELTA SOUND SPEED 175-199                                         CWW3  14

      EQUIVALENCE (W(175),DCMODEL),(W(176),DCFORM),(W(177),DCID)        CWW3  15

C                                                                       CWW3  16

C     TEMPERATURE    200-224                                            CWW3  17

      EQUIVALENCE (W(200),TMODEL),(W(201),TFORM),(W(202),TID)           CWW3  18

C                                                                       CWW3  19

C     DELTA TEMPERATURE    225-249                                      CWW3  20

      EQUIVALENCE (W(225),DTMODEL),(W(226),DTFORM),(W(227),DTID)        CWW3  21

C                                                                       CWW3  22

C     MOLECULAR   250-274                                               CWW3  23

      EQUIVALENCE (W(250),MMODEL),(W(251),MFORM),(W(252),MID)           CWW3  24

C                                                                       CWW3  25

C     RECEIVER HEIGHT   275-299                                         CWW3  26

      EQUIVALENCE (W(275),RMODEL),(W(276),RFORM),(W(277),RID)           CWW3  27

C                                                                       CWW3  28

C     TOPOGRAPHY   300-324                                              CWW3  29

      EQUIVALENCE (W(300),GMODEL),(W(301),GFORM),(W(302),GID)           CWW3  30

C                                                                       CWW3  31

C     DELTA TOPOGRAPHY   325-349                                        CWW3  32

      EQUIVALENCE (W(325),GUMODEL),(W(326),GUFORM),(W(327),GUID)        CWW3  33

C                                                                       CWW3  34

C     UPPER SURFACE TOPOGRAPHY   350-374                                CWW3  35

      EQUIVALENCE (W(350),SMODEL),(W(351),SFORM),(W(352),SID)           CWW3  36

C     PLOT ENHANCEMENTS CONTROL PARAMETERS                              CWW3  37

C                                                                       CWW3  38

      EQUIVALENCE (W(490),XFQMDL),(W(491),YFQMDL)                       CWW3  39

C     ABSORPTION        500-524                                         CWW3  40

      EQUIVALENCE (W(500),AMODEL),(W(501),AFORM),(W(502),AID)           CWW3  41

C                                                                       CWW3  42

C     DELTA ABSORPTION        525-549                                   CWW3  43

      EQUIVALENCE (W(525),DAMODEL),(W(526),DAFORM),(W(527),DAID)        CWW3  44

C                                                                       CWW3  45

C     PRESSURE        550-574                                           CWW3  46

      EQUIVALENCE (W(550),PMODEL),(W(551),PFORM),(W(552),PID)           CWW3  47

C                                                                       CWW3  48

C     DELTA PRESSURE        575-599                                     CWW3  49

      EQUIVALENCE (W(575),DPMODEL),(W(576),DPFORM),(W(577),DPID)        CWW3  50

C                                                                       CWW3  51

C                                                                       AWWWL 17

C     COMMON DECK "AA" INSERTED HERE                                    CAA    2

      real*8 moda

c     REAL MODA                                                         CAA    4

      REAL*8 MU,MUPT,MUPR,MUPTH,MUPPH                                   CAA    5

      REAL*8 KAP,KAPPT,KAPPR,KAPPTH,KAPPPH                              CAA    6

      COMMON/AA/MODA(4),MU,MUPT,MUPR,MUPTH,MUPPH                        CAA    7

      COMMON/AA/KAP,KAPPT,KAPPR,KAPPTH,KAPPPH                           CAA    8

C                                                                       AWWWL 19

C     COMMON DECK "PP" INSERTED HERE                                    CPP    2

      real*8 modp

c     REAL MODP                                                         CPP    4

      COMMON/PP/MODP(4),P,PPT,PPR,PPTH,PPPH                             CPP    5

C                                                                       AWWWL 21

C     COMMON DECK "MM" INSERTED HERE                                    CMM    2

      REAL*8 M,MODM                                                     CMM    4

      COMMON/MM/MODM(4),M,PMT,PMR,PMTH,PMPH                             CMM    5

C                                                                       AWWWL 23

      REAL*8 KS,KV                                                      AWWWL 24

      REAL*8 KVECT(24)                                                  AWWWL 25

      EQUIVALENCE(KVECT,KAY2)                                           AWWWL 26

C                                                                       AWWWL 27

C                                                                       AWWWL 30

      ENTRY IDISPER                                                     AWWWL 31

      CALL ISPEED                                                       AWWWL 32

      CALL IWINDR                                                       AWWWL 33

      CALL IRECVR                                                       AWWWL 34

      CALL ITOPOG                                                       AWWWL 35

      CALL ISURFAC                                                      AWWWL 36

C                                                                       AWWWL 37

      CALL IPRES                                                        AWWWL 38

      CALL IABSRP                                                       AWWWL 39

      RETURN                                                            AWWWL 40

C                                                                       AWWWL 41

      ENTRY DISPER                                                      AWWWL 42

C                                                                       AWWWL 43

      SPACE=.FALSE.                                                     AWWWL 44

C                                                                       AWWWL 45

      KS=KR*KR+KTH*KTH+KPH*KPH                                          AWWWL 46

C     WIND VELOCITY                                                     AWWWL 47

      CALL WINDR                                                        AWWWL 48

      KV=KR*VR+KTH*VTH+KPH*VPH                                          AWWWL 49

      VLS=KV*KV/KS                                                      AWWWL 50

C     SOUND SPEED                                                       AWWWL 51

      CALL SPEED                                                        AWWWL 52

      OWS=OW*OW                                                         AWWWL 53

      KAY2=OWS/(DSQRT(CS)+KV/DSQRT(KS))**2                              AWWWL 54

C                                                                       AWWWL 55

      OWI=OW-KV                                                         AWWWL 56

      H=OWI*OWI - CS*KS                                                 AWWWL 57

      POWIT=-KR*PVRT - KTH*PVTHT - KPH*PVPHT                            AWWWL 58

      PHT=2.0*OWI*POWIT - KS*PCST                                       AWWWL 59

      POWIR=-KR*PVRR - KTH*PVTHR - KPH*PVPHR                            AWWWL 60

      PHR=2.0*OWI*POWIR - KS*PCSR                                       AWWWL 61

      POWITH=-KR*PVRTH - KTH*PVTHTH - KPH*PVPHTH                        AWWWL 62

      PHTH=2.0*OWI*POWITH - KS*PCSTH                                    AWWWL 63

      POWIPH=-KR*PVRPH - KTH*PVTHPH - KPH*PVPHPH                        AWWWL 64

      PHPH=2.0*OWI*POWIPH - KS*PCSPH                                    AWWWL 65

C                                                                       AWWWL 66

      PHOW=2.0*OWI                                                      AWWWL 67

      PHKR=-2.0*(OWI*VR + CS*KR)                                        AWWWL 68

      PHKTH=-2.0*(OWI*VTH + CS*KTH)                                     AWWWL 69

      PHKPH=-2.0*(OWI*VPH + CS*KPH)                                     AWWWL 70

      KPHK=-2.0*(OWI*KV + CS*KS)                                        AWWWL 71

C                                                                       AWWWL 72

      CALL PRES                                                         AWWWL 73

      CALL ABSRP                                                        AWWWL 74

      GMS=GAMMA-1.0                                                     AWWWL 75

      KAY2I=-(OW/(GAMMA*P))*(4./3.*MU+GMS*GMS*M/(GAMMA*RGAS)*KAP)*KAY2  AWWWL 76

      RETURN                                                            AWWWL 77

      END                                                               AWWWL 78











      SUBROUTINE ULOGZ2                                                 ULOGZ2 8

c

      implicit real*8 (a-h,o-z)

c

C     LOGARITHMIC WIND VELOCITY PROFILE                                 ULOGZ2 9

C     SINGULARITY IS AVOIDED BY A LINEAR TANGENT UNIQUELY               ULOGZ210

C     DETERMINED BY CONTINUITY OF VALUE AND SLOPE GOING THROUGH         ULOGZ211

C     THE ORIGIN.                                                       ULOGZ212

      REAL*8 K                                                          ULOGZ213

      EQUIVALENCE (USTAR,W(103)),(K,W(104)),(Z0,W(105))                 ULOGZ214

C                                                                       ULOGZ215

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL*8 KR,KTH,KPH                                                 RKAMCOM4

      COMMON//R,TH,PH,KR,KTH,KPH,RKVARS(14),TPULSE,CSTEP,DRDT(20)       RKAMCOM5

C     COMMON DECK "UU" INSERTED HERE                                    CUU    2

      real*8 modu

c     REAL MODU                                                         CUU    4

      COMMON/UU/MODU(4)                                                 CUU    5

     1  ,V  ,PVT  ,PVR  ,PVTH  ,PVPH                                    CUU    6

     2  ,VR ,PVRT ,PVRR ,PVRTH ,PVRPH                                   CUU    7

     3  ,VTH,PVTHT,PVTHR,PVTHTH,PVTHPH                                  CUU    8

     4  ,VPH,PVPHT,PVPHR,PVPHTH,PVPHPH                                  CUU    9

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      PARAMETER (NWARSZ=1000)                                           CWW1   3

      real*8 id

      COMMON/WW/ID(10),MAXW,W(NWARSZ)                                   CWW1   4

      REAL*8 MAXSTP,MAXERR,INTYP,LLAT,LLON                              CWW2   2

      EQUIVALENCE (EARTHR,W(1)),(RAY,W(2)),(XMTRH,W(3)),(TLAT,W(4)),    CWW2   3

     1 (TLON,W(5)),(OW,W(6)),(FBEG,W(7)),(FEND,W(8)),(FSTEP,W(9)),      CWW2   4

     2 (AZ1,W(10)),(AZBEG,W(11)),(AZEND,W(12)),(AZSTEP,W(13)),          CWW2   5

     3 (BETA,W(14)),(ELBEG,W(15)),(ELEND,W(16)),(ELSTEP,W(17)),         CWW2   6

     8 (RCVRH,W(20)),                                                   CWW2   7

     4 (ONLY,W(21)),(HOP,W(22)),(MAXSTP,W(23)),(PLAT,W(24)),(PLON,W(25))CWW2   8

     5,(HMAX,W(26)),(RAYFNC,W(29)),(EXTINC,W(33)),                      CWW2   9

     6 (HMIN,W(27)),(RGMAX,W(28)),                                      CWW2  10

     8 (INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),                     CWW2  11

     6 (STEP1,W(44)),(STPMAX,W(45)),(STPMIN,W(46)),(FACTR,W(47)),       CWW2  12

     7 (SKIP,W(71)),(RAYSET,W(72)),(PRTSRP,W(74)),(HITLET,W(75))        CWW2  13

     9 ,(BINRAY,W(76)),(PAGLN,W(77)),(PLT,W(81)),(PFACTR,W(82)),        CWW2  14

     1 (LLAT,W(83)),(LLON,W(84)),(RLAT,W(85)),(RLON,W(86))              CWW2  15

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89)),(TICV,W(96))                   CWW2  16

      REAL*8 MMODEL,MFORM,MID                                           CWW3   2

C                                                                       CWW3   3

C     WIND        100-124                                               CWW3   4

      EQUIVALENCE (W(100),UMODEL),(W(101),UFORM),(W(102),UID)           CWW3   5

C                                                                       CWW3   6

C     DELTA WIND        125-149                                         CWW3   7

      EQUIVALENCE (W(125),DUMODEL),(W(126),DUFORM),(W(127),DUID)        CWW3   8

C                                                                       CWW3   9

C     SOUND SPEED 150-174                                               CWW3  10

      EQUIVALENCE (W(150),CMODEL),(W(151),CFORM),(W(152),CID)           CWW3  11

      EQUIVALENCE (W(153),REFC)                                         CWW3  12

C                                                                       CWW3  13

C     DELTA SOUND SPEED 175-199                                         CWW3  14

      EQUIVALENCE (W(175),DCMODEL),(W(176),DCFORM),(W(177),DCID)        CWW3  15

C                                                                       CWW3  16

C     TEMPERATURE    200-224                                            CWW3  17

      EQUIVALENCE (W(200),TMODEL),(W(201),TFORM),(W(202),TID)           CWW3  18

C                                                                       CWW3  19

C     DELTA TEMPERATURE    225-249                                      CWW3  20

      EQUIVALENCE (W(225),DTMODEL),(W(226),DTFORM),(W(227),DTID)        CWW3  21

C                                                                       CWW3  22

C     MOLECULAR   250-274                                               CWW3  23

      EQUIVALENCE (W(250),MMODEL),(W(251),MFORM),(W(252),MID)           CWW3  24

C                                                                       CWW3  25

C     RECEIVER HEIGHT   275-299                                         CWW3  26

      EQUIVALENCE (W(275),RMODEL),(W(276),RFORM),(W(277),RID)           CWW3  27

C                                                                       CWW3  28

C     TOPOGRAPHY   300-324                                              CWW3  29

      EQUIVALENCE (W(300),GMODEL),(W(301),GFORM),(W(302),GID)           CWW3  30

C                                                                       CWW3  31

C     DELTA TOPOGRAPHY   325-349                                        CWW3  32

      EQUIVALENCE (W(325),GUMODEL),(W(326),GUFORM),(W(327),GUID)        CWW3  33

C                                                                       CWW3  34

C     UPPER SURFACE TOPOGRAPHY   350-374                                CWW3  35

      EQUIVALENCE (W(350),SMODEL),(W(351),SFORM),(W(352),SID)           CWW3  36

C     PLOT ENHANCEMENTS CONTROL PARAMETERS                              CWW3  37

C                                                                       CWW3  38

      EQUIVALENCE (W(490),XFQMDL),(W(491),YFQMDL)                       CWW3  39

C     ABSORPTION        500-524                                         CWW3  40

      EQUIVALENCE (W(500),AMODEL),(W(501),AFORM),(W(502),AID)           CWW3  41

C                                                                       CWW3  42

C     DELTA ABSORPTION        525-549                                   CWW3  43

      EQUIVALENCE (W(525),DAMODEL),(W(526),DAFORM),(W(527),DAID)        CWW3  44

C                                                                       CWW3  45

C     PRESSURE        550-574                                           CWW3  46

      EQUIVALENCE (W(550),PMODEL),(W(551),PFORM),(W(552),PID)           CWW3  47

C                                                                       CWW3  48

C     DELTA PRESSURE        575-599                                     CWW3  49

      EQUIVALENCE (W(575),DPMODEL),(W(576),DPFORM),(W(577),DPID)        CWW3  50

C                                                                       CWW3  51

C     COMMON DECK "B1" INSERTED HERE                                    CB1    2

      real*8 ugp

      INTEGER UMX,UNTBL,UITBL,UFRMTBL,IDSU(20)                          CB1    4

      COMMON/B1/UMX,UNTBL(10),UITBL(10),UFRMTBL(10),UGP(10)             CB1    5

      EQUIVALENCE (UGP,IDSU)                                            CB1    6

C     COMMON DECK "GG" INSERTED HERE                                    CGG    2

      real*8 modg

c     REAL MODG                                                         CGG    4

      COMMON/GG/MODG(4)                                                 CGG    5

      COMMON/GG/G,PGR,PGRR,PGRTH,PGRPH                                  CGG    6

      COMMON/GG/PGTH,PGPH,PGTHTH,PGPHPH,PGTHPH,GSELECT,GTIME            CGG    7

      DATA RECOGU/6.0/                                                  ULOGZ221

C                                                                       ULOGZ224

      ENTRY IWINDR                                                      ULOGZ225

C                                                                       ULOGZ226

      IF(RECOGU .NE. UMODEL)                                            ULOGZ227

     1    CALL RERROR('ULOGZ2 ','WRNG MODEL',RECOGU)                    ULOGZ228

C                                                                       ULOGZ229

      MODU(1)=6HULOGZ2                                                  ULOGZ230

      MODU(2)=UID                                                       ULOGZ231

C                                                                       ULOGZ232

      Z0E=Z0*DEXP(1.0)                                                  ULOGZ233

      C=USTAR/K                                                         ULOGZ234

      CZ0E=C/Z0E                                                        ULOGZ235

      CALL IPWINDR                                                      ULOGZ236

C                                                                       ULOGZ237

      RETURN                                                            ULOGZ238

C                                                                       ULOGZ239

       ENTRY WINDR                                                      ULOGZ240

      CALL CLEAR(V,20)                                                  ULOGZ241

      CALL TOPOG                                                        ULOGZ242

      Z = G/PGR                                                         ULOGZ243

      IF(Z.GT.Z0E) GO TO 100                                            ULOGZ244

C                                                                       ULOGZ245

      VPH=CZ0E*Z                                                        ULOGZ246

      PVPHR=CZ0E*PGR                                                    ULOGZ247

      PVPHTH=CZ0E*PGTH                                                  ULOGZ248

      PVPHPH=CZ0E*PGPH                                                  ULOGZ249

      GO TO 120                                                         ULOGZ250

C                                                                       ULOGZ251

100   VPH=C*DLOG(Z/Z0)                                                  ULOGZ252

      CZ=C/Z                                                            ULOGZ253

      PVPHR=CZ*PGR                                                      ULOGZ254

      PVPHTH=CZ*PGTH                                                    ULOGZ255

      PVPHPH=CZ*PGPH                                                    ULOGZ256

C                                                                       ULOGZ257

120   V=DABS(VPH)                                                       ULOGZ258

      PVR=DSIGN(PVPHR,VPH)                                              ULOGZ259

C                                                                       ULOGZ260

      CALL PWINDR                                                       ULOGZ261

       RETURN                                                           ULOGZ262

       END                                                              ULOGZ263











      SUBROUTINE NPWIND                                                 NPWIND 8

c

      implicit real*8 (a-h,o-z)

c

C     DO-NOTHING WIND-VELOCITY PERTURBATION MODEL                       NPWIND 9

C     COMMON DECK "UU" INSERTED HERE                                    CUU    2

      real*8 modu

c     REAL MODU                                                         CUU    4

      COMMON/UU/MODU(4)                                                 CUU    5

     1  ,V  ,PVT  ,PVR  ,PVTH  ,PVPH                                    CUU    6

     2  ,VR ,PVRT ,PVRR ,PVRTH ,PVRPH                                   CUU    7

     3  ,VTH,PVTHT,PVTHR,PVTHTH,PVTHPH                                  CUU    8

     4  ,VPH,PVPHT,PVPHR,PVPHTH,PVPHPH                                  CUU    9

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      PARAMETER (NWARSZ=1000)                                           CWW1   3

      real*8 id

      COMMON/WW/ID(10),MAXW,W(NWARSZ)                                   CWW1   4

      REAL*8 MAXSTP,MAXERR,INTYP,LLAT,LLON                              CWW2   2

      EQUIVALENCE (EARTHR,W(1)),(RAY,W(2)),(XMTRH,W(3)),(TLAT,W(4)),    CWW2   3

     1 (TLON,W(5)),(OW,W(6)),(FBEG,W(7)),(FEND,W(8)),(FSTEP,W(9)),      CWW2   4

     2 (AZ1,W(10)),(AZBEG,W(11)),(AZEND,W(12)),(AZSTEP,W(13)),          CWW2   5

     3 (BETA,W(14)),(ELBEG,W(15)),(ELEND,W(16)),(ELSTEP,W(17)),         CWW2   6

     8 (RCVRH,W(20)),                                                   CWW2   7

     4 (ONLY,W(21)),(HOP,W(22)),(MAXSTP,W(23)),(PLAT,W(24)),(PLON,W(25))CWW2   8

     5,(HMAX,W(26)),(RAYFNC,W(29)),(EXTINC,W(33)),                      CWW2   9

     6 (HMIN,W(27)),(RGMAX,W(28)),                                      CWW2  10

     8 (INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),                     CWW2  11

     6 (STEP1,W(44)),(STPMAX,W(45)),(STPMIN,W(46)),(FACTR,W(47)),       CWW2  12

     7 (SKIP,W(71)),(RAYSET,W(72)),(PRTSRP,W(74)),(HITLET,W(75))        CWW2  13

     9 ,(BINRAY,W(76)),(PAGLN,W(77)),(PLT,W(81)),(PFACTR,W(82)),        CWW2  14

     1 (LLAT,W(83)),(LLON,W(84)),(RLAT,W(85)),(RLON,W(86))              CWW2  15

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89)),(TICV,W(96))                   CWW2  16

      REAL*8 MMODEL,MFORM,MID                                           CWW3   2

C                                                                       CWW3   3

C     WIND        100-124                                               CWW3   4

      EQUIVALENCE (W(100),UMODEL),(W(101),UFORM),(W(102),UID)           CWW3   5

C                                                                       CWW3   6

C     DELTA WIND        125-149                                         CWW3   7

      EQUIVALENCE (W(125),DUMODEL),(W(126),DUFORM),(W(127),DUID)        CWW3   8

C                                                                       CWW3   9

C     SOUND SPEED 150-174                                               CWW3  10

      EQUIVALENCE (W(150),CMODEL),(W(151),CFORM),(W(152),CID)           CWW3  11

      EQUIVALENCE (W(153),REFC)                                         CWW3  12

C                                                                       CWW3  13

C     DELTA SOUND SPEED 175-199                                         CWW3  14

      EQUIVALENCE (W(175),DCMODEL),(W(176),DCFORM),(W(177),DCID)        CWW3  15

C                                                                       CWW3  16

C     TEMPERATURE    200-224                                            CWW3  17

      EQUIVALENCE (W(200),TMODEL),(W(201),TFORM),(W(202),TID)           CWW3  18

C                                                                       CWW3  19

C     DELTA TEMPERATURE    225-249                                      CWW3  20

      EQUIVALENCE (W(225),DTMODEL),(W(226),DTFORM),(W(227),DTID)        CWW3  21

C                                                                       CWW3  22

C     MOLECULAR   250-274                                               CWW3  23

      EQUIVALENCE (W(250),MMODEL),(W(251),MFORM),(W(252),MID)           CWW3  24

C                                                                       CWW3  25

C     RECEIVER HEIGHT   275-299                                         CWW3  26

      EQUIVALENCE (W(275),RMODEL),(W(276),RFORM),(W(277),RID)           CWW3  27

C                                                                       CWW3  28

C     TOPOGRAPHY   300-324                                              CWW3  29

      EQUIVALENCE (W(300),GMODEL),(W(301),GFORM),(W(302),GID)           CWW3  30

C                                                                       CWW3  31

C     DELTA TOPOGRAPHY   325-349                                        CWW3  32

      EQUIVALENCE (W(325),GUMODEL),(W(326),GUFORM),(W(327),GUID)        CWW3  33

C                                                                       CWW3  34

C     UPPER SURFACE TOPOGRAPHY   350-374                                CWW3  35

      EQUIVALENCE (W(350),SMODEL),(W(351),SFORM),(W(352),SID)           CWW3  36

C     PLOT ENHANCEMENTS CONTROL PARAMETERS                              CWW3  37

C                                                                       CWW3  38

      EQUIVALENCE (W(490),XFQMDL),(W(491),YFQMDL)                       CWW3  39

C     ABSORPTION        500-524                                         CWW3  40

      EQUIVALENCE (W(500),AMODEL),(W(501),AFORM),(W(502),AID)           CWW3  41

C                                                                       CWW3  42

C     DELTA ABSORPTION        525-549                                   CWW3  43

      EQUIVALENCE (W(525),DAMODEL),(W(526),DAFORM),(W(527),DAID)        CWW3  44

C                                                                       CWW3  45

C     PRESSURE        550-574                                           CWW3  46

      EQUIVALENCE (W(550),PMODEL),(W(551),PFORM),(W(552),PID)           CWW3  47

C                                                                       CWW3  48

C     DELTA PRESSURE        575-599                                     CWW3  49

      EQUIVALENCE (W(575),DPMODEL),(W(576),DPFORM),(W(577),DPID)        CWW3  50

C                                                                       CWW3  51

C     COMMON DECK "B2" INSERTED HERE                                    CB2    2

      real*8 dugp

      INTEGER DUMX,DUNTBL,DUITBL,DUFRMTB,IDSDU(20)                      CB2    4

      COMMON/B2/DUMX,DUNTBL(10),DUITBL(10),DUFRMTB(10),DUGP(10)         CB2    5

      EQUIVALENCE (DUGP,IDSDU)                                          CB2    6

      DATA RECOGDU/0.0/                                                 NPWIND13

C                                                                       NPWIND16

      ENTRY IPWINDR                                                     NPWIND17

      IF(RECOGDU .NE. DUMODEL)                                          NPWIND18

     1    CALL RERROR('DWINDR ','WRNG MODEL',RECOGDU)                   NPWIND19

      MODU(3)=6HNPWIND                                                  NPWIND20

      MODU(4)=DUID                                                      NPWIND21

      RETURN                                                            NPWIND22

C                                                                       NPWIND23

      ENTRY PWINDR                                                      NPWIND24

      RETURN                                                            NPWIND25

      END                                                               NPWIND26











      SUBROUTINE GAMRTDM                                                GAMRTDM8

c

      implicit real*8 (a-h,o-z)

c

C     SOUND SPEED MODEL, C**2=GAMMA*R*T/M                               GAMRTDM9

C     COMMON DECK "CC" INSERTED HERE                                    CCC    2

      real*8 modc

c     REAL MODC                                                         CCC    4

      COMMON/CC/MODC(4),CS,PCST,PCSR,PCSTH,PCSPH                        CCC    5

C     COMMON DECK "TT" INSERTED HERE                                    CTT    2

      real*8 modt

c     REAL MODT                                                         CTT    4

      COMMON/TT/MODT(4), T,PTT,PTR,PTTH,PTPH                            CTT    5

C     COMMON DECK "MM" INSERTED HERE                                    CMM    2

      REAL*8 M,MODM                                                     CMM    4

      COMMON/MM/MODM(4),M,PMT,PMR,PMTH,PMPH                             CMM    5

C     COMMON DECK "CONST" INSERTED HERE                                 CCONST 2

      COMMON/PCONST/CREF,RGAS,GAMMA                                     CCONST 4

      COMMON/MCONST/PI,PIT2,PID2,DEGS,RAD,ALN10                         CCONST 5

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      PARAMETER (NWARSZ=1000)                                           CWW1   3

      real*8 id

      COMMON/WW/ID(10),MAXW,W(NWARSZ)                                   CWW1   4

      REAL*8 MAXSTP,MAXERR,INTYP,LLAT,LLON                              CWW2   2

      EQUIVALENCE (EARTHR,W(1)),(RAY,W(2)),(XMTRH,W(3)),(TLAT,W(4)),    CWW2   3

     1 (TLON,W(5)),(OW,W(6)),(FBEG,W(7)),(FEND,W(8)),(FSTEP,W(9)),      CWW2   4

     2 (AZ1,W(10)),(AZBEG,W(11)),(AZEND,W(12)),(AZSTEP,W(13)),          CWW2   5

     3 (BETA,W(14)),(ELBEG,W(15)),(ELEND,W(16)),(ELSTEP,W(17)),         CWW2   6

     8 (RCVRH,W(20)),                                                   CWW2   7

     4 (ONLY,W(21)),(HOP,W(22)),(MAXSTP,W(23)),(PLAT,W(24)),(PLON,W(25))CWW2   8

     5,(HMAX,W(26)),(RAYFNC,W(29)),(EXTINC,W(33)),                      CWW2   9

     6 (HMIN,W(27)),(RGMAX,W(28)),                                      CWW2  10

     8 (INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),                     CWW2  11

     6 (STEP1,W(44)),(STPMAX,W(45)),(STPMIN,W(46)),(FACTR,W(47)),       CWW2  12

     7 (SKIP,W(71)),(RAYSET,W(72)),(PRTSRP,W(74)),(HITLET,W(75))        CWW2  13

     9 ,(BINRAY,W(76)),(PAGLN,W(77)),(PLT,W(81)),(PFACTR,W(82)),        CWW2  14

     1 (LLAT,W(83)),(LLON,W(84)),(RLAT,W(85)),(RLON,W(86))              CWW2  15

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89)),(TICV,W(96))                   CWW2  16

      REAL*8 MMODEL,MFORM,MID                                           CWW3   2

C                                                                       CWW3   3

C     WIND        100-124                                               CWW3   4

      EQUIVALENCE (W(100),UMODEL),(W(101),UFORM),(W(102),UID)           CWW3   5

C                                                                       CWW3   6

C     DELTA WIND        125-149                                         CWW3   7

      EQUIVALENCE (W(125),DUMODEL),(W(126),DUFORM),(W(127),DUID)        CWW3   8

C                                                                       CWW3   9

C     SOUND SPEED 150-174                                               CWW3  10

      EQUIVALENCE (W(150),CMODEL),(W(151),CFORM),(W(152),CID)           CWW3  11

      EQUIVALENCE (W(153),REFC)                                         CWW3  12

C                                                                       CWW3  13

C     DELTA SOUND SPEED 175-199                                         CWW3  14

      EQUIVALENCE (W(175),DCMODEL),(W(176),DCFORM),(W(177),DCID)        CWW3  15

C                                                                       CWW3  16

C     TEMPERATURE    200-224                                            CWW3  17

      EQUIVALENCE (W(200),TMODEL),(W(201),TFORM),(W(202),TID)           CWW3  18

C                                                                       CWW3  19

C     DELTA TEMPERATURE    225-249                                      CWW3  20

      EQUIVALENCE (W(225),DTMODEL),(W(226),DTFORM),(W(227),DTID)        CWW3  21

C                                                                       CWW3  22

C     MOLECULAR   250-274                                               CWW3  23

      EQUIVALENCE (W(250),MMODEL),(W(251),MFORM),(W(252),MID)           CWW3  24

C                                                                       CWW3  25

C     RECEIVER HEIGHT   275-299                                         CWW3  26

      EQUIVALENCE (W(275),RMODEL),(W(276),RFORM),(W(277),RID)           CWW3  27

C                                                                       CWW3  28

C     TOPOGRAPHY   300-324                                              CWW3  29

      EQUIVALENCE (W(300),GMODEL),(W(301),GFORM),(W(302),GID)           CWW3  30

C                                                                       CWW3  31

C     DELTA TOPOGRAPHY   325-349                                        CWW3  32

      EQUIVALENCE (W(325),GUMODEL),(W(326),GUFORM),(W(327),GUID)        CWW3  33

C                                                                       CWW3  34

C     UPPER SURFACE TOPOGRAPHY   350-374                                CWW3  35

      EQUIVALENCE (W(350),SMODEL),(W(351),SFORM),(W(352),SID)           CWW3  36

C     PLOT ENHANCEMENTS CONTROL PARAMETERS                              CWW3  37

C                                                                       CWW3  38

      EQUIVALENCE (W(490),XFQMDL),(W(491),YFQMDL)                       CWW3  39

C     ABSORPTION        500-524                                         CWW3  40

      EQUIVALENCE (W(500),AMODEL),(W(501),AFORM),(W(502),AID)           CWW3  41

C                                                                       CWW3  42

C     DELTA ABSORPTION        525-549                                   CWW3  43

      EQUIVALENCE (W(525),DAMODEL),(W(526),DAFORM),(W(527),DAID)        CWW3  44

C                                                                       CWW3  45

C     PRESSURE        550-574                                           CWW3  46

      EQUIVALENCE (W(550),PMODEL),(W(551),PFORM),(W(552),PID)           CWW3  47

C                                                                       CWW3  48

C     DELTA PRESSURE        575-599                                     CWW3  49

      EQUIVALENCE (W(575),DPMODEL),(W(576),DPFORM),(W(577),DPID)        CWW3  50

C                                                                       CWW3  51

C                                                                       GAMRTD15

C     COMMON DECK "B3" INSERTED HERE                                    CB3    2

      real*8 cgp,anc

      INTEGER CMX,CNTBL,CITBL,CFRMTBL,IDSC(20)                          CB3    4

      COMMON/B3/CMX,CNTBL(10),CITBL(10),CFRMTBL(10),CGP(512)            CB3    5

      EQUIVALENCE (CGP,IDSC),(ANC,CGP(11))                              CB3    6

      DATA RECOGC/1.0/                                                  GAMRTD19

C                                                                       GAMRTD20

      ENTRY ISPEED                                                      GAMRTD21

C                                                                       GAMRTD22

      IF(REFC.GT.0.0) CREF=REFC                                         GAMRTD23

      IF(RECOGC .NE. CMODEL)                                            GAMRTD24

     1    CALL RERROR('SPEED  ','WRNG MODEL',RECOGC)                    GAMRTD25

      MODC(1)=7HGAMRTDM                                                 GAMRTD26

      MODC(2)=CID                                                       GAMRTD27

      CALL ITEMP                                                        GAMRTD28

      CALL IMOLWT                                                       GAMRTD29

      CALL IPSPEED                                                      GAMRTD30

C                                                                       GAMRTD31

      RETURN                                                            GAMRTD32

C                                                                       GAMRTD33

      ENTRY SPEED                                                       GAMRTD34

      CALL TEMP                                                         GAMRTD35

      CALL MOLWT                                                        GAMRTD36

      CS=GAMMA*RGAS*T/M                                                 GAMRTD37

      PCST=CS*(PTT/T - PMT/M)                                           GAMRTD38

      PCSR=CS*(PTR/T - PMR/M)                                           GAMRTD39

      PCSTH=CS*(PTTH/T - PMTH/M)                                        GAMRTD40

      PCSPH=CS*(PTPH/T - PMPH/M)                                        GAMRTD41

C                                                                       GAMRTD42

C                                                                       GAMRTD43

      CALL PSPEED                                                       GAMRTD44

      RETURN                                                            GAMRTD45

      END                                                               GAMRTD46











      SUBROUTINE CBLOB2                                                 CBLOB2 8

c

      implicit real*8 (a-h,o-z)

c

C     SOUND SPEED PERTURBATION MODEL                                    CBLOB2 9

C     MULTIPLICATIVE PERTURBATION WITH EXPONENTIALLY DECAYING           CBLOB210

C     EFFECT IN ALL THREE DIRECTIONS. GIVE LATITUDE                     CBLOB211

C     INSTEAD OF CO-LATITUDE.                                           CBLOB212

C     COMMON DECK "CONST" INSERTED HERE                                 CCONST 2

      COMMON/PCONST/CREF,RGAS,GAMMA                                     CCONST 4

      COMMON/MCONST/PI,PIT2,PID2,DEGS,RAD,ALN10                         CCONST 5

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL*8 KR,KTH,KPH                                                 RKAMCOM4

      COMMON//R,TH,PH,KR,KTH,KPH,RKVARS(14),TPULSE,CSTEP,DRDT(20)       RKAMCOM5

C     COMMON DECK "B4" INSERTED HERE                                    CB4    2

      real*8 dcgp

      INTEGER DCMX,DCNTBL,DCITBL,DCFRMTB,IDSDC(20)                      CB4    4

      COMMON/B4/DCMX,DCNTBL(10),DCITBL(10),DCFRMTB(10),DCGP(10)         CB4    5

      EQUIVALENCE (DCGP,IDSDC)                                          CB4    6

C                                                                       CBLOB216

C     COMMON DECK "CC" INSERTED HERE                                    CCC    2

      real*8 modc

c     REAL MODC                                                         CCC    4

      COMMON/CC/MODC(4),CS,PCST,PCSR,PCSTH,PCSPH                        CCC    5

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      PARAMETER (NWARSZ=1000)                                           CWW1   3

      real*8 id

      COMMON/WW/ID(10),MAXW,W(NWARSZ)                                   CWW1   4

      REAL*8 MAXSTP,MAXERR,INTYP,LLAT,LLON                              CWW2   2

      EQUIVALENCE (EARTHR,W(1)),(RAY,W(2)),(XMTRH,W(3)),(TLAT,W(4)),    CWW2   3

     1 (TLON,W(5)),(OW,W(6)),(FBEG,W(7)),(FEND,W(8)),(FSTEP,W(9)),      CWW2   4

     2 (AZ1,W(10)),(AZBEG,W(11)),(AZEND,W(12)),(AZSTEP,W(13)),          CWW2   5

     3 (BETA,W(14)),(ELBEG,W(15)),(ELEND,W(16)),(ELSTEP,W(17)),         CWW2   6

     8 (RCVRH,W(20)),                                                   CWW2   7

     4 (ONLY,W(21)),(HOP,W(22)),(MAXSTP,W(23)),(PLAT,W(24)),(PLON,W(25))CWW2   8

     5,(HMAX,W(26)),(RAYFNC,W(29)),(EXTINC,W(33)),                      CWW2   9

     6 (HMIN,W(27)),(RGMAX,W(28)),                                      CWW2  10

     8 (INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),                     CWW2  11

     6 (STEP1,W(44)),(STPMAX,W(45)),(STPMIN,W(46)),(FACTR,W(47)),       CWW2  12

     7 (SKIP,W(71)),(RAYSET,W(72)),(PRTSRP,W(74)),(HITLET,W(75))        CWW2  13

     9 ,(BINRAY,W(76)),(PAGLN,W(77)),(PLT,W(81)),(PFACTR,W(82)),        CWW2  14

     1 (LLAT,W(83)),(LLON,W(84)),(RLAT,W(85)),(RLON,W(86))              CWW2  15

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89)),(TICV,W(96))                   CWW2  16

      REAL*8 MMODEL,MFORM,MID                                           CWW3   2

C                                                                       CWW3   3

C     WIND        100-124                                               CWW3   4

      EQUIVALENCE (W(100),UMODEL),(W(101),UFORM),(W(102),UID)           CWW3   5

C                                                                       CWW3   6

C     DELTA WIND        125-149                                         CWW3   7

      EQUIVALENCE (W(125),DUMODEL),(W(126),DUFORM),(W(127),DUID)        CWW3   8

C                                                                       CWW3   9

C     SOUND SPEED 150-174                                               CWW3  10

      EQUIVALENCE (W(150),CMODEL),(W(151),CFORM),(W(152),CID)           CWW3  11

      EQUIVALENCE (W(153),REFC)                                         CWW3  12

C                                                                       CWW3  13

C     DELTA SOUND SPEED 175-199                                         CWW3  14

      EQUIVALENCE (W(175),DCMODEL),(W(176),DCFORM),(W(177),DCID)        CWW3  15

C                                                                       CWW3  16

C     TEMPERATURE    200-224                                            CWW3  17

      EQUIVALENCE (W(200),TMODEL),(W(201),TFORM),(W(202),TID)           CWW3  18

C                                                                       CWW3  19

C     DELTA TEMPERATURE    225-249                                      CWW3  20

      EQUIVALENCE (W(225),DTMODEL),(W(226),DTFORM),(W(227),DTID)        CWW3  21

C                                                                       CWW3  22

C     MOLECULAR   250-274                                               CWW3  23

      EQUIVALENCE (W(250),MMODEL),(W(251),MFORM),(W(252),MID)           CWW3  24

C                                                                       CWW3  25

C     RECEIVER HEIGHT   275-299                                         CWW3  26

      EQUIVALENCE (W(275),RMODEL),(W(276),RFORM),(W(277),RID)           CWW3  27

C                                                                       CWW3  28

C     TOPOGRAPHY   300-324                                              CWW3  29

      EQUIVALENCE (W(300),GMODEL),(W(301),GFORM),(W(302),GID)           CWW3  30

C                                                                       CWW3  31

C     DELTA TOPOGRAPHY   325-349                                        CWW3  32

      EQUIVALENCE (W(325),GUMODEL),(W(326),GUFORM),(W(327),GUID)        CWW3  33

C                                                                       CWW3  34

C     UPPER SURFACE TOPOGRAPHY   350-374                                CWW3  35

      EQUIVALENCE (W(350),SMODEL),(W(351),SFORM),(W(352),SID)           CWW3  36

C     PLOT ENHANCEMENTS CONTROL PARAMETERS                              CWW3  37

C                                                                       CWW3  38

      EQUIVALENCE (W(490),XFQMDL),(W(491),YFQMDL)                       CWW3  39

C     ABSORPTION        500-524                                         CWW3  40

      EQUIVALENCE (W(500),AMODEL),(W(501),AFORM),(W(502),AID)           CWW3  41

C                                                                       CWW3  42

C     DELTA ABSORPTION        525-549                                   CWW3  43

      EQUIVALENCE (W(525),DAMODEL),(W(526),DAFORM),(W(527),DAID)        CWW3  44

C                                                                       CWW3  45

C     PRESSURE        550-574                                           CWW3  46

      EQUIVALENCE (W(550),PMODEL),(W(551),PFORM),(W(552),PID)           CWW3  47

C                                                                       CWW3  48

C     DELTA PRESSURE        575-599                                     CWW3  49

      EQUIVALENCE (W(575),DPMODEL),(W(576),DPFORM),(W(577),DPID)        CWW3  50

C                                                                       CWW3  51

C                                                                       CBLOB219

      EQUIVALENCE (C0,W(178)), (Z0,W(179)),(CBTH0,W(180))               CBLOB220

      EQUIVALENCE (PH0,W(181)),(WZ,W(182)),(WTH,W(183)),(WPH,W(184))    CBLOB221

      DATA RECOGDC/2.0/                                                 CBLOB222

C                                                                       CBLOB225

      ENTRY IPSPEED                                                     CBLOB226

      IF(RECOGDC .NE. DCMODEL)                                          CBLOB227

     1    CALL RERROR('DSPEED ','WRNG MODEL',RECOGDC)                   CBLOB228

C                                                                       CBLOB229

      MODC(3)=6HCBLOB2                                                  CBLOB230

      MODC(4)=DCID                                                      CBLOB231

C                                                                       CBLOB232

      FWZ=0.0                                                           CBLOB233

      FWTH=0.0                                                          CBLOB234

      FWPH=0.0                                                          CBLOB235

      TH0= PID2-CBTH0                                                   CBLOB236

      IF(WZ.NE.0.0) FWZ=2.0/WZ/WZ                                       CBLOB237

      IF(WTH.NE.0.0) FWTH=2.0/WTH/WTH                                   CBLOB238

      IF(WPH.NE.0.0) FWPH=2.0/WPH/WPH                                   CBLOB239

      RETURN                                                            CBLOB240

C                                                                       CBLOB241

      ENTRY PSPEED                                                      CBLOB242

C                                                                       CBLOB243

      IF(C0.EQ.0.0) RETURN                                              CBLOB244

C                                                                       CBLOB245

      DZ=R-EARTHR-Z0                                                    CBLOB246

      DTH=TH-TH0                                                        CBLOB247

      DPH=PH-PH0                                                        CBLOB248

      DEXPO=0.0                                                         CBLOB249

      EXPO=-0.5*(DZ*DZ*FWZ+DTH*DTH*FWTH+DPH*DPH*FWPH)                   CBLOB250

      IF(EXPO .GT. -200.0) DEXPO=C0*DEXP(EXPO)                          CBLOB251

      DEL=1.0+DEXPO                                                     CBLOB252

C                                                                       CBLOB253

      PCSR=PCSR*DEL-CS*DEXPO*FWZ*DZ                                     CBLOB254

      PCSTH=PCSTH*DEL-CS*DEXPO*FWTH*DTH                                 CBLOB255

      PCSPH=PCSPH*DEL-CS*DEXPO*FWPH*DPH                                 CBLOB256

      CS=CS*DEL                                                         CBLOB257

      RETURN                                                            CBLOB258

      END                                                               CBLOB259











      SUBROUTINE TTANH5                                                 TTANH5 9

c

      implicit real*8 (a-h,o-z)

c

C     TEMPERATURE PROFILE REPRESENTED BY A SEQUENCE OF LINEAR SEGMENTS  TTANH510

C     SMOOTHLY JOINED BY HYPERBOLIC FUNCTIONS. PARAMETERS ARE INPUT     TTANH511

C     AS TABULAR DATA WITH SLOPES COMPUTED FROM TEMPERATURE DATA.       TTANH512

C     REFERENCE TEMPERATURE T0 IS READ FROM TABULAR DATA.               TTANH513

      DIMENSION C(20), TM(19), Z(19), DL(19)                            TTANH514

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL*8 KR,KTH,KPH                                                 RKAMCOM4

      COMMON//R,TH,PH,KR,KTH,KPH,RKVARS(14),TPULSE,CSTEP,DRDT(20)       RKAMCOM5

C     COMMON DECK "TT" INSERTED HERE                                    CTT    2

      real*8 modt

c     REAL MODT                                                         CTT    4

      COMMON/TT/MODT(4), T,PTT,PTR,PTTH,PTPH                            CTT    5

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      PARAMETER (NWARSZ=1000)                                           CWW1   3

      real*8 id

      COMMON/WW/ID(10),MAXW,W(NWARSZ)                                   CWW1   4

      REAL*8 MAXSTP,MAXERR,INTYP,LLAT,LLON                              CWW2   2

      EQUIVALENCE (EARTHR,W(1)),(RAY,W(2)),(XMTRH,W(3)),(TLAT,W(4)),    CWW2   3

     1 (TLON,W(5)),(OW,W(6)),(FBEG,W(7)),(FEND,W(8)),(FSTEP,W(9)),      CWW2   4

     2 (AZ1,W(10)),(AZBEG,W(11)),(AZEND,W(12)),(AZSTEP,W(13)),          CWW2   5

     3 (BETA,W(14)),(ELBEG,W(15)),(ELEND,W(16)),(ELSTEP,W(17)),         CWW2   6

     8 (RCVRH,W(20)),                                                   CWW2   7

     4 (ONLY,W(21)),(HOP,W(22)),(MAXSTP,W(23)),(PLAT,W(24)),(PLON,W(25))CWW2   8

     5,(HMAX,W(26)),(RAYFNC,W(29)),(EXTINC,W(33)),                      CWW2   9

     6 (HMIN,W(27)),(RGMAX,W(28)),                                      CWW2  10

     8 (INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),                     CWW2  11

     6 (STEP1,W(44)),(STPMAX,W(45)),(STPMIN,W(46)),(FACTR,W(47)),       CWW2  12

     7 (SKIP,W(71)),(RAYSET,W(72)),(PRTSRP,W(74)),(HITLET,W(75))        CWW2  13

     9 ,(BINRAY,W(76)),(PAGLN,W(77)),(PLT,W(81)),(PFACTR,W(82)),        CWW2  14

     1 (LLAT,W(83)),(LLON,W(84)),(RLAT,W(85)),(RLON,W(86))              CWW2  15

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89)),(TICV,W(96))                   CWW2  16

      REAL*8 MMODEL,MFORM,MID                                           CWW3   2

C                                                                       CWW3   3

C     WIND        100-124                                               CWW3   4

      EQUIVALENCE (W(100),UMODEL),(W(101),UFORM),(W(102),UID)           CWW3   5

C                                                                       CWW3   6

C     DELTA WIND        125-149                                         CWW3   7

      EQUIVALENCE (W(125),DUMODEL),(W(126),DUFORM),(W(127),DUID)        CWW3   8

C                                                                       CWW3   9

C     SOUND SPEED 150-174                                               CWW3  10

      EQUIVALENCE (W(150),CMODEL),(W(151),CFORM),(W(152),CID)           CWW3  11

      EQUIVALENCE (W(153),REFC)                                         CWW3  12

C                                                                       CWW3  13

C     DELTA SOUND SPEED 175-199                                         CWW3  14

      EQUIVALENCE (W(175),DCMODEL),(W(176),DCFORM),(W(177),DCID)        CWW3  15

C                                                                       CWW3  16

C     TEMPERATURE    200-224                                            CWW3  17

      EQUIVALENCE (W(200),TMODEL),(W(201),TFORM),(W(202),TID)           CWW3  18

C                                                                       CWW3  19

C     DELTA TEMPERATURE    225-249                                      CWW3  20

      EQUIVALENCE (W(225),DTMODEL),(W(226),DTFORM),(W(227),DTID)        CWW3  21

C                                                                       CWW3  22

C     MOLECULAR   250-274                                               CWW3  23

      EQUIVALENCE (W(250),MMODEL),(W(251),MFORM),(W(252),MID)           CWW3  24

C                                                                       CWW3  25

C     RECEIVER HEIGHT   275-299                                         CWW3  26

      EQUIVALENCE (W(275),RMODEL),(W(276),RFORM),(W(277),RID)           CWW3  27

C                                                                       CWW3  28

C     TOPOGRAPHY   300-324                                              CWW3  29

      EQUIVALENCE (W(300),GMODEL),(W(301),GFORM),(W(302),GID)           CWW3  30

C                                                                       CWW3  31

C     DELTA TOPOGRAPHY   325-349                                        CWW3  32

      EQUIVALENCE (W(325),GUMODEL),(W(326),GUFORM),(W(327),GUID)        CWW3  33

C                                                                       CWW3  34

C     UPPER SURFACE TOPOGRAPHY   350-374                                CWW3  35

      EQUIVALENCE (W(350),SMODEL),(W(351),SFORM),(W(352),SID)           CWW3  36

C     PLOT ENHANCEMENTS CONTROL PARAMETERS                              CWW3  37

C                                                                       CWW3  38

      EQUIVALENCE (W(490),XFQMDL),(W(491),YFQMDL)                       CWW3  39

C     ABSORPTION        500-524                                         CWW3  40

      EQUIVALENCE (W(500),AMODEL),(W(501),AFORM),(W(502),AID)           CWW3  41

C                                                                       CWW3  42

C     DELTA ABSORPTION        525-549                                   CWW3  43

      EQUIVALENCE (W(525),DAMODEL),(W(526),DAFORM),(W(527),DAID)        CWW3  44

C                                                                       CWW3  45

C     PRESSURE        550-574                                           CWW3  46

      EQUIVALENCE (W(550),PMODEL),(W(551),PFORM),(W(552),PID)           CWW3  47

C                                                                       CWW3  48

C     DELTA PRESSURE        575-599                                     CWW3  49

      EQUIVALENCE (W(575),DPMODEL),(W(576),DPFORM),(W(577),DPID)        CWW3  50

C                                                                       CWW3  51

C     COMMON DECK "B5" INSERTED HERE                                    CB5    2

      real*8 tgp,ant

      INTEGER TMX,TNTBL,TITBL,TFRMTBL,IDST(20)                          CB5    4

      COMMON/B5/TMX,TNTBL(10),TITBL(10),TFRMTBL(10),TGP(262)            CB5    5

      EQUIVALENCE (TGP,IDST),(ANT,TGP(11))                              CB5    6

      EQUIVALENCE             (Z0,TGP(12)),(TM,TGP(33))                 TTANH519

      EQUIVALENCE (Z,TGP(13)),(C,TGP(32)),(DL,TGP(53))                  TTANH520

C                                                                       TTANH521

      DATA RECOGT,N/7.0,0/                                              TTANH522

C                                                                       TTANH525

      COSH (X) = (DEXP(X) + 1. / (DEXP(X))) / 2.                        TTANH526

C                                                                       TTANH527

      ENTRY ITEMP                                                       TTANH528

C                                                                       TTANH529

      CALL IPTEMP                                                       TTANH530

C                                                                       TTANH531

C     IF HAD PREVIOUS CALL BUT NOTHING THIS TIME, EXIT NOW              TTANH532

C     RETAINING PREVIOUS TABULAR DATA COUNT                             TTANH533

      IF(N.GT.0 .AND. ANT.EQ.0.0) RETURN                                TTANH534

C                                                                       TTANH535

      IF(RECOGT .NE. TMODEL)                                            TTANH536

     1    CALL RERROR('TEMP   ','WRNG MODEL',RECOGT)                    TTANH537

C                                                                       TTANH538

      MODT(1)=7HTTANH5                                                  TTANH539

      MODT(2)=TID                                                       TTANH540

C                                                                       TTANH541

      N=(ANT+1)/3 - 2                                                   TTANH542

C                                                                       TTANH543

      avl = float(n)

      IF(N.LE.0)                                                        TTANH544

     1    CALL RERROR('TTANH5','BAD N VALUE',  avl   )                  TTANH545

C                                                                       TTANH546

      ANT=0.0                                                           TTANH547

C                                                                       TTANH548

C                                                                       TTANH549

C     CONVERT 'T' ARRAY INPUT(OVERLAYS 'C' ARRAY) TO 'C' ARRAY          TTANH550

C                                                                       TTANH551



      T0=C(1)                                                           TTANH552

      TIM1=T0                                                           TTANH553

      ZIM1= Z0                                                          TTANH554

      NP1=N+1                                                           TTANH555

      DO 10 I=1,NP1                                                     TTANH556

         TI=TM(I)                                                       TTANH557

         ZI=Z(I)                                                        TTANH558

         C(I)=(TI-TIM1)/(ZI-ZIM1)                                       TTANH559

         TIM1=TI                                                        TTANH560

10       ZIM1=ZI                                                        TTANH561

C                                                                       TTANH562

      RETURN                                                            TTANH563

C                                                                       TTANH564

      ENTRY TEMP                                                        TTANH565

      H = R - EARTHR                                                    TTANH566

      SUM = 0.                                                          TTANH567

C                                                                       TTANH568

C     LOOP TO SUM OVER ALL COEFFICIENTS                                 TTANH569

C     USE SPECIAL FUNCTION 'ALCOSH' WHICH ALLOWS FOR LARGE ARGUMENTS.   TTANH570

      t0=288.

      DO 1 I = 1, N                                                     TTANH571

   1  SUM = SUM + DL(I) * (C(I + 1) - C(I)) / 2. *(ALCOSH((H - Z        TTANH572

     1(I)) / DL(I)) - ALCOSH((Z(I)-Z0) / DL(I)))                        TTANH573

      T = T0 + SUM + (C(1) + C(N + 1)) * (H - Z0) * 0.5                 TTANH574

      SUM = 0.                                                          TTANH575

      DO 2 I = 1, N                                                     TTANH576

   2  SUM = SUM + (C(I + 1) - C(I)) / 2. * (1. + DTANH((H - Z(I)) /DL   TTANH577

     1 (I)))                                                            TTANH578

      PTT=0.0                                                           TTANH579

      PTR = C(1) + SUM                                                  TTANH580

      PTTH=0.0                                                          TTANH581

      PTPH=0.0                                                          TTANH582

C                                                                       TTANH583

      CALL PTEMP                                                        TTANH584

      RETURN                                                            TTANH585

      END                                                               TTANH586



