      SUBROUTINE ANWNL                                                  ANWNL  2

C     DISPERSION RELATION FOR ACOUSTIC WAVES NO WIND, NO LOSSES         ANWNL  3

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL 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 MODC                                                         CCC    4

      COMMON/CC/MODC(4),CS,PCSR,PCST,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

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

C     COMMON DECK "RINREAL" INSERTED HERE                               CRINREA2

      LOGICAL SPACE                                                     CRINREA4

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

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

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

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

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

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

C     COMMON DECK "UU" INSERTED HERE                                    CUU    2

      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

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

C                                                                       ANWNL 11

      REAL KS,MKS                                                       ANWNL 12

      REAL KVECT(24)                                                    ANWNL 13

      EQUIVALENCE(KVECT,KAY2)                                           ANWNL 14

C                                                                       ANWNL 15

      DATA KVECT/24*0.0/                                                ANWNL 16

      DATA MODRIN/8HACOUSTIC , 2*1H ,7HNO WIND,2*1H ,9HNO LOSSES ,1H /  ANWNL 17

      DATA RAYNAME/6*1H /                                               ANWNL 18

      DATA MODU/4HNULL ,0.0, 1H1 ,0.0/,RECOGU/0.0/                      ANWNL 19

      DATA OMEGMIN,OMEGMAX/0.0,0.0/                                     ANWNL 20

      DATA TYPE,POLAR,POLARI,LPOLAR,LPOLRI/3*1H ,0.0,0.0,1.0,0.0/       ANWNL 21

C                                                                       ANWNL 22

      ENTRY IDISPER                                                     ANWNL 23

      CALL ISPEED                                                       ANWNL 24

      RETURN                                                            ANWNL 25

C                                                                       ANWNL 26

      ENTRY DISPER                                                      ANWNL 27

      ENTRY RINDEX                                                      ANWNL 28

C                                                                       ANWNL 29

      SPACE=.FALSE.                                                     ANWNL 30

C                                                                       ANWNL 31

      KS=KR*KR+KTH*KTH+KPH*KPH                                          ANWNL 32

C     SOUND SPEED                                                       ANWNL 33

      CALL SPEED                                                        ANWNL 34

      OWS=OW*OW                                                         ANWNL 35

      KAY2=OWS/CS                                                       ANWNL 36

C                                                                       ANWNL 37

      H=OW*OW - CS*KS                                                   ANWNL 38

      MKS=-KS                                                           ANWNL 39

      PHT=MKS*PCST                                                      ANWNL 40

      PHR=MKS*PCSR                                                      ANWNL 41

      PHTH=MKS*PCSTH                                                    ANWNL 42

      PHPH=MKS*PCSPH                                                    ANWNL 43

C                                                                       ANWNL 44

      PHOW=2.0*OW                                                       ANWNL 45

      CS2=-2.0*CS                                                       ANWNL 46

      PHKR=CS2*KR                                                       ANWNL 47

      PHKTH=CS2*KTH                                                     ANWNL 48

      PHKPH=CS2*KPH                                                     ANWNL 49

      KPHK=CS2*KS                                                       ANWNL 50

      RETURN                                                            ANWNL 51

      END                                                               ANWNL 52

      SUBROUTINE ATMOSHD                                                ATMOSHD2

C     PRINTS PAGE HEADINGS                                              ATMOSHD3

C     COMMON DECK "B2" INSERTED HERE                                    CB2    2

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

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

      EQUIVALENCE (DUGP,IDSDU)                                          CB2    6

C     COMMON DECK "B4" INSERTED HERE                                    CB4    2

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

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

      EQUIVALENCE (DCGP,IDSDC)                                          CB4    6

C     COMMON DECK "B6" INSERTED HERE                                    CB6    2

      INTEGER DTMX,DTNTBL,DTITBL,DTFRMTB,IDSDT(10)                      CB6    4

      COMMON/B6/DTMX,DTNTBL(10),DTITBL(10),DTFRMTB(10),DTGP(10)         CB6    5

      EQUIVALENCE (DTGP,IDSDT)                                          CB6    6

C     COMMON DECK "B1" INSERTED HERE                                    CB1    2

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

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

      EQUIVALENCE (UGP,IDSU)                                            CB1    6

C     COMMON DECK "B3" INSERTED HERE                                    CB3    2

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

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

      EQUIVALENCE (CGP,IDSC)                                            CB3    6

C     COMMON DECK "B5" INSERTED HERE                                    CB5    2

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

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

      EQUIVALENCE (TGP,IDST)                                            CB5    6

C     COMMON DECK "B7" INSERTED HERE                                    CB7    2

      INTEGER MMX,MNTBL,MITBL,MFRMTBL,IDSM(10)                          CB7    4

      COMMON/B7/MMX,MNTBL(10),MITBL(10),MFRMTBL(10),MGP(10)             CB7    5

      EQUIVALENCE (MGP,IDSM)                                            CB7    6

C     COMMON DECK "HDR" INSERTED HERE                                   CHDR   2

      REAL INITID,MU,MFLD                                               CHDR   4

      COMMON/HDR/DAT,TOD,SEC,INITID(8),MU,MFLD(2)                       CHDR   5

C     COMMON DECK "RINPLEX" INSERTED HERE                               CRINPLE2

      REAL KAY2,KAY2I                                                   CRINPLE4

      COMPLEX PNP,POLAR,LPOLAR                                          CRINPLE5

      LOGICAL SPACE                                                     CRINPLE6

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

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

      COMMON/RIN/PNP(10),POLAR,LPOLAR,SGN                               CRINPLE9

C     COMMON DECK "CC" INSERTED HERE                                    CCC    2

      REAL MODC                                                         CCC    4

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

C     COMMON DECK "MM" INSERTED HERE                                    CMM    2

      REAL M,MODM                                                       CMM    4

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

C     COMMON DECK "FLAG" INSERTED HERE                                  CFLAG  2

      LOGICAL NEWWR,NEWWP,PENET                                         CFLAG  4

      COMMON /FLG/ NTYP,NEWWR,NEWWP,PENET,LINES,IHOP,HPUNCH             CFLAG  5

C     COMMON DECK "TT" INSERTED HERE                                    CTT    2

      REAL MODT                                                         CTT    4

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

C     COMMON DECK "UU" INSERTED HERE                                    CUU    2

      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

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      DATA IDSDC,IDSDT,IDSDU,IDSC,IDSM,IDST,IDSU/70*" "/                ATMOSH19

      DATA IBLK/" "/                                                    ATMOSH20

C                                                                       ATMOSH21

      ENTRY HEADER1                                                     ATMOSH22

C                                                                       ATMOSH23

      NTYP=2                                                            ATMOSH24

      IF(RAY.NE.0.0) NTYP=2.0+SIGN(1.0,RAY)                             ATMOSH25

      MFLD(1)=RAYNAME(1,NTYP)                                           ATMOSH26

      MFLD(2)=RAYNAME(2,NTYP)                                           ATMOSH27

C                                                                       ATMOSH28

      WRITE(3,1000) ID,DAT,TOD,MODRIN,MFLD,MODU,MODC,MODT,MODM          ATMOSH29

      PUNCH 1200,ID                                                     ATMOSH30

      PUNCH 1600, MODU,MODC,MODT,MODM                                   ATMOSH31

1600  FORMAT(2(2(A10,F5.1,1X),2X))                                      ATMOSH32

      WRITE(3,1100)                                                     ATMOSH33

      IF(IDSU(1) .NE. IBLK) WRITE(3,1100) IDSU                          ATMOSH34

      IF(IDSU(1) .NE. IBLK) PUNCH 1200, IDSU                            ATMOSH35

      IF(IDSDU(1) .NE. IBLK) WRITE(3,1100) IDSDU                        ATMOSH36

      IF(IDSDU(1) .NE. IBLK) PUNCH 1200, IDSDU                          ATMOSH37

      IF(IDSC(1) .NE. IBLK) WRITE(3,1100) IDSC                          ATMOSH38

      IF(IDSC(1) .NE. IBLK) PUNCH 1200, IDSC                            ATMOSH39

      IF(IDSDC(1) .NE. IBLK) WRITE(3,1100) IDSDC                        ATMOSH40

      IF(IDSDC(1) .NE. IBLK) PUNCH 1200, IDSDC                          ATMOSH41

      IF(IDST(1) .NE. IBLK) WRITE(3,1100) IDST                          ATMOSH42

      IF(IDST(1) .NE. IBLK) PUNCH 1200, IDST                            ATMOSH43

      IF(IDSDT(1) .NE. IBLK) WRITE(3,1100) IDSDT                        ATMOSH44

      IF(IDSDT(1) .NE. IBLK) PUNCH 1200, IDSDT                          ATMOSH45

      IF(IDSM(1) .NE. IBLK) WRITE(3,1100) IDSM                          ATMOSH46

      IF(IDSM(1) .NE. IBLK) PUNCH 1200, IDSM                            ATMOSH47

      WRITE(3,1100)                                                     ATMOSH48

 1000 FORMAT ("1",10A8,24X,2A10/1X,8A10,1X,2A10//                       ATMOSH49

     1   "      WIND    VELOCITY   MODEL     ",                         ATMOSH50

     2    "    SOUND     SPEED     MODEL     ",                         ATMOSH51

     3    "     TEMPERATURE       MODEL      ",                         ATMOSH52

     4    " MOLECULAR     WEIGHT     MODEL"/,1X,                        ATMOSH53

     5  3("    MAIN       PERTURBATION       ")/                        ATMOSH54

     8   1X,4(2(A10,F4.1,2X),2X))                                       ATMOSH55

1100  FORMAT(" ",10A8)                                                  ATMOSH56

1200  FORMAT(10A8)                                                      ATMOSH57

      RETURN                                                            ATMOSH58

C                                                                       ATMOSH59

      ENTRY HEADER2                                                     ATMOSH60

C                                                                       ATMOSH61

      WRITE(3,1000) ID,DAT,TOD,MODRIN,MFLD,MODU,MODC,MODT,MODM          ATMOSH62

      WRITE(3,1100)                                                     ATMOSH63

      RETURN                                                            ATMOSH64

C                                                                       ATMOSH65

      END                                                               ATMOSH66

      SUBROUTINE AWWNL                                                  AWWNL  2

C     DISPERSION RELATION FOR ACOUSTIC WAVES WITH WIND, NO LOSSES       AWWNL  3

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL 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 MODC                                                         CCC    4

      COMMON/CC/MODC(4),CS,PCSR,PCST,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

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

C     COMMON DECK "RINREAL" INSERTED HERE                               CRINREA2

      LOGICAL SPACE                                                     CRINREA4

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

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

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

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

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

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

C     COMMON DECK "UU" INSERTED HERE                                    CUU    2

      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

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

C                                                                       AWWNL 11

      REAL KS,KV                                                        AWWNL 12

      REAL KVECT(24)                                                    AWWNL 13

      EQUIVALENCE(KVECT,KAY2)                                           AWWNL 14

C                                                                       AWWNL 15

      DATA KVECT/24*0.0/                                                AWWNL 16

      DATA MODRIN/"ACOUSTIC W","AVE"," " ,"WITH WIND",2*" ","NO LOSSES" AWWNL 17

     1      ," "/                                                       AWWNL 18

      DATA RAYNAME/6*1H /                                               AWWNL 19

      DATA OMEGMIN,OMEGMAX/0.0,0.0/                                     AWWNL 20

      DATA TYPE,POLAR,POLARI,LPOLAR,LPOLRI/3*1H1,0.0,0.0,1.0,0.0/       AWWNL 21

C                                                                       AWWNL 22

      ENTRY IDISPER                                                     AWWNL 23

      CALL ISPEED                                                       AWWNL 24

      CALL IWINDR                                                       AWWNL 25

      RETURN                                                            AWWNL 26

C                                                                       AWWNL 27

      ENTRY DISPER                                                      AWWNL 28

C                                                                       AWWNL 29

      SPACE=.FALSE.                                                     AWWNL 30

C                                                                       AWWNL 31

      KS=KR*KR+KTH*KTH+KPH*KPH                                          AWWNL 32

C     WIND VELOCITY                                                     AWWNL 33

      CALL WINDR                                                        AWWNL 34

      KV=KR*VR+KTH*VTH+KPH*VPH                                          AWWNL 35

      VLS=KV*KV/KS                                                      AWWNL 36

C     SOUND SPEED                                                       AWWNL 37

      CALL SPEED                                                        AWWNL 38

      OWS=OW*OW                                                         AWWNL 39

      KAY2=OWS/(SQRT(CS)+KV/SQRT(KS))**2                                AWWNL 40

C                                                                       AWWNL 41

      OWI=OW-KV                                                         AWWNL 42

      H=OWI*OWI - CS*KS                                                 AWWNL 43

      POWIT=-KR*PVRT - KTH*PVTHT - KPH*PVPHT                            AWWNL 44

      PHT=2.0*OWI*POWIT - KS*PCST                                       AWWNL 45

      POWIR=-KR*PVRR - KTH*PVTHR - KPH*PVPHR                            AWWNL 46

      PHR=2.0*OWI*POWIR - KS*PCSR                                       AWWNL 47

      POWITH=-KR*PVRTH - KTH*PVTHTH - KPH*PVPHTH                        AWWNL 48

      PHTH=2.0*OWI*POWITH - KS*PCSTH                                    AWWNL 49

      POWIPH=-KR*PVRPH - KTH*PVTHPH - KPH*PVPHPH                        AWWNL 50

      PHPH=2.0*OWI*POWIPH - KS*PCSPH                                    AWWNL 51

C                                                                       AWWNL 52

      PHOW=2.0*OWI                                                      AWWNL 53

      PHKR=-2.0*(OWI*VR + CS*KR)                                        AWWNL 54

      PHKTH=-2.0*(OWI*VTH + CS*KTH)                                     AWWNL 55

      PHKPH=-2.0*(OWI*VPH + CS*KPH)                                     AWWNL 56

      KPHK=-2.0*(OWI*KV + CS*KS)                                        AWWNL 57

      RETURN                                                            AWWNL 58

      END                                                               AWWNL 59

      SUBROUTINE BACK UP(HS,RSIGN,TC)                                   BACKUP 2

      COMMON /RK/ N,STEP,MODE,E1MAX,E1MIN,E2MAX,E2MIN,FACT,RSTART       BACKUP 3

      COMMON /TRAC/ GROUND,PERIGE,THERE,MINDIS,NEWRAY,SMT               BACKUP 4

      COMMON R(20),T,STP,DRDT(20) /WW/ ID(10),MAXW,W(400)               BACKUP 5

      EQUIVALENCE (EARTHR,W(1)),(INTYP,W(41)),(STEP1,W(44))             BACKUP 6

      REAL KR                                                           BACKUP 7

      EQUIVALENCE (KR,R(4)),(DKRDT,DRDT(4))                             BACKUP 8

      REAL INTYP                                                        BACKUP 9

      LOGICAL PCNTRL,GROUND,PERIGE,THERE,MINDIS,NEWRAY,HOME             BACKUP10

C                                                                       BACKUP11

C     DEFINE BASE STEP SIZE                                             BACKUP12

      STPB=STP                                                          BACKUP13

      PCNTRL=W(73).NE.0.0                                               BACKUP14

      THERE=.TRUE.                                                      BACKUP15

C      STEP TO ESTIMATED CROSSING AT TC.                                BACKUP16

      DO 1 I=1,4                                                        BACKUP17

C********* DIAGNOSTIC PRINTOUT                                          BACKUP18

       IF(PCNTRL) CALL PRINTR (8HBACK UP0,0.)                           BACKUP19

      STEP=TC-T                                                         BACKUP20

      STEP=SIGN(AMIN1(ABS(STPB),ABS(STEP)),STEP)                        BACKUP21

      MODE=1                                                            BACKUP22

      RSTART=1                                                          BACKUP23

      TOLD=T                                                            BACKUP24

      DROLD=DRDT(1)                                                     BACKUP25

      CALL RKAM                                                         BACKUP26

      RSTART=1.0                                                        BACKUP27

      IF(T.EQ.TC) GO TO 2                                               BACKUP28

1     CONTINUE                                                          BACKUP29

2     CONTINUE                                                          BACKUP30

      IF(RSIGN*DRDT(1).LE.0.0) GO TO 12                                 BACKUP31

C                                                                       BACKUP32

C********* FIND NEAREST INTERSECTION OF RAY WITH THE HEIGHT HS          BACKUP33

      DO 10 I=1,10                                                      BACKUP34

      STEP=-(R(1)-EARTHR-HS)/DRDT(1)                                    BACKUP35

      STEP=SIGN(AMIN1(ABS(STPB),ABS(STEP)),STEP)                        BACKUP36

      IF (ABS(R(1)-EARTHR-HS).LT..5E-4.AND.ABS(STEP).LT.1.) GO TO 60    BACKUP37

C********* DIAGNOSTIC PRINTOUT                                          BACKUP38

       IF(PCNTRL) CALL PRINTR(8HBACK UP1,0.)                            BACKUP39

      MODE=1                                                            BACKUP40

      RSTART=1.                                                         BACKUP41

      TOLD=T                                                            BACKUP42

      DROLD=DRDT(1)                                                     BACKUP43

      CALL RKAM                                                         BACKUP44

   10 RSTART=1.                                                         BACKUP45

      GO TO 12                                                          BACKUP46

C                                                                       BACKUP47

C********* FIND NEAREST CLOSEST APPROACH OF RAY TO THE HEIGHT HS        BACKUP48

      ENTRY GRAZE                                                       BACKUP49

C                                                                       BACKUP50

C     DEFINE BASE STEP SIZE                                             BACKUP51

      STPB=STP                                                          BACKUP52

      PCNTRL=W(73).NE.0.0                                               BACKUP53

      THERE=.FALSE.                                                     BACKUP54

C     STEP TO ESTIMATED CLOSEST APPROACH AT TC.                         BACKUP55

      DO 11 I=1,4                                                       BACKUP56

C********* DIAGNOSTIC PRINTOUT                                          BACKUP57

       IF(PCNTRL) CALL PRINTR (8HGRAZE 0 ,0.)                           BACKUP58

      STEP=TC-T                                                         BACKUP59

      STEP=SIGN(AMIN1(ABS(STPB),ABS(STEP)),STEP)                        BACKUP60

      MODE=1                                                            BACKUP61

      RSTART=1.0                                                        BACKUP62

      TOLD=T                                                            BACKUP63

      DROLD=DRDT(1)                                                     BACKUP64

      CALL RKAM                                                         BACKUP65

      RSTART=1.0                                                        BACKUP66

      IF(T.EQ.TC) GO TO 12                                              BACKUP67

11     CONTINUE                                                         BACKUP68

12     CONTINUE                                                         BACKUP69

      THERE=.FALSE.                                                     BACKUP70

      DO 20 I=1,10                                                      BACKUP71

      RDOT=DRDT(1)                                                      BACKUP72

      RDDOT=(DRDT(1)-DROLD)/(T-TOLD)                                    BACKUP73

      STEP=-RDOT/RDDOT                                                  BACKUP74

      STEP=SIGN(AMIN1(ABS(STPB),ABS(STEP)),STEP)                        BACKUP75

      IF (ABS(RDOT).LE.1.E-6.AND.ABS(STEP).LT.1.) GO TO 60              BACKUP76

C********* DIAGNOSTIC PRINTOUT                                          BACKUP77

       IF(PCNTRL) CALL PRINTR (8HGRAZE 1 ,0.)                           BACKUP78

      MODE=1                                                            BACKUP79

      RSTART=1.                                                         BACKUP80

      TOLD=T                                                            BACKUP81

      DROLD=DRDT(1)                                                     BACKUP82

      CALL RKAM                                                         BACKUP83

      RSTART=1.                                                         BACKUP84

      IF (DRDT(4)*(R(1)-EARTHR-HS).LT.0.) GO TO 30                      BACKUP85

      IF(R(5).EQ.0..AND.R(6).EQ.0.) GO TO 60                            BACKUP86

   20 CONTINUE                                                          BACKUP87

C********* IF A CLOSEST APPROACH COULD NOT BE FOUND IN 10 STEPS, IT     BACKUP88

C********* PROBABLY MEANS THAT THE RAY INTERSECTS THE HEIGHT HS         BACKUP89

   30 CONTINUE                                                          BACKUP90

C********* DIAGNOSTIC PRINTOUT                                          BACKUP91

       IF(PCNTRL) CALL PRINTR (8HBACK UP2,0.)                           BACKUP92

      MODE=1                                                            BACKUP93

C********* ESTIMATE DISTANCE TO NEAREST INTERSECTION GOING THE RIGHT    BACKUP94

C********* DIRECTION OF RAY WITH HEIGHT HS                              BACKUP95

      RDOT=DRDT(1)                                                      BACKUP96

      RDDOT=(DRDT(1)-DROLD)/(T-TOLD)                                    BACKUP97

      STEP=(-RDOT+RSIGN*SQRT(RDOT**2-2.*(R(1)-EARTHR-HS)*RDDOT))/RDDOT  BACKUP98

      RSTART=1.                                                         BACKUP99

      CALL RKAM                                                         BACKU100

      RSTART=1.                                                         BACKU101

C********* FIND NEAREST INTERSECTION OF RAY WITH HEIGHT HS              BACKU102

      DO 40 I=1,10                                                      BACKU103

      STEP=-(R(1)-EARTHR-HS)/DRDT(1)                                    BACKU104

      STEP=SIGN(AMIN1(ABS(STPB),ABS(STEP)),STEP)                        BACKU105

      IF (ABS(R(1)-EARTHR-HS).LT..5E-4.AND.ABS(STEP).LT.1.) GO TO 50    BACKU106

C********* DIAGNOSTIC PRINTOUT                                          BACKU107

       IF(PCNTRL) CALL PRINTR (8HBACK UP3,0.)                           BACKU108

      MODE=1                                                            BACKU109

      RSTART=1.                                                         BACKU110

      CALL RKAM                                                         BACKU111

   40 RSTART=1.                                                         BACKU112

   50 THERE=.TRUE.                                                      BACKU113

C********* RESET STANDARD MODE AND INTEGRATION TYPE                     BACKU114

   60 MODE=INTYP                                                        BACKU115

      STEP=STPB                                                         BACKU116

      RETURN                                                            BACKU117

         END                                                            BACKU118

      SUBROUTINE CBLOB                                                  CBLOB  2

C     SOUND SPEED PERTURBATION MODEL                                    CBLOB  3

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL 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

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

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

      EQUIVALENCE (DCGP,IDSDC)                                          CB4    6

C                                                                       CBLOB  6

C     COMMON DECK "CC" INSERTED HERE                                    CCC    2

      REAL MODC                                                         CCC    4

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

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

C                                                                       CBLOB  9

      EQUIVALENCE (C0,W(178)), (Z0,W(179)),(TH0,W(180))                 CBLOB 10

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

      DATA MODC(3),MODC(4)/"CBLOB",0.0/                                 CBLOB 12

      DATA RECOGDC/1.0/                                                 CBLOB 13

      DATA DCMX/1/                                                      CBLOB 14

      DATA DCNTBL/1,11,8*0/                                             CBLOB 15

      DATA DCITBL/1,9*0/                                                CBLOB 16

      DATA DCFRMTB/1,9*0/                                               CBLOB 17

C                                                                       CBLOB 18

      ENTRY IPSPEED                                                     CBLOB 19

      IF(RECOGDC .NE. DCMODEL)                                          CBLOB 20

     1    CALL RERROR(7HDSPEED    ,10HWRNG MODEL ,RECOGDC)              CBLOB 21

C                                                                       CBLOB 22

      MODC(4)=DCID                                                      CBLOB 23

C                                                                       CBLOB 24

      FWZ=0.0                                                           CBLOB 25

      FWTH=0.0                                                          CBLOB 26

      FWPH=0.0                                                          CBLOB 27

      IF(WZ.NE.0.0) FWZ=2.0/WZ/WZ                                       CBLOB 28

      IF(WTH.NE.0.0) FWTH=2.0/WTH/WTH                                   CBLOB 29

      IF(WPH.NE.0.0) FWPH=2.0/WPH/WPH                                   CBLOB 30

      RETURN                                                            CBLOB 31

C                                                                       CBLOB 32

      ENTRY PSPEED                                                      CBLOB 33

C                                                                       CBLOB 34

      IF(C0.EQ.0.0) RETURN                                              CBLOB 35

C                                                                       CBLOB 36

      DZ=R-EARTHR-Z0                                                    CBLOB 37

      DTH=TH-TH0                                                        CBLOB 38

      DPH=PH-PH0                                                        CBLOB 39

      DEXPO=0.0                                                         CBLOB 40

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

      IF(EXPO .GT. -200.0) DEXPO=C0*EXP(EXPO)                           CBLOB 42

      DEL=1.0+DEXPO                                                     CBLOB 43

C                                                                       CBLOB 44

      PCSR=PCSR*DEL-CS*DEXPO*FWZ*DZ                                     CBLOB 45

      PCSTH=PCSTH*DEL-CS*DEXPO*FWTH*DTH                                 CBLOB 46

      PCSPH=PCSPH*DEL-CS*DEXPO*FWPH*DPH                                 CBLOB 47

      CS=CS*DEL                                                         CBLOB 48

      RETURN                                                            CBLOB 49

      END                                                               CBLOB 50

      SUBROUTINE CLEAR(A,N)                                             CLEAR  2

      REAL A(1)                                                         CLEAR  3

      IF(N.LE.0) RETURN                                                 CLEAR  4

      DO    10 I=1,N                                                    CLEAR  5

10    A(I)=0.0                                                          CLEAR  6

      RETURN                                                            CLEAR  7

      END                                                               CLEAR  8

      SUBROUTINE RERROR(ROUTIN,STR,VAL)                                 CLEAR  9

      PRINT 10,ROUTIN,STR,VAL                                           CLEAR 10

10    FORMAT(39H ERROR CONDITION IN RAYTRACE ROUTINE <                  CLEAR 11

     1  ,A8,10H> DUE TO " ,A10,9H", VALUE=  ,F8.2)                      CLEAR 12

      STOP                                                              CLEAR 13

      END                                                               CLEAR 14

      FUNCTION RENORM(VECTOR,NNORM,NCOMPS)                              CLEAR 15

      REAL NNORM,VECTOR(1)                                              CLEAR 16

C                                                                       CLEAR 17

      RENORM=0.0                                                        CLEAR 18

      IF(NNORM.LE.0.0) RETURN                                           CLEAR 19

C                                                                       CLEAR 20

      RENORM=0.0                                                        CLEAR 21

      DO 10 I=1,NCOMPS                                                  CLEAR 22

10    RENORM=RENORM+VECTOR(I)*VECTOR(I)                                 CLEAR 23

      IF(RENORM.EQ.0.0) RETURN                                          CLEAR 24

C                                                                       CLEAR 25

      RENORM=SQRT(NNORM/RENORM)                                         CLEAR 26

      DO 20 I=1,NCOMPS                                                  CLEAR 27

20    VECTOR(I)=VECTOR(I)*RENORM                                        CLEAR 28

C                                                                       CLEAR 29

      RETURN                                                            CLEAR 30

      END                                                               CLEAR 31

C     COMMON DECK "B1" INSERTED HERE                                    CB1    2

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

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

      EQUIVALENCE (UGP,IDSU)                                            CB1    6

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "B2" INSERTED HERE                                    CB2    2

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

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

      EQUIVALENCE (DUGP,IDSDU)                                          CB2    6

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "B3" INSERTED HERE                                    CB3    2

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

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

      EQUIVALENCE (CGP,IDSC)                                            CB3    6

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "B4" INSERTED HERE                                    CB4    2

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

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

      EQUIVALENCE (DCGP,IDSDC)                                          CB4    6

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "B5" INSERTED HERE                                    CB5    2

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

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

      EQUIVALENCE (TGP,IDST)                                            CB5    6

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "B6" INSERTED HERE                                    CB6    2

      INTEGER DTMX,DTNTBL,DTITBL,DTFRMTB,IDSDT(10)                      CB6    4

      COMMON/B6/DTMX,DTNTBL(10),DTITBL(10),DTFRMTB(10),DTGP(10)         CB6    5

      EQUIVALENCE (DTGP,IDSDT)                                          CB6    6

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "B7" INSERTED HERE                                    CB7    2

      INTEGER MMX,MNTBL,MITBL,MFRMTBL,IDSM(10)                          CB7    4

      COMMON/B7/MMX,MNTBL(10),MITBL(10),MFRMTBL(10),MGP(10)             CB7    5

      EQUIVALENCE (MGP,IDSM)                                            CB7    6

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "B8" INSERTED HERE                                    CB8    2

      INTEGER GMX,GNTBL,GITBL,GFRMTBL,IDSG(10)                          CB8    4

      COMMON/B8/GMX,GNTBL(10),GITBL(10),GFRMTBL(10),GGP(10)             CB8    5

      EQUIVALENCE (GGP,IDSG)                                            CB8    6

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "B9" INSERTED HERE                                    CB9    2

      INTEGER GMX,GNTBL,GITBL,GFRMTBL,IDSG(10)                          CB9    4

      COMMON/B9/GMX,GNTBL(10),GITBL(10),GFRMTBL(10),GGP(10)             CB9    5

      EQUIVALENCE (GGP,IDSG)                                            CB9    6

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "B10" INSERTED HERE                                   CB10   2

      INTEGER RMX,RNTBL,RITBL,RFRMTBL,IDSG(10)                          CB10   4

      COMMON/B10/RMX,RNTBL(10),RITBL(10),RFRMTBL(10),RGP(10)            CB10   5

      EQUIVALENCE (RGP,IDSG)                                            CB10   6

                                                                        SPACER 2

                                                                        SPACER 3

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

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "CC" INSERTED HERE                                    CCC    2

      REAL MODC                                                         CCC    4

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

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "FLAG" INSERTED HERE                                  CFLAG  2

      LOGICAL NEWWR,NEWWP,PENET                                         CFLAG  4

      COMMON /FLG/ NTYP,NEWWR,NEWWP,PENET,LINES,IHOP,HPUNCH             CFLAG  5

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "GAMANG" INSERTED HERE                                CGAMANG2

      COMMON/SPHGAM/SINLM0,COSLM0,GPH0,COSPHD,SINTH,COSTH               CGAMANG4

      COMMON/SPHGAM/GAMFUN,PGMTH,PGMPH,PGMTHTH,PGMPHPH,PGMTHPH          CGAMANG5

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "GG" INSERTED HERE                                    CGG    2

      COMMON/GG/ MODGRD(4)                                              CGG    4

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

      COMMON/GG/PGTH,PGPH,PGTHTH,PGPHPH,PGTHPH                          CGG    6

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "HDR" INSERTED HERE                                   CHDR   2

      REAL INITID,MU,MFLD                                               CHDR   4

      COMMON/HDR/DAT,TOD,SEC,INITID(8),MU,MFLD(2)                       CHDR   5

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "MM" INSERTED HERE                                    CMM    2

      REAL M,MODM                                                       CMM    4

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

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "RINREAL" INSERTED HERE                               CRINREA2

      LOGICAL SPACE                                                     CRINREA4

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

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

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

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

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

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

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "RINPLEX" INSERTED HERE                               CRINPLE2

      REAL KAY2,KAY2I                                                   CRINPLE4

      COMPLEX PNP,POLAR,LPOLAR                                          CRINPLE5

      LOGICAL SPACE                                                     CRINPLE6

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

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

      COMMON/RIN/PNP(10),POLAR,LPOLAR,SGN                               CRINPLE9

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "RK" INSERTED HERE                                    CRK    2

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

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL KR,KTH,KPH                                                   RKAMCOM4

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

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "RR" INSERTED HERE                                    CRR    2

      COMMON/RR/ MODREC(4)                                              CRR    4

      COMMON/RR/F,PFR,PFRR,PFRTH,PFRPH                                  CRR    5

      COMMON/RR/PFTH,PFPH,PFTHTH,PFPHPH,PFTHPH                          CRR    6

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "TT" INSERTED HERE                                    CTT    2

      REAL MODT                                                         CTT    4

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

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "UU" INSERTED HERE                                    CUU    2

      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

                                                                        SPACER 2

                                                                        SPACER 3

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

                                                                        SPACER 2

                                                                        SPACER 3

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

                                                                        SPACER 2

                                                                        SPACER 3

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

                                                                        SPACER 2

                                                                        SPACER 3

C     COMMON DECK "ZEXP" INSERTED HERE                                  CZEXP  2

      COMMON/CZEXP/ZGAIN,ZWIDTH,ZALPH0,ZBETA                            CZEXP  4

      COMMON/CZEXP/ZFUN,PZTH,PZPH,PZTHTH,PZPHPH,PZTHPH                  CZEXP  5

      SUBROUTINE DDINIT(N,TEXT)                                         DDPACK 2

C                                                                       DDPACK 3

      COMMON/PLOTCN/NPLOT,INABLE,FX,FY                                  DDPACK 4

      COMMON/WW/KILL(11),W(400)                                         DDPACK 5

      EQUIVALENCE (W(90),PLOTSZ),(W(91),XAXIS),(W(92),YAXIS)            DDPACK 6

      DATA NPLOT,INABLE/0,0/                                            DDPACK 7

C                                                                       DDPACK 8

C     NO RE-INITIALIZATIONS BEFORE ENDPL'S                              DDPACK 9

      IF(INABLE.GT.0) RETURN                                            DDPACK10

C                                                                       DDPACK11

      IF(NPLOT.GT.0) GO TO 10                                           DDPACK12

C                                                                       DDPACK13

      IF(PLOTSZ.LE.0.0) PLOTSZ=7.5                                      DDPACK14

      IF(XAXIS.LE.0.0) XAXIS=10.0                                       DDPACK15

      IF(YAXIS.LE.0.0) YAXIS=6.0                                        DDPACK16

C                                                                       DDPACK17

      CALL ID(TEXT,N*10)                                                DDPACK18

12     CALL COMPRS(4HCONT,4)                                            DDPACK19

      FY=PLOTSZ/1024.                                                   DDPACK20

      FX=FY                                                             DDPACK21

C     ALLOW LOWER CASE LETTERING WITH "!" ESCAPE CHARACTER              DDPACK22

      CALL BASALF("STAND","!")                                          DDPACK23

      CALL MIXALF("L/CST","!")                                          DDPACK24

C                                                                       DDPACK25

10    NPLOT=NPLOT+1                                                     DDPACK26

      INABLE=1                                                          DDPACK27

      CALL BGNPL(-NPLOT)                                                DDPACK28

      CALL TITLE(" ",-1," ",0," ",0,XAXIS,YAXIS)                        DDPACK29

      CALL GRACE(0.0)                                                   DDPACK30

      RETURN                                                            DDPACK31

      END                                                               DDPACK32

      SUBROUTINE DDBP                                                   DDPACK33

      COMMON/PLOTCN/NPLOT,INABLE,FX,FY                                  DDPACK34

      COMMON/DD/INT,IOR,IT,IS,IC,ICC,IX,IY                              DDPACK35

C                                                                       DDPACK36

C     "DDPLOT" DOES NOT REQUIRE RE-INITIALIZATION AFTER EACH FRAME      DDPACK37

C     BUT "DISPLA" DOES SO WE USE THE STATUS OF "INABLE" TO TELL US     DDPACK38

C     WHERE WE ARE.                                                     DDPACK39

      IF(INABLE.EQ.0) CALL DDINIT(-1,0)                                 DDPACK40

      CALL STRTPT(IX*FX,IY*FY)                                          DDPACK41

      RETURN                                                            DDPACK42

      END                                                               DDPACK43

      SUBROUTINE DDVC                                                   DDPACK44

      COMMON/PLOTCN/NPLOT,INABLE,FX,FY                                  DDPACK45

      COMMON/DD/INT,IOR,IT,IS,IC,ICC,IX,IY                              DDPACK46

C                                                                       DDPACK47

C     SEE "DDVC" FOR THE REASON FOR THIS TEST.                          DDPACK48

      IF(INABLE.EQ.0) CALL DDINIT(-1,0)                                 DDPACK49

      CALL CONNPT(IX*FX,IY*FY)                                          DDPACK50

      RETURN                                                            DDPACK51

      END                                                               DDPACK52

      SUBROUTINE DDEND                                                  DDPACK53

      COMMON/PLOTCN/NPLOT,INABLE,FX,FY                                  DDPACK54

C     CHECK SYNCH, DDFR SHOULD HAVE BEEN CALLED BY NOW                  DDPACK55

      IF(INABLE.GT.0) CALL ENDPL(0)                                     DDPACK56

C                                                                       DDPACK57

      CALL DONEPL                                                       DDPACK58

C                                                                       DDPACK59

      INABLE=0                                                          DDPACK60

      RETURN                                                            DDPACK61

      END                                                               DDPACK62

      SUBROUTINE DDTEXT(N,TEXT)                                         DDPACK63

      COMMON/PLOTCN/NPLOT,INABLE,FX,FY                                  DDPACK64

      COMMON/DD/INT,IOR,IT,IS,IC,ICC,IX,IY                              DDPACK65

C                                                                       DDPACK66

      IF(IOR.EQ.0) CALL ANGLE(0.0)                                      DDPACK67

      IF(IOR.NE.0) CALL ANGLE(90.0)                                     DDPACK68

      CALL MESSAG(TEXT,N*10,IX*FX,IY*FY)                                DDPACK69

      RETURN                                                            DDPACK70

      END                                                               DDPACK71

      SUBROUTINE DDTAB                                                  DDPACK72

      RETURN                                                            DDPACK73

      END                                                               DDPACK74

      SUBROUTINE DDFR                                                   DDPACK75

      COMMON/PLOTCN/NPLOT,INABLE,FX,FY                                  DDPACK76

      IF(INABLE.GT.0) CALL ENDPL(0)                                     DDPACK77

      INABLE=0                                                          DDPACK78

      RETURN                                                            DDPACK79

      END                                                               DDPACK80

      SUBROUTINE GAMANG(THA,PHA)                                        GAMANG 2

C     COMMON DECK "GAMANG" INSERTED HERE                                CGAMANG2

      COMMON/SPHGAM/SINLM0,COSLM0,GPH0,COSPHD,SINTH,COSTH               CGAMANG4

      COMMON/SPHGAM/GAMFUN,PGMTH,PGMPH,PGMTHTH,PGMPHPH,PGMTHPH          CGAMANG5

C                                                                       GAMANG 4

      COSPHD=COS(PHA-GPH0)                                              GAMANG 5

      SINTH=SIN(THA)                                                    GAMANG 6

      COSTH=COS(THA)                                                    GAMANG 7

C                                                                       GAMANG 8

      GAMFUN=SINLM0*COSTH+COSLM0*SINTH*COSPHD                           GAMANG 9

C                                                                       GAMANG10

      PGMTH=-SINLM0*SINTH+COSLM0*COSTH*COSPHD                           GAMANG11

C                                                                       GAMANG12

      PGMPH=-COSLM0*SINTH*SIN(PHA-GPH0)                                 GAMANG13

C                                                                       GAMANG14

      PGMTHTH=-(SINLM0*COSTH+COSLM0*SINTH*COSPHD)                       GAMANG15

C                                                                       GAMANG16

      PGMPHPH=-COSLM0*SINTH*COSPHD                                      GAMANG17

C                                                                       GAMANG18

      PGMTHPH=-COSLM0*COSTH*SIN(PHA-GPH0)                               GAMANG19

C                                                                       GAMANG20

      RETURN                                                            GAMANG21

      END                                                               GAMANG22

      SUBROUTINE GAMRTDM                                                GAMRTDM2

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

C     COMMON DECK "CC" INSERTED HERE                                    CCC    2

      REAL MODC                                                         CCC    4

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

C     COMMON DECK "TT" INSERTED HERE                                    CTT    2

      REAL MODT                                                         CTT    4

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

C     COMMON DECK "MM" INSERTED HERE                                    CMM    2

      REAL 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

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

C                                                                       GAMRTDM9

C     COMMON DECK "B3" INSERTED HERE                                    CB3    2

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

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

      EQUIVALENCE (CGP,IDSC)                                            CB3    6

      DATA MODC/10HGAMMA RT/M  ,0.0, 1H ,0.0/                           GAMRTD11

      DATA RECOGC/1.0/                                                  GAMRTD12

      DATA CMX/1/                                                       GAMRTD13

      DATA CNTBL/1,11,8*0/                                              GAMRTD14

      DATA CITBL/1,9*0/                                                 GAMRTD15

      DATA CFRMTBL/1,9*0/                                               GAMRTD16

      DATA CREF,GAMMA,RGAS/.344,1.4,8.31436E-3/                         GAMRTD17

C                                                                       GAMRTD18

      ENTRY ISPEED                                                      GAMRTD19

C                                                                       GAMRTD20

      IF(RECOGC .NE. CMODEL)                                            GAMRTD21

     1    CALL RERROR(7HSPEED  ,10HWRNG MODEL ,RECOGC)                  GAMRTD22

      MODC(2)=CID                                                       GAMRTD23

      CALL ITEMP                                                        GAMRTD24

      CALL IMOLWT                                                       GAMRTD25

      CALL IPSPEED                                                      GAMRTD26

C                                                                       GAMRTD27

      RETURN                                                            GAMRTD28

C                                                                       GAMRTD29

      ENTRY SPEED                                                       GAMRTD30

      CALL TEMP                                                         GAMRTD31

      CALL MOLWT                                                        GAMRTD32

      CS=GAMMA*RGAS*T/M                                                 GAMRTD33

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

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

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

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

C                                                                       GAMRTD38

C                                                                       GAMRTD39

      CALL PSPEED                                                       GAMRTD40

      RETURN                                                            GAMRTD41

      END                                                               GAMRTD42

      SUBROUTINE GAUSEL (C,NRD,NRR,NCC,NSF)                             GAUSEL 2

C********* SAME AS SUBROUTINE GAUSSEL WRITTEN BY L. DAVID LEWIS ********GAUSEL 3

      DIMENSION C(NRD,NCC),L(128,2)                                     GAUSEL 4

C          BITS = 2.**-18                                               GAUSEL 5

      DATA (BITS=3.8146972656E-6)                                       GAUSEL 6

      NR=NRR                                                            GAUSEL 7

      NC=NCC                                                            GAUSEL 8

      IF(NC.LT.NR.OR.NR.GT.128.OR.NR.LE.0) CALL EXIT                    GAUSEL 9

C                                                                       GAUSEL10

C          INITIALIZE.                                                  GAUSEL11

      NSF=0                                                             GAUSEL12

      NRM=NR-1                                                          GAUSEL13

      NRP=NR+1                                                          GAUSEL14

      D=1.                                                              GAUSEL15

      LSD=1                                                             GAUSEL16

      DO 1 KR=1,NR                                                      GAUSEL17

      L(KR,1)=KR                                                        GAUSEL18

1     L(KR,2)=0                                                         GAUSEL19

      IF(NR.EQ.1) GO TO 42                                              GAUSEL20

C                                                                       GAUSEL21

C          ELIMINATION PHASE.                                           GAUSEL22

      DO 41 KP=1,NRM                                                    GAUSEL23

      KPP=KP+1                                                          GAUSEL24

      PM=0.                                                             GAUSEL25

      MPN=0                                                             GAUSEL26

C                                                                       GAUSEL27

C          SEARCH COLUMN KP FROM DIAGONAL DOWN FOR MAX PIVOT.           GAUSEL28

      DO 2 KR=KP,NR                                                     GAUSEL29

      LKR=L(KR,1)                                                       GAUSEL30

      PT=ABS(C(LKR,KP))                                                 GAUSEL31

      IF(PT.LE.PM) GO TO 2                                              GAUSEL32

      PM=PT                                                             GAUSEL33

      MPN=KR                                                            GAUSEL34

      LMP=LKR                                                           GAUSEL35

2     CONTINUE                                                          GAUSEL36

C                                                                       GAUSEL37

C          IF MAX PIVOT IS ZERO, MATRIX IS SINGULAR.                    GAUSEL38

      IF(MPN.EQ.0) GO TO 9                                              GAUSEL39

      NSF=NSF+1                                                         GAUSEL40

      IF(MPN.EQ.KP) GO TO 3                                             GAUSEL41

C                                                                       GAUSEL42

C          NEW ROW NUMBER KP HAS MAX PIVOT.                             GAUSEL43

      LSD=-LSD                                                          GAUSEL44

      L(KP,2)=L(MPN,1)=L(KP,1)                                          GAUSEL45

      L(KP,1)=LMP                                                       GAUSEL46

C                                                                       GAUSEL47

C          ROW OPERATIONS TO ZERO COLUMN KP BELOW DIAGONAL.             GAUSEL48

3     MKP=L(KP,1)                                                       GAUSEL49

      P=C(MKP,KP)                                                       GAUSEL50

      D=D*P                                                             GAUSEL51

      DO 41 KR=KPP,NR                                                   GAUSEL52

      MKR=L(KR,1)                                                       GAUSEL53

      Q=C(MKR,KP)/P                                                     GAUSEL54

      IF(Q.EQ.0.) GO TO 41                                              GAUSEL55

C                                                                       GAUSEL56

C          SUBTRACT Q * PIVOT ROW FROM ROW KR.                          GAUSEL57

      DO 4 LC=KPP,NC                                                    GAUSEL58

      R=Q*C(MKP,LC)                                                     GAUSEL59

      C(MKR,LC)=C(MKR,LC)-R                                             GAUSEL60

4     IF(ABS(C(MKR,LC)).LT.ABS(R)*BITS) C(MKR,LC)=0.                    GAUSEL61

41    CONTINUE                                                          GAUSEL62

C                                                                       GAUSEL63

C          LOWER RIGHT HAND CORNER.                                     GAUSEL64

42    LNR=L(NR,1)                                                       GAUSEL65

      P=C(LNR,NR)                                                       GAUSEL66

      IF(P.EQ.0.) GO TO 9                                               GAUSEL67

      NSF=NSF+1                                                         GAUSEL68

      D=D*P*LSD                                                         GAUSEL69

      IF(NR.EQ.NC) GO TO 8                                              GAUSEL70

C                                                                       GAUSEL71

C          BACK SOLUTION PHASE.                                         GAUSEL72

      DO 61 MC=NRP,NC                                                   GAUSEL73

      C(LNR,MC)=C(LNR,MC)/P                                             GAUSEL74

      IF(NR.EQ.1) GO TO 61                                              GAUSEL75

      DO 6 LL=1,NRM                                                     GAUSEL76

      KR=NR-LL                                                          GAUSEL77

      MR=L(KR,1)                                                        GAUSEL78

      KRP=KR+1                                                          GAUSEL79

      DO 5 MS=KRP,NR                                                    GAUSEL80

      LMS=L(MS,1)                                                       GAUSEL81

      R=C(MR,MS)*C(LMS,MC)                                              GAUSEL82

      C(MR,MC)=C(MR,MC)-R                                               GAUSEL83

5     IF(ABS(C(MR,MC)).LT.ABS(R)*BITS) C(MR,MC)=0.                      GAUSEL84

6     C(MR,MC)=C(MR,MC)/C(MR,KR)                                        GAUSEL85

61    CONTINUE                                                          GAUSEL86

C                                                                       GAUSEL87

C          SHUFFLE SOLUTION ROWS BACK TO NATURAL ORDER.                 GAUSEL88

      DO 71 LL=1,NRM                                                    GAUSEL89

      KR=NR-LL                                                          GAUSEL90

      MKR=L(KR,2)                                                       GAUSEL91

      IF(MKR.EQ.0) GO TO 71                                             GAUSEL92

      MKP=L(KR,1)                                                       GAUSEL93

      DO 7 LC=NRP,NC                                                    GAUSEL94

      Q=C(MKR,LC)                                                       GAUSEL95

      C(MKR,LC)=C(MKP,LC)                                               GAUSEL96

7     C(MKP,LC)=Q                                                       GAUSEL97

71    CONTINUE                                                          GAUSEL98

C                                                                       GAUSEL99

C          NORMAL AND SINGULAR RETURNS.  GOOD SOLUTION COULD HAVE D=0.  GAUSE100

8     C(1,1)=D                                                          GAUSE101

      GO TO 91                                                          GAUSE102

9     C(1,1)=0.                                                         GAUSE103

   91 RETURN                                                            GAUSE104

         END                                                            GAUSE105

       SUBROUTINE GRIDGE                                                GRIDGE 2

C                                                                       GRIDGE 3

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL KR,KTH,KPH                                                   RKAMCOM4

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

C     COMMON DECK "GG" INSERTED HERE                                    CGG    2

      COMMON/GG/ MODGRD(4)                                              CGG    4

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

      COMMON/GG/PGTH,PGPH,PGTHTH,PGPHPH,PGTHPH                          CGG    6

C     COMMON DECK "B9" INSERTED HERE                                    CB9    2

      INTEGER GMX,GNTBL,GITBL,GFRMTBL,IDSG(10)                          CB9    4

      COMMON/B9/GMX,GNTBL(10),GITBL(10),GFRMTBL(10),GGP(10)             CB9    5

      EQUIVALENCE (GGP,IDSG)                                            CB9    6

C     COMMON DECK "GAMANG" INSERTED HERE                                CGAMANG2

      COMMON/SPHGAM/SINLM0,COSLM0,GPH0,COSPHD,SINTH,COSTH               CGAMANG4

      COMMON/SPHGAM/GAMFUN,PGMTH,PGMPH,PGMTHTH,PGMPHPH,PGMTHPH          CGAMANG5

C     COMMON DECK "ZEXP" INSERTED HERE                                  CZEXP  2

      COMMON/CZEXP/ZGAIN,ZWIDTH,ZALPH0,ZBETA                            CZEXP  4

      COMMON/CZEXP/ZFUN,PZTH,PZPH,PZTHTH,PZPHPH,PZTHPH                  CZEXP  5

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

      EQUIVALENCE (GRZMAX,W(303)) ,(GRWIDTH,W(304)), (GRALPH0,W(305))   GRIDGE10

      EQUIVALENCE (GRLAMZ,W(306)) ,(GRPH0,W(307))                       GRIDGE11

C                                                                       GRIDGE12

      DATA MODGRD(1),MODGRD(2)/7HGRIDGE  ,0.0/                          GRIDGE13

      DATA RECOGG/1.0/                                                  GRIDGE14

C                                                                       GRIDGE15

      DATA GMX/1/                                                       GRIDGE16

      DATA GNTBL/1,11,8*0/                                              GRIDGE17

      DATA GITBL/1,9*0/                                                 GRIDGE18

      DATA GFRMTBL/1,9*0/                                               GRIDGE19

C                                                                       GRIDGE20

      ENTRY IGRDO                                                       GRIDGE21

C                                                                       GRIDGE22

      IF(RECOGG .NE. GMODEL)                                            GRIDGE23

     1    CALL RERROR(7HGROUND  ,10HWRNG MODEL ,RECOGG)                 GRIDGE24

      MODGRD(2)=GID                                                     GRIDGE25

C                                                                       GRIDGE26

      SINLMZ=SIN(GRLAMZ)                                                GRIDGE27

      COSLMZ=COS(GRLAMZ)                                                GRIDGE28

      WINV=0.0                                                          GRIDGE29

      IF(GRWIDTH.NE.0.0) WINV=1.0/GRWIDTH                               GRIDGE30

      RETURN                                                            GRIDGE31

C                                                                       GRIDGE32

      ENTRY GRDO                                                        GRIDGE33

C                                                                       GRIDGE34

      CALL CLEAR(PGR,4)                                                 GRIDGE35

C                                                                       GRIDGE36

      ZGAIN=-GRZMAX                                                     GRIDGE37

      ZWIDTH=WINV                                                       GRIDGE38

      ZALPH0=GRALPH0                                                    GRIDGE39

      SINLM0=SINLMZ                                                     GRIDGE40

      COSLM0=COSLMZ                                                     GRIDGE41

      GPH0=GRPH0                                                        GRIDGE42

C                                                                       GRIDGE43

      CALL ZEXP(TH,PH)                                                  GRIDGE44

C                                                                       GRIDGE45

      G=(R-EARTHR)+ZFUN                                                 GRIDGE46

      PGR=1.0                                                           GRIDGE47

      CALL RMOVE(PGTH,PZTH,5)                                           GRIDGE48

C                                                                       GRIDGE49

      RETURN                                                            GRIDGE50

      END                                                               GRIDGE51

      SUBROUTINE HAMLTN                                                 HAMLTN 2

C********* CALCULATES HAMILTONS EQUATIONS FOR RAY TRACING               HAMLTN 3

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 "RINREAL" INSERTED HERE                               CRINREA2

      LOGICAL SPACE                                                     CRINREA4

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

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

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

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

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

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

      COMMON R(20),T,STP,DRDT(20) /WW/ ID(10),MAXW,W(400)               HAMLTN 6

      EQUIVALENCE (TH,R(2)),(PH,R(3)),(KR,R(4)),(KTH,R(5)),(KPH,R(6)),  HAMLTN 7

     1 (DTHDT,DRDT(2)),(DPHDT,DRDT(3)),(DKRDT,DRDT(4)),(DKTHDT,DRDT(5)),HAMLTN 8

     2 (DKPHDT,DRDT(6)),(HMAX,W(26)),(OW,W(6))                          HAMLTN 9

      REAL KR,KTH,KPH                                                   HAMLTN10

      STH=SIN(TH)                                                       HAMLTN11

      CTH=SIN(PID2-TH)                                                  HAMLTN12

      RSTH=R(1)*STH                                                     HAMLTN13

      RCTH=R(1)*CTH                                                     HAMLTN14

      CALL DISPER                                                       HAMLTN15

      DENPHC=1.0/(PHOW*CREF)                                            HAMLTN16

      DRDT(1)=-PHKR*DENPHC                                              HAMLTN17

      DTHDT=-PHKTH*DENPHC/R(1)                                          HAMLTN18

      DPHDT=-PHKPH*DENPHC/RSTH                                          HAMLTN19

      DKRDT=PHR*DENPHC+KTH*DTHDT+KPH*STH*DPHDT                          HAMLTN20

      DKTHDT=(PHTH*DENPHC-KTH*DRDT(1)+KPH*RCTH*DPHDT)/R(1)              HAMLTN21

      DKPHDT=(PHPH*DENPHC-KPH*STH*DRDT(1)-KPH*RCTH*DTHDT)/RSTH          HAMLTN22

      NR=6                                                              HAMLTN23

C********* PHASE PATH                                                   HAMLTN24

      IF (W(57).EQ.0.) GO TO 10                                         HAMLTN25

      NR=NR+1                                                           HAMLTN26

      DRDT(NR)=-     KPHK/PHOW/OW                                       HAMLTN27

C********* ABSORPTION                                                   HAMLTN28

   10 IF (W(58).EQ.0.) GO TO 15                                         HAMLTN29

      NR=NR+1                                                           HAMLTN30

      DRDT(NR)= 10./ALN10*KPHK*KAY2I/(KR*KR+KTH*KTH+KPH*KPH)*DENPHC     HAMLTN31

C********* DOPPLER SHIFT                                                HAMLTN32

   15 IF (W(59).EQ.0.) GO TO 20                                         HAMLTN33

      NR=NR+1                                                           HAMLTN34

      DRDT(NR)=-PHT*DENPHC/PIT2                                         HAMLTN35

C********* GEOMETRICAL PATH LENGTH                                      HAMLTN36

   20 IF (W(60).EQ.0.) GO TO 25                                         HAMLTN37

      NR=NR+1                                                           HAMLTN38

      DRDT(NR)=SQRT(PHKR**2+PHKTH**2+PHKPH**2)*ABS(DENPHC)              HAMLTN39

C********* OTHER CALCULATIONS                                           HAMLTN40

   25 CONTINUE                                                          HAMLTN41

      RETURN                                                            HAMLTN42

         END                                                            HAMLTN43

      SUBROUTINE LABPLT                                                 LABPLT 2

C          LABEL THE CURRENT PLOT                                       LABPLT 3

      DIMENSION LABEL(8)                                                LABPLT 4

C     COMMON DECK "UU" INSERTED HERE                                    CUU    2

      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 "CC" INSERTED HERE                                    CCC    2

      REAL MODC                                                         CCC    4

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

C     COMMON DECK "TT" INSERTED HERE                                    CTT    2

      REAL MODT                                                         CTT    4

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

C     COMMON DECK "MM" INSERTED HERE                                    CMM    2

      REAL M,MODM                                                       CMM    4

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

C     COMMON DECK "HDR" INSERTED HERE                                   CHDR   2

      REAL INITID,MU,MFLD                                               CHDR   4

      COMMON/HDR/DAT,TOD,SEC,INITID(8),MU,MFLD(2)                       CHDR   5

C     COMMON DECK "RINPLEX" INSERTED HERE                               CRINPLE2

      REAL KAY2,KAY2I                                                   CRINPLE4

      COMPLEX PNP,POLAR,LPOLAR                                          CRINPLE5

      LOGICAL SPACE                                                     CRINPLE6

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

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

      COMMON/RIN/PNP(10),POLAR,LPOLAR,SGN                               CRINPLE9

      COMMON /DD/ INT,IOR,IT,IS,IC,ICC,IX,IY                            LABPLT11

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 "FLAG" INSERTED HERE                                  CFLAG  2

      LOGICAL NEWWR,NEWWP,PENET                                         CFLAG  4

      COMMON /FLG/ NTYP,NEWWR,NEWWP,PENET,LINES,IHOP,HPUNCH             CFLAG  5

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

C                                                                       LABPLT15

      REAL LTIC                                                         LABPLT16

      ENCODE (56,1000,LABEL) (ID(I),I=1,7)                              LABPLT17

 1000 FORMAT (10A8)                                                     LABPLT18

      IOR=IT=0                                                          LABPLT19

      IS=2                                                              LABPLT20

      IX=0                                                              LABPLT21

        IY=1023                                                         LABPLT22

        CALL DDTAB                                                      LABPLT23

        CALL DDTEXT (6,LABEL)                                           LABPLT24

      IX=879                                                            LABPLT25

        IY=1023                                                         LABPLT26

        CALL DDTAB                                                      LABPLT27

        CALL DDTEXT (2,DAT)                                             LABPLT28

      F=OW/PIT2                                                         LABPLT29

      ANGLE=AZ1*DEGS                                                    LABPLT30

      ANOTE=4HAZ =                                                      LABPLT31

      NEL=0                                                             LABPLT32

      IF(ELSTEP.NE.0.0) NEL=(ELEND-ELBEG)/ELSTEP+1.5                    LABPLT33

      IF(NEL.GT.1) GO TO 100                                            LABPLT34

         ANOTE=4HEL =                                                   LABPLT35

         ANGLE=BETA*DEGS                                                LABPLT36

100   DTIC=TIC*EARTHR                                                   LABPLT37

      ENCODE (70,1500,LABEL)  F,ANOTE,ANGLE,RAYNAME(1,NTYP),DTIC        LABPLT38

 1500 FORMAT (3HF =,F9.3,2H, ,A4, F9.4,2H, ,A8,2H, ,F7.2,               LABPLT39

     1" KM BETWEEN TICK MARKS.")                                        LABPLT40

      IX=0                                                              LABPLT41

        IY=IY-32                                                        LABPLT42

        CALL DDTAB                                                      LABPLT43

        CALL DDTEXT (7,LABEL)                                           LABPLT44

      IY=IY-32                                                          LABPLT45

      CALL DDTAB                                                        LABPLT46

      CALL DDTEXT(8,MODRIN)                                             LABPLT47

C                                                                       LABPLT48

      DO 1700 I=1,2                                                     LABPLT49

      IF(I.EQ.1) ENCODE(80,1600,LABEL) MODU,MODC                        LABPLT50

      IF(I.EQ.2) ENCODE(80,1600,LABEL) MODT,MODM                        LABPLT51

1600  FORMAT(10(2(A10,F5.1,1X),2X))                                     LABPLT52

      IY=IY-32                                                          LABPLT53

      CALL DDTAB                                                        LABPLT54

1700  CALL DDTEXT(8,LABEL)                                              LABPLT55

C                                                                       LABPLT56

      IF (PLT.EQ.1.) RETURN                                             LABPLT57

      LTIC=DTIC/PFACTR                                                  LABPLT58

      ENCODE (32,2000,LABEL)  LTIC                                      LABPLT59

 2000 FORMAT (F7.2,24H KM BETWEEN TICK MARKS".)                         LABPLT60

      IOR=1                                                             LABPLT61

      IX=0                                                              LABPLT62

        IY=0                                                            LABPLT63

        CALL DDTAB                                                      LABPLT64

        CALL DDTEXT (4,LABEL)                                           LABPLT65

      IOR=0                                                             LABPLT66

      RETURN                                                            LABPLT67

         END                                                            LABPLT68

      SUBROUTINE MCONST                                                 MCONST 2

C     CONSTANT MOLECULAR WEIGHT MODEL                                   MCONST 3

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

C     COMMON DECK "MM" INSERTED HERE                                    CMM    2

      REAL M,MODM                                                       CMM    4

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

      REAL  MLCNST                                                      MCONST 6

      EQUIVALENCE (W(253),MLCNST)                                       MCONST 7

C     COMMON DECK "B7" INSERTED HERE                                    CB7    2

      INTEGER MMX,MNTBL,MITBL,MFRMTBL,IDSM(10)                          CB7    4

      COMMON/B7/MMX,MNTBL(10),MITBL(10),MFRMTBL(10),MGP(10)             CB7    5

      EQUIVALENCE (MGP,IDSM)                                            CB7    6

      DATA MODM/6HMCONST  ,0.0, 1H  , 0.0/                              MCONST 9

      DATA RECOGM/1.0/                                                  MCONST10

      DATA MMX/1/                                                       MCONST11

      DATA MNTBL/1,11,8*0/                                              MCONST12

      DATA MITBL/1,9*0/                                                 MCONST13

      DATA MFRMTBL/1,9*0/                                               MCONST14

C                                                                       MCONST15

      ENTRY IMOLWT                                                      MCONST16

C                                                                       MCONST17

      IF(RECOGM .NE. MMODEL)                                            MCONST18

     1    CALL RERROR(7HIMOLWT  ,10HWRNG MODEL ,RECOGM)                 MCONST19

      MODM(2)=MID                                                       MCONST20

C                                                                       MCONST21

      RETURN                                                            MCONST22

C                                                                       MCONST23

      ENTRY MOLWT                                                       MCONST24

      M=MLCNST                                                          MCONST25

      CALL CLEAR(PMT,4)                                                 MCONST26

      END                                                               MCONST27

      PROGRAM NITIAL (INPUT,OUTPUT,PUNCH,TAPE3,TAPE4)                   NITIAL 2

C          SETS THE INITIAL CONDITIONS FOR EACH RAY AND CALLS TRACE     NITIAL 3

C                                                                       NITIAL 4

C     COMMON DECK "HDR" INSERTED HERE                                   CHDR   2

      REAL INITID,MU,MFLD                                               CHDR   4

      COMMON/HDR/DAT,TOD,SEC,INITID(8),MU,MFLD(2)                       CHDR   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 "FLAG" INSERTED HERE                                  CFLAG  2

      LOGICAL NEWWR,NEWWP,PENET                                         CFLAG  4

      COMMON /FLG/ NTYP,NEWWR,NEWWP,PENET,LINES,IHOP,HPUNCH             CFLAG  5

C     COMMON DECK "RINPLEX" INSERTED HERE                               CRINPLE2

      REAL KAY2,KAY2I                                                   CRINPLE4

      COMPLEX PNP,POLAR,LPOLAR                                          CRINPLE5

      LOGICAL SPACE                                                     CRINPLE6

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

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

      COMMON/RIN/PNP(10),POLAR,LPOLAR,SGN                               CRINPLE9

C     COMMON DECK "RK" INSERTED HERE                                    CRK    2

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

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL KR,KTH,KPH                                                   RKAMCOM4

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

C     COMMON DECK "WWR" INSERTED HERE                                   CWWR   2

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      DATA FIRST/0.0/                                                   NITIAL12

C                                                                       NITIAL13

      CALL DATE(DAT)                                                    NITIAL14

      CALL TIME(TOD)                                                    NITIAL15

      CALL SECOND(SEC)                                                  NITIAL16

C     READ IN USERS NAME AND TELEPHONE EXTENSION FOR IDENTIFYING MICROF NITIAL17

C     PLOTS.                                                            NITIAL18

      READ 1100,INITID                                                  NITIAL19

 1100 FORMAT(8A10)                                                      NITIAL20

C********* MATHEMATICAL CONSTANTS                                       NITIAL21

      PI=4.0*ATAN(1.0)                                                  NITIAL22

      PIT2=2.*PI                                                        NITIAL23

      PID2=PI/2.                                                        NITIAL24

      DEGS=180./PI                                                      NITIAL25

      RAD=PI/180.                                                       NITIAL26

      ALN10=ALOG(10.)                                                   NITIAL27

C********* INITIALIZE THE W ARRAY                                       NITIAL28

      CALL SETW                                                         NITIAL29

C                                                                       NITIAL30

C********* READ W ARRAY AND PRINT NON-ZERO VALUES                       NITIAL31

   10 CALL READ W                                                       NITIAL32

C                                                                       NITIAL33

C******** INITIALIZE THE MODELS VIA 'DISPER'                            NITIAL34

      CALL IDISPER                                                      NITIAL35

C                                                                       NITIAL36

      IF(FIRST.EQ.0.0.AND.PLT.NE.0.) CALL DDINIT(8,INITID)              NITIAL37

      IF(PLT.NE.0.) FIRST=1.                                            NITIAL38

      OW=BETA=AZ1=0.                                                    NITIAL39

      IF (SKIP.EQ.0.) SKIP=MAXSTP                                       NITIAL40

C                                                                       NITIAL41

      CALL HEADER1                                                      NITIAL42

C                                                                       NITIAL43

C********* PRINT OUT THE CONTENTS OF THE 'W' ARRAY                      NITIAL44

      CALL PRINTW                                                       NITIAL45

C********* LET SUBROUTINES PRINTR AND RAYPLT KNOW THERE IS A NEW W ARRAYNITIAL46

      NEWWP=.TRUE.                                                      NITIAL47

      NEWWR=.TRUE.                                                      NITIAL48

C********* INITIALIZE PARAMETERS FOR INTEGRATION SUBROUTINE RKAM        NITIAL49

      NEQS=6                                                            NITIAL50

      DO 20 NR=7,20                                                     NITIAL51

      IF (W(50+NR).NE.0.) NEQS=NEQS+1                                   NITIAL52

   20 CONTINUE                                                          NITIAL53

      MODE=INTYP                                                        NITIAL54

      STEP=STEP1                                                        NITIAL55

      E1MAX=MAXERR                                                      NITIAL56

      E1MIN=MAXERR/ERATIO                                               NITIAL57

      E2MAX=STPMAX                                                      NITIAL58

      E2MIN=STPMIN                                                      NITIAL59

      FACT=FACTR                                                        NITIAL60

C********* DETERMINE TRANSMITTER LOCATION IN COMPUTATIONAL COORDINATE   NITIAL61

C********* SYSTEM (GEOMAGNETIC COORDINATES IF DIPOLE FIELD IS USED)     NITIAL62

      R0=EARTHR+XMTRH                                                   NITIAL63

      SP=SIN (PLAT)                                                     NITIAL64

      CP=SIN (PID2-PLAT)                                                NITIAL65

      SDPH=SIN (TLON-PLON)                                              NITIAL66

      CDPH=SIN (PID2-(TLON-PLON))                                       NITIAL67

      SL=SIN (TLAT)                                                     NITIAL68

      CL=SIN (PID2-TLAT)                                                NITIAL69

      ALPHA=ATAN2(-SDPH*CP,-CDPH*CP*SL+SP*CL)                           NITIAL70

      TH0=ACOS (CDPH*CP*CL+SP*SL)                                       NITIAL71

      PH0=ATAN2(SDPH*CL,CDPH*SP*CL-CP*SL)                               NITIAL72

C********* LOOP ON FREQUENCY, AZIMUTH ANGLE, AND ELEVATION ANGLE        NITIAL73

      NFREQ=1                                                           NITIAL74

      IF (FSTEP.NE.0.) NFREQ=(FEND-FBEG)/FSTEP+1.5                      NITIAL75

      NAZ=1                                                             NITIAL76

      IF (AZSTEP.NE.0.) NAZ=(AZEND-AZBEG)/AZSTEP+1.5                    NITIAL77

      NBETA=1                                                           NITIAL78

      IF (ELSTEP.NE.0.) NBETA=(ELEND-ELBEG)/ELSTEP+1.5                  NITIAL79

      DO 50 NF=1,NFREQ                                                  NITIAL80

      OW=FBEG+(NF-1)*FSTEP                                              NITIAL81

      DO 45 J=1,NAZ                                                     NITIAL82

      AZ1=AZBEG+(J-1)*AZSTEP                                            NITIAL83

      AZA=AZ1*DEGS                                                      NITIAL84

      GAMMA1=PI-AZ1+ALPHA                                               NITIAL85

      SGAMMA=SIN (GAMMA1)                                               NITIAL86

      CGAMMA=SIN (PID2-GAMMA1)                                          NITIAL87

      DO 40 I=1,NBETA                                                   NITIAL88

      BETA=ELBEG+(I-1)*ELSTEP                                           NITIAL89

      EL=BETA*DEGS                                                      NITIAL90

      CBETA=SIN (PID2-BETA)                                             NITIAL91

      R=R0                                                              NITIAL92

      TH=TH0                                                            NITIAL93

      PH=PH0                                                            NITIAL94

      KR=SIN (BETA)                                                     NITIAL95

      KTH=CBETA*CGAMMA                                                  NITIAL96

      KPH=CBETA*SGAMMA                                                  NITIAL97

      TPULSE=0.                                                         NITIAL98

      RSTART=1.                                                         NITIAL99

C********* THE FOLLOWING LINE NEEDED FOR RAY TRACING IN COMPLEX SPACE   NITIA100

      SGN=1.0                                                           NITIA101

C********* ALLOW IONOSPHERIC MODEL SUBROUTINES TO READ AND PRINT DATA   NITIA102

      CALL DISPER                                                       NITIA103

      IF (I.NE.1.AND.NPAGE.LT.3.AND.LINES.LE.17) GO TO 25               NITIA104

      NPAGE=LINES=0                                                     NITIA105

      CALL HEADER2                                                      NITIA106

      F=OW/PIT2                                                         NITIA107

      PERIOD=1.0/F                                                      NITIA108

      WRITE(3,2400) F,AZA,PERIOD                                        NITIA109

 2400 FORMAT (18X,11HFREQUENCY =,F12.6,36H HZ, AZIMUTH ANGLE OF TRANSMISNITIA110

     1SION =,F12.6,4H DEG                                               NITIA111

     2/       18X,11HPERIOD    =,F12.6,8H SECONDS )                     NITIA112

   25 NPAGE=NPAGE+1                                                     NITIA113

      WRITE(3,2500) EL                                                  NITIA114

 2500 FORMAT (/31X,33HELEVATION ANGLE OF TRANSMISSION =,F12.6,4H DEG/)  NITIA115

      IF (KAY2.GT.0.) GO TO 30                                          NITIA116

      WRITE(3,2900) OMEGMIN,OMEGMAX                                     NITIA117

 2900 FORMAT (58H0TRANSMITTER IN EVANESCENT REGION, TRANSMISSION IMPOSSINITIA118

     1BLE/20H0MINIMUM FREQUENCY =,E17.10,20H MAXIMUM FREQUENCY =,E17.10)NITIA119

      GO TO 44                                                          NITIA120

30    CALL RENORM(KR,KAY2,3)                                            NITIA121

      CALL CLEAR(RKVARS,NEQS-6)                                         NITIA122

C     CALCULATE ONE RAY PATH                                            NITIA123

      CALL TRACE                                                        NITIA124

      OSEC=SEC                                                          NITIA125

      CALL SECOND(SEC)                                                  NITIA126

      DIFF=SEC-OSEC                                                     NITIA127

      WRITE(3,3500) DIFF                                                NITIA128

 3500 FORMAT (36X,26HTHIS RAY CALCULATION TOOK ,F8.3,4H SEC)            NITIA129

      IF (PENET.AND.ONLY.NE.0..AND.IHOP.EQ.1) GO TO 44                  NITIA130

   40 CONTINUE                                                          NITIA131

   44 IF (PLT.NE.0. .AND. NBETA.GT.1) CALL ENDPLT                       NITIA132

   45 CONTINUE                                                          NITIA133

      IF(NAZ.GT.1 .AND. NBETA.LE.1 .AND. PLT.NE.0) CALL ENDPLT          NITIA134

      IF(PENET.AND.ONLY.NE.0..AND.IHOP.EQ.1.AND.NAZ.EQ.1.AND.NBETA.EQ.1)NITIA135

     1 GO TO 55                                                         NITIA136

   50 CONTINUE                                                          NITIA137

  55  IF (RAYSET.NE.0.) PUNCH 5000                                      NITIA138

 5000 FORMAT (78X,1H-)                                                  NITIA139

      GO TO 10                                                          NITIA140

         END                                                            NITIA141

      SUBROUTINE NPSPEED                                                NPSPEED2

C     DO-NOTHING SOUND SPEED PERTURBATION MODEL                         NPSPEED3

C     COMMON DECK "CC" INSERTED HERE                                    CCC    2

      REAL MODC                                                         CCC    4

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

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

      DATA MODC(3),MODC(4)/"NPSPEED",0.0/                               NPSPEED6

      DATA RECOGDC/0.0/                                                 NPSPEED7

C                                                                       NPSPEED8

      ENTRY IPSPEED                                                     NPSPEED9

      IF(RECOGDC .NE. DCMODEL)                                          NPSPEE10

     1    CALL RERROR(7HDSPEED    ,10HWRNG MODEL ,RECOGDC)              NPSPEE11

      MODC(4)=DCID                                                      NPSPEE12

      RETURN                                                            NPSPEE13

C                                                                       NPSPEE14

      ENTRY PSPEED                                                      NPSPEE15

      RETURN                                                            NPSPEE16

      END                                                               NPSPEE17

      SUBROUTINE NPTEMP                                                 NPTEMP 2

C     DO-NOTHING TEMPERATURE PERTURBATION MODEL                         NPTEMP 3

C     COMMON DECK "TT" INSERTED HERE                                    CTT    2

      REAL MODT                                                         CTT    4

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

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

      DATA MODT(3),MODT(4)/"NPTEMP",0.0/                                NPTEMP 6

      DATA RECOGDT/0.0/                                                 NPTEMP 7

C                                                                       NPTEMP 8

      ENTRY IPTEMP                                                      NPTEMP 9

      IF(RECOGDT .NE. DTMODEL)                                          NPTEMP10

     1    CALL RERROR(7HDTEMP    ,10HWRNG MODEL ,RECOGDT)               NPTEMP11

      MODT(4)=DTID                                                      NPTEMP12

      RETURN                                                            NPTEMP13

C                                                                       NPTEMP14

      ENTRY PTEMP                                                       NPTEMP15

      RETURN                                                            NPTEMP16

      END                                                               NPTEMP17

      SUBROUTINE NPWIND                                                 NPWIND 2

C     DO-NOTHING WIND-VELOCITY PERTURBATION MODEL                       NPWIND 3

C     COMMON DECK "UU" INSERTED HERE                                    CUU    2

      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

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

      DATA MODU(3),MODU(4)/"NPWIND",0.0/                                NPWIND 6

      DATA RECOGDU/0.0/                                                 NPWIND 7

C                                                                       NPWIND 8

      ENTRY IPWINDR                                                     NPWIND 9

      IF(RECOGDU .NE. DUMODEL)                                          NPWIND10

     1    CALL RERROR(7HDWINDR    ,10HWRNG MODEL ,RECOGDU)              NPWIND11

      MODU(4)=DUID                                                      NPWIND12

      RETURN                                                            NPWIND13

C                                                                       NPWIND14

      ENTRY PWINDR                                                      NPWIND15

      RETURN                                                            NPWIND16

      END                                                               NPWIND17

      SUBROUTINE PLOT (X,Y,NEW)                                         PLOT   2

      COMMON /PLT/ XMIN0,XMAX0,YMIN0,YMAX0,RESET                        PLOT   3

      COMMON /DD/ INT,IOR,IT,IS,IC,ICC,IX,IY                            PLOT   4

      DATA (INITAL=1),(MINX=0),(MINY=0),(MAXX=1023),(MAXY=1023),        PLOT   5

     1 (MINX0=23),(MINY0=23),(MAXX0=1000),(MAXY0=1000)                  PLOT   6

C                                                                       PLOT   7

C          INITIALIZE LIBRARY PLOTTING ROUTINES                         PLOT   8

      IF (INITAL.EQ.0) GO TO 1                                          PLOT   9

      INITAL=0                                                          PLOT  10

      CALL DDINIT (21,21HJACK RILEY, EXT. 6464 )                        PLOT  11

C                                                                       PLOT  12

C          COMPUTE SCALE FACTORS                                        PLOT  13

    1 IF (RESET.EQ.0.) GO TO 5                                          PLOT  14

      RESET=0.                                                          PLOT  15

      XSCALE=(MAXX0-MINX0)/(XMAX0-XMIN0)                                PLOT  16

      YSCALE=(MAXY0-MINY0)/(YMAX0-YMIN0)                                PLOT  17

      XMIN=XMIN0-(MINX0-MINX)/XSCALE                                    PLOT  18

      YMIN=YMIN0-(MINY0-MINY)/YSCALE                                    PLOT  19

      XMAX=XMAX0+(MAXX-MAXX0)/XSCALE                                    PLOT  20

      YMAX=YMAX0+(MAXY-MAXY0)/YSCALE                                    PLOT  21

C                                                                       PLOT  22

C          START A NEW LINE                                             PLOT  23

    5 IF (NEW.EQ.0) GO TO 10                                            PLOT  24

      IX=MINX0+(X-XMIN0)*XSCALE                                         PLOT  25

      IY=MINY0+(Y-YMIN0)*YSCALE                                         PLOT  26

      IF (IX.GE.MINX.AND.IX.LE.MAXX.AND.IY.GE.MINY.AND.IY.LE.MAXY)      PLOT  27

     1 CALL DDBP                                                        PLOT  28

      GO TO 50                                                          PLOT  29

C                                                                       PLOT  30

C          HORIZONTAL DISPLACEMENT                                      PLOT  31

   10 XS=X-XOLD                                                         PLOT  32

      YS=Y-YOLD                                                         PLOT  33

      IF (XS) 11,12,16                                                  PLOT  34

C          NEGATIVE                                                     PLOT  35

   11 X1=XMAX                                                           PLOT  36

      X2=XMIN                                                           PLOT  37

      GO TO 20                                                          PLOT  38

C          ZERO                                                         PLOT  39

   12 IF (YS) 13,50,14                                                  PLOT  40

   13 S1=(YMAX-YOLD)/YS                                                 PLOT  41

      S2=(YMIN-YOLD)/YS                                                 PLOT  42

      GO TO 40                                                          PLOT  43

   14 S1=(YMIN-YOLD)/YS                                                 PLOT  44

      S2=(YMAX-YOLD)/YS                                                 PLOT  45

      GO TO 40                                                          PLOT  46

C          POSITIVE                                                     PLOT  47

   16 X1=XMIN                                                           PLOT  48

      X2=XMAX                                                           PLOT  49

C                                                                       PLOT  50

C          VERTICAL DISPLACEMENT                                        PLOT  51

   20 IF (YS) 21,22,26                                                  PLOT  52

C          NEGATIVE                                                     PLOT  53

   21 Y1=YMAX                                                           PLOT  54

      Y2=YMIN                                                           PLOT  55

      GO TO 30                                                          PLOT  56

C          ZERO                                                         PLOT  57

   22 S1=(X1-XOLD)/XS                                                   PLOT  58

      S2=(X2-XOLD)/XS                                                   PLOT  59

      GO TO 40                                                          PLOT  60

C          POSITIVE                                                     PLOT  61

   26 Y1=YMIN                                                           PLOT  62

      Y2=YMAX                                                           PLOT  63

C                                                                       PLOT  64

   30 S1=AMAX1((X1-XOLD)/XS,(Y1-YOLD)/YS)                               PLOT  65

      S2=AMIN1((X2-XOLD)/XS,(Y2-YOLD)/YS)                               PLOT  66

C                                                                       PLOT  67

C          PLOT LINE -- CHECKING FOR BORDER CROSSINGS                   PLOT  68

   40 S=SQRT(XS**2+YS**2)                                               PLOT  69

      IF (S2.LT.0..OR.S*S1-S.GT.0.) GO TO 50                            PLOT  70

      IF (S1.LT.0.) GO TO 42                                            PLOT  71

C          PREVIOUS POINT OFF GRAPH                                     PLOT  72

      IX=MINX0+(XOLD+XS*S1-XMIN0)*XSCALE+0.5                            PLOT  73

      IY=MINY0+(YOLD+YS*S1-YMIN0)*YSCALE+0.5                            PLOT  74

      CALL DDBP                                                         PLOT  75

   42 IF (S*S2-S.GT.0.) GO TO 44                                        PLOT  76

C          CURRENT POINT OFF GRAPH                                      PLOT  77

      IX=MINX0+(XOLD+XS*S2-XMIN0)*XSCALE+0.5                            PLOT  78

      IY=MINY0+(YOLD+YS*S2-YMIN0)*YSCALE+0.5                            PLOT  79

      CALL DDVC                                                         PLOT  80

      GO TO 50                                                          PLOT  81

C          CURRENT POINT ON GRAPH                                       PLOT  82

   44 IX=MINX0+(X-XMIN0)*XSCALE+0.5                                     PLOT  83

      IY=MINY0+(Y-YMIN0)*YSCALE+0.5                                     PLOT  84

      CALL DDVC                                                         PLOT  85

C                                                                       PLOT  86

C          EXIT ROUTINE                                                 PLOT  87

   50 XOLD=X                                                            PLOT  88

      YOLD=Y                                                            PLOT  89

      RETURN                                                            PLOT  90

C                                                                       PLOT  91

C          TERMINATE THE CURRENT PLOT                                   PLOT  92

      ENTRY PLTEND                                                      PLOT  93

      CALL DDFR                                                         PLOT  94

C                                                                       PLOT  95

      RETURN                                                            PLOT  96

         END                                                            PLOT  97

      SUBROUTINE PLUS(X,Y,TIC,ALPHA)                                    PLUS   2

      CALL PLOT(X,Y,1)                                                  PLUS   3

      DX=TIC*COS(ALPHA)                                                 PLUS   4

      DY=TIC*SIN(ALPHA)                                                 PLUS   5

      CALL PLOT(X+DX,Y+DY,0)                                            PLUS   6

      CALL PLOT(X,Y,0)                                                  PLUS   7

      CALL PLOT(X-DY,Y+DX,0)                                            PLUS   8

      CALL PLOT(X,Y,0)                                                  PLUS   9

      CALL PLOT(X-DX,Y-DY,0)                                            PLUS  10

      CALL PLOT(X,Y,0)                                                  PLUS  11

      CALL PLOT(X+DY,Y-DX,0)                                            PLUS  12

      CALL PLOT(X,Y,0)                                                  PLUS  13

      RETURN                                                            PLUS  14

         END                                                            PLUS  15

      SUBROUTINE POL CAR                                                POLCAR 2

      DIMENSION X0(6),X(6),R0(4)                                        POLCAR 3

      COMMON R(6) /COORD/ S                                             POLCAR 4

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                                                                       POLCAR 6

C          CONVERTS SPHERICAL COORDINATES TO CARTESIAN                  POLCAR 7

      IF (R(5).EQ.0..AND.R(6).EQ.0.) GO TO 1                            POLCAR 8

      VERT=0.                                                           POLCAR 9

      SINA=SIN(R(2))                                                    POLCAR10

      COSA=SIN(PID2-R(2))                                               POLCAR11

      SINP=SIN(R(3))                                                    POLCAR12

      COSP=SIN(PID2-R(3))                                               POLCAR13

      X0(1)=R(1)*SINA*COSP                                              POLCAR14

      X0(2)=R(1)*SINA*SINP                                              POLCAR15

      X0(3)=R(1)*COSA                                                   POLCAR16

      X(4)=R(4)*SINA*COSP+R(5)*COSA*COSP-R(6)*SINP                      POLCAR17

      X(5)=R(4)*SINA*SINP+R(5)*COSA*SINP+R(6)*COSP                      POLCAR18

      X(6)=R(4)*COSA-R(5)*SINA                                          POLCAR19

      RETURN                                                            POLCAR20

C          VERTICAL INCIDENCE                                           POLCAR21

    1 VERT=1.                                                           POLCAR22

      R0(1)=R(1)                                                        POLCAR23

      R0(2)=R(2)                                                        POLCAR24

      R0(3)=R(3)                                                        POLCAR25

      R0(4)=SIGN (1.,R(4))                                              POLCAR26

      RETURN                                                            POLCAR27

C                                                                       POLCAR28

C          STEPS THE RAY A DISTANCE S, AND THEN                         POLCAR29

C          CONVERTS CARTESIAN COORDINATES TO SPHERICAL COORDINATES      POLCAR30

      ENTRY CAR POL                                                     POLCAR31

      IF (VERT.NE.0.) GO TO 2                                           POLCAR32

      X(1)=X0(1)+S*X(4)                                                 POLCAR33

      X(2)=X0(2)+S*X(5)                                                 POLCAR34

      X(3)=X0(3)+S*X(6)                                                 POLCAR35

      TEMP=SQRT(X(1)**2+X(2)**2)                                        POLCAR36

      R(1)=SQRT(X(1)**2+X(2)**2+X(3)**2)                                POLCAR37

      R(2)=ATAN2(TEMP,X(3))                                             POLCAR38

      R(3)=ATAN2(X(2),X(1))                                             POLCAR39

      R(4)=(X(1)*X(4)+X(2)*X(5)+X(3)*X(6))/R(1)                         POLCAR40

      R(5)=(X(3)*(X(1)*X(4)+X(2)*X(5))-(X(1)**2+X(2)**2)*X(6))/         POLCAR41

     1 (R(1)*TEMP)                                                      POLCAR42

      R(6)=(X(1)*X(5)-X(2)*X(4))/TEMP                                   POLCAR43

      RETURN                                                            POLCAR44

C          VERTICAL INCIDENCE                                           POLCAR45

    2 R(1)=R0(1)+R0(4)*S                                                POLCAR46

      R(2)=R0(2)                                                        POLCAR47

      R(3)=R0(3)                                                        POLCAR48

      R(4)=R0(4)                                                        POLCAR49

      R(5)=0.                                                           POLCAR50

      R(6)=0.                                                           POLCAR51

      RETURN                                                            POLCAR52

         END                                                            POLCAR53

      SUBROUTINE PRINTR(NWHY,CARD)                                      PRINTR 2

C          PRINTS OUTPUT AND PUNCHES RAYSETS WHEN REQUESTED             PRINTR 3

      DIMENSION G(3,3),G1(3,3),HEADR1(20),HEADR2(20),UNITS(20),         PRINTR 4

     1          HEAD1(20),HEAD2(20),UNIT(20),RPRINT(20),NPR(20)         PRINTR 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 "FLAG" INSERTED HERE                                  CFLAG  2

      LOGICAL NEWWR,NEWWP,PENET                                         CFLAG  4

      COMMON /FLG/ NTYP,NEWWR,NEWWP,PENET,LINES,IHOP,HPUNCH             CFLAG  5

C     COMMON DECK "RINPLEX" INSERTED HERE                               CRINPLE2

      REAL KAY2,KAY2I                                                   CRINPLE4

      COMPLEX PNP,POLAR,LPOLAR                                          CRINPLE5

      LOGICAL SPACE                                                     CRINPLE6

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

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

      COMMON/RIN/PNP(10),POLAR,LPOLAR,SGN                               CRINPLE9

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL KR,KTH,KPH                                                   RKAMCOM4

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

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

      EQUIVALENCE(T,TPULSE),(PHI,PH),(TH,THETA)                         PRINTR11

      DATA                                                              PRINTR12

     2  HEADR1(7)/6H  PHAS/,HEADR2(7)/6HE TIME/,UNITS(7)/6H   KM /      PRINTR13

     3 ,HEADR1(8)/6H  ABSO/,HEADR2(8)/6HRPTION/,UNITS(8)/6H   DB /      PRINTR14

     4 ,HEADR1(9)/6H   DOP/,HEADR2(9)/6HPLER  /,UNITS(9)/6H  C/,S /     PRINTR15

     5 ,HEADR1(10)/6H PATH /,HEADR2(10)/6HLENGTH/,UNITS(10)/6H   KM /   PRINTR16

C                                                                       PRINTR17

C      ROUND-OFF FUNCTION                                               PRINTR18

      ROUND(X)=SIGN(ABS(X)+0.5,X)                                       PRINTR19

C                                                                       PRINTR20

      CALL DISPER                                                       PRINTR21

      IF (.NOT.NEWWP) GO TO 10                                          PRINTR22

C********* NEW W ARRAY -- REINITIALIZE                                  PRINTR23

      NEWWP=.FALSE.                                                     PRINTR24

      SPL=SIN (PLON-TLON)                                               PRINTR25

      CPL=SIN (PID2-(PLON-TLON))                                        PRINTR26

      SP=SIN (PLAT)                                                     PRINTR27

      CP=SIN (PID2-PLAT)                                                PRINTR28

      SL=SIN (TLAT)                                                     PRINTR29

      CL=SIN (PID2-TLAT)                                                PRINTR30

C********* MATRIX TO ROTATE COORDINATES                                 PRINTR31

      G(1,1)=CPL*SP*CL-CP*SL                                            PRINTR32

      G(1,2)=SPL*SP                                                     PRINTR33

      G(1,3)=-SL*SP*CPL-CL*CP                                           PRINTR34

      G(2,1)=-SPL*CL                                                    PRINTR35

      G(2,2)=CPL                                                        PRINTR36

      G(2,3)=SL*SPL                                                     PRINTR37

      G(3,1)=CL*CP*CPL+SP*SL                                            PRINTR38

      G(3,2)=CP*SPL                                                     PRINTR39

      G(3,3)=-SL*CP*CPL+SP*CL                                           PRINTR40

      DENM=G(1,1)*G(2,2)*G(3,3)+G(1,2)*G(3,1)*G(2,3)+G(2,1)*G(3,2)*G(1,3PRINTR41

     1)-G(2,2)*G(3,1)*G(1,3)-G(1,2)*G(2,1)*G(3,3)-G(1,1)*G(3,2)*G(2,3)  PRINTR42

C********* THE MATRIX G1 IS THE INVERSE OF THE MATRIX G                 PRINTR43

      G1(1,1)=(G(2,2)*G(3,3)-G(3,2)*G(2,3))/DENM                        PRINTR44

      G1(1,2)=(G(3,2)*G(1,3)-G(1,2)*G(3,3))/DENM                        PRINTR45

      G1(1,3)=(G(1,2)*G(2,3)-G(2,2)*G(1,3))/DENM                        PRINTR46

      G1(2,1)=(G(3,1)*G(2,3)-G(2,1)*G(3,3))/DENM                        PRINTR47

      G1(2,2)=(G(1,1)*G(3,3)-G(3,1)*G(1,3))/DENM                        PRINTR48

      G1(2,3)=(G(2,1)*G(1,3)-G(1,1)*G(2,3))/DENM                        PRINTR49

      G1(3,1)=(G(2,1)*G(3,2)-G(3,1)*G(2,2))/DENM                        PRINTR50

      G1(3,2)=(G(3,1)*G(1,2)-G(1,1)*G(3,2))/DENM                        PRINTR51

      G1(3,3)=(G(1,1)*G(2,2)-G(2,1)*G(1,2))/DENM                        PRINTR52

      R0=EARTHR+XMTRH                                                   PRINTR53

C********* CARTESIAN COORDINATES OF TRANSMITTER                         PRINTR54

      XR=R0*G(1,1)                                                      PRINTR55

      YR=R0*G(2,1)                                                      PRINTR56

      ZR=R0*G(3,1)                                                      PRINTR57

      CTHR=G(3,1)                                                       PRINTR58

      STHR=SIN (ACOS (CTHR))                                            PRINTR59

      PHIR=ATAN2(YR,XR)                                                 PRINTR60

      ALPH=ATAN2(G(3,2),G(3,3))                                         PRINTR61

C*********                                                              PRINTR62

      NR=0                                                              PRINTR63

      NP=0                                                              PRINTR64

      DO 7 NN=7,20                                                      PRINTR65

      IF (W(NN+50).EQ.0.) GO TO 7                                       PRINTR66

C********* DEPENDENT VARIABLE NUMBER NN IS BEING INTEGRATED             PRINTR67

C********* NR IS THE NUMBER OF DEPENDENT VARIABLES BEING INTEGRATED     PRINTR68

      NR=NR+1                                                           PRINTR69

      IF (W(NN+50).NE.2.) GO TO 7                                       PRINTR70

C********* DEPENDENT VARIABLE NUMBER NN IS BEING INTEGRATED AND PRINTED.PRINTR71

C********* NP IS THE NUMBER OF DEPENDENT VARIABLES BEING INTEGRATED AND PRINTR72

C********* PRINTED                                                      PRINTR73

      NP=NP+1                                                           PRINTR74

C********* SAVE THE INDEX OF THE DEPENDENT VARIABLE TO PRINT            PRINTR75

      NPR(NP)=NR                                                        PRINTR76

      HEAD1(NP)=HEADR1(NN)                                              PRINTR77

      HEAD2(NP)=HEADR2(NN)                                              PRINTR78

      UNIT(NP)=UNITS(NN)                                                PRINTR79

    7 CONTINUE                                                          PRINTR80

      NP1=MIN0(NP,3)                                                    PRINTR81

      PDEV=ABSORB=DOPP=0.                                               PRINTR82

C********* PRINT COLUMN HEADINGS AT THE BEGINNING OF EACH RAY           PRINTR83

   10 IF (IHOP.NE.0) GO TO 12                                           PRINTR84

      WRITE(3,1100) (HEAD1(NN),HEAD2(NN),NN=1,NP1)                      PRINTR85

 1100 FORMAT (44X,7HAZIMUTH/43X,9HDEVIATION,8X,9HELEVATION/             PRINTR86

     1 19X,16HHEIGHT     RANGE,1X,2(5X,12HXMTR   LOCAL),5X,26HPOLARIZATIPRINTR87

     2ON    GROUP TIME,5A6,A5)                                          PRINTR88

      WRITE(3,1150) (UNIT(NN),NN=1,NP1)                                 PRINTR89

 1150 FORMAT (13X,2(8X,2HKM),2X,2(6X,3HDEG,5X,3HDEG),6X,12HREAL    IMAG,PRINTR90

     1 7X,2HKM,4X,3(3X,A7,2X))                                          PRINTR91

      IF (RAYSET.EQ.0.) GO TO 12                                        PRINTR92

C********* OUTPUT A TRANSMITTER RAYSET                                  PRINTR93

      TLOND=TLON*DEGS                                                   PRINTR94

      IF (TLOND.LT.0.) TLOND=TLOND+360.                                 PRINTR95

      TLATD=TLAT*DEGS                                                   PRINTR96

      IF (TLATD.LT.0.) TLATD=TLATD+360.                                 PRINTR97

      AZ=AZ1*DEGS                                                       PRINTR98

      EL=BETA*DEGS                                                      PRINTR99

      NHOP=HOP                                                          PRINT100

      NXMTRH=ROUND(XMTRH*1.E4)                                          PRINT101

      NTLATD=ROUND(TLATD*1.E3)                                          PRINT102

       NTLOND=ROUND(TLOND*1.E3)                                         PRINT103

      NRCVRH=ROUND(RCVRH*1.E4)                                          PRINT104

       NF=ROUND(OW*1.E4)                                                PRINT105

      NAZ=ROUND(AZ*1.E5)                                                PRINT106

       NEL=ROUND(EL*1.E5)                                               PRINT107

      NPOLAR1=ROUND(REAL(POLAR)*1.E2)                                   PRINT108

       NPOLAR2=ROUND(AIMAG(POLAR)*1.E2)                                 PRINT109

      PUNCH 1201,ID(1),TYPE(NTYP),NXMTRH,NTLATD,NTLOND,NRCVRH,NF,NAZ,NELPRINT110

     1 ,NPOLAR1,NPOLAR2,NHOP,1HT                                        PRINT111

 1201 FORMAT(A3,A1,I9,2I6,2I9,2I10,5X,2I5,I1,A1)                        PRINT112

      GO TO 12                                                          PRINT113

C     PUNCH 1200, ID(1),TYPE(NTYP),XMTRH,TLATD,TLOND,RCVRH,OW,AZ,EL,POLAPRINT114

C    1,NHOP,1HT                                                         PRINT115

 1200 FORMAT (A3,A1,4PF9.0,3P2F6.0,4P2F9.0,5P2F10.0,5X,2P2F5.0,I1,A1)   PRINT116

C*********                                                              PRINT117

   12 V=1.E10                                                           PRINT118

      IF (KAY2.NE.0.) V=(KR**2+KTH**2+KPH**2)/KAY2-1.                   PRINT119

      H=R-EARTHR                                                        PRINT120

      STH=SIN (THETA)                                                   PRINT121

      CTH=SIN (PID2-THETA)                                              PRINT122

C********* CARTESIAN COORDINATES OF RAY POINT, ORIGIN AT TRANSMITTER    PRINT123

      XP=R*STH*SIN (PID2-PHI)-XR                                        PRINT124

      YP=R*STH*SIN (PHI)-YR                                             PRINT125

      ZP=R*CTH-ZR                                                       PRINT126

C********* CARTESIAN COORDINATES OF RAY POINT, ORIGIN AT TRANSMITTER ANDPRINT127

C********* ROTATED                                                      PRINT128

      EPS=XP*G1(1,1)+YP*G1(1,2)+ZP*G1(1,3)                              PRINT129

      ETA=XP*G1(2,1)+YP*G1(2,2)+ZP*G1(2,3)                              PRINT130

      ZETA=XP*G1(3,1)+YP*G1(3,2)+ZP*G1(3,3)                             PRINT131

      RCE2=ETA**2+ZETA**2                                               PRINT132

      RCE=SQRT (RCE2)                                                   PRINT133

C********* GROUND RANGE                                                 PRINT134

      RANGE=EARTHR*ATAN2(RCE,EARTHR+EPS+XMTRH)                          PRINT135

C********* ANGLE OF WAVE NORMAL WITH LOCAL HORIZONTAL                   PRINT136

      ELL=ATAN2(KR,SQRT (KTH**2+KPH**2))*DEGS                           PRINT137

C********* STRAIGHT LINE DISTANCE FROM TRANSMITTER TO RAY POINT         PRINT138

      SR=SQRT (RCE2+EPS**2)                                             PRINT139

      IF (NP.LT.1) GO TO 16                                             PRINT140

      DO 15 I=1,NP                                                      PRINT141

      NN=NPR(I)                                                         PRINT142

   15 RPRINT(I)=RKVARS(NN)                                              PRINT143

   16 IF (SR.GE.1.E-6) GO TO 20                                         PRINT144

C********* TOO CLOSE TO TRANSMITTER TO CALCULATE DIRECTION FROM         PRINT145

C********* TRANSMITTER                                                  PRINT146

      WRITE(3,1500) V,NWHY,H,RANGE,ELL,POLAR,T,(RPRINT(NN),NN=1,NP1)    PRINT147

 1500 FORMAT (1X,E8.1,A8,F10.4,F11.4,26X,F8.3,F9.3,F8.3,4F12.4)         PRINT148

C     SET RAYSET VARIABLES TO UNDEFINDED VALUES FOR FLAGS               PRINT149

      AZDEV=999.0                                                       PRINT150

      AZA=999.0                                                         PRINT151

      GO TO 40                                                          PRINT152

C********* ELEVATION ANGLE OF RAY POINT FROM TRANSMITTER                PRINT153

   20 EL=ATAN2(EPS,RCE)*DEGS                                            PRINT154

      IF (RCE.GE.1.E-6) GO TO 30                                        PRINT155

C********* NEARLY DIRECTLY ABOVE OR BELOW TRANSMITTER. CAN NOT CALCULATEPRINT156

C********* AZIMUTH DIRECTION FROM TRANSMITTER ACCURATELY                PRINT157

      WRITE(3,2500) V,NWHY,H,RANGE,EL,ELL,POLAR,T,(RPRINT(NN),NN=1,NP1) PRINT158

 2500 FORMAT (1X,E8.1,A8,F10.4,F11.4,17X,F9.3,F8.3,F9.3,F8.3,           PRINT159

     1 4F12.4)                                                          PRINT160

      GO TO 40                                                          PRINT161

C********* AZIMUTH ANGLE OF RAY POINT FROM TRANSMITTER                  PRINT162

   30 ANGA=ATAN2(ETA,ZETA)                                              PRINT163

      AZDEV=180.-AMOD(540.-(AZ1-ANGA)*DEGS,360.)                        PRINT164

      IF (KTH.NE.0..OR.KPH.NE.0.) GO TO 34                              PRINT165

C********* WAVE NORMAL IS VERTICAL, SO AZIMUTH DIRECTION CANNOT BE      PRINT166

C********* CALCULATED                                                   PRINT167

      WRITE(3,3000)V,NWHY,H,RANGE,AZDEV,EL,ELL,POLAR,T,(RPRINT(NN),NN=1,PRINT168

     1 NP1)                                                             PRINT169

 3000 FORMAT (1X,E8.1,A8,F10.4,F11.4,F9.3,8X,F9.3,F8.3,F9.3,F8.3,       PRINT170

     1 4F12.4)                                                          PRINT171

      GO TO 40                                                          PRINT172

   34 ANA=ANGA-ALPH                                                     PRINT173

      SANA=SIN (ANA)                                                    PRINT174

      SPHI=SANA*STHR/STH                                                PRINT175

      CPHI=-SIN (PID2-ANA)*SIN (PID2-(PHI-PHIR))+SANA*SIN (PHI-PHIR)    PRINT176

     1 *CTHR                                                            PRINT177

      AZA=180.-AMOD (540.-(ATAN2(SPHI,CPHI)-ATAN2(KPH,KTH))*DEGS,360.)  PRINT178

      WRITE(3,3500)V,NWHY,H,RANGE,AZDEV,AZA,EL,ELL,POLAR,T,(RPRINT(NN)  PRINT179

     1 ,NN=1,NP1)                                                       PRINT180

 3500 FORMAT (1X,E8.1,A8,F10.4,F11.4,2(F9.3,F8.3),F9.3,F8.3,            PRINT181

     1 4F12.4)                                                          PRINT182

C*********                                                              PRINT183

   40 LINES=LINES+1                                                     PRINT184

      IF (NP.LE.3) GO TO 45                                             PRINT185

C********* ADDITIONAL LINE TO PRINT REMAINING DEPENDENT INTEGRATION     PRINT186

C********* VARIABLES                                                    PRINT187

      WRITE(3,4000) (RPRINT(NN),NN=4,NP)                                PRINT188

 4000 FORMAT (99X,3F12.4)                                               PRINT189

      LINES=LINES+1                                                     PRINT190

   45 IF (CARD.EQ.0.) RETURN                                            PRINT191

C                                                                       PRINT192

C********* PUNCH A RAYSET                                               PRINT193

      IF (AZDEV.LT.-90.) AZDEV=AZDEV+360.                               PRINT194

      IF (AZA.LT.-90.) AZA=AZA+360.                                     PRINT195

      TDEV=T-SR                                                         PRINT196

      NR=0                                                              PRINT197

      IF (W(57).EQ.0.) GO TO 47                                         PRINT198

C********* PHASE PATH                                                   PRINT199

      NR=NR+1                                                           PRINT200

      P=RKVARS(NR)                                                      PRINT201

   47 IF (W(58).EQ.0.) GO TO 48                                         PRINT202

C********* ABSORPTION                                                   PRINT203

      NR=NR+1                                                           PRINT204

      ABSORB=RKVARS(NR)                                                 PRINT205

C********* DOPPLER SHIFT                                                PRINT206

   48 IF (W(59).NE.0.) DOPP=RKVARS(NR+1)                                PRINT207

      NHPUNCH=ROUND(HPUNCH*1.E4)                                        PRINT208

       NRANGE=ROUND(RANGE*1.E4)                                         PRINT209

      NAZDEV=ROUND(AZDEV*1.E3)                                          PRINT210

       NAZA=ROUND(AZA*1.E3)                                             PRINT211

       NELL=ROUND(ELL*1.E3)                                             PRINT212

      NSR=ROUND(SR*1.E3)                                                PRINT213

       NTDEV=ROUND(TDEV*1.E3)                                           PRINT214

       NPDEV=ROUND(PDEV*1.E3)                                           PRINT215

      NABSORB=ROUND(ABSORB*1.E3)                                        PRINT216

       NDOPP=ROUND(DOPP*1.E3)                                           PRINT217

      NPOLAR1=ROUND(REAL(POLAR)*1.E2)                                   PRINT218

       NPOLAR2=ROUND(AIMAG(POLAR)*1.E2)                                 PRINT219

      JP=ROUND(P*1.E5)                                                  PRINT220

      JT=ROUND(T*1.E5)                                                  PRINT221

      PUNCH 4501,NHPUNCH,NRANGE,NAZDEV,NAZA,NELL,JT,JP,NABSORB          PRINT222

     1 ,NDOPP,NPOLAR1,NPOLAR2,IHOP,NWHY                                 PRINT223

 4501 FORMAT(2I9,3I6,2I10,2I6,2I5,I1,A1)                                PRINT224

      RETURN                                                            PRINT225

         END                                                            PRINT226

      SUBROUTINE RAYPLT                                                 RAYPLT 2

C        W(81)=1. PLOTS PROJECTION OF RAYPATH ON VERTICAL PLANE         RAYPLT 3

C             =2. PLOTS PROJECTION OF RAYPATH ON GROUND                 RAYPLT 4

      COMMON /PLT/ XL,XR,YB,YT,RESET                                    RAYPLT 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 "FLAG" INSERTED HERE                                  CFLAG  2

      LOGICAL NEWWR,NEWWP,PENET                                         CFLAG  4

      COMMON /FLG/ NTYP,NEWWR,NEWWP,PENET,LINES,IHOP,HPUNCH             CFLAG  5

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL KR,KTH,KPH                                                   RKAMCOM4

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

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

      REAL LTIC                                                         RAYPLT10

C                                                                       RAYPLT11

      IF (.NOT.NEWWR) GO TO 5                                           RAYPLT12

C                                                                       RAYPLT13

C          NEW W ARRAY -- REINITIALIZE                                  RAYPLT14

      NEWWR=.FALSE.                                                     RAYPLT15

      RESET=1.                                                          RAYPLT16

CONVERT COORDINATES OF VERTICAL PLANE FROM GEOGRAPHIC TO GEOMAGNETIC    RAYPLT17

      SW=SIN (PLAT)                                                     RAYPLT18

      CW=SIN (PID2-PLAT)                                                RAYPLT19

      SLM=SIN (LLAT)                                                    RAYPLT20

      CLM=SIN (PID2-LLAT)                                               RAYPLT21

      SRM=SIN (RLAT)                                                    RAYPLT22

      CRM=SIN (PID2-RLAT)                                               RAYPLT23

      CDPHI=SIN (PID2-(LLON-PLON))                                      RAYPLT24

      PHL=ATAN2(SIN (LLON-PLON)*CLM,CDPHI*SW*CLM-CW*SLM)                RAYPLT25

      CTHL=CDPHI*CW*CLM+SW*SLM                                          RAYPLT26

      STHL=SIN (ACOS (CTHL))                                            RAYPLT27

      CDPHI=SIN (PID2-(RLON-PLON))                                      RAYPLT28

      PHR=ATAN2(SIN (RLON-PLON)*CRM,CDPHI*SW*CRM-CW*SRM)                RAYPLT29

      CTHR=CDPHI*CW*CRM+SW*SRM                                          RAYPLT30

      STHR=SIN (ACOS (CTHR))                                            RAYPLT31

      CLR=CTHL*CTHR+STHL*STHR*SIN (PID2-(PHL-PHR))                      RAYPLT32

      SLR=SQRT (1.-CLR**2)                                              RAYPLT33

      IF (PLT.EQ.2.) GO TO 3                                            RAYPLT34

      PFACTR=1.                                                         RAYPLT35

      R0=EARTHR+HB                                                      RAYPLT36

      ALPHA=.5*ACOS (CLR)                                               RAYPLT37

      XR=R0*SIN (ALPHA)                                                 RAYPLT38

      XR1=XR                                                            RAYPLT39

       XL1=-XR1                                                         RAYPLT40

      IF(HT.GT.HB) XR=(EARTHR+HT)*SIN(ALPHA)                            RAYPLT41

      XL=-XR                                                            RAYPLT42

      YB=R0*SIN (PID2-ALPHA)                                            RAYPLT43

      YT1=(EARTHR+HT)*YB/R0                                             RAYPLT44

      YT=YB+2.*XR                                                       RAYPLT45

      GO TO 5                                                           RAYPLT46

    3 IF (PFACTR.EQ.0.) PFACTR=1.                                       RAYPLT47

      ALPH1=ATAN2(STHR*SIN (PHR-PHL),(CTHR-CTHL*CLR)/STHL)              RAYPLT48

      XL=0.                                                             RAYPLT49

      XR=EARTHR*ACOS (CLR)                                              RAYPLT50

      YT=0.5*XR/PFACTR                                                  RAYPLT51

      YB=-YT                                                            RAYPLT52

C                                                                       RAYPLT53

    5 STH=SIN (TH)                                                      RAYPLT54

      CTH=SIN (PID2-TH)                                                 RAYPLT55

      CR=CTHR*CTH+STHR*STH*SIN (PID2-(PHR-PH))                          RAYPLT56

      CL=CTHL*CTH+STHL*STH*SIN (PID2-(PHL-PH))                          RAYPLT57

      CEA=ATAN2(CR-CL*CLR,CL*SLR)                                       RAYPLT58

      NEW=1                                                             RAYPLT59

      IF (IHOP.NE.0) NEW=0                                              RAYPLT60

      IF (PLT.EQ.2.) GO TO 10                                           RAYPLT61

      CALL PLOT (R*SIN(CEA-ALPHA),R*SIN(PID2-(CEA-ALPHA)),NEW)          RAYPLT62

      RETURN                                                            RAYPLT63

   10 SL=SQRT(AMAX1(0.,1.-CL**2))                                       RAYPLT64

      TMP1=STH*SIN (PH-PHL)                                             RAYPLT65

      TMP2=(CTH-CTHL*CL)/STHL                                           RAYPLT66

      ALPH2=0.                                                          RAYPLT67

      IF (TMP1.NE.0..OR.TMP2.NE.0.) ALPH2=ATAN2(TMP1,TMP2)              RAYPLT68

      CALL PLOT (EARTHR*CEA,EARTHR*ASIN(SL*SIN (ALPH1-ALPH2)),NEW)      RAYPLT69

      RETURN                                                            RAYPLT70

C                                                                       RAYPLT71

C          DRAW AXES AND CALL FOR LABELING AND TERMINATION OF THIS PLOT RAYPLT72

      ENTRY ENDPLT                                                      RAYPLT73

      TICKX=0.01*(YT-YB)                                                RAYPLT74

      IF (PLT.EQ.2.) GO TO 25                                           RAYPLT75

      R1=EARTHR-TICKX                                                   RAYPLT76

      X=XL                                                              RAYPLT77

      X=XL1                                                             RAYPLT78

      Y=YB                                                              RAYPLT79

      CALL PLOT (X,Y,1)                                                 RAYPLT80

      NTIC=2                                                            RAYPLT81

      IF (TIC.NE.0.) NTIC=NTIC+2.*ALPHA/TIC                             RAYPLT82

      NLINE=MAX0 (1,100/NTIC)                                           RAYPLT83

      DO 20 I=1,NTIC                                                    RAYPLT84

      ANG=-ALPHA+(I-1)*TIC                                              RAYPLT85

      CALL PLOT (R1*SIN (ANG),R1*SIN (PID2-ANG),0)                      RAYPLT86

      CALL PLOT (X,Y,0)                                                 RAYPLT87

      DO 20 J=1,NLINE                                                   RAYPLT88

      ANG=ANG+TIC/NLINE                                                 RAYPLT89

      X=EARTHR*SIN (ANG)                                                RAYPLT90

      Y=EARTHR*SIN (PID2-ANG)                                           RAYPLT91

   20 CALL PLOT (X,Y,0)                                                 RAYPLT92

      CALL PLOT (XR,YB,0)                                               RAYPLT93

      CALL PLUS(XL1,YB,TICKX, ALPHA)                                    RAYPLT94

      CALL PLUS(XR1,YB,TICKX,-ALPHA)                                    RAYPLT95

      CALL PLUS(XL,YT1,TICKX, ALPHA)                                    RAYPLT96

      CALL PLUS(XR,YT1,TICKX,-ALPHA)                                    RAYPLT97

      CALL PLOT(XR,YB,1)                                                RAYPLT98

      GO TO 50                                                          RAYPLT99

   25 DTIC=TIC*EARTHR                                                   RAYPL100

      LTIC=DTIC/PFACTR                                                  RAYPL101

      TICY=XL+0.01*(XR-XL)                                              RAYPL102

      NTIC=YT/LTIC                                                      RAYPL103

      TIC1=-LTIC*NTIC                                                   RAYPL104

      CALL PLOT (XL,YB,1)                                               RAYPL105

      NTIC=2*NTIC+1                                                     RAYPL106

      DO 30 I=1,NTIC                                                    RAYPL107

      Y=TIC1+(I-1)*LTIC                                                 RAYPL108

      CALL PLOT (XL,Y,0)                                                RAYPL109

      CALL PLOT (TICY,Y,0)                                              RAYPL110

   30 CALL PLOT (XL,Y,0)                                                RAYPL111

      CALL PLOT (XL,YT,0)                                               RAYPL112

      CALL PLOT (XL,0.,1)                                               RAYPL113

      NTIC=(XR-XL)/DTIC                                                 RAYPL114

      DO 40 I=1,NTIC                                                    RAYPL115

      X=I*DTIC                                                          RAYPL116

      CALL PLOT (X,0.,0)                                                RAYPL117

      CALL PLOT (X,TICKX,0)                                             RAYPL118

   40 CALL PLOT (X,0.,0)                                                RAYPL119

      CALL PLOT (XR,0.,0)                                               RAYPL120

   50 CALL LABPLT                                                       RAYPL121

      CALL PLTEND                                                       RAYPL122

      RETURN                                                            RAYPL123

         END                                                            RAYPL124

      SUBROUTINE REACH                                                  REACH  2

C          CALCULATES THE STRAIGHT LINE RAY PATH BETWEEN THE EARTH      REACH  3

C          AND THE IONOSPHERE OR BETWEEN IONOSPHERIC LAYERS             REACH  4

      COMMON /RK/ N,STEP,MODE,E1MAX,E1MIN,E2MAX,E2MIN,FACT,RSTART       REACH  5

      COMMON /TRAC/ GROUND,PERIGE,THERE,MINDIS,NEWRAY,SMT               REACH  6

      COMMON /COORD/ S                                                  REACH  7

C     COMMON DECK "RINPLEX" INSERTED HERE                               CRINPLE2

      REAL KAY2,KAY2I                                                   CRINPLE4

      COMPLEX PNP,POLAR,LPOLAR                                          CRINPLE5

      LOGICAL SPACE                                                     CRINPLE6

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

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

      COMMON/RIN/PNP(10),POLAR,LPOLAR,SGN                               CRINPLE9

      COMMON/XX/MODX(2),X,PXPR,PXPTH,PXPPH,PXPT                         REACH  9

      COMMON R(20),T,STP,DRDT(20) /WW/ ID(10),MAXW,W(400)               REACH 10

      EQUIVALENCE (EARTHR,W(1)),(XMTRH,W(3)),(RCVRH,W(20))              REACH 11

      EQUIVALENCE (HMAX,W(26))                                          REACH 12

      LOGICAL CROSS,CROSSG,CROSSR,GROUND,PERIGE,THERE,MINDIS,           REACH 13

     1        NEWRAY,RSPACE                                             REACH 14

      DATA (NSTEP=500)                                                  REACH 15

      CALL HAMLTN                                                       REACH 16

      H=R(1)-EARTHR                                                     REACH 17

      IF (.NOT.NEWRAY.AND..NOT.RSPACE) CALL PRINTR(8HEXIT ION,0.)       REACH 18

      NEWRAY=.FALSE.                                                    REACH 19

      V=SQRT(R(4)**2+R(5)**2+R(6)**2)                                   REACH 20

C********* NORMALIZE THE WAVE NORMAL DIRECTION TO ONE                   REACH 21

      R(4)=R(4)/V                                                       REACH 22

      R(5)=R(5)/V                                                       REACH 23

      R(6)=R(6)/V                                                       REACH 24

C********* NEGATIVE OF DISTANCE ALONG RAY TO CLOSEST APPROACH TO CENTER REACH 25

C********* OF EARTH                                                     REACH 26

      UP=R(1)*R(4)                                                      REACH 27

      RADG=EARTHR**2-R(1)**2*(R(5)**2+R(6)**2)                          REACH 28

      DISTG=SQRT (AMAX1(0.,RADG))                                       REACH 29

C********* DISTANCE ALONG RAY TO FIRST INTERSECTION WITH OR CLOSEST     REACH 30

C********* APPROACH TO THE EARTH                                        REACH 31

      SG=-UP-DISTG                                                      REACH 32

C********* CROSSG IS TRUE IF THE RAY WILL INTERSECT OR TOUCH THE EARTH  REACH 33

      CROSSG=UP.LT.0..AND.RADG.GE.0.                                    REACH 34

      RADR=(EARTHR+RCVRH)**2-R(1)**2*(R(5)**2+R(6)**2)                  REACH 35

      DISTR=SQRT (AMAX1(0.,RADR))                                       REACH 36

C********* DISTANCE ALONG RAY TO THE FIRST INTERSECTION WITH OR CLOSEST REACH 37

C********* APPROACH TO THE RECEIVER HEIGHT                              REACH 38

      SR=DISTR-UP                                                       REACH 39

      IF (UP.LT.0..AND.DISTR.LT.-UP.AND.R(1).NE.EARTHR+RCVRH) SR=-DISTR REACH 40

     1 -UP                                                              REACH 41

C********* CROSSR IS TRUE IF THE RAY WILL INTERSECT WITH OR MAKE A      REACH 42

C********* CLOSEST APPROACH TO THE RECEIVER HEIGHT                      REACH 43

      CROSSR=R(4).LT.0..OR.R(1).LT.(EARTHR+RCVRH)                       REACH 44

      CROSS=CROSSG.OR.CROSSR                                            REACH 45

C********* MAXIMUM DISTANCE IN WHICH TO LOOK FOR THE IONOSPHERE         REACH 46

      S1=AMIN1(SR,SG)                                                   REACH 47

      IF(.NOT.CROSSG) S1=SR                                             REACH 48

      IF (UP.GE.0.) GO TO 15                                            REACH 49

      CROSS=.TRUE.                                                      REACH 50

C********* IF RAY IS GOING DOWN, S1 IS AT MOST THE DISTANCE TO A PERIGEEREACH 51

      S1=AMIN1(S1,-UP)                                                  REACH 52

C********* CONVERT THE POSITION AND DIRECTION OF THE RAY TO CARTESIAN   REACH 53

C********* COORDINATES                                                  REACH 54

   15 CALL POL CAR                                                      REACH 55

      SSTEP=100.                                                        REACH 56

      S=SSTEP                                                           REACH 57

      DO 20 I=1,NSTEP                                                   REACH 58

      IF ((S-SSTEP).GT.S1.AND.CROSS) GO TO 25                           REACH 59

C********* CONVERT POSITION AND DIRECTION TO SPHERICAL POLAR COORDINATESREACH 60

C********* AT A DISTANCE S ALONG THE RAY                                REACH 61

      CALL CAR POL                                                      REACH 62

C     CALL ELECTX                                                       REACH 63

C********* FREE SPACE                                                   REACH 64

      IF (X.EQ.0.) GO TO 20                                             REACH 65

      CALL RINDEX                                                       REACH 66

C********* EFFECTIVELY FREE SPACE                                       REACH 67

      IF (SPACE) GO TO 20                                               REACH 68

      IF (SSTEP.LT.0.5E-4) GO TO 25                                     REACH 69

C********* RAY IN THE IONOSPHERE.  STEP BACK OUT                        REACH 70

      S=S-SSTEP                                                         REACH 71

C********* DECREASE STEP SIZE                                           REACH 72

      SSTEP=SSTEP/10.                                                   REACH 73

   20 S=S+SSTEP                                                         REACH 74

      PRINT 2000, NSTEP                                                 REACH 75

 2000 FORMAT (9H EXCEEDED,I5,26H STEPS IN SUBROUTINE REACH)             REACH 76

      CALL EXIT                                                         REACH 77

   25 IF(CROSS) S=AMIN1(S,S1)                                           REACH 78

C********* CONVERT POSITION AND DIRECTION TO SPHERICAL POLAR COORDINATESREACH 79

C********* AT A DISTANCE S ALONG THE RAY                                REACH 80

      CALL CAR POL                                                      REACH 81

C********* AVOID THE RAY BEING SLIGHTLY UNDERGROUND                     REACH 82

      R(1)=AMAX1(R(1),EARTHR)                                           REACH 83

C********* ONE STEP INTEGRATION                                         REACH 84

      IF (N.LT.7) GO TO 31                                              REACH 85

      DO 30 NN=7,N                                                      REACH 86

   30 R(NN)=R(NN)+S*DRDT(NN)                                            REACH 87

   31 T=T+S                                                             REACH 88

      CALL RINDEX                                                       REACH 89

C********* AT A PERIGEE                                                 REACH 90

      PERIGE=S.EQ.(-UP)                                                 REACH 91

C********* CORRECT MINOR ERRORS                                         REACH 92

      IF (PERIGE) R(4)=0.                                               REACH 93

C********* KEEP CONSISTENCY AFTER CORRECTING MINOR ERRORS               REACH 94

      DRDT(1)=R(4)                                                      REACH 95

C********* ON THE GROUND                                                REACH 96

      GROUND=S.EQ.SG.AND.CROSSG                                         REACH 97

C********* AT THE RECEIVER HEIGHT                                       REACH 98

      THERE=S.EQ.SR.AND.CROSSR.AND..NOT.PERIGE                          REACH 99

C********* AT A CLOSEST APPROACH TO THE RECEIVER HEIGHT                 REACH100

      MINDIS=PERIGE.AND.S.EQ.SR.AND.CROSSR                              REACH101

      RSPACE=SPACE                                                      REACH102

      V=SQRT(KAY2/(R(4)**2+R(5)**2+R(6)**2))                            REACH103

C********* RENORMALIZE THE WAVE NORMAL DIRECTION TO = SQRT(REAL(N**2))  REACH104

      R(4)=R(4)*V                                                       REACH105

      R(5)=R(5)*V                                                       REACH106

      R(6)=R(6)*V                                                       REACH107

      RSTART=1.                                                         REACH108

      IF (.NOT.SPACE) CALL PRINTR (8HENTR ION,0.)                       REACH109

      RETURN                                                            REACH110

         END                                                            REACH111

      SUBROUTINE REACH                                                  REACHDU2

C     THIS IS A SUBSTITUTE ROUTINE AND SHOULD NOT BE CALLED             REACHDU3

      CALL RERROR(7HREACHDM ,10HDUMMY ROUT ,0.0)                        REACHDU4

      STOP                                                              REACHDU5

      END                                                               REACHDU6

      SUBROUTINE READW                                                  READW  2

C                        READS W ARRAY                                  READW  3

C       A 1 IN THE FOLLOWING COLUMNS WILL MAKE THE DESCRIBED CONVERSIONSREADW  4

COL 18   DEGREES TO RADIANS                                             READW  5

COL 19   GREAT CIRCLE DISTANCE IN KM TO RADIANS                         READW  6

COL 20   NAUTICAL MILES TO KM                                           READW  7

COL 21   FEET TO KM                                                     READW  8

COL 22   CYCLES TO RADIANS                                              READW  9

COL 23   PERIODS TO RADIANS                                             READW 10

COL 24    METERS TO KILOMETERS   19-NOV-81                              READW 11

C                                                                       READW 12

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 "WWR" INSERTED HERE                                   CWWR   2

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

C     COMMON DECK "B1" INSERTED HERE                                    CB1    2

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

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

      EQUIVALENCE (UGP,IDSU)                                            CB1    6

C     COMMON DECK "B2" INSERTED HERE                                    CB2    2

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

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

      EQUIVALENCE (DUGP,IDSDU)                                          CB2    6

C     COMMON DECK "B3" INSERTED HERE                                    CB3    2

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

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

      EQUIVALENCE (CGP,IDSC)                                            CB3    6

C     COMMON DECK "B4" INSERTED HERE                                    CB4    2

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

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

      EQUIVALENCE (DCGP,IDSDC)                                          CB4    6

C     COMMON DECK "B5" INSERTED HERE                                    CB5    2

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

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

      EQUIVALENCE (TGP,IDST)                                            CB5    6

C     COMMON DECK "B6" INSERTED HERE                                    CB6    2

      INTEGER DTMX,DTNTBL,DTITBL,DTFRMTB,IDSDT(10)                      CB6    4

      COMMON/B6/DTMX,DTNTBL(10),DTITBL(10),DTFRMTB(10),DTGP(10)         CB6    5

      EQUIVALENCE (DTGP,IDSDT)                                          CB6    6

C     COMMON DECK "B7" INSERTED HERE                                    CB7    2

      INTEGER MMX,MNTBL,MITBL,MFRMTBL,IDSM(10)                          CB7    4

      COMMON/B7/MMX,MNTBL(10),MITBL(10),MFRMTBL(10),MGP(10)             CB7    5

      EQUIVALENCE (MGP,IDSM)                                            CB7    6

C     COMMON DECK "B8" INSERTED HERE                                    CB8    2

      INTEGER GMX,GNTBL,GITBL,GFRMTBL,IDSG(10)                          CB8    4

      COMMON/B8/GMX,GNTBL(10),GITBL(10),GFRMTBL(10),GGP(10)             CB8    5

      EQUIVALENCE (GGP,IDSG)                                            CB8    6

      INTEGER LINEX(8),DEG,FEET,CYCLE,PER                               READW 23

      LOGICAL NWOK,AB                                                   READW 24

C                                                                       READW 25

      AB=.FALSE.                                                        READW 26

      READ 1000, ID                                                     READW 27

 1000 FORMAT (10A8)                                                     READW 28

      IF (EOF(5LINPUT)) 3,4                                             READW 29

3     PRINT 1040                                                        READW 30

      WRITE(3,1040)                                                     READW 31

1040  FORMAT(* END OF INPUT DATA*)                                      READW 32

      IF(PLT.NE.0.0) CALL DDEND                                         READW 33

      CALL EXIT                                                         READW 34

C                                                                       READW 35

    4 READ 1100, NW,WWW,DEG,KM,NM,FEET,CYCLE,PER,MSKMS                  READW 36

 1100 FORMAT (I3,E14.7,7I1)                                             READW 37

      IF (NW.EQ.0) GO TO 10                                             READW 38

      IF (NW.LE.MAXW .AND. NW.GT.0) GO TO 5                             READW 39

C     TABULAR INPUT DATA                                                READW 40

      NWOK=.FALSE.                                                      READW 41

      NW=-NW                                                            READW 42

      IF(NW.EQ.1)CALLREADW1(AB,NWOK,NW,UMX,UNTBL,UITBL,UFRMTBL,UGP)     READW 43

      IF(NW.EQ.2)CALLREADW1(AB,NWOK,NW,DUMX,DUNTBL,DUITBL,DUFRMTB,DUGP) READW 44

      IF(NW.EQ.3)CALLREADW1(AB,NWOK,NW,CMX,CNTBL,CITBL,CFRMTBL,CGP)     READW 45

      IF(NW.EQ.4)CALLREADW1(AB,NWOK,NW,DCMX,DCNTBL,DCITBL,DCFRMTB,DCGP) READW 46

      IF(NW.EQ.5)CALLREADW1(AB,NWOK,NW,TMX,TNTBL,TITBL,TFRMTBL,TGP)     READW 47

      IF(NW.EQ.6)CALLREADW1(AB,NWOK,NW,DTMX,DTNTBL,DTITBL,DTFRMTB,DTGP) READW 48

      IF(NW.EQ.7)CALLREADW1(AB,NWOK,NW,MMX,MNTBL,MITBL,MFRMTBL,MGP)     READW 49

      IF(NW.EQ.8)CALLREADW1(AB,NWOK,NW,GMX,GNTBL,GITBL,GFRMTBL,GGP)     READW 50

      IF(NWOK) GO TO 4                                                  READW 51

      NW=-NW                                                            READW 52

C                                                                       READW 53

      WRITE(3,4000) NW,MAXW                                             READW 54

 4000 FORMAT(15H1THE SUBSCRIPT ,I3,  * ON THE W-ARRAY INPUT IS OUT OF BOREADW 55

     1UNDS.  ALLOWABLE VALUES ARE -8 THROUGH,*,I4,*.* )                 READW 56

      IF(PLT.NE.0.0) CALL DDEND                                         READW 57

      CALL EXIT                                                         READW 58

    5 IF (DEG.NE.0.) WWW=WWW*RAD                                        READW 59

      IF (KM.NE.0) WWW=WWW/EARTHR                                       READW 60

      IF (NM.NE.0) WWW=WWW*1.852                                        READW 61

      IF (FEET.NE.0) WWW=WWW*3.048006096E-4                             READW 62

      IF(CYCLE.NE.0) WWW=WWW*PIT2                                       READW 63

      IF(PER.NE.0) WWW=PIT2/WWW                                         READW 64

      IF(MSKMS.NE.0) WWW=WWW*1.E-3                                      READW 65

      W(NW)=WWW                                                         READW 66

      GO TO 4                                                           READW 67

   10 IF(.NOT.AB) RETURN                                                READW 68

      PRINT 1200                                                        READW 69

1200  FORMAT(* A DATA FORMATTING ERROR PREVENTS CONTINUED EXECUTION*)   READW 70

      CALL EXIT                                                         READW 71

C                                                                       READW 72

      ENTRY SETW                                                        READW 73

CC********* INITIALIZE SOME VARIABLES IN THE W ARRAY                    READW 74

      MAXW=400                                                          READW 75

      CALL CLEAR(W,MAXW)                                                READW 76

      PLON=0.                                                           READW 77

      PLAT=PID2                                                         READW 78

      EARTHR=6370.                                                      READW 79

      INTYP=3.                                                          READW 80

      MAXERR=1.E-4                                                      READW 81

      ERATIO=50.                                                        READW 82

      STEP1=1.                                                          READW 83

      STPMAX=100.                                                       READW 84

      STPMIN=1.E-8                                                      READW 85

      FACTR=0.5                                                         READW 86

      MAXSTP=1000.                                                      READW 87

      HOP=1.                                                            READW 88

      HMAX=500.0                                                        READW 89

C                                                                       READW 90

      RETURN                                                            READW 91

C                                                                       READW 92

      ENTRY PRINTW                                                      READW 93

C                                                                       READW 94

      WRITE(3,1050)                                                     READW 95

 1050 FORMAT (85H INITIAL VALUES FOR THE W ARRAY -- ALL ANGLES IN RADIANREADW 96

     1S, ONLY NONZERO VALUES PRINTED/)                                  READW 97

      DO 17 NW=1,MAXW                                                   READW 98

      IF (W(NW).NE.0.) WRITE(3,1700) NW,W(NW)                           READW 99

 1700 FORMAT (I4,E19.11)                                                READW100

   17 CONTINUE                                                          READW101

C                                                                       READW102

C     PRINT OUT TABULAR DATA                                            READW103

      REWIND 4                                                          READW104

1080  READ(4,1000) LINEX                                                READW105

      IF(EOF(5LTAPE4)) 1090,1085                                        READW106

1085  WRITE(3,1000) LINEX                                               READW107

      GO TO 1080                                                        READW108

C                                                                       READW109

1090  RETURN                                                            READW110

         END                                                            READW111

      SUBROUTINE READW1(AB,NWOK,MSET,MX,NTBL,ITBL,FRMTBL,GP)            READW112

      LOGICAL NWOK,AB                                                   READW113

C                                                                       READW114

      INTEGER LINE(8),NTBL(1),ITBL(1),FRMTBL(1)                         READW115

      REAL GP(20),V(3)                                                  READW116

C                                                                       READW117

      NWOK=.TRUE.                                                       READW118

C                                                                       READW119

5     READ 10, ITEM,LINE                                                READW120

      WRITE(4,10) ITEM,LINE                                             READW121

10    FORMAT(I3,10A10)                                                  READW122

      IF(ITEM .EQ. 0) RETURN                                            READW123

C                                                                       READW124

      IT=ITEM                                                           READW125

      IF(ITEM.LE.10) NFRM=FRMTBL(ITEM)                                  READW126

      IF(ITEM.LE.MX .AND. ITEM.GT.0) GO TO 100                          READW127

C                                                                       READW128

C     CHECK NOW FOR SPECIAL NUMERICAL FORMATS                           READW129

C     THESE ARE PROVIDED FOR EASE OF INPUT OF TABULATED DATA            READW130

C     AND ARE PARTLY 'TRANSPARENT' TO THE MODEL INVOLVED.               READW131

C     THAT IS, THE USER HAS THE OPTION OF EITHER SINGLE COLUMN          READW132

C     INPUT OR N-COLUMN INPUT WHERE N MUST BE THE 'CYCLE' LENGTH        READW133

C     EXPECTED BY THE MODEL.  CURRENTLY WE ALLOW N=3 OR 2 ONLY BUT      READW134

C     THIS IS EASILY GENERALIZED.                                       READW135

C                                                                       READW136

C                                                                       READW137

      IF(ITEM.LT.2 .OR. ITEM.GT.4) GO TO 15                             READW138

      IT=2                                                              READW139

      IF(IT.GT.MX) GO TO 15                                             READW140

      NFRM=ITEM                                                         READW141

      IF(FRMTBL(IT).EQ.2) GO TO 100                                     READW142

C                                                                       READW143

15    AB=.TRUE.                                                         READW144

      PRINT 20, MSET,ITEM,MX                                            READW145

20    FORMAT(* FOR SET*,I5,* ITEM NUMBER*,I5,* EXCEEDED MAXIMUM OF*,I5) READW146

C      ERROR IN INPUT DATA , STOP HERE                                  READW147

      STOP                                                              READW148

C                                                                       READW149

100   N1=NTBL(IT)                                                       READW150

      N3=ITBL(IT)                                                       READW151

      N2=NTBL(IT+1)-N3                                                  READW152

      IF(NFRM.NE.1) GO TO 110                                           READW153

      DECODE(80,1010,LINE)((GP(I+J-1),I=N1,N2,N3),J=1,N3)               READW154

1010  FORMAT(10A8)                                                      READW155

      GO TO 5                                                           READW156

C                                                                       READW157

110   IF(NFRM.LT.2 .OR. NFRM.GT.4) GO TO 200                            READW158

C     HANDLE FORMATS 2-4                                                READW159

C                                                                       READW160

C     THESE FORMATS ALLOW AN ARRAY PRECEEDED BY A COUNT OF NUMBER OF DATREADW161

C     VALUES TO BE FILLED. THESE DATA ARE TO BE PRECEEDED AND FOLLOWED  READW162

C     BY AN ARBITRARY DELIMITER VALUE.                                  READW163

C     OTHERWISE THESE FORMATS DIFFER BY THE NUMERIC FORMAT USED.        READW164

C     FOR 2 A SINGLE COLUMN IS ASSUMED, FOR 3 THREE COLUMNS ARE ASSUMED READW165

C     FOR 4 TWO COLUMNS                                                 READW166

C                                                                       READW167

      N1=N1+1                                                           READW168

      DECODE(80,1020,LINE) DELIM                                        READW169

1020  FORMAT(G13.6)                                                     READW170

1025  FORMAT(10G13.6)                                                   READW171

      DO 150 J=1,N3                                                     READW172

         IF(NFRM.EQ.3) READ 1025, V(1),V(2),V(3)                        READW173

         IF(NFRM.EQ.3) READ 1025, V(1),V(2),V(3)                        READW174

         IF(NFRM.EQ.3) WRITE(4,1025) V(1),V(2),V(3)                     READW175

         IF(NFRM.EQ.3) WRITE(4,1025) V(1),V(2),V(3)                     READW176

         K=1                                                            READW177

         DO 150 I=N1,N2,N3                                              READW178

               IF(NFRM.EQ.2) READ 1020, V(1)                            READW179

               IF(NFRM.EQ.2) WRITE(4,1020) V(1)                         READW180

               IF(NFRM.NE.2) V(1)=V(K)                                  READW181

               K=K+1                                                    READW182

               IF(V(1) .EQ. DELIM) GO TO 160                            READW183

C                                                                       READW184

               GP(I+J-1)=V(1)                                           READW185

150            N=N+1                                                    READW186

C                                                                       READW187

      IF(V(1).NE.DELIM) CALL RERROR("READW1","NO DELIM",FLOAT(MSET))    READW188

160   GP(N1-1)=N                                                        READW189

      GO TO 5                                                           READW190

C                                                                       READW191

C                                                                       READW192

200   CALL RERROR("READW1","BAD FORMAT",FLOAT(MSET))                    READW193

C                                                                       READW194

      END                                                               READW195

      SUBROUTINE RKAM                                                   RKAM   2

C        NUMERICAL INTEGRATION OF DIFFERENTIAL EQUATIONS                RKAM   3

      COMMON /RK/ NN,SPACE,MODE,E1MAX,E1MIN,E2MAX,E2MIN,FACT,RSTART     RKAM   4

      COMMON Y(20),T,STEP,DYDT(20)                                      RKAM   5

      DIMENSION DELY(4,20),BET(4),XV(5),FV(4,20),YU(5,20)               RKAM   6

      TYPE DOUBLE YU                                                    RKAM   7

      IF (RSTART.EQ.0.) GO TO 1000                                      RKAM   8

      LL=MM=1                                                           RKAM   9

      IF (MODE.EQ.1) MM=4                                               RKAM  10

      ALPHA=T                                                           RKAM  11

      EPM=0.0                                                           RKAM  12

      BET(1)=BET(2)=0.5                                                 RKAM  13

      BET(3)=1.0                                                        RKAM  14

      BET(4)=0.0                                                        RKAM  15

      STEP=SPACE                                                        RKAM  16

      R=19.0/270.0                                                      RKAM  17

      XV(MM)=T                                                          RKAM  18

      IF (E1MIN.LE.0.) E1MIN=E1MAX/55.                                  RKAM  19

      IF (FACT.LE.0.) FACT=0.5                                          RKAM  20

      CALL HAMLTN                                                       RKAM  21

      DO 320 I=1,NN                                                     RKAM  22

      FV(MM,I)=DYDT(I)                                                  RKAM  23

  320 YU(MM,I)=Y(I)                                                     RKAM  24

      RSTART=0.                                                         RKAM  25

      GO TO 1001                                                        RKAM  26

 1000 IF (MODE.NE.1) GO TO 2000                                         RKAM  27

C                                                                       RKAM  28

C          RUNGE-KUTTA                                                  RKAM  29

 1001 DO 1034 K=1,4                                                     RKAM  30

      DO 1350 I=1,NN                                                    RKAM  31

      DELY(K,I)=STEP*FV(MM,I)                                           RKAM  32

      Z=YU(MM,I)                                                        RKAM  33

 1350 Y(I)=Z+BET(K)*DELY(K,I)                                           RKAM  34

      T=BET(K)*STEP+XV(MM)                                              RKAM  35

      CALL HAMLTN                                                       RKAM  36

      DO 1034 I=1,NN                                                    RKAM  37

 1034 FV(MM,I)=DYDT(I)                                                  RKAM  38

      DO 1039 I=1,NN                                                    RKAM  39

      DEL=(DELY(1,I)+2.0*DELY(2,I)+2.0*DELY(3,I)+DELY(4,I))/6.0         RKAM  40

 1039 YU(MM+1,I)=YU(MM,I)+DEL                                           RKAM  41

      MM=MM+1                                                           RKAM  42

      XV(MM)=XV(MM-1)+STEP                                              RKAM  43

      DO 1400 I=1,NN                                                    RKAM  44

 1400 Y(I)=YU(MM,I)                                                     RKAM  45

      T=XV(MM)                                                          RKAM  46

      CALL HAMLTN                                                       RKAM  47

      IF (MODE.EQ.1) GO TO 42                                           RKAM  48

      DO 150 I=1,NN                                                     RKAM  49

  150 FV(MM,I)=DYDT(I)                                                  RKAM  50

      IF (MM.LE.3) GO TO 1001                                           RKAM  51

C                                                                       RKAM  52

C          ADAMS-MOULTON                                                RKAM  53

 2000 DO 2048 I=1,NN                                                    RKAM  54

      DEL=STEP*(55.*FV(4,I)-59.*FV(3,I)+37.*FV(2,I)-9.*FV(1,I))/24.     RKAM  55

      Y(I)=YU(4,I)+DEL                                                  RKAM  56

 2048 DELY(1,I)=Y(I)                                                    RKAM  57

      T=XV(4)+STEP                                                      RKAM  58

      CALL HAMLTN                                                       RKAM  59

      XV(5)=T                                                           RKAM  60

      DO 2051 I=1,NN                                                    RKAM  61

      DEL=STEP*(9.*DYDT(I)+19.*FV(4,I)-5.*FV(3,I)+FV(2,I))/24.          RKAM  62

      YU(5,I)=YU(4,I)+DEL                                               RKAM  63

 2051 Y(I)=YU(5,I)                                                      RKAM  64

      CALL HAMLTN                                                       RKAM  65

      IF (MODE.LE.2) GO TO 42                                           RKAM  66

C                                                                       RKAM  67

C          ERROR ANALYSIS                                               RKAM  68

      SSE=0.0                                                           RKAM  69

      DO 3033 I=1,NN                                                    RKAM  70

      EPSIL=R*ABS(Y(I)-DELY(1,I))                                       RKAM  71

      IF (MODE.EQ.3.AND.Y(I).NE.0.) EPSIL=EPSIL/ABS(Y(I))               RKAM  72

      IF (SSE.LT.EPSIL) SSE=EPSIL                                       RKAM  73

 3033 CONTINUE                                                          RKAM  74

      IF (E1MAX.GT.SSE) GO TO 3035                                      RKAM  75

      IF (ABS(STEP).LE.E2MIN) GO TO 42                                  RKAM  76

      LL=MM=1                                                           RKAM  77

      STEP=STEP*FACT                                                    RKAM  78

      GO TO 1001                                                        RKAM  79

 3035 IF (LL.LE.1.OR.SSE.GE.E1MIN.OR.E2MAX.LE.ABS(STEP)) GO TO 42       RKAM  80

      LL=2                                                              RKAM  81

      MM=3                                                              RKAM  82

      XV(2)=XV(3)                                                       RKAM  83

      XV(3)=XV(5)                                                       RKAM  84

      DO 5363 I=1,NN                                                    RKAM  85

      FV(2,I)=FV(3,I)                                                   RKAM  86

      FV(3,I)=DYDT(I)                                                   RKAM  87

      YU(2,I)=YU(3,I)                                                   RKAM  88

 5363 YU(3,I)=YU(5,I)                                                   RKAM  89

      STEP=2.0*STEP                                                     RKAM  90

      GO TO 1001                                                        RKAM  91

C                                                                       RKAM  92

C          EXIT ROUTINE                                                 RKAM  93

   42 LL=2                                                              RKAM  94

      MM=4                                                              RKAM  95

      DO 12 K=1,3                                                       RKAM  96

      XV(K)=XV(K+1)                                                     RKAM  97

      DO 12 I=1,NN                                                      RKAM  98

      FV(K,I)=FV(K+1,I)                                                 RKAM  99

   12 YU(K,I)=YU(K+1,I)                                                 RKAM 100

      XV(4)=XV(5)                                                       RKAM 101

      DO 52 I=1,NN                                                      RKAM 102

      FV(4,I)=DYDT(I)                                                   RKAM 103

   52 YU(4,I)=YU(5,I)                                                   RKAM 104

      IF (MODE.LE.2) RETURN                                             RKAM 105

      E=ABS(XV(4)-ALPHA)                                                RKAM 106

      IF (E.LE.EPM) GO TO 2000                                          RKAM 107

      EPM=E                                                             RKAM 108

      RETURN                                                            RKAM 109

         END                                                            RKAM 110

      SUBROUTINE RMOVE(X,Y,N)                                           RMOVE  2

      REAL X(1),Y(1)                                                    RMOVE  3

C                                                                       RMOVE  4

      IF(N.LE.0) RETURN                                                 RMOVE  5

      DO 10 I=1,N                                                       RMOVE  6

10    X(I)=Y(I)                                                         RMOVE  7

C                                                                       RMOVE  8

      RETURN                                                            RMOVE  9

      END                                                               RMOVE 10

       SUBROUTINE RVERT                                                 RVERT  2

C                                                                       RVERT  3

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL KR,KTH,KPH                                                   RKAMCOM4

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

C     COMMON DECK "RR" INSERTED HERE                                    CRR    2

      COMMON/RR/ MODREC(4)                                              CRR    4

      COMMON/RR/F,PFR,PFRR,PFRTH,PFRPH                                  CRR    5

      COMMON/RR/PFTH,PFPH,PFTHTH,PFPHPH,PFTHPH                          CRR    6

C     COMMON DECK "B10" INSERTED HERE                                   CB10   2

      INTEGER RMX,RNTBL,RITBL,RFRMTBL,IDSG(10)                          CB10   4

      COMMON/B10/RMX,RNTBL(10),RITBL(10),RFRMTBL(10),RGP(10)            CB10   5

      EQUIVALENCE (RGP,IDSG)                                            CB10   6

C     COMMON DECK "GAMANG" INSERTED HERE                                CGAMANG2

      COMMON/SPHGAM/SINLM0,COSLM0,GPH0,COSPHD,SINTH,COSTH               CGAMANG4

      COMMON/SPHGAM/GAMFUN,PGMTH,PGMPH,PGMTHTH,PGMPHPH,PGMTHPH          CGAMANG5

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

      EQUIVALENCE (RVALPH0,W(278)) ,(RVLAMZ,W(279)), (RVPH0,W(280))     RVERT  9

C                                                                       RVERT 10

      DATA MODREC(1),MODREC(2)/7HRVERT  ,0.0/                           RVERT 11

      DATA RECORR/1.0/                                                  RVERT 12

C                                                                       RVERT 13

      DATA RMX/1/                                                       RVERT 14

      DATA RNTBL/1,11,8*0/                                              RVERT 15

      DATA RITBL/1,9*0/                                                 RVERT 16

      DATA RFRMTBL/1,9*0/                                               RVERT 17

C                                                                       RVERT 18

      ENTRY IRECVR                                                      RVERT 19

C                                                                       RVERT 20

      IF(RECORR .NE. RMODEL)                                            RVERT 21

     1    CALL RERROR(7HRECEIVR  ,10HWRNG MODEL ,RECORR)                RVERT 22

      MODREC(2)=RID                                                     RVERT 23

C                                                                       RVERT 24

      SINLMZ=SIN(RVLAMZ)                                                RVERT 25

      COSLMZ=COS(RVLAMZ)                                                RVERT 26

      COSALP=COS(RVALPH0)                                               RVERT 27

C                                                                       RVERT 28

      RETURN                                                            RVERT 29

C                                                                       RVERT 30

      ENTRY RECVR                                                       RVERT 31

C                                                                       RVERT 32

      SINLM0=SINLMZ                                                     RVERT 33

      COSLM0=COSLMZ                                                     RVERT 34

      GPH0=RVPH0                                                        RVERT 35

C                                                                       RVERT 36

      CALL GAMANG(TH,PH)                                                RVERT 37

C                                                                       RVERT 38

      F=GAMFUN-COSALP                                                   RVERT 39

      PFR=0                                                             RVERT 40

      CALL RMOVE(PFTH,PGMTH,5)                                          RVERT 41

C                                                                       RVERT 42

      RETURN                                                            RVERT 43

      END                                                               RVERT 44

      SUBROUTINE TBLOB                                                  TBLOB  2

C     TEMPERATURE PERTURBATION MODEL                                    TBLOB  3

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL KR,KTH,KPH                                                   RKAMCOM4

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

C     COMMON DECK "B2" INSERTED HERE                                    CB2    2

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

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

      EQUIVALENCE (DUGP,IDSDU)                                          CB2    6

C                                                                       TBLOB  6

C     COMMON DECK "TT" INSERTED HERE                                    CTT    2

      REAL MODT                                                         CTT    4

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

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

C                                                                       TBLOB  9

      EQUIVALENCE (C0,W(228)), (Z0,W(229)),(TH0,W(230))                 TBLOB 10

      EQUIVALENCE (PH0,W(231)),(WZ,W(232)),(WTH,W(233)),(WPH,W(234))    TBLOB 11

      DATA MODT(3),MODT(4)/"TBLOB",0.0/                                 TBLOB 12

      DATA RECOGDT/1.0/                                                 TBLOB 13

      DATA DUMX/1/                                                      TBLOB 14

      DATA DUNTBL/1,11,8*0/                                             TBLOB 15

      DATA DUITBL/1,9*0/                                                TBLOB 16

      DATA DUFRMTB/1,9*0/                                               TBLOB 17

C                                                                       TBLOB 18

      ENTRY IPTEMP                                                      TBLOB 19

      IF(RECOGDT .NE. DTMODEL)                                          TBLOB 20

     1    CALL RERROR(7HDTEMP    ,10HWRNG MODEL ,RECOGDT)               TBLOB 21

C                                                                       TBLOB 22

      MODT(4)=DTID                                                      TBLOB 23

C                                                                       TBLOB 24

      FWZ=0.0                                                           TBLOB 25

      FWTH=0.0                                                          TBLOB 26

      FWPH=0.0                                                          TBLOB 27

      IF(WZ.NE.0.0) FWZ=2.0/WZ/WZ                                       TBLOB 28

      IF(WTH.NE.0.0) FWTH=2.0/WTH/WTH                                   TBLOB 29

      IF(WPH.NE.0.0) FWPH=2.0/WPH/WPH                                   TBLOB 30

      RETURN                                                            TBLOB 31

C                                                                       TBLOB 32

      ENTRY PTEMP                                                       TBLOB 33

C                                                                       TBLOB 34

      IF(C0.EQ.0.0) RETURN                                              TBLOB 35

C                                                                       TBLOB 36

      DZ=R-EARTHR-Z0                                                    TBLOB 37

      DTH=TH-TH0                                                        TBLOB 38

      DPH=PH-PH0                                                        TBLOB 39

      DEXPO=0.0                                                         TBLOB 40

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

      IF(EXPO .GT. -200.0) DEXPO=C0*EXP(EXPO)                           TBLOB 42

      DEL=1.0+DEXPO                                                     TBLOB 43

C                                                                       TBLOB 44

      PTR=PTR*DEL-T*DEXPO*FWZ*DZ                                        TBLOB 45

      PTTH=PTTH*DEL-T*DEXPO*FWTH*DTH                                    TBLOB 46

      PTPH=PTPH*DEL-T*DEXPO*FWPH*DPH                                    TBLOB 47

      T=T*DEL                                                           TBLOB 48

      RETURN                                                            TBLOB 49

      END                                                               TBLOB 50

      SUBROUTINE TLINEAR                                                TLINEAR2

C     LINEAR TEMPERATURE PROFILE                                        TLINEAR3

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL KR,KTH,KPH                                                   RKAMCOM4

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

C     COMMON DECK "MM" INSERTED HERE                                    CMM    2

      REAL M,MODM                                                       CMM    4

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

C     COMMON DECK "TT" INSERTED HERE                                    CTT    2

      REAL MODT                                                         CTT    4

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

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

       EQUIVALENCE (TGND, W(203)), (A, W(204))                          TLINEAR8

C     COMMON DECK "B5" INSERTED HERE                                    CB5    2

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

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

      EQUIVALENCE (TGP,IDST)                                            CB5    6

      DATA MODT/7HTLINEAR  ,0.0, 1H  , 0.0 /                            TLINEA10

      DATA RECOGT/1.0/                                                  TLINEA11

      DATA TMX/1/                                                       TLINEA12

      DATA TNTBL/1,11,8*0/                                              TLINEA13

      DATA TITBL/1,9*0/                                                 TLINEA14

      DATA TFRMTBL/1,9*0/                                               TLINEA15

      ENTRY ITEMP                                                       TLINEA16

C                                                                       TLINEA17

      IF(RECOGT .NE. TMODEL)                                            TLINEA18

     1    CALL RERROR(7HTEMP    ,10HWRNG MODEL ,RECOGT)                 TLINEA19

      MODT(2)=TID                                                       TLINEA20

      CALL IPTEMP                                                       TLINEA21

C                                                                       TLINEA22

      RETURN                                                            TLINEA23

C                                                                       TLINEA24

       ENTRY TEMP                                                       TLINEA25

       H = R - EARTHR                                                   TLINEA26

       T = TGND + A * H                                                 TLINEA27

      CALL CLEAR(PTT,4)                                                 TLINEA28

      PTR=A                                                             TLINEA29

C                                                                       TLINEA30

      CALL PTEMP                                                        TLINEA31

       RETURN                                                           TLINEA32

       END                                                              TLINEA33

      SUBROUTINE TRACE                                                  TRACE  2

C          CALCULATES THE RAY PATH                                      TRACE  3

      DIMENSION ROLD(20),DROLD(20)                                      TRACE  4

      COMMON /RK/ N,STEP,MODE,E1MAX,E1MIN,E2MAX,E2MIN,FACT,RSTART       TRACE  5

      COMMON /FLG/ NTYP,NEWWR,NEWWP,PENET,LINES,IHOP,HPUNCH             TRACE  6

      COMMON /TRAC/ GROUND,PERIGE,THERE,MINDIS,NEWRAY,SMT               TRACE  7

C     COMMON DECK "RINPLEX" INSERTED HERE                               CRINPLE2

      REAL KAY2,KAY2I                                                   CRINPLE4

      COMPLEX PNP,POLAR,LPOLAR                                          CRINPLE5

      LOGICAL SPACE                                                     CRINPLE6

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

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

      COMMON/RIN/PNP(10),POLAR,LPOLAR,SGN                               CRINPLE9

      COMMON R(20),T,STP,DRDT(20) /WW/ ID(10),MAXW,W(400)               TRACE  9

      LOGICAL HOME,WASNT,GROUND,PERIGE,THERE,MINDIS,NEWWR,              TRACE 10

     1        NEWWP,PENET,NEWRAY,WAS                                    TRACE 11

      LOGICAL LAUNCH,GCROSS                                             TRACE 12

      REAL MAXSTP                                                       TRACE 13

      EQUIVALENCE (EARTHR,W(1)),(RCVRH,W(20)),(HOP,W(22)),(MAXSTP,W(23))TRACE 14

     1,(HMAX,W(26)),(SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81))             TRACE 15

C                                                                       TRACE 16

C                                                                       TRACE 17

      DATA ITRIG/0/                                                     TRACE 18

      NHOP=HOP                                                          TRACE 19

      MAX=MAXSTP                                                        TRACE 20

      NSKIP=SKIP                                                        TRACE 21

      RSTART=1.                                                         TRACE 22

      CALL HAMLTN                                                       TRACE 23

      H=R(1)-EARTHR                                                     TRACE 24

      HRCVRH=H-RCVRH                                                    TRACE 25

      THERE=H.EQ.RCVRH                                                  TRACE 26

      HOME=DRDT(1)*HRCVRH.GE.0.                                         TRACE 27

C********* IHOP=0 TELLS PRINTR TO PRINT HEADING AND PUNCH A TRANSMITTER TRACE 28

C********* RAYSET AND TELLS RAYPLT TO START A NEW RAY                   TRACE 29

      IHOP=0                                                            TRACE 30

C     SIGN OF NEXT INTERSECTION OF RAY WITH RECEIVER HEIGHT             TRACE 31

C     (WILL SOON BE REVERSED).                                          TRACE 32

      RSIGN=SIGN(1.0,DRDT(1))                                           TRACE 33

      IF(.NOT.THERE) RSIGN=SIGN(1.0,HRCVRH)                             TRACE 34

      IF(RCVRH.EQ.0.0) RSIGN=1.0                                        TRACE 35

      CALL PRINTR (8HXMTR    ,0.)                                       TRACE 36

      IF (PLT.NE.0.) CALL RAYPLT                                        TRACE 37

      NEWRAY=.TRUE.                                                     TRACE 38

C********* LOOP ON NUMBER OF HOPS                                       TRACE 39

   10 IHOP=IHOP+1                                                       TRACE 40

C      REVERSE SIGN AT EACH CROSSING OF RECEIVER HEIGHT                 TRACE 41

      RSIGN=-RSIGN                                                      TRACE 42

      IF (IHOP.GT.NHOP) RETURN                                          TRACE 43

      PENET=.FALSE.                                                     TRACE 44

C********* LOOP ON MAXIMUM NUMBER OF STEPS PER HOP                      TRACE 45

      DO 79 J=1,MAX                                                     TRACE 46

      H=R(1)-EARTHR                                                     TRACE 47

      HRCVRH=H-RCVRH                                                    TRACE 48

      THERE=H.EQ.RCVRH                                                  TRACE 49

      LAUNCH=H.EQ.0.0 .AND. DRDT(1).LT.0.0                              TRACE 50

      IF (.NOT.SPACE) GO TO 12                                          TRACE 51

      CALL REACH                                                        TRACE 52

      RSTART=1.                                                         TRACE 53

      H=R(1)-EARTHR                                                     TRACE 54

      HRCVRH=H-RCVRH                                                    TRACE 55

      IF (.NOT.SPACE) GO TO 12                                          TRACE 56

      IF (PERIGE) CALL PRINTR (8HPERIGEE ,0.)                           TRACE 57

      IF (THERE) GO TO 51                                               TRACE 58

      IF (MINDIS) GO TO 40                                              TRACE 59

      IF (GROUND) GO TO 60                                              TRACE 60

      IF (PLT.NE.0.) CALL RAYPLT                                        TRACE 61

      IF (PERIGE) GO TO 79                                              TRACE 62

   12 DO 13 L=1,N                                                       TRACE 63

      ROLD(L)=R(L)                                                      TRACE 64

   13 DROLD(L)=DRDT(L)                                                  TRACE 65

      TOLD=T                                                            TRACE 66

      WAS=THERE                                                         TRACE 67

      CALL RKAM                                                         TRACE 68

      H=R(1)-EARTHR                                                     TRACE 69

      HRCVRH=H-RCVRH                                                    TRACE 70

      THERE=.FALSE.                                                     TRACE 71

      WASNT=.NOT.HOME                                                   TRACE 72

      HOME=DRDT(1)*HRCVRH.GE.0.                                         TRACE 73

C     THE STATEMENTS FROM HERE TO 'END FIT' IMPLEMENT THE               TRACE 74

C     PARABOLIC FITS IN EQUATIONS J.1 AND U.3 OF THE TEXT.              TRACE 75

      D2R=(DRDT(1)-DROLD(1))/(T-TOLD)                                   TRACE 76

      VOLD=DROLD(1)                                                     TRACE 77

      V=DRDT(1)                                                         TRACE 78

C     USE FIT U.3 AT THE CURRENT POINT OF RAY PATH                      TRACE 79

      SMT=0.                                                            TRACE 80

      IF (D2R.NE.0.) SMT=0.5*V*V/D2R                                    TRACE 81

C     USE FIT U.3 AT THE PREVIOUS POINT OF RAY PATH                     TRACE 82

      OSMT=0.                                                           TRACE 83

      IF (D2R.NE.0.) OSMT=0.5*VOLD*VOLD/D2R                             TRACE 84

C     IMPLEMENTATION OF FIT FOR EQUATION J.1                            TRACE 85

      RDOTM=.5*(DRDT(1)+DROLD(1))                                       TRACE 86

      IF(ABS(RDOTM).LE..05*ABS(DRDT(1))) GO TO 1000                     TRACE 87

      FCTR=(R(1)-ROLD(1))/(T-TOLD)/RDOTM                                TRACE 88

      D2R=FCTR*D2R                                                      TRACE 89

      V=FCTR*V                                                          TRACE 90

      VOLD=FCTR*VOLD                                                    TRACE 91

C     END FIT                                                           TRACE 92

1000  CONTINUE                                                          TRACE 93

C                                                                       TRACE 94

      GCROSS=H.LT.0..OR.DRDT(1).GT.0..AND.DROLD(1).LT.0.                TRACE 95

     1      .AND.(SMT.GT.H.OR.OSMT.GT.ROLD(1)-EARTHR)                   TRACE 96

      IF(.NOT.LAUNCH.AND.HRCVRH*RSIGN.GT.0.0                            TRACE 97

     1      .AND..NOT.(RSIGN.GT.0.0.AND.GCROSS)) GO TO 50               TRACE 98

      IF (HOME.AND.WASNT) GO TO 30                                      TRACE 99

      IF(GCROSS) GO TO 20                                               TRACE100

      IF (DROLD(1).LT.0..AND.DRDT(1).GT.0.) CALL PRINTR(8HPERIGEE ,0.)  TRACE101

      IF (DROLD(1).GT.0..AND.DRDT(1).LT.0.) CALL PRINTR(8HAPOGEE  ,0.)  TRACE102

      IF (DROLD(2)*DRDT(2).LT.0.) CALL PRINTR(8HMAX LAT ,0.)            TRACE103

      IF (DROLD(3)*DRDT(3).LT.0.) CALL PRINTR(8HMAX LONG,0.)            TRACE104

      DO 14 I=4,6                                                       TRACE105

      IF (ROLD(I)*R(I).LT.0.) CALL PRINTR(8HWAVE REV,0.)                TRACE106

   14 CONTINUE                                                          TRACE107

      GO TO 75                                                          TRACE108

C********* RAY WENT UNDERGROUND                                         TRACE109

20    RAD=V*V-2.*H*D2R                                                  TRACE110

      RAD1=SQRT(AMAX1(RAD,0.0))                                         TRACE111

C     ESTIMATE GROUP TIME WHEN RAY INTERSECTS THE GROUND                TRACE112

      TC=T-2.0*H/(V-RAD1)                                               TRACE113

      CALL BACK UP(0.,-1.,TC)                                           TRACE114

C********* GROUND REFLECT                                               TRACE115

      R(4)=ABS (R(4))                                                   TRACE116

      DRDT(1)=ABS (DRDT(1))                                             TRACE117

      RSTART=1.                                                         TRACE118

      HPUNCH=R(1)-EARTHR                                                TRACE119

      CALL PRINTR(8HGRND REF,RAYSET)                                    TRACE120

      IF(RCVRH.EQ.0.0) RSIGN=-1                                         TRACE121

      GO TO 65                                                          TRACE122

C********* RAY MAY HAVE MADE A CLOSEST APPROACH                         TRACE123

30    RAD=V*V-2.0*HRCVRH*D2R                                            TRACE124

      IF(RAD.GE.0.0) GO TO 501                                          TRACE125

C     ESTIMATE TIME OF CLOSEST APPROACH                                 TRACE126

      TP=T-V/D2R                                                        TRACE127

      CALL GRAZE(RCVRH,RSIGN,TP)                                        TRACE128

      IF (THERE) GO TO 51                                               TRACE129

C                                                                       TRACE130

C     SET DRDT(1)=0 TO AVOID INCORRECT APOGEE OR PERIGEE PRINTOUT, A NEWTRACE131

C     VALUE WILL BE COMPUTED BEFORE FURTHER ANALYSIS IS DONE            TRACE132

40    DRDT(1)=0.                                                        TRACE133

      HPUNCH=R(1)-EARTHR                                                TRACE134

      CALL PRINTR(8HMIN DIST,RAYSET)                                    TRACE135

      IF (PLT.NE.0.) CALL RAYPLT                                        TRACE136

      IF (IHOP.GE.NHOP) RETURN                                          TRACE137

      IHOP=IHOP+1                                                       TRACE138

      RSIGN=-RSIGN                                                      TRACE139

      CALL PRINTR (8HMIN DIST,RAYSET)                                   TRACE140

      GO TO 89                                                          TRACE141

C********* RAY CROSSED RECEIVER HEIGHT                                  TRACE142

50    RAD=V*V-2.*HRCVRH*D2R                                             TRACE143

      RAD=AMAX1(RAD,0.0)                                                TRACE144

501   RAD1=SQRT(RAD)                                                    TRACE145

C     ESTIMATE GROUP TIME WHEN RAY CROSSES RECEIVER HEIGHT              TRACE146

C     (IN THE CORRECT DIRECTION).                                       TRACE147

      TC=T-2.0*HRCVRH/(V+SIGN(RAD1,RSIGN))                              TRACE148

2000   CALL BACK UP(RCVRH,RSIGN,TC)                                     TRACE149

      IF(.NOT.THERE) GO TO 40                                           TRACE150

51    HPUNCH=R(1)-EARTHR                                                TRACE151

      CALL PRINTR(8HRCVR    ,RAYSET)                                    TRACE152

      IF (PLT.NE.0.) CALL RAYPLT                                        TRACE153

      IF (RCVRH.NE.0.) GO TO 89                                         TRACE154

      IF (IHOP.GE.NHOP) RETURN                                          TRACE155

      IHOP=IHOP+1                                                       TRACE156

      RSIGN=-RSIGN                                                      TRACE157

C********* GROUND REFLECT                                               TRACE158

60    R(4)=ABS (R(4))                                                   TRACE159

      DRDT(1)=ABS (DRDT(1))                                             TRACE160

      RSTART=1.                                                         TRACE161

      HPUNCH=R(1)-EARTHR                                                TRACE162

      CALL PRINTR(8HGRND REF,RAYSET)                                    TRACE163

      IF (RCVRH.NE.0.) GO TO 65                                         TRACE164

      THERE=.TRUE.                                                      TRACE165

      HPUNCH=R(1)-EARTHR                                                TRACE166

      CALL PRINTR (8HRCVR    ,RAYSET)                                   TRACE167

      GO TO 89                                                          TRACE168

   65 H=0.                                                              TRACE169

      THERE=.FALSE.                                                     TRACE170

C*********                                                              TRACE171

   75 IF (PLT.NE.0.) CALL RAYPLT                                        TRACE172

      IF (H.GT.HMAX.AND.H.GT.RCVRH.AND.DRDT(1).GT.0.) GO TO 90          TRACE173

      IF (MOD(J,NSKIP).EQ.0) CALL PRINTR(8H        ,0.)                 TRACE174

   79 CONTINUE                                                          TRACE175

C********* EXCEEDED MAXIMUM NUMBER OF STEPS                             TRACE176

      HPUNCH=H                                                          TRACE177

      CALL PRINTR(8HSTEP MAX,RAYSET)                                    TRACE178

      RETURN                                                            TRACE179

C*********                                                              TRACE180

   89 HOME=.TRUE.                                                       TRACE181

      GO TO 10                                                          TRACE182

C********* RAY PENETRATED                                               TRACE183

   90 PENET=.TRUE.                                                      TRACE184

      HPUNCH=H                                                          TRACE185

      CALL PRINTR(8HPENETRAT,RAYSET)                                    TRACE186

      RETURN                                                            TRACE187

         END                                                            TRACE188

      SUBROUTINE TTABLE                                                 TTABLE 2

C     TABULAR TEMPERATURE PROFILE THAT MAKES A CUBIC INTERPOLATION      TTABLE 3

C     BETWEEN POINTS TO INSURE A CONTINUOUS TERMPERATURE GRADIENT       TTABLE 4

      DIMENSION HPC(250),FN2C(250),ALPHA(250),TTBETA(250),GAMM(250),    TTABLE 5

     1 DELTA(250),SLOPE(250),MAT(4,5)                                   TTABLE 6

      REAL MAT                                                          TTABLE 7

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 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 MODT                                                         CTT    4

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

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

C     COMMON DECK "B5" INSERTED HERE                                    CB5    2

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

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

      EQUIVALENCE (TGP,IDST)                                            CB5    6

      EQUIVALENCE (AN,TGP(11)),(HPC,TGP(12)),(FN2C,TGP(262))            TTABLE13

C                                                                       TTABLE14

      DATA RECOGT/6.0/                                                  TTABLE15

      DATA MODT/7HTTABLE  ,0.0, 1H  , 0.0 /                             TTABLE16

      DATA TMX/2/                                                       TTABLE17

      DATA TNTBL/1,11,512,7*0/                                          TTABLE18

      DATA TITBL/1,250,8*0/                                             TTABLE19

      DATA TFRMTBL/1,2,8*0/                                             TTABLE20

C                                                                       TTABLE21

      ENTRY ITEMP                                                       TTABLE22

C                                                                       TTABLE23

      IF(RECOGT.NE.TMODEL)                                              TTABLE24

     1    CALL RERROR(7HTEMP    ,10HWRNG MODEL ,RECOGT)                 TTABLE25

C                                                                       TTABLE26

      NOC=AN/2                                                          TTABLE27

      IF(AN.NE.2*NOC) CALL RERROR("TTABLE","BAD NUMBER",AN)             TTABLE28

      MODT(2)=TID                                                       TTABLE29

C                                                                       TTABLE30

      CALL IPTEMP                                                       TTABLE31

C                                                                       TTABLE32

      SLOPE(1)=(FN2C(2)-FN2C(1))/(HPC(2)-HPC(1))                        TTABLE33

      SLOPE(NOC)=0.                                                     TTABLE34

      NMAX=1                                                            TTABLE35

      DO 6 I=2,NOC                                                      TTABLE36

      IF (FN2C(I).GT.FN2C(NMAX)) NMAX=I                                 TTABLE37

      IF (I.EQ.NOC) GO TO 4                                             TTABLE38

      DO 3 J=1,3                                                        TTABLE39

      M=I+J-2                                                           TTABLE40

      MAT(J,1)=1.                                                       TTABLE41

      MAT(J,2)=HPC(M)                                                   TTABLE42

      MAT(J,3)=HPC(M)**2                                                TTABLE43

  3   MAT(J,4)=FN2C(M)                                                  TTABLE44

      CALL GAUSEL (MAT,4,3,4,NRANK)                                     TTABLE45

      IF (NRANK.LT.3) GO TO 60                                          TTABLE46

      SLOPE(I)=MAT(2,4)+2.*MAT(3,4)*HPC(I)                              TTABLE47

    4 DO 5 J=1,2                                                        TTABLE48

      M=I+J-2                                                           TTABLE49

      MAT(J,1)=1.                                                       TTABLE50

      MAT(J,2)=HPC(M)                                                   TTABLE51

      MAT(J,3)=HPC(M)**2                                                TTABLE52

      MAT(J,4)=HPC(M)**3                                                TTABLE53

      MAT(J,5)=FN2C(M)                                                  TTABLE54

      L=J+2                                                             TTABLE55

      MAT(L,1)=0.                                                       TTABLE56

      MAT(L,2)=1.                                                       TTABLE57

      MAT(L,3)=2.*HPC(M)                                                TTABLE58

      MAT(L,4)=3.*HPC(M)**2                                             TTABLE59

    5 MAT(L,5)=SLOPE(M)                                                 TTABLE60

      CALL GAUSEL (MAT,4,4,5,NRANK)                                     TTABLE61

      IF (NRANK.LT.4) GO TO 60                                          TTABLE62

      ALPHA(I)=MAT(1,5)                                                 TTABLE63

      TTBETA(I)=MAT(2,5)                                                TTABLE64

      GAMM(I)=MAT(3,5)                                                  TTABLE65

    6 DELTA(I)=MAT(4,5)                                                 TTABLE66

      HMAX=HPC(NMAX)                                                    TTABLE67

      NH=2                                                              TTABLE68

C                                                                       TTABLE69

      RETURN                                                            TTABLE70

C                                                                       TTABLE71

   60 PRINT 6000, I,HPC(I)                                              TTABLE72

 6000 FORMAT(" THE",I4,"TH POINT IN THE TEMPERATURE PROFILE HAS"        TTABLE73

     1," THE HEIGHT",F8.2," KM, WHICH IS THE SAME AS ANOTHER POINT.")   TTABLE74

      CALL EXIT                                                         TTABLE75

C                                                                       TTABLE76

      ENTRY TEMP                                                        TTABLE77

C                                                                       TTABLE78

      H=R-EARTHR                                                        TTABLE79

      PTT=PTR=PTTH=PTPH=0.                                              TTABLE80

      IF (H.GE.HPC(1)) GO TO 12                                         TTABLE81

   11 NH=2                                                              TTABLE82

      T=FN2C(1)+SLOPE(1)*(H-HPC(1))                                     TTABLE83

      PTR=SLOPE(1)                                                      TTABLE84

      RETURN                                                            TTABLE85

   12 IF (H.GE.HPC(NOC)) GO TO 18                                       TTABLE86

      NSTEP=1                                                           TTABLE87

      IF (H.LT.HPC(NH-1)) NSTEP=-1                                      TTABLE88

   15 IF (HPC(NH-1).LE.H.AND.H.LT.HPC(NH)) GO TO 16                     TTABLE89

      NH=NH+NSTEP                                                       TTABLE90

      GO TO 15                                                          TTABLE91

   16 T=(ALPHA(NH)+H*(TTBETA(NH)+H*(GAMM(NH)+H*DELTA(NH))))             TTABLE92

      PTR=(TTBETA(NH)+H*(2.*GAMM(NH)+H*3.*DELTA(NH)))                   TTABLE93

      RETURN                                                            TTABLE94

   18 T=FN2C(NOC)                                                       TTABLE95

C                                                                       TTABLE96

      CALL PTEMP                                                        TTABLE97

      RETURN                                                            TTABLE98

         END                                                            TTABLE99

      SUBROUTINE TTANH1                                                 TTANH1 2

C     OBSOLETE TEMPERATURE PROFILE                                      TTANH1 3

      DIMENSION D (5), Z (4), B (4)                                     TTANH1 4

C     COMMON DECK "B5" INSERTED HERE                                    CB5    2

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

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

      EQUIVALENCE (TGP,IDST)                                            CB5    6

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL 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 MODT                                                         CTT    4

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

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

      DATA RECOGT/2.0/                                                  TTANH1 9

      DATA TMX/1/                                                       TTANH110

      DATA TNTBL/1,11,8*0/                                              TTANH111

      DATA TITBL/1,9*0/                                                 TTANH112

      DATA TFRMTBL/1,9*0/                                               TTANH113

      DATA D (1)/- 6.5/,D (2)/3.5/,D (3)/- 3./,D (4)/18.0/              TTANH114

     1, D (5)/1./,Z (1)/15./,Z (2)/52./,Z (3)/95./,Z (4)                TTANH115

     2/165./,B (1)/10./,B (2)/7.5/,B (3)/10./,B (4)/50.0/               TTANH116

     3 ,T0/288./,N/4/,MODT/7HTTANH1  ,0.0, 1H  , 0.0 /                  TTANH117

      COSH (X) = (EXP (X) + 1. / (EXP (X))) / 2.                        TTANH118

C                                                                       TTANH119

      ENTRY ITEMP                                                       TTANH120

C                                                                       TTANH121

      IF(RECOGT .NE. TMODEL)                                            TTANH122

     1    CALL RERROR(7HTEMP    ,10HWRNG MODEL ,RECOGT)                 TTANH123

      MODT(2)=TID                                                       TTANH124

      CALL IPTEMP                                                       TTANH125

C                                                                       TTANH126

      RETURN                                                            TTANH127

C                                                                       TTANH128

      ENTRY TEMP                                                        TTANH129

      H = R - EARTHR                                                    TTANH130

      SUM = 0.                                                          TTANH131

      DO 1 I = 1, N                                                     TTANH132

   1  SUM = SUM + B (I) * (D (I + 1) - D (I)) / 2. * ALOG (COSH ((H - Z TTANH133

     1(I)) / B (I)) / COSH (Z (I) / B (I)))                             TTANH134

      T = T0 + SUM + D(1)*H/2.0                                         TTANH135

C      T = T0 + SUM + (D (1) + D (N + 1)) * H / 2.                      TTANH136

      SUM = 0.                                                          TTANH137

      DO 2 I = 1, N                                                     TTANH138

   2  SUM = SUM + (D (I + 1) - D (I)) / 2. * (0. + TANH ((H - Z (I)) / BTTANH139

     1 (I)))                                                            TTANH140

      PTT=0.0                                                           TTANH141

      PTR = D (1)/2.0 + SUM                                             TTANH142

      PTTH=0.0                                                          TTANH143

      PTPH=0.0                                                          TTANH144

C                                                                       TTANH145

      CALL PTEMP                                                        TTANH146

      RETURN                                                            TTANH147

      END                                                               TTANH148

      SUBROUTINE TTANH2                                                 TTANH2 2

C     TEMPERATURE PROFILE                                               TTANH2 3

      DIMENSION C(5), Z(4), DL(4)                                       TTANH2 4

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL 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 MODT                                                         CTT    4

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

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

      EQUIVALENCE (T0,W(203))                                           TTANH2 8

      EQUIVALENCE (AN,W(204)),(Z,W(205)),(C,W(209)),(DL,W(214))         TTANH2 9

C     COMMON DECK "B5" INSERTED HERE                                    CB5    2

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

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

      EQUIVALENCE (TGP,IDST)                                            CB5    6

      DATA RECOGT/3.0/                                                  TTANH211

      DATA TMX/1/                                                       TTANH212

      DATA TNTBL/1,11,8*0/                                              TTANH213

      DATA TITBL/1,9*0/                                                 TTANH214

      DATA TFRMTBL/1,9*0/                                               TTANH215

      DATA MODT(1),MODT(2)/7HTTANH2  ,0.0/                              TTANH216

      COSH (X) = (EXP (X) + 1. / (EXP (X))) / 2.                        TTANH217

C                                                                       TTANH218

      ENTRY ITEMP                                                       TTANH219

C                                                                       TTANH220

      IF(RECOGT .NE. TMODEL)                                            TTANH221

     1    CALL RERROR(7HTEMP    ,10HWRNG MODEL ,RECOGT)                 TTANH222

      MODT(2)=TID                                                       TTANH223

      CALL IPTEMP                                                       TTANH224

C                                                                       TTANH225

      RETURN                                                            TTANH226

C                                                                       TTANH227

      ENTRY TEMP                                                        TTANH228

      H = R - EARTHR                                                    TTANH229

      SUM = 0.                                                          TTANH230

      N=AN                                                              TTANH231

      DO 1 I = 1, N                                                     TTANH232

   1  SUM = SUM + DL(I) * (C(I + 1) - C(I)) / 2. * ALOG (COSH ((H - Z   TTANH233

     1(I)) / DL(I)) / COSH (Z(I) / DL(I)))                              TTANH234

      T = T0 + SUM + (C(1) + C(N + 1)) * H / 2.                         TTANH235

      SUM = 0.                                                          TTANH236

      DO 2 I = 1, N                                                     TTANH237

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

     1 (I)))                                                            TTANH239

      PTT=0.0                                                           TTANH240

      PTR = C(1) + SUM                                                  TTANH241

      PTTH=0.0                                                          TTANH242

      PTPH=0.0                                                          TTANH243

      CALL PTEMP                                                        TTANH244

      RETURN                                                            TTANH245

      END                                                               TTANH246

      SUBROUTINE TTANH3                                                 TTANH3 2

C     TEMPERATURE PROFILE                                               TTANH3 3

      DIMENSION C(5), Z(4), DL(4)                                       TTANH3 4

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL 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 MODT                                                         CTT    4

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

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

      EQUIVALENCE (T0,W(203))                                           TTANH3 8

      EQUIVALENCE (AN,TGP(11)),(C,TGP(12)),(Z,TGP(32)),(DL,TGP(52))     TTANH3 9

C     COMMON DECK "B5" INSERTED HERE                                    CB5    2

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

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

      EQUIVALENCE (TGP,IDST)                                            CB5    6

      DATA RECOGT/4.0/                                                  TTANH311

      DATA MODT/7HTTANH3  ,0.0, 1H  , 0.0 /                             TTANH312

      DATA TMX/2/                                                       TTANH313

      DATA TNTBL/1,11,72,7*0/                                           TTANH314

      DATA TITBL/1,20,8*0/                                              TTANH315

      DATA TFRMTBL/1,2,8*0/                                             TTANH316

C                                                                       TTANH317

      COSH (X) = (EXP (X) + 1. / (EXP (X))) / 2.                        TTANH318

C                                                                       TTANH319

      ENTRY ITEMP                                                       TTANH320

      AN=AN-1                                                           TTANH321

      N=AN/3                                                            TTANH322

      IF(AN.NE.3*N) CALL RERROR("TTANH3","BAD NUMBER",AN+1.0)           TTANH323

C                                                                       TTANH324

      IF(RECOGT .NE. TMODEL)                                            TTANH325

     1    CALL RERROR(7HTEMP    ,10HWRNG MODEL ,RECOGT)                 TTANH326

      MODT(2)=TID                                                       TTANH327

      CALL IPTEMP                                                       TTANH328

C                                                                       TTANH329

      RETURN                                                            TTANH330

C                                                                       TTANH331

      ENTRY TEMP                                                        TTANH332

      H = R - EARTHR                                                    TTANH333

      SUM = 0.                                                          TTANH334

      DO 1 I = 1, N                                                     TTANH335

   1  SUM = SUM + DL(I) * (C(I + 1) - C(I)) / 2. * ALOG (COSH ((H - Z   TTANH336

     1(I)) / DL(I)) / COSH (Z(I) / DL(I)))                              TTANH337

      T = T0 + SUM + (C(1) + C(N + 1)) * H / 2.                         TTANH338

      SUM = 0.                                                          TTANH339

      DO 2 I = 1, N                                                     TTANH340

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

     1 (I)))                                                            TTANH342

      PTT=0.0                                                           TTANH343

      PTR = C(1) + SUM                                                  TTANH344

      PTTH=0.0                                                          TTANH345

      PTPH=0.0                                                          TTANH346

C                                                                       TTANH347

      CALL PTEMP                                                        TTANH348

      RETURN                                                            TTANH349

      END                                                               TTANH350

      SUBROUTINE TTANH4                                                 TTANH4 2

C     TEMPERATURE PROFILE                                               TTANH4 3

      DIMENSION C(5), Z(4), DL(4)                                       TTANH4 4

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL 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 MODT                                                         CTT    4

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

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

C     COMMON DECK "B5" INSERTED HERE                                    CB5    2

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

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

      EQUIVALENCE (TGP,IDST)                                            CB5    6

      EQUIVALENCE (T0,W(203))                                           TTANH4 9

      EQUIVALENCE (AN,TGP(11)),(Z,TGP(12)),(C,TGP(32)),(DL,TGP(52))     TTANH410

C                                                                       TTANH411

      DATA AN,N/0.0,0/                                                  TTANH412

      DATA RECOGT/5.0/                                                  TTANH413

      DATA MODT/7HTTANH4  ,0.0, 1H  , 0.0 /                             TTANH414

      DATA TMX/2/                                                       TTANH415

      DATA TNTBL/1,11,72,7*0/                                           TTANH416

      DATA TITBL/1,20,8*0/                                              TTANH417

      DATA TFRMTBL/1,2,8*0/                                             TTANH418

C                                                                       TTANH419

      COSH (X) = (EXP (X) + 1. / (EXP (X))) / 2.                        TTANH420

C                                                                       TTANH421

      ENTRY ITEMP                                                       TTANH422

      IF(N.GT.0 .AND. AN.EQ.0.0) RETURN                                 TTANH423

      IF(RECOGT .NE. TMODEL)                                            TTANH424

     1    CALL RERROR(7HTEMP    ,10HWRNG MODEL ,RECOGT)                 TTANH425

      MODT(2)=TID                                                       TTANH426

      AN=AN-2.0                                                         TTANH427

      N=AN/3                                                            TTANH428

      IF(AN.NE.3*N) CALL RERROR("TTANH4","BAD NUMBER",AN+2.0)           TTANH429

      AN=0.0                                                            TTANH430

C                                                                       TTANH431

C                                                                       TTANH432

      CALL IPTEMP                                                       TTANH433

C                                                                       TTANH434

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

C                                                                       TTANH436

      TIM1=T0                                                           TTANH437

      ZIM1=0.0                                                          TTANH438

      NP1=N+1                                                           TTANH439

      DO 10 I=1,NP1                                                     TTANH440

         TI=C(I)                                                        TTANH441

         ZI=Z(I)                                                        TTANH442

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

         TIM1=TI                                                        TTANH444

10       ZIM1=ZI                                                        TTANH445

C                                                                       TTANH446

      RETURN                                                            TTANH447

C                                                                       TTANH448

      ENTRY TEMP                                                        TTANH449

      H = R - EARTHR                                                    TTANH450

      SUM = 0.                                                          TTANH451

      DO 1 I = 1, N                                                     TTANH452

   1  SUM = SUM + DL(I) * (C(I + 1) - C(I)) / 2. * ALOG (COSH ((H - Z   TTANH453

     1(I)) / DL(I)) / COSH (Z(I) / DL(I)))                              TTANH454

      T = T0 + SUM + (C(1) + C(N + 1)) * H / 2.                         TTANH455

      SUM = 0.                                                          TTANH456

      DO 2 I = 1, N                                                     TTANH457

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

     1 (I)))                                                            TTANH459

      PTT=0.0                                                           TTANH460

      PTR = C(1) + SUM                                                  TTANH461

      PTTH=0.0                                                          TTANH462

      PTPH=0.0                                                          TTANH463

C                                                                       TTANH464

      CALL PTEMP                                                        TTANH465

      RETURN                                                            TTANH466

      END                                                               TTANH467

       SUBROUTINE ULOGZ                                                 ULOGZ  2

C     LOGARITHMIC WIND VELOCITY PROFILE                                 ULOGZ  3

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL 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 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

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

      REAL K                                                            ULOGZ  7

      EQUIVALENCE (USTAR,W(103)),(K,W(104)),(Z0,W(105)),(Z1,W(106))     ULOGZ  8

C     COMMON DECK "B1" INSERTED HERE                                    CB1    2

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

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

      EQUIVALENCE (UGP,IDSU)                                            CB1    6

      DATA RECOGU/2.0/                                                  ULOGZ 10

      DATA UMX/1/                                                       ULOGZ 11

      DATA UNTBL/1,11,8*0/                                              ULOGZ 12

      DATA UITBL/1,9*0/                                                 ULOGZ 13

      DATA UFRMTBL/1,9*0/                                               ULOGZ 14

      DATA MODU/6HULOGZ  ,0.0, 1H  , 0.0/                               ULOGZ 15

C                                                                       ULOGZ 16

      ENTRY IWINDR                                                      ULOGZ 17

C                                                                       ULOGZ 18

      IF(RECOGU .NE. UMODEL)                                            ULOGZ 19

     1    CALL RERROR(7HSPEED  ,10HWRNG MODEL ,RECOGU)                  ULOGZ 20

      MODU(2)=UID                                                       ULOGZ 21

      CALL IPWINDR                                                      ULOGZ 22

C                                                                       ULOGZ 23

      RETURN                                                            ULOGZ 24

C                                                                       ULOGZ 25

       ENTRY WINDR                                                      ULOGZ 26

      CALL CLEAR(V,20)                                                  ULOGZ 27

       HH = R - EARTHR                                                  ULOGZ 28

      IF ( HH.LE.0. ) HH=0.                                             ULOGZ 29

      C=USTAR/K                                                         ULOGZ 30

      VPH=C*ALOG((HH+Z1)/Z0)                                            ULOGZ 31

      PVPHR=C/(HH+Z1)                                                   ULOGZ 32

      V=ABS(VPH)                                                        ULOGZ 33

      PVR=SIGN(PVPHR,VPH)                                               ULOGZ 34

C                                                                       ULOGZ 35

      CALL PWINDR                                                       ULOGZ 36

       RETURN                                                           ULOGZ 37

       END                                                              ULOGZ 38

       SUBROUTINE VVORTEX                                               VVORTEX2

C     WIND VELOCITY MODEL                                               VVORTEX3

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 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 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

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

       EQUIVALENCE (U0,W(103)),(R0,W(104)),(TH0,W(105)),(PH0,W(106))    VVORTEX8

C     COMMON DECK "B1" INSERTED HERE                                    CB1    2

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

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

      EQUIVALENCE (UGP,IDSU)                                            CB1    6

      DATA RECOGU/3.0/                                                  VVORTE10

      DATA UMX/1/                                                       VVORTE11

      DATA UNTBL/1,11,8*0/                                              VVORTE12

      DATA UITBL/1,9*0/                                                 VVORTE13

      DATA UFRMTBL/1,9*0/                                               VVORTE14

      DATA MODU/7HVVORTEX  ,0.0, 1H  , 0.0/                             VVORTE15

C                                                                       VVORTE16

      ENTRY IWINDR                                                      VVORTE17

C                                                                       VVORTE18

      IF(RECOGU .NE. UMODEL)                                            VVORTE19

     1    CALL RERROR(7HSPEED  ,10HWRNG MODEL ,RECOGU)                  VVORTE20

      MODU(2)=UID                                                       VVORTE21

      CALL IPWINDR                                                      VVORTE22

C                                                                       VVORTE23

      RETURN                                                            VVORTE24

C                                                                       VVORTE25

       ENTRY WINDR                                                      VVORTE26

      CALL CLEAR(V,20)                                                  VVORTE27

       DTH = TH - TH0                                                   VVORTE28

       DPH = PH - PH0                                                   VVORTE29

       RAD2 = EARTHR * SQRT(DTH * DTH + DPH * DPH)                      VVORTE30

       A = 1.397                                                        VVORTE31

       B = - 1.26                                                       VVORTE32

      EXPO=RAD2/R0                                                      VVORTE33

      EXPO=B*EXPO*EXPO                                                  VVORTE34

      EXB=0.0                                                           VVORTE35

       IF(EXPO .GT. -675.0) EXB = EXP(EXPO)                             VVORTE36

      FX=1.-EXB                                                         VVORTE37

       DUM = A * EARTHR * U0 * R0 / RAD2 * * 2                          VVORTE38

       DUX = FX / RAD2 + RAD2 * B * EXB / R0 * * 2                      VVORTE39

       VTH = - DUM * FX * DPH                                           VVORTE40

       VPH = DUM * FX * DTH                                             VVORTE41

      V=SQRT(VTH*VTH + VPH*VPH)                                         VVORTE42

       PVTHTH = 2. * DUM * EARTHR * * 2 * DTH * DPH / RAD2 * DUX        VVORTE43

       PVPHPH = - PVTHTH                                                VVORTE44

       PVTHPH = 2. * DPH * * 2 * DUM * EARTHR * * 2 / RAD2 * DUX -DUM*FXVVORTE45

       PVPHTH = - 2.* DTH**2* DUM* EARTHR**2 / RAD2* DUX + DUM*FX       VVORTE46

C                                                                       VVORTE47

      PVTH=(VTH*PVTHTH + VPH*PVPHTH)/V                                  VVORTE48

      PVPH=(VTH*PVTHPH + VPH*PVPHPH)/V                                  VVORTE49

      CALL PWINDR                                                       VVORTE50

       RETURN                                                           VVORTE51

       END                                                              VVORTE52

       SUBROUTINE WCONST                                                WCONST 2

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL 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 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

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

      EQUIVALENCE (W(103),VR0)                                          WCONST 6

      EQUIVALENCE (W(104),VTH0),(W(105),VPH0),(W(106),PVTHZ0)           WCONST 7

      EQUIVALENCE (W(107),WGRAD)                                        WCONST 8

C     COMMON DECK "B1" INSERTED HERE                                    CB1    2

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

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

      EQUIVALENCE (UGP,IDSU)                                            CB1    6

      DATA MODU/6HWCONST  ,0.0, 1H  , 0.0/                              WCONST10

      DATA RECOGU/1.0/                                                  WCONST11

C                                                                       WCONST12

      ENTRY IWINDR                                                      WCONST13

C                                                                       WCONST14

      IF(RECOGU .NE. UMODEL)                                            WCONST15

     1    CALL RERROR(7HSPEED  ,10HWRNG MODEL ,RECOGU)                  WCONST16

      MODU(2)=UID                                                       WCONST17

      CALL IPWINDR                                                      WCONST18

C                                                                       WCONST19

      RETURN                                                            WCONST20

C                                                                       WCONST21

       ENTRY WINDR                                                      WCONST22

       HH = R - EARTHR                                                  WCONST23

C                                                                       WCONST24

      CALL CLEAR(V,20)                                                  WCONST25

C                                                                       WCONST26

       VR = VR0                                                         WCONST27

       VTH = VTH0                                                       WCONST28

       VPH = (VPH0 + WGRAD * HH)                                        WCONST29

       PVTHR = WGRAD                                                    WCONST30

      V=SQRT(VR*VR+VTH*VTH+VPH*VPH)                                     WCONST31

      PVR=PVTHR                                                         WCONST32

      IF(V.NE.0.0) PVR=VTH/V*PVTHR                                      WCONST33

      CALL PWINDR                                                       WCONST34

       RETURN                                                           WCONST35

       END                                                              WCONST36

       SUBROUTINE WGAUSS                                                WGAUSS 2

C     WIND VELOCITY MODEL                                               WGAUSS 3

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL 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 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

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

C     COMMON DECK "B1" INSERTED HERE                                    CB1    2

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

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

      EQUIVALENCE (UGP,IDSU)                                            CB1    6

      EQUIVALENCE (UPH0,W(103)),(WH,W(104)),(WTH,W(105))                WGAUSS 8

      EQUIVALENCE  (WPH,W(106)),(H0,W(107)),(TH0,W(108)),(PH0,W(109))   WGAUSS 9

       DATA MODU(1),MODU(2)/6HWGAUSS,0.0/                               WGAUSS10

      DATA RECOGU/4.0/                                                  WGAUSS11

      DATA UMX/1/                                                       WGAUSS12

      DATA UNTBL/1,11,8*0/                                              WGAUSS13

      DATA UITBL/1,9*0/                                                 WGAUSS14

      DATA UFRMTBL/1,9*0/                                               WGAUSS15

C                                                                       WGAUSS16

      ENTRY IWINDR                                                      WGAUSS17

C                                                                       WGAUSS18

      IF(RECOGU .NE. UMODEL)                                            WGAUSS19

     1    CALL RERROR(7HSPEED  ,10HWRNG MODEL ,RECOGU)                  WGAUSS20

      MODU(2)=UID                                                       WGAUSS21

      CALL IPWINDR                                                      WGAUSS22

C                                                                       WGAUSS23

      WIDH=0.0                                                          WGAUSS24

      WIDTH=0.0                                                         WGAUSS25

      WIDPH=0.0                                                         WGAUSS26

      IF(WH.NE.0.0) WIDH=1.0/WH                                         WGAUSS27

      IF(WTH.NE.0.0) WIDTH=1.0/WTH                                      WGAUSS28

      IF(WPH.NE.0.0) WIDPH=1.0/WPH                                      WGAUSS29

      RETURN                                                            WGAUSS30

C                                                                       WGAUSS31

       ENTRY WINDR                                                      WGAUSS32

      CALL CLEAR(V,20)                                                  WGAUSS33

       H = R - EARTHR                                                   WGAUSS34

      DFH=(H-H0)*WIDH                                                   WGAUSS35

      DFTH=(TH-TH0)*WIDTH                                               WGAUSS36

      DFPH=(PH-PH0)*WIDPH                                               WGAUSS37

      EXPO=-(DFH*DFH+DFTH*DFTH+DFPH*DFPH)                               WGAUSS38

      EXPN=0.0                                                          WGAUSS39

      IF(EXPO.GT.-200.0) EXPN=EXP(EXPO)                                 WGAUSS40

       VPH = UPH0*EXPN                                                  WGAUSS41

       PVPHR = - 2. * VPH * DFH*WIDH                                    WGAUSS42

       PVPHTH = - 2. * VPH * DFTH*WIDTH                                 WGAUSS43

       PVPHPH = - 2. * VPH * DFPH*WIDPH                                 WGAUSS44

       END                                                              WGAUSS45

       SUBROUTINE WLINEAR                                               WLINEAR2

C     LINEAR WIND VELOCITY PROFILE                                      WLINEAR3

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL 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 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

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

C     COMMON DECK "B1" INSERTED HERE                                    CB1    2

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

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

      EQUIVALENCE (UGP,IDSU)                                            CB1    6

      EQUIVALENCE (W(103),UR0)                                          WLINEAR8

      EQUIVALENCE (W(104),UTH0),(W(105),UPH0),(W(106),PUPHZ0)           WLINEAR9

C                                                                       WLINEA10

      DATA MODU(1),MODU(2)/7HWLINEAR  ,0.0/                             WLINEA11

      DATA RECOGU/1.0/                                                  WLINEA12

      DATA UMX/1/                                                       WLINEA13

      DATA UNTBL/1,11,8*0/                                              WLINEA14

      DATA UITBL/1,9*0/                                                 WLINEA15

      DATA UFRMTBL/1,9*0/                                               WLINEA16

C                                                                       WLINEA17

      ENTRY IWINDR                                                      WLINEA18

C                                                                       WLINEA19

      IF(RECOGU .NE. UMODEL)                                            WLINEA20

     1    CALL RERROR(7HSPEED  ,10HWRNG MODEL ,RECOGU)                  WLINEA21

      MODU(2)=UID                                                       WLINEA22

      CALL IPWINDR                                                      WLINEA23

C                                                                       WLINEA24

      RETURN                                                            WLINEA25

C                                                                       WLINEA26

       ENTRY WINDR                                                      WLINEA27

       H = R - EARTHR                                                   WLINEA28

C                                                                       WLINEA29

      CALL CLEAR(V,20)                                                  WLINEA30

C                                                                       WLINEA31

       VR = UR0                                                         WLINEA32

       VTH = UTH0                                                       WLINEA33

       VPH = (UPH0 + PUPHZ0 * H)                                        WLINEA34

      V=SQRT(VR*VR+VTH*VTH+VPH*VPH)                                     WLINEA35

      PVR=PUPHZ0                                                        WLINEA36

      IF(V.NE.0.0) PVR=VPH/V*PUPHZ0                                     WLINEA37

      PVPHR = PUPHZ0                                                    WLINEA38

      CALL PWINDR                                                       WLINEA39

       RETURN                                                           WLINEA40

       END                                                              WLINEA41

       SUBROUTINE WTIDE                                                 WTIDE  2

C     WIND VELOCITY MODEL                                               WTIDE  3

C                                                                       WTIDE  4

      REAL LAMZ                                                         WTIDE  5

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL 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 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

      COMMON/WW/ID(10),MAXW,W(400)                                      CWW1   2

      REAL 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)),(INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),        CWW2   9

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

     7 (SKIP,W(71)),(RAYSET,W(72)),(PLT,W(81)),(PFACTR,W(82)),          CWW2  11

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

     2,(TIC,W(87)),(HB,W(88)),(HT,W(89))                                CWW2  13

      REAL 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

C                                                                       CWW3  12

C     DELTA SOUND SPEED 175-199                                         CWW3  13

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

C                                                                       CWW3  15

C     TEMPERATURE    200-224                                            CWW3  16

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

C                                                                       CWW3  18

C     DELTA TEMPERATURE    225-249                                      CWW3  19

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

C                                                                       CWW3  21

C     MOLECULAR   250-274                                               CWW3  22

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

C                                                                       CWW3  24

C     RECEIVER HEIGHT   275-299                                         CWW3  25

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

C                                                                       CWW3  27

C     TOPOGRAPHY   300-324                                              CWW3  28

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

C     COMMON DECK "B1" INSERTED HERE                                    CB1    2

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

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

      EQUIVALENCE (UGP,IDSU)                                            CB1    6

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

      EQUIVALENCE (W(103),UPH0)                                         WTIDE 11

      EQUIVALENCE (W(104),UTH0),(W(105),LAMZ),(W(106),TTAU),(W(107),TAU)WTIDE 12

C                                                                       WTIDE 13

      DATA MODU(1),MODU(2)/7HWTIDE  ,0.0/                               WTIDE 14

      DATA RECOGU/5.0/                                                  WTIDE 15

C                                                                       WTIDE 16

      DATA UMX/1/                                                       WTIDE 17

      DATA UNTBL/1,11,8*0/                                              WTIDE 18

      DATA UITBL/1,9*0/                                                 WTIDE 19

      DATA UFRMTBL/1,9*0/                                               WTIDE 20

C                                                                       WTIDE 21

      ENTRY IWINDR                                                      WTIDE 22

C                                                                       WTIDE 23

      IF(RECOGU .NE. UMODEL)                                            WTIDE 24

     1    CALL RERROR(7HSPEED  ,10HWRNG MODEL ,RECOGU)                  WTIDE 25

      MODU(2)=UID                                                       WTIDE 26

      CALL IPWINDR                                                      WTIDE 27

C                                                                       WTIDE 28

      Q=PID2/LAMZ                                                       WTIDE 29

      S=PID2/TAU                                                        WTIDE 30

      RETURN                                                            WTIDE 31

C                                                                       WTIDE 32

      ENTRY WINDR                                                       WTIDE 33

C                                                                       WTIDE 34

      CALL CLEAR(V,20)                                                  WTIDE 35

C                                                                       WTIDE 36

      ARG=PID2*((R-EARTHR)/LAMZ+TTAU)                                   WTIDE 37

C                                                                       WTIDE 38

      CSA=COS(ARG)                                                      WTIDE 39

      SSA=SIN(ARG)                                                      WTIDE 40

      VTH=UTH0*SSA                                                      WTIDE 41

      VPH=UPH0*CSA                                                      WTIDE 42

C                                                                       WTIDE 43

      PVTHR=CSA*Q*UTH0                                                  WTIDE 44

      PVPHR=SSA*Q*UPH0                                                  WTIDE 45

C      V=SQRT(VTH*VTH+VPH*VPH)                                          WTIDE 46

      PVTHT=CSA*S*UTH0                                                  WTIDE 47

      PVPHT=SSA*S*UPH0                                                  WTIDE 48

      CALL PWINDR                                                       WTIDE 49

       RETURN                                                           WTIDE 50

       END                                                              WTIDE 51

      SUBROUTINE ZEXP(THA,PHA)                                          ZEXP   2

C     COMMON DECK "GAMANG" INSERTED HERE                                CGAMANG2

      COMMON/SPHGAM/SINLM0,COSLM0,GPH0,COSPHD,SINTH,COSTH               CGAMANG4

      COMMON/SPHGAM/GAMFUN,PGMTH,PGMPH,PGMTHTH,PGMPHPH,PGMTHPH          CGAMANG5

C     COMMON DECK "ZEXP" INSERTED HERE                                  CZEXP  2

      COMMON/CZEXP/ZGAIN,ZWIDTH,ZALPH0,ZBETA                            CZEXP  4

      COMMON/CZEXP/ZFUN,PZTH,PZPH,PZTHTH,PZPHPH,PZTHPH                  CZEXP  5

C                                                                       ZEXP   5

      CALL GAMANG(THA,PHA)                                              ZEXP   6

C                                                                       ZEXP   7

      ZBETA=ACOS(GAMFUN)-ZALPH0                                         ZEXP   8

      ZWSQ=ZWIDTH*ZWIDTH                                                ZEXP   9

      EXPF=ZWSQ*ZBETA*ZBETA                                             ZEXP  10

C                                                                       ZEXP  11

      ZFUN=ZGAIN*EXP(-EXPF)                                             ZEXP  12

C                                                                       ZEXP  13

      IF(GAMFUN.NE.1.0) GO TO 100                                       ZEXP  14

      CALL CLEAR(PZTH,5)                                                ZEXP  15

      RETURN                                                            ZEXP  16

C                                                                       ZEXP  17

100   SINBAI=1.0/SQRT(1.0-GAMFUN*GAMFUN)                                ZEXP  18

      PBTH=-SINBAI*PGMTH                                                ZEXP  19

      PBPH=-SINBAI*PGMPH                                                ZEXP  20

C                                                                       ZEXP  21

      FW2Z=-2.0*ZFUN*ZWSQ*ZBETA                                         ZEXP  22

      PZTH=FW2Z*PBTH                                                    ZEXP  23

      PZPH=FW2Z*PBPH                                                    ZEXP  24

C                                                                       ZEXP  25

      G1=FW2Z*SINBAI                                                    ZEXP  26

      G2=G1*GAMFUN+(1.0-2.0*EXPF)                                       ZEXP  27

C                                                                       ZEXP  28

      PZTHTH=G2*PBTH*PBTH-G1*PGMTHTH                                    ZEXP  29

      PZPHPH=G2*PBPH*PBPH-G1*PGMPHPH                                    ZEXP  30

      PZTHPH=G2*PBTH*PBPH-G1*PGMTHPH                                    ZEXP  31

      RETURN                                                            ZEXP  32

      END                                                               ZEXP  33

