







      FUNCTION REFLECT(Z)                                               REFLECT2

c

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

c

C     COMPUTES NORMAL AND PARALLEL COMPONENTS OF THE K-VECTOR AT        REFLECT3

C     REFLECTION POINTS TO A SURFACE. WIND EFFECTS ARE INCLUDED.        REFLECT4

C                                                                       REFLECT5

      REAL*8 Z(12),KPARLEL,KNORM                                        REFLECT6

C     COMMON DECK "CC" INSERTED HERE                                    CCC    2

      real*8 modc

c     REAL MODC                                                         CCC    4

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

C     COMMON DECK "WWR" INSERTED HERE                                   CWWR   2

      PARAMETER (NWARSZ=1000)                                           CWW1   3

      real*8 id

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL*8 KR,KTH,KPH                                                 RKAMCOM4

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

C     COMMON DECK "UU" INSERTED HERE                                    CUU    2

      real*8 modu

c     REAL MODU                                                         CUU    4

      COMMON/UU/MODU(4)                                                 CUU    5

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

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

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

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

C     COMMON DECK "FNDER" INSERTED HERE                                 CFNDER 2

      COMMON/FNDER/NZ,NPZR,NPZRR,NPZRTH,NPZRPH,NPZTH,NPZPH,NPZTHTH      CFNDER 4

      COMMON/FNDER/NPZPHPH,NPZTHPH,NSELECT,NTIME                        CFNDER 5

C                                                                       REFLEC12

      REAL*8 NR,NTH,NPH,KRNR,KPARR,KPARTH,KPARPH                        REFLEC13

      real*8 anr(3)

      equivalence (anr(1),nr),(anr(2),nth),(anr(3),nph)

C                                                                       REFLEC14

      IENTRY=1                                                          REFLEC15

      REFLECT=0.0                                                       REFLEC16

      GO TO 5                                                           REFLEC17

C                                                                       REFLEC18

      ENTRY KPARLEL(Z)                                                  REFLEC19

      KPARLEL=0.0                                                       REFLEC20

      IENTRY=2                                                          REFLEC21

      GO TO 5                                                           REFLEC22

C                                                                       REFLEC23

      ENTRY KNORM(Z)                                                    REFLEC24

      KNORM=0.0                                                         REFLEC25

      IENTRY=3                                                          REFLEC26

C                                                                       REFLEC27

5     zholdr = get(z)

      Z(1)=zholdr                                                       REFLEC28

      NR=Z(NPZR)                                                        REFLEC29

      NTH=Z(NPZTH)/R                                                    REFLEC30

      NPH=Z(NPZPH)/(R*DSIN(TH))                                         REFLEC31

C                                                                       REFLEC32

      avl = 1.0

      r999=renorm(anr,avl,3)

c     CALL RENORM(NR,1.0,3)                                             REFLEC33

C     COMPUTE THE NORMAL COMPONENT OF K-VECTOR TO SURFACE               REFLEC34

      KRNR=KR*NR+KTH*NTH+KPH*NPH                                        REFLEC35

      IF(IENTRY.NE.3) GO TO 8                                           REFLEC36

C     IF ENTRY 3 THEN WE ARE DONE                                       REFLEC37

      REFLECT=KRNR                                                      REFLEC38

      RETURN                                                            REFLEC39

C                                                                       REFLEC40

C     COMPUTE THE PARALLEL VECTOR COMPONENT                             REFLEC41

8     KPARR=KR-KRNR*NR                                                  REFLEC42

      KPARTH=KTH-KRNR*NTH                                               REFLEC43

      KPARPH=KPH-KRNR*NPH                                               REFLEC44

C                                                                       REFLEC45

      IF(IENTRY.NE.2) GO TO 10                                          REFLEC46

      REFLECT=DABS(KPARR)+DABS(KPARTH)+DABS(KPARPH)                     REFLEC47

      RETURN                                                            REFLEC48

C                                                                       REFLEC49

10    OWIPAR=OW-KPARR*VR-KPARTH*VTH-KPARPH*VPH                          REFLEC50

      VNR=VR*NR+VTH*NTH+VPH*NPH                                         REFLEC51

C                                                                       REFLEC52

      FCTR=2.0*(KRNR+OWIPAR*VNR/(CS-VNR*VNR))                           REFLEC53

      KR=KR-FCTR*NR                                                     REFLEC54

      KTH=KTH-FCTR*NTH                                                  REFLEC55

      KPH=KPH-FCTR*NPH                                                  REFLEC56

      END                                                               REFLEC57











      SUBROUTINE FIT(Z,ZOLD,ZDOLD)                                      FIT    2

c

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

c

C     COMPUTES THREE TYPES OF PARABOLIC FITS TO RAY PATH RELATIVE       FIT    3

C     TO TERRAIN.                                                       FIT    4

C                                                                       FIT    5

      REAL*8 Z(12)                                                      FIT    6

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL*8 KR,KTH,KPH                                                 RKAMCOM4

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

C     COMMON DECK "TRAC" INSERTED HERE                                  CTRAC  2

      LOGICAL GROUND,SURF,PERIGE,THERE,MINDIS,NEWRAY                    CTRAC  4

      COMMON /TRAC/ GROUND,SURF,PERIGE,THERE,MINDIS,NEWRAY,SMT,OSMT     CTRAC  5

      COMMON/TRAC/ROLD(20),DROLD(20),TOLD,ZDOT,D2Z,RAD,RAD1             CTRAC  6

C     COMMON DECK "FNDER" INSERTED HERE                                 CFNDER 2

      COMMON/FNDER/NZ,NPZR,NPZRR,NPZRTH,NPZRPH,NPZTH,NPZPH,NPZTHTH      CFNDER 4

      COMMON/FNDER/NPZPHPH,NPZTHPH,NSELECT,NTIME                        CFNDER 5

C                                                                       FIT   10

      REAL*8 D2(3)                                                      FIT   11

C                                                                       FIT   12

C     USE FIT OF APPENDIX 'J' OF REPORT 'WPL-103' WHICH USES            FIT   13

C     WEIGHTED ESTIMATE OF 1ST DERIVATIVE.                              FIT   14

C                                                                       FIT   15

      IENTRY=1                                                          FIT   16

      GO TO 5                                                           FIT   17

C                                                                       FIT   18

C     USE MODIFIED FIT REQUIRING HEIGHTS OF PARABOLA VERTICES FROM      FIT   19

C     CURRENT AND PREVIOUS RAY POINTS.                                  FIT   20

      ENTRY FIT2(Z,ZOLD,ZDOLD)                                          FIT   21

      IENTRY=2                                                          FIT   22

      GO TO 5                                                           FIT   23

C                                                                       FIT   24

C     USE FIT OF APPENDIX U(LOCAL VALUE OF 1ST DERIVATIVE)              FIT   25

      ENTRY FIT3(Z,ZOLD,ZDOLD)                                          FIT   26

      IENTRY=3                                                          FIT   27

C                                                                       FIT   28

5     ZDOT=DOT(Z)                                                       FIT   29

C                                                                       FIT   30

      DTI=1.0/(TPULSE-TOLD)                                             FIT   31

      DO 10 I=1,3                                                       FIT   32

10    D2(I)=(DRDT(I)-DROLD(I))*DTI                                      FIT   33

C                                                                       FIT   34

      D2Z=Z(NPZR)*D2(1)+Z(NPZTH)*D2(2)+Z(NPZPH)*D2(3)                   FIT   35

     1        +Z(NPZRR)*DRDT(1)*DRDT(1)                                 FIT   36

     1        +Z(NPZTHTH)*DRDT(2)*DRDT(2)                               FIT   37

     1        +Z(NPZPHPH)*DRDT(3)*DRDT(3)                               FIT   38

     1   +2.0*(Z(NPZRTH)*DRDT(1)*DRDT(2)                                FIT   39

     1        +Z(NPZRPH)*DRDT(1)*DRDT(3)                                FIT   40

     1        +Z(NPZTHPH)*DRDT(2)*DRDT(3) )                             FIT   41

C                                                                       FIT   42

C     THE STATEMENTS FROM HERE TO 'END FIT' IMPLEMENT THE               FIT   43

C     PARABOLIC FITS IN EQUATIONS J.1 AND U.3 OF THE TEXT.              FIT   44

C                                                                       FIT   45

      IF(IENTRY.NE.2) GO TO 30                                          FIT   46

      SMT=0.                                                            FIT   47

      IF (D2Z.NE.0.) SMT=0.5*ZDOT*ZDOT/D2Z                              FIT   48

C     USE FIT U.3 AT THE PREVIOUS POINT OF RAY PATH                     FIT   49

      OSMT=0.                                                           FIT   50

      IF (D2Z.NE.0.) OSMT=0.5*ZDOLD*ZDOLD/D2Z                           FIT   51

      GO TO 2000                                                        FIT   52

C                                                                       FIT   53

C     IMPLEMENTATION OF FIT FOR EQUATION J.1                            FIT   54

C                                                                       FIT   55

30    IF(IENTRY.EQ.3) GO TO 1000                                        FIT   56

      ZDOTM=.5*(ZDOT+ZDOLD)                                             FIT   57

C     IMPLEMENT TESTS OF EQUATIONS J.2 AND J.3                          FIT   58

      IF(DABS(ZDOTM).LE..05*DABS(ZDOT)) GO TO 1000                      FIT   59

      FCTR=(Z(NZ)-ZOLD)*DTI/ZDOTM                                       FIT   60

      D2Z=FCTR*D2Z                                                      FIT   61

      ZDOT=FCTR*ZDOT                                                    FIT   62

C     END FIT                                                           FIT   63

C                                                                       FIT   64

C     COMMON CODE FOR FIT AND FIT3                                      FIT   65

1000  RAD=ZDOT*ZDOT-2.0*Z(NZ)*D2Z                                       FIT   66

      xxx=0.0

      RAD1=DSQRT(DMAX1(RAD,xxx))                                        FIT   67

C                                                                       FIT   68

2000  CONTINUE                                                          FIT   69

C                                                                       FIT   70

      END                                                               FIT   71











      FUNCTION GET1(Z)                                                  GET   14

c

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

c

C     FUNCTIONALLY THE SAME AS 'GET' PROGRAM, SEE DOCUMENTATION THERE   GET   15

C     NEEDED BECAUSE RECEIVER MODELS WILL CALL GET TO OBTAIN TERRAIN VA GET   16

C     BUT THEY THEMSELVES ARE CALLED VIA GET. HENCE HAVE RE-ENTRANCE    GET   17

C     PROBLEM.                                                          GET   18

C                                                                       GET   19

      real*8 z(12)

c

c     REAL*8 Z(*)                                                       GET   20

      REAL*8 PF(10),PG(10)                                              GET   21

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL*8 KR,KTH,KPH                                                 RKAMCOM4

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

C     COMMON DECK "FNDER" INSERTED HERE                                 CFNDER 2

      COMMON/FNDER/NZ,NPZR,NPZRR,NPZRTH,NPZRPH,NPZTH,NPZPH,NPZTHTH      CFNDER 4

      COMMON/FNDER/NPZPHPH,NPZTHPH,NSELECT,NTIME                        CFNDER 5

C     COMMON DECK "RR" INSERTED HERE                                    CRR    2

      real*8 modrec

c     REAL MODREC                                                       CRR    4

      COMMON/RR/ MODREC(4)                                              CRR    5

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

      COMMON/RR/PFTH,PFPH,PFTHTH,PFPHPH,PFTHPH,FSELECT,FTIME            CRR    7

C     COMMON DECK "GG" INSERTED HERE                                    CGG    2

      real*8 modg

c     REAL MODG                                                         CGG    4

      COMMON/GG/MODG(4)                                                 CGG    5

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

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

C     COMMON DECK "RKTIME" INSERTED HERE                                CRKTIME2

      COMMON/CRKTIME/RKTIME                                             CRKTIME4

C                                                                       GET   27

C     COMMON DECK "RMACH" INSERTED HERE                                 CRMACH 2

      real*8 rmach

      COMMON/CRMACH/RMACH(5)                                            CRMACH 4

      EQUIVALENCE(RKTIME,IRKTIME)                                       GET   29

C     COMMON DECK "WWR" INSERTED HERE                                   CWWR   2

      PARAMETER (NWARSZ=1000)                                           CWW1   3

      real*8 id

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

C                                                                       GET   31

      COMMON/CGET/ZERO                                                  GET   32

C                                                                       GET   33

      IENTRY=1                                                          GET   34

      GO TO 5                                                           GET   35

C                                                                       GET   36

      ENTRY DOT1(Z)                                                     GET   37

      IENTRY=2                                                          GET   38

5     CONTINUE                                                          GET   39

      IF(ZERO.EQ.0.0) ZERO=EARTHR*RMACH(3)*2.0                          GET   40

C                                                                       GET   41

      if (z(ntime) .eq. rktime) go to 10

c     IF(ITEST(Z(NTIME)).EQ.IRKTIME) GO TO 10                           GET   42

C                                                                       GET   43

      IF(Z(NSELECT).EQ.FSELECT) CALL RECEVER                            GET   44

      IF(Z(NSELECT).EQ.GSELECT) CALL TOPOG                              GET   45

      Z(NTIME)=RKTIME                                                   GET   46

C     REMOVE MACHINE ROUND OFF NOISE FROM EXACT RECEIVER LOCATIONS      GET   47

      IF(DABS(Z(NZ)).LE.ZERO) Z(NZ)=0.0                                 GET   48

C                                                                       GET   49

10    IF(IENTRY.NE.1) GO TO 20                                          GET   50

      GET1=Z(NZ)                                                        GET   51

      RETURN                                                            GET   52

C                                                                       GET   53

20    GET1=Z(NPZR)*DRDT(1)+Z(NPZTH)*DRDT(2)+Z(NPZPH)*DRDT(3)            GET   54

      dot1 = get1

      RETURN                                                            GET   55

      ENTRY GETST1(Z)                                                   GET   56

C                                                                       GET   57

C     FORCE LOAD THE GET ROUTINE                                        GET   58

      getst1 = get(z)

c     CALL GET                                                          GET   59

      END                                                               GET   60











      FUNCTION GET(Z)                                                   GET   61

c

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

c

C     'GET' AND ENTRY 'DOT' PROVIDE A CONTROL METHOD FOR AVOIDING       GET   62

C     REDUNDANT CALLS TO THE TERRAIN AND RECEIVER MODELS. THE VALUES    GET   63

C     RETURNED ARE THE FUNCTION VALUES FOR 'F' OR 'G' OR THEIR DERIVATI GET   64

C     (VIA 'DOT' ENTRY). UNNECESSARY CALLS ARE ELIMINATED THROUGH USE   GET   65

C     OF 'TIME OF CALL' VARIABLES WHICH ARE COMPARED WITH THE CURRENT   GET   66

C     LAST CALL TIME MAINTAINED BY THE 'RKAM' PROGRAM. WHEN VALUES ARE  GET   67

C     NOT CURRENT THEY ARE UPDATED BY CALLS TO THE APPROPRIATE ROUTINES GET   68

C                                                                       GET   69

      REAL*8 Z(12),PF(10),PG(10)                                        GET   70

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL*8 KR,KTH,KPH                                                 RKAMCOM4

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

C     COMMON DECK "FNDER" INSERTED HERE                                 CFNDER 2

      COMMON/FNDER/NZ,NPZR,NPZRR,NPZRTH,NPZRPH,NPZTH,NPZPH,NPZTHTH      CFNDER 4

      COMMON/FNDER/NPZPHPH,NPZTHPH,NSELECT,NTIME                        CFNDER 5

C     COMMON DECK "RR" INSERTED HERE                                    CRR    2

      real*8 modrec

c     REAL MODREC                                                       CRR    4

      COMMON/RR/ MODREC(4)                                              CRR    5

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

      COMMON/RR/PFTH,PFPH,PFTHTH,PFPHPH,PFTHPH,FSELECT,FTIME            CRR    7

C     COMMON DECK "GG" INSERTED HERE                                    CGG    2

      real*8 modg

c     REAL MODG                                                         CGG    4

      COMMON/GG/MODG(4)                                                 CGG    5

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

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

C     COMMON DECK "RKTIME" INSERTED HERE                                CRKTIME2

      COMMON/CRKTIME/RKTIME                                             CRKTIME4

C                                                                       GET   76

C     COMMON DECK "RMACH" INSERTED HERE                                 CRMACH 2

      real*8 rmach

      COMMON/CRMACH/RMACH(5)                                            CRMACH 4

      EQUIVALENCE(RKTIME,IRKTIME)                                       GET   78

C                                                                       GET   79

C     COMMON DECK "WWR" INSERTED HERE                                   CWWR   2

      PARAMETER (NWARSZ=1000)                                           CWW1   3

      real*8 id

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

C                                                                       GET   81

      COMMON/CGET/ZERO                                                  GET   82

C                                                                       GET   83

C                                                                       GET   86

      IENTRY=1                                                          GET   87

      GO TO 5                                                           GET   88

C                                                                       GET   89

      ENTRY DOT(Z)                                                      GET   90

      IENTRY=2                                                          GET   91

5     CONTINUE                                                          GET   92

      IF(ZERO.EQ.0.0) ZERO=EARTHR*RMACH(3)*2.0                          GET   93

C                                                                       GET   94

      if (z(ntime) .eq. rktime) go to 10

c     IF(ITEST(Z(NTIME)).EQ.IRKTIME) GO TO 10                           GET   95

C                                                                       GET   96

      IF(Z(NSELECT).EQ.FSELECT) CALL RECEVER                            GET   97

      IF(Z(NSELECT).EQ.GSELECT) CALL TOPOG                              GET   98

      Z(NTIME)=RKTIME                                                   GET   99

C     REMOVE MACHINE ROUND OFF NOISE FROM EXACT RECEIVER LOCATIONS      GET  100

      IF(DABS(Z(NZ)).LE.ZERO) Z(NZ)=0.0                                 GET  101

C                                                                       GET  102

10    IF(IENTRY.NE.1) GO TO 20                                          GET  103

      GET=Z(NZ)                                                         GET  104

      RETURN                                                            GET  105

C                                                                       GET  106

20    GET=Z(NPZR)*DRDT(1)+Z(NPZTH)*DRDT(2)+Z(NPZPH)*DRDT(3)             GET  107

      dot = get

      RETURN                                                            GET  108

c     ENTRY DFCNCL(Z)                                                   GET  109

C                                                                       GET  110

C     FORCE LOAD THE MACHINE DEPENDENT CONSTANTS(SEE MODULE 'DFCNST')   GET  111

C                                                                       GET  112

c     CALL DFCNST                                                       GET  113

      END                                                               GET  114











      FUNCTION ITEST(I)                                                 ITEST  2

C     USED TO PASS INTEGER VALUES THROUGH FOR VARIABLES TYPED REAL      ITEST  3

C     (AS IN MIXED REAL/INTEGER ARRAYS)                                 ITEST  4

      ITEST=I                                                           ITEST  5

      END                                                               ITEST  6







      SUBROUTINE CONBLK                                                 CONBLK 3

c

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

c

C     DATA INITIALIZATION AND FILE OPENING SERVICE ROUTINE              CONBLK 4

C                                                                       CONBLK 5

C     COMMON DECK "HDR" INSERTED HERE                                   CHDR   2

      CHARACTER*10 INITID*80,DAT,TOD                                    CHDR   4

      COMMON/HDR/SEC                                                    CHDR   5

      COMMON/HDRC/INITID,DAT,TOD                                        CHDR   6

C                                                                       CONBLK 9

C     COMMON DECK "CPROCFL" INSERTED HERE                               CPROCFL2

      INTEGER PMX,PNTBL,PITBL,PFRMTBL,IDSP(20)                          CPROCFL4

C     PARAMETER DECK "PGROUPS"                                          PGROUPS2

      PARAMETER (NCHPG1=11,NWPV=250,NSPGP=NCHPG1+2*NWPV+1)              PGROUPS3

      PARAMETER (MNGRP=9,MXGRP=69,MXLIST=MXGRP-MNGRP+2)                 PGROUPS4

      COMMON/PROCFL/LIST(MXLIST)                                        CPROCFL6

      COMMON/PROCFL/PMX,PNTBL(10),PITBL(10),PFRMTBL(10),PGP(NSPGP)      CPROCFL7

      EQUIVALENCE (PGP,IDSP)                                            CPROCFL8

C     COMMON DECK "CC" INSERTED HERE                                    CCC    2

c     REAL MODC                                                         CCC    4

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

C     COMMON DECK "GG" INSERTED HERE                                    CGG    3

      real*8 modg

c     REAL MODG                                                         CGG    4

      COMMON/GG/MODG(4)                                                 CGG    5

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

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

C     COMMON DECK "RR" INSERTED HERE                                    CRR    2

      real*8 modrec

c     REAL MODREC                                                       CRR    4

      COMMON/RR/ MODREC(4)                                              CRR    5

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

      COMMON/RR/PFTH,PFPH,PFTHTH,PFPHPH,PFTHPH,FSELECT,FTIME            CRR    7

C     COMMON DECK "TT" INSERTED HERE                                    CTT    2

c     REAL MODT                                                         CTT    4

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

C     COMMON DECK "UU" INSERTED HERE                                    CUU    2

c     REAL MODU                                                         CUU    4

c     COMMON/UU/MODU(4)                                                 CUU    5

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

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

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

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

c                                                                       CONBLK16

C     COMMON DECK "RAYDEV" INSERTED HERE                                CRAYDEV2

C     DEVICE ASSIGNED TO RAYTRC INPUT FILE                              CRAYDEV4

      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVGRP,NDEVBIN               CRAYDEV5

C     COMMON DECK "CUCON" INSERTED HERE                                 CUCON  2

c     COMMON/UCONV/CNVV(4,4)                                            CUCON  4

c     CHARACTER PCV*3,CNVC*2                                            CUCON  5

c     COMMON/UCONC/PCV(4),CNVC(4,4)                                     CUCON  6

C                                                                       CONBLK19

C     COMMON DECK "SS" INSERTED HERE                                    CSS    2

c     REAL MODSURF                                                      CSS    4

c     COMMON/SS/ MODSURF(4)                                             CSS    5

c     COMMON/SS/U,PUR,PURR,PURTH,PURPH                                  CSS    6

c     COMMON/SS/PUTH,PUPH,PUTHTH,PUPHPH,PUTHPH,USELECT,UTIME            CSS    7

C     COMMON DECK "CONST" INSERTED HERE                                 CCONST 2

c     COMMON/PCONST/CREF,RGAS,GAMMA                                     CCONST 4

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

C     COMMON DECK "WWR" INSERTED HERE                                   CWWR   2

c     PARAMETER (NWARSZ=1000)                                           CWW1   3

c     real*8 id

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

c     REAL MAXSTP,MAXERR,INTYP,LLAT,LLON                                CWW2   2

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

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

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

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

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

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

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

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

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

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

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

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

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

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

C     COMMON DECK "B9" INSERTED HERE                                    CB8    2

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

c     COMMON/B9/GMX,GNTBL(10),GITBL(10),GFRMTBL(10),GGP(113)            CB8    5

c     EQUIVALENCE (GGP,IDSG),(ANG,GGP(11))                              CB8    6

C     COMMON DECK "B2" INSERTED HERE                                    CB2    2

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

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

c     EQUIVALENCE (DUGP,IDSDU)                                          CB2    6

C     COMMON DECK "B4" INSERTED HERE                                    CB4    2

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

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

c     EQUIVALENCE (DCGP,IDSDC)                                          CB4    6

C     COMMON DECK "B6" INSERTED HERE                                    CB6    2

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

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

c     EQUIVALENCE (DTGP,IDSDT)                                          CB6    6

C     COMMON DECK "B1" INSERTED HERE                                    CB1    2

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

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

c     EQUIVALENCE (UGP,IDSU)                                            CB1    6

C     COMMON DECK "B3" INSERTED HERE                                    CB3    2

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

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

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

C     COMMON DECK "B5" INSERTED HERE                                    CB5    2

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

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

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

C     COMMON DECK "B7" INSERTED HERE                                    CB7    2

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

c     REAL MGP                                                          CB7    5

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

c     EQUIVALENCE (MGP,IDSM)                                            CB7    7

C     COMMON DECK "RINPLEX" INSERTED HERE                               CRINPLE2

c     REAL KAY2,KAY2I                                                   CRINPLE4

c     COMPLEX*16 PNP,POLAR,LPOLAR                                       CRINPLE5

c     LOGICAL SPACE                                                     CRINPLE6

c     CHARACTER DISPM*6                                                 CRINPLE7

c     COMMON/RINPL/DISPM                                                CRINPLE8

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

c     COMMON/RIN/OMEGMIN,OMEGMAX,KAY2,KAY2I                             CRINPL10

c     COMMON/RIN/PNP(10),POLAR,LPOLAR,SGN                               CRINPL11

C     COMMON DECK "MM" INSERTED HERE                                    CMM    2

c     REAL M,MODM                                                       CMM    4

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

C     COMMON DECK "PP" INSERTED HERE                                    CPP    2

c     REAL MODP                                                         CPP    4

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

C     COMMON DECK "AA" INSERTED HERE                                    CAA    2

c     REAL MODA                                                         CAA    4

c     REAL MU,MUPT,MUPR,MUPTH,MUPPH                                     CAA    5

c     REAL KAP,KAPPT,KAPPR,KAPPTH,KAPPPH                                CAA    6

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

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

C     COMMON DECK "FLAG" INSERTED HERE                                  CFLAG  2

c     LOGICAL NEWWR,NEWWP,NEWTRC,PENET                                  CFLAG  4

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

c     COMMON/FLGP/NSET                                                  CFLAG  6

C     COMMON DECK "RKTIME" INSERTED HERE                                CRKTIME2

c     COMMON/CRKTIME/RKTIME                                             CRKTIME4

C                                                                       CONBLK37

c     COMMON/RAYCON/MCONP                                               CONBLK38

C                                                                       CONBLK39

c     EQUIVALENCE(RKTIME,IRKTIME)                                       CONBLK40

C                                                                       CONBLK41

C     COMMON DECK "B10" INSERTED HERE                                   CB9    2

c     INTEGER DGMX,DGNTBL,DGITBL,DGFRMTB,IDSDG(10)                      CB9    4

c     COMMON/B10/DGMX,DGNTBL(10),DGITBL(10),DGFRMTB(10),DGGP(10)        CB9    5

c     EQUIVALENCE (DGGP,IDSDG)                                          CB9    6

C     COMMON DECK "B8" INSERTED HERE                                    CB10   2

c     INTEGER RMX,RNTBL,RITBL,RFRMTBL,IDSR(10)                          CB10   4

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

c     EQUIVALENCE (RGP,IDSR)                                            CB10   6

C     COMMON DECK "CB17" INSERTED HERE                                  CB17   2

c     INTEGER VMX,VNTBL,VITBL,VFRMTBL,IDSV(10)                          CB17   4

c     COMMON/B17/VMX,VNTBL(10),VITBL(10),VFRMTBL(10),VGP(53)            CB17   5

c     EQUIVALENCE (VGP,IDSV),(ANV,VGP(11))                              CB17   6

C     COMMON DECK "CB18" INSERTED HERE                                  CB18   2

c     INTEGER DVMX,DVNTBL,DVITBL,DVFRMTB,IDSDV(10)                      CB18   4

c     COMMON/B18/DVMX,DVNTBL(10),DVITBL(10),DVFRMTB(10),DVGP(11)        CB18   5

c     EQUIVALENCE (DVGP,IDSDV),(ANDV,DVGP(11))                          CB18   6

C     COMMON DECK "CB19" INSERTED HERE                                  CB19   2

c     INTEGER PRMX,PRNTBL,PRITBL,PRFRMTB,IDSPR(10)                      CB19   4

c     COMMON/B19/PRMX,PRNTBL(10),PRITBL(10),PRFRMTB(10),PRGP(11)        CB19   5

c     EQUIVALENCE (PRGP,IDSPR),(ANP,PRGP(11))                           CB19   6

C     COMMON DECK "CB20" INSERTED HERE                                  CB20   2

c     INTEGER DPMX,DPNTBL,DPITBL,DPFRMTB,IDSDP(10)                      CB20   4

c     COMMON/B20/DPMX,DPNTBL(10),DPITBL(10),DPFRMTB(10),DPGP(11)        CB20   5

c     EQUIVALENCE (DPGP,IDSDP),(ANDP,DPGP(11))                          CB20   6

c     REAL KVECT(22)                                                    CONBLK48

c     REAL VSET(20)                                                     CONBLK49

c     EQUIVALENCE(KVECT,KAY2),(VSET,V)                                  CONBLK50

C                                                                       CONBLK51

C                                                                       CONBLK82

      RETURN                                                            CONBLK91

C                                                                       CONBLK92

      ENTRY STDINI                                                      CONBLK93

      CALL OPNREP(NDEVTMP,'TAPE4')                                      CONBLK94

      CALL OPNURP(NDEVBIN,'TAPE6')                                      CONBLK95

      CALL OPNREP(9,'PUNCH')                                            CONBLK96

C                                                                       CONBLK97

      ENTRY STDINT                                                      CONBLK98

      OPEN(UNIT=NRYIND,FILE='DINP',STATUS='OLD',ERR=1000)               CONBLK99

      REWIND NRYIND                                                     CONBL100

      CALL OPNREP(2,'OUTPUT')                                           CONBL101

      CALL OPNREP(3,'DOUTP')                                            CONBL102

      CALL OPNURP(NDEVGRP,'TAPE5')                                      CONBL103

C                                                                       CONBL104

C     TEMPORARY WE HOPE, TO MAKE CRAY VERSION WORK                      CONBL105

      FSELECT=8HRECEIVER                                                CONBL106

      GSELECT=7HTERRAIN                                                 CONBL107

C  INITIALIZE RAYSET FILE                                               CONBL108

      READ(NRYIND,'(A)',END=1000) INITID                                CONBL109

      CALL SETW                                                         CONBL110

      CALL SYSDAT(DAT)                                                  CONBL111

      CALL SYSTIM(TOD)                                                  CONBL112

      CALL SYSSEC(SEC)                                                  CONBL113

C     INITIALIZE POINT MODEL LIST                                       CONBL114

      LIST(1)=1                                                         CONBL115

      LIST(2)=0                                                         CONBL116

C     FILL FORMAT CONTROL ARRAYS                                        CONBL117

      PNTBL(1)=1                                                        CONBL118

C     ALLOW FOR AN 80 CHARACTER IDENT STRING(A8)                        CONBL119

      PNTBL(2)=NCHPG1                                                   CONBL120

C     ALLOW MAXIMUM 250 WORD PER VARIABLE                               CONBL121

      PITBL(2)=NWPV                                                     CONBL122

C     FOR BOTH X AND Y PLUS 1 FOR NUMBER OF VARIABLES                   CONBL123

      PNTBL(3)=NSPGP                                                    CONBL124

      RETURN                                                            CONBL125

1000  STOP 'DINP FORMAT ERROR'                                          CONBL126

      END                                                               CONBL127





      LOGICAL FUNCTION WCHANGE(W1,W2)                                   WCHANGE2

c

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

c

      REAL*8 W1(400),W2(400)                                            WCHANGE3

C                                                                       WCHANGE4

C WCHANGE PROVIDES A TEST AGAINST TWO W-ARRAYS                          WCHANGE5

C     IF BOTH WOULD PRODUCE THE SAME SET OF RAYS BY RAYTRC THEN RESULT  WCHANGE6

C     IS <FALSE>.                                                       WCHANGE7

C                                                                       WCHANGE8

      INTEGER NDX(8)                                                    WCHANGE9

C                                                                       WCHANG10

      DATA NGRPS,NDX/8, 1,17, 21,26, 41,47, 100,399/                    WCHANG11

C                                                                       WCHANG12

      WCHANGE=.FALSE.                                                   WCHANG13

      DO 20 N=1,NGRPS,2                                                 WCHANG14

         N1=NDX(N)                                                      WCHANG15

         N2=NDX(N+1)                                                    WCHANG16

      DO 20 I=N1,N2                                                     WCHANG17

          WCHANGE=W1(I).NE.W2(I)                                        WCHANG18

          IF(WCHANGE) RETURN                                            WCHANG19

20    CONTINUE                                                          WCHANG20

      END                                                               WCHANG21











      FUNCTION RENORM(VECTOR,NNORM,NCOMPS)                              RENORM 2

c

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

c

C     NORMALIZES 'NCOMPS' COMPONENT VECTOR 'VECTOR' TO MAGNITUDE        RENORM 3

C     'NNORM' AND RETURNS SQUARE ROOT OF FACTOR NEEDED.                 RENORM 4

      REAL*8 NNORM,VECTOR(*)                                            RENORM 5

C                                                                       RENORM 6

      RENORM=0.0                                                        RENORM 7

      IF(NNORM.LE.0.0) RETURN                                           RENORM 8

C                                                                       RENORM 9

      RENORM=0.0                                                        RENORM10

      DO 10 I=1,NCOMPS                                                  RENORM11

10    RENORM=RENORM+VECTOR(I)*VECTOR(I)                                 RENORM12

      IF(RENORM.EQ.0.0) RETURN                                          RENORM13

C                                                                       RENORM14

      RENORM=DSQRT(NNORM/RENORM)                                        RENORM15

      DO 20 I=1,NCOMPS                                                  RENORM16

20    VECTOR(I)=VECTOR(I)*RENORM                                        RENORM17

C                                                                       RENORM18

      RETURN                                                            RENORM19

      END                                                               RENORM20











      SUBROUTINE SET2(A,V,N)                                            SET2   2

c

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

c

C     SETS N COMPONENTS OF VECTER TO SINGLE VALUE V                     SET2   3

C                                                                       SET2   4

      REAL*8 A(N)                                                       SET2   5

C                                                                       SET2   6

      DO 100 I=1,N                                                      SET2   7

100   A(I)=V                                                            SET2   8

      END                                                               SET2   9











      SUBROUTINE PRINTR(EVENT,CARD)                                     PRINTR 2

c

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

c

C                                                                       PRINTR 3

      CHARACTER EVENT*9,testme*9,NWHY*8,CC*1,PC*1,TMP*9                 PRINTR 4

C                                                                       PRINTR 5

C     PRINTS OUTPUT AND OUTPUTS RAYSETS(MACHINE READABLE OUTPUT)        PRINTR 6

C     WHEN 'CARD' ARGUMENT NONZERO.                                     PRINTR 7

      REAL*8 KNORM                                                      PRINTR 8

      DIMENSION G0(3,3),G1(3,3)                                         PRINTR 9

      CHARACTER*12 HEADRS(20),HEAD(20),UNITS(20),UNIT(20)               PRINTR10

      DIMENSION RPRINT(20),NPR(20)                                      PRINTR11

C     COMMON DECK "RK" INSERTED HERE                                    CRK    2

C     DEFINE SIZE REQUIRED FOR RAY STATE SAVE ARRAY                     CRK    4

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

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

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

C     COMMON DECK "CERR" INSERTED HERE                                  CERR   2

      COMMON/ERR/NERG,NERR,NERT,NERP                                    CERR   3

C     COMMON DECK "GG" INSERTED HERE                                    CGG    2

      real*8 modg

c     REAL MODG                                                         CGG    4

      COMMON/GG/MODG(4)                                                 CGG    5

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

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

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,NEWTRC,PENET                                  CFLAG  4

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

      COMMON/FLGP/NSET                                                  CFLAG  6

C     COMMON DECK "RINPLEX" INSERTED HERE                               CRINPLE2

      REAL*8 KAY2,KAY2I                                                 CRINPLE4

      COMPLEX*16 PNP,POLAR,LPOLAR                                       CRINPLE5

      LOGICAL SPACE                                                     CRINPLE6

      CHARACTER DISPM*6                                                 CRINPLE7

      COMMON/RINPL/DISPM                                                CRINPLE8

c

      real*8 modrin

c      

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

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

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

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL*8 KR,KTH,KPH                                                 RKAMCOM4

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

C     COMMON DECK "WW" INSERTED HERE                                    CWW    2

      PARAMETER (NWARSZ=1000)                                           CWW1   3

      real*8 id

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      REAL*8 MMODEL,MFORM,MID                                           CWW3   2

C                                                                       CWW3   3

C     WIND        100-124                                               CWW3   4

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

C                                                                       CWW3   6

C     DELTA WIND        125-149                                         CWW3   7

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

C                                                                       CWW3   9

C     SOUND SPEED 150-174                                               CWW3  10

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

      EQUIVALENCE (W(153),REFC)                                         CWW3  12

C                                                                       CWW3  13

C     DELTA SOUND SPEED 175-199                                         CWW3  14

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

C                                                                       CWW3  16

C     TEMPERATURE    200-224                                            CWW3  17

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

C                                                                       CWW3  19

C     DELTA TEMPERATURE    225-249                                      CWW3  20

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

C                                                                       CWW3  22

C     MOLECULAR   250-274                                               CWW3  23

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

C                                                                       CWW3  25

C     RECEIVER HEIGHT   275-299                                         CWW3  26

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

C                                                                       CWW3  28

C     TOPOGRAPHY   300-324                                              CWW3  29

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

C                                                                       CWW3  31

C     DELTA TOPOGRAPHY   325-349                                        CWW3  32

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

C                                                                       CWW3  34

C     UPPER SURFACE TOPOGRAPHY   350-374                                CWW3  35

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

C     PLOT ENHANCEMENTS CONTROL PARAMETERS                              CWW3  37

C                                                                       CWW3  38

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

C     ABSORPTION        500-524                                         CWW3  40

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

C                                                                       CWW3  42

C     DELTA ABSORPTION        525-549                                   CWW3  43

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

C                                                                       CWW3  45

C     PRESSURE        550-574                                           CWW3  46

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

C                                                                       CWW3  48

C     DELTA PRESSURE        575-599                                     CWW3  49

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

C                                                                       CWW3  51

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

c

      real*8 gtoo(12)

      equivalence (gtoo(1),g)

c

      DATA                                                              PRINTR21

     2  HEADRS(7)/'  PHASE TIME'/,UNITS(7)/'   SEC'/                    PRINTR22

     3 ,HEADRS(8)/'  ABSORPTION'/,UNITS(8)/'   DB '/                    PRINTR23

     4 ,HEADRS(9)/'   DOPPLER  '/,UNITS(9)/'  C/,S '/                   PRINTR24

     5 ,HEADRS(10)/' PATH LENGTH'/,UNITS(10)/'   KM '/                  PRINTR25

     6 ,HEADRS(11)/' TERRAIN'/,UNITS(11)/' '/                           PRINTR26

     7 ,HEADRS(12)/' TERRAIN PGR'/,UNITS(12)/' '/                       PRINTR27

     8 ,HEADRS(13)/' TERRAIN PGT'/,UNITS(13)/' '/                       PRINTR28

     9 ,HEADRS(14)/' TERRAIN PGP'/,UNITS(14)/' '/                       PRINTR29

      data testme/'testme'/

C                                                                       PRINTR30

C      ROUND-OFF FUNCTION                                               PRINTR31

      ROUND(X)=DSIGN(DABS(X)+0.5,X)                                     PRINTR32

C                                                                       PRINTR33

c     go to 6543

      WRITE (*,789) EVENT

  789 format(1x,a9)

      NWHY=EVENT(2:)                                                    PRINTR34

      GO TO 10                                                          PRINTR35

C                                                                       PRINTR36

C     INITIALIZATION ENTRY POINT FOR PRINTR. CALLED FOR EACH NEW        PRINTR37

C     W-ARRAY.                                                          PRINTR38

      ENTRY IPRINTR                                                     PRINTR39

C                                                                       PRINTR40

C********* NEW W ARRAY -- REINITIALIZE                                  PRINTR41

      NEWWP=.FALSE.                                                     PRINTR42

      SPL=DSIN(PLON-TLON)                                               PRINTR43

      CPL=DSIN(PID2-(PLON-TLON))                                        PRINTR44

      SP=DSIN(PLAT)                                                     PRINTR45

      CP=DSIN(PID2-PLAT)                                                PRINTR46

      SL=DSIN(TLAT)                                                     PRINTR47

      CL=DSIN(PID2-TLAT)                                                PRINTR48

C********* MATRIX TO ROTATE COORDINATES                                 PRINTR49

      G0(1,1)=CPL*SP*CL-CP*SL                                           PRINTR50

      G0(1,2)=SPL*SP                                                    PRINTR51

      G0(1,3)=-SL*SP*CPL-CL*CP                                          PRINTR52

      G0(2,1)=-SPL*CL                                                   PRINTR53

      G0(2,2)=CPL                                                       PRINTR54

      G0(2,3)=SL*SPL                                                    PRINTR55

      G0(3,1)=CL*CP*CPL+SP*SL                                           PRINTR56

      G0(3,2)=CP*SPL                                                    PRINTR57

      G0(3,3)=-SL*CP*CPL+SP*CL                                          PRINTR58

      DENM=G0(1,1)*G0(2,2)*G0(3,3)+G0(1,2)*G0(3,1)*G0(2,3)              PRINTR59

     1   +G0(2,1)*G0(3,2)*G0(1,3)-G0(2,2)*G0(3,1)*G0(1,3)               PRINTR60

     2   -G0(1,2)*G0(2,1)*G0(3,3)-G0(1,1)*G0(3,2)*G0(2,3)               PRINTR61

c

      if (denm .eq. 0.) stop 'inverting g1'

c

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

      G1(1,1)=(G0(2,2)*G0(3,3)-G0(3,2)*G0(2,3))/DENM                    PRINTR63

      G1(1,2)=(G0(3,2)*G0(1,3)-G0(1,2)*G0(3,3))/DENM                    PRINTR64

      G1(1,3)=(G0(1,2)*G0(2,3)-G0(2,2)*G0(1,3))/DENM                    PRINTR65

      G1(2,1)=(G0(3,1)*G0(2,3)-G0(2,1)*G0(3,3))/DENM                    PRINTR66

      G1(2,2)=(G0(1,1)*G0(3,3)-G0(3,1)*G0(1,3))/DENM                    PRINTR67

      G1(2,3)=(G0(2,1)*G0(1,3)-G0(1,1)*G0(2,3))/DENM                    PRINTR68

      G1(3,1)=(G0(2,1)*G0(3,2)-G0(3,1)*G0(2,2))/DENM                    PRINTR69

      G1(3,2)=(G0(3,1)*G0(1,2)-G0(1,1)*G0(3,2))/DENM                    PRINTR70

      G1(3,3)=(G0(1,1)*G0(2,2)-G0(2,1)*G0(1,2))/DENM                    PRINTR71

      R0=EARTHR+XMTRH                                                   PRINTR72

C********* CARTESIAN COORDINATES OF TRANSMITTER                         PRINTR73

      XR=R0*G0(1,1)                                                     PRINTR74

      YR=R0*G0(2,1)                                                     PRINTR75

      ZR=R0*G0(3,1)                                                     PRINTR76

      CTHR=G0(3,1)                                                      PRINTR77

      STHR=DSIN(ACOS (CTHR))                                            PRINTR78

      PHIR=DATAN2(YR,XR)                                                PRINTR79

      ALPH=DATAN2(G0(3,2),G0(3,3))                                      PRINTR80

C*********                                                              PRINTR81

      NR=0                                                              PRINTR82

      NP=0                                                              PRINTR83

      NERG=0                                                            PRINTR84

      NERR=0                                                            PRINTR85

      NERT=0                                                            PRINTR86

      NERP=0                                                            PRINTR87

C     INSURE NO GARBLE IN HEADERS                                       PRINTR88

      HEAD(1)=' '                                                       PRINTR89

      UNIT(1)=' '                                                       PRINTR90

C                                                                       PRINTR91

      DO 7 NN=7,20                                                      PRINTR92

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

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

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

      NR=NR+1                                                           PRINTR96

C     ENABLE SELECTED RELATIVE ERROR PRINTOUTS FOR TERRAIN(G) OR        PRINTR97

C     ITS DERIVATIVES WITH RESPECT TO (R)ANGE, (T)HETA OR (P)HI.        PRINTR98

      IF(NN.EQ.11) NERG=NR                                              PRINTR99

      IF(NN.EQ.12) NERR=NR                                              PRINT100

      IF(NN.EQ.13) NERT=NR                                              PRINT101

      IF(NN.EQ.14) NERP=NR                                              PRINT102

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

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

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

C********* PRINTED                                                      PRINT106

      NP=NP+1                                                           PRINT107

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

      NPR(NP)=NR                                                        PRINT109

      HEAD(NP)=HEADRS(NN)                                               PRINT110

      HEAD(NP)=HEADRS(NN)                                               PRINT111

      UNIT(NP)=UNITS(NN)                                                PRINT112

    7 CONTINUE                                                          PRINT113

      NPM=MIN0(NP,3)                                                    PRINT114

      NP1=NPM+1                                                         PRINT115

      P=0.0                                                             PRINT116

      ABSORB=0.0                                                        PRINT117

      DOPP=0.0                                                          PRINT118

      NEQS=NR+6                                                         PRINT119

      RETURN                                                            PRINT120

C                                                                       PRINT121

      ENTRY PRNHD1(CC)                                                  PRINT122

C     PRINT PRINTR HEADER 1                                             PRINT123

C   IF NO OUTPUT NEEDED EXIT NOW                                        PRINT124

      IF(PRTSRP.NE.0.0) RETURN                                          PRINT125

C                                                                       PRINT126

C     ADD NUMBER OF LINES NEEDED FOR THIS HEADER                        PRINT127

      PC=CC                                                             PRINT128

      IF(CC.EQ.'1') CALL NEWPAG(NPAG,INT(PAGLN),PC)                     PRINT129

      LINES=LINES+3                                                     PRINT130

C********* PRINT COLUMN HEADINGS                                        PRINT131

C                                                                       PRINT132

      WRITE(3,1100) PC,(HEAD(NN),NN=1,NPM)                              PRINT133

C                                                                       PRINT134

1100  FORMAT (   A,T25,'ELEVATION',T54,'AZIMUTH',T71,'ELEVATION'/       PRINT135

     3 ,T20,2('ABOVE',6X),T53,'DEVIATION',T72,'ANGLE'/'  ERROR   EVENT' PRINT136

     4  ,T20,'SEA LEVEL  TERRAIN     RANGE',4X,2('XMTR   LOCAL',5X),    PRINT137

     5  'PULSE TIME',3A12)                                              PRINT138

C                                                                       PRINT139

      WRITE(3,1150) (UNIT(NN),NN=1,NPM)                                 PRINT140

 1150 FORMAT(13X,3(8X,'KM'),2X,2(6X,'DEG',5X,'DEG'),T88                 PRINT141

     1 ,'SEC',3X,3(3X,A7,2X))                                           PRINT142

C                                                                       PRINT143

      RETURN                                                            PRINT144

C                                                                       PRINT145

      ENTRY PRNHD2(CC)                                                  PRINT146

C     PRINT PRINTR HEADER 1                                             PRINT147

C   IF NO OUTPUT NEEDED EXIT NOW                                        PRINT148

      IF(PRTSRP.NE.0.0) RETURN                                          PRINT149

C     PAGE BY HALF LENGTH                                               PRINT150

      LINSPP=PAGLN/2                                                    PRINT151

      IF(LINSPP.LT.40) LINSPP=PAGLN                                     PRINT152

      PC=CC                                                             PRINT153

      IF(CC.EQ.'1') CALL NEWPAG(NPAG,LINSPP,PC)                         PRINT154

C     ADD NUMBER OF LINES NEEDED FOR THIS SUBHEADER                     PRINT155

      LINES=LINES+1                                                     PRINT156

C                                                                       PRINT157

      IF(ELEND.GE.ELBEG+ELSTEP) THEN                                    PRINT158

         WRITE(3,'(A,''ELEVATION ANGLE OF TRANSMISSION =''              PRINT159

     1    ,F10.4,'' DEG'')') PC,BETA*DEGS                               PRINT160

      ELSEIF(AZEND.GE.AZBEG+AZSTEP) THEN                                PRINT161

         WRITE(3,'(A,''AZIMUTH ANGLE OF TRANSMISSION =''                PRINT162

     1    ,F10.4,'' DEG'')') PC,AZ1*DEGS                                PRINT163

      ENDIF                                                             PRINT164

      RETURN                                                            PRINT165

C                                                                       PRINT166

C     IF PRINTING SUPPRESSED AND RAYSETS OFF NOTHING TO DO              PRINT167

10    IF(PRTSRP.NE.0.0 .AND. CARD.EQ.0.0) RETURN                        PRINT168

      CALL DISPER                                                       PRINT169

      IF (CARD.EQ.0.0 .OR. IHOP.NE.0) GO TO 12                          PRINT170

C********* OUTPUT A TRANSMITTER RAYSET                                  PRINT171

C        NOTE: THIS IS A SPECIAL CASE, ALL OTHER RAY EVENTS ARE         PRINT172

C           OUTPUT AT CODE 'PUNCH A RAYSET' BELOW.                      PRINT173

C                                                                       PRINT174

      TLOND=TLON*DEGS                                                   PRINT175

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

      TLATD=TLAT*DEGS                                                   PRINT177

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

      AZ=AZ1*DEGS                                                       PRINT179

      EL=BETA*DEGS                                                      PRINT180

      NHOP=HOP                                                          PRINT181

      NXMTRH=ROUND(XMTRH*1.E4)                                          PRINT182

      NTLATD=ROUND(TLATD*1.E3)                                          PRINT183

       NTLOND=ROUND(TLOND*1.E3)                                         PRINT184

      NRCVRH=ROUND(RCVRH*1.E4)                                          PRINT185

       NF=ROUND(OW*1.E4)                                                PRINT186

      NAZ=ROUND(AZ*1.E5)                                                PRINT187

       NEL=ROUND(EL*1.E5)                                               PRINT188

      NPOLAR1=ROUND(DREAL(POLAR)*1.E2)                                  PRINT189

       NPOLAR2=ROUND(DIMAG(POLAR)*1.E2)                                 PRINT190

      WRITE(9,1201) ID(1),TYPE(NTYP),NXMTRH,NTLATD,NTLOND,NRCVRH,NF,NAZ PRINT191

     1 ,NEL,NPOLAR1,NPOLAR2,NHOP,'T'                                    PRINT192

 1201 FORMAT(A3,A1,I9,2I6,2I9,2I10,5X,I5,I4,I2,A1)                      PRINT193

C*********                                                              PRINT194

12    V=1.E10                                                           PRINT195

C     OBTAIN THE WORST ERROR OF THOSE ENABLED.                          PRINT196

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

      ERT=1HK                                                           PRINT198

      V=RERR(V,ERT,'G',NERG,G)                                          PRINT199

      V=RERR(V,ERT,'R',NERR,PGR)                                        PRINT200

      V=RERR(V,ERT,'T',NERT,PGTH)                                       PRINT201

      V=RERR(V,ERT,'P',NERP,PGPH)                                       PRINT202

C                                                                       PRINT203

      H=R-EARTHR                                                        PRINT204

      STH=DSIN(THETA)                                                   PRINT205

      CTH=DSIN(PID2-THETA)                                              PRINT206

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

      XP=R*STH*DSIN(PID2-PHI)-XR                                        PRINT208

      YP=R*STH*DSIN(PHI)-YR                                             PRINT209

      ZP=R*CTH-ZR                                                       PRINT210

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

C********* ROTATED                                                      PRINT212

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

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

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

      RCE2=ETA**2+ZETA**2                                               PRINT216

      RCE=DSQRT(RCE2)                                                   PRINT217

C********* GROUND RANGE                                                 PRINT218

      RANGE=EARTHR*DATAN2(RCE,EARTHR+EPS+XMTRH)                         PRINT219

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

      ELL=DATAN2(KR,DSQRT(KTH**2+KPH**2))*DEGS                          PRINT221

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

      SR=DSQRT(RCE2+EPS**2)                                             PRINT223

C********* TERRAIN RELATIVE HEIGHT                                      PRINT224

      GRH=GET(gtoo)/PGR                                                 PRINT225

C     REPORT GROUP TIME AS FIRST 'OPTION'                               PRINT226

      RPRINT(1)=T                                                       PRINT227

      IF (NP1.LT.2) GO TO 16                                            PRINT228

C     ADD MORE OPTIONS IF REQUESTED                                     PRINT229

      DO 15 I=2,NP1                                                     PRINT230

      NN=NPR(I-1)                                                       PRINT231

   15 RPRINT(I)=RKVARS(NN)                                              PRINT232

C                                                                       PRINT233

16    IF(V.GE.0.0) THEN                                                 PRINT234

         WRITE(TMP,'(A1,E7.2)') ERT,V                                   PRINT235

      ELSE                                                              PRINT236

         WRITE(TMP,'(A1,E7.1)') ERT,V                                   PRINT237

      ENDIF                                                             PRINT238

C     DETERMINE WHERE TO PUT A SPACE                                    PRINT239

C     AT BEGINNING OR END OF 1ST 2 VALUES                               PRINT240

      KT=1                                                              PRINT241

      IF(TMP(1:1).EQ.'K') KT=2                                          PRINT242

C                                                                       PRINT243

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

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

C********* TRANSMITTER                                                  PRINT246

      IF(PRTSRP.EQ.0.0)                                                 PRINT247

     1 WRITE(3,1500)TMP(KT:9),NWHY,H,GRH,RANGE,ELL,(RPRINT(NN),NN=1,NP1)PRINT248

 1500 FORMAT (1X,A8,A8,2F10.4,F11.4,26X,F8.3,4F12.4)                    PRINT249

C     SET RAYSET VARIABLES TO UNDEFINDED VALUES FOR FLAGS               PRINT250

      AZDEV=999.0                                                       PRINT251

      AZA=999.0                                                         PRINT252

      GO TO 40                                                          PRINT253

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

   20 EL=DATAN2(EPS,RCE)*DEGS                                           PRINT255

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

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

C********* AZIMUTH DIRECTION FROM TRANSMITTER ACCURATELY                PRINT258

      IF(PRTSRP.EQ.0.0)                                                 PRINT259

     1   WRITE(3,2500)TMP(KT:9),NWHY,H,GRH,RANGE,EL,ELL                 PRINT260

     2  ,(RPRINT(NN),NN=1,NP1)                                          PRINT261

 2500 FORMAT (1X,A8,A8,2F10.4,F11.4,17X,F9.3,F8.3,                      PRINT262

     1 4F12.4)                                                          PRINT263

      GO TO 40                                                          PRINT264

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

   30 ANGA=DATAN2(ETA,ZETA)                                             PRINT266

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

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

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

C********* CALCULATED                                                   PRINT270

      IF(PRTSRP.EQ.0.0)                                                 PRINT271

     1 WRITE(3,3000)TMP(KT:9),NWHY,H,GRH,RANGE,AZDEV,EL,ELL,(RPRINT(NN),PRINT272

     1 NN=1,NP1)                                                        PRINT273

 3000 FORMAT (1X,A8,A8,2F10.4,F11.4,F9.3,8X,F9.3,F8.3,                  PRINT274

     1 4F12.4)                                                          PRINT275

      GO TO 40                                                          PRINT276

   34 ANA=ANGA-ALPH                                                     PRINT277

      SANA=DSIN(ANA)                                                    PRINT278

      SPHI=SANA*STHR/STH                                                PRINT279

      CPHI=-DSIN(PID2-ANA)*DSIN(PID2-(PHI-PHIR))+SANA*DSIN(PHI-PHIR)    PRINT280

     1 *CTHR                                                            PRINT281

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

      IF(PRTSRP.EQ.0.0)                                                 PRINT283

     1  WRITE(3,3500)TMP(KT:9),NWHY,H,GRH,RANGE,AZDEV,AZA,EL,ELL        PRINT284

     2  ,(RPRINT(NN),NN=1,NP1)                                          PRINT285

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

     1 4F12.4)                                                          PRINT287

C*********                                                              PRINT288

   40 LINES=LINES+1                                                     PRINT289

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

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

C********* VARIABLES                                                    PRINT292

      IF(PRTSRP.EQ.0.0)                                                 PRINT293

     1   WRITE(3,4000) (RPRINT(NN),NN=4,NP)                             PRINT294

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

      LINES=LINES+1                                                     PRINT296

C                                                                       PRINT297

C     IF NO 'CARDS' WANTED OR AT TRANSMITTER, NO RAYSET OUTPUT          PRINT298

C                                                                       PRINT299

45    IF (CARD.EQ.0.0 .OR. IHOP.LT.1) RETURN                            PRINT300

C                                                                       PRINT301

C********* PUNCH A RAYSET                                               PRINT302

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

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

      NR=0                                                              PRINT305

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

C********* PHASE PATH                                                   PRINT307

      NR=NR+1                                                           PRINT308

      P=RKVARS(NR)                                                      PRINT309

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

C********* ABSORPTION                                                   PRINT311

      NR=NR+1                                                           PRINT312

      ABSORB=RKVARS(NR)                                                 PRINT313

C********* DOPPLER SHIFT                                                PRINT314

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

      NHPUNCH=ROUND(HPUNCH*1.E4)                                        PRINT316

       NRANGE=ROUND(RANGE*1.E4)                                         PRINT317

      NAZDEV=ROUND(AZDEV*1.E3)                                          PRINT318

       NAZA=ROUND(AZA*1.E3)                                             PRINT319

       NELL=ROUND(ELL*1.E3)                                             PRINT320

      IF(NWHY.EQ.'GRND REF') NELL =                                     PRINT321

     1 ROUND((PID2 -DACOS(KNORM(gtoo)/DSQRT(KR*KR+KTH*KTH+KPH*KPH)))    PRINT322

     2   *DEGS*1.E3)                                                    PRINT323

      yyy = 999999.0

      NABSORB=DMIN1(  yyy   ,ROUND(ABSORB*1.D3))                        PRINT324

       NDOPP=ROUND(DOPP*1.E3)                                           PRINT325

      NPOLAR1=ROUND(DREAL(POLAR)*1.E2)                                  PRINT326

       NPOLAR2=ROUND(DIMAG(POLAR)*1.E2)                                 PRINT327

      JP=ROUND(P*1.E5)                                                  PRINT328

      JT=ROUND(T*1.E5)                                                  PRINT329

      WRITE(9,4501) NHPUNCH,NRANGE,NAZDEV,NAZA,NELL,JT,JP,NABSORB       PRINT330

     1 ,NDOPP,NPOLAR1,NPOLAR2,IHOP,EVENT(1:1)                           PRINT331

 4501 FORMAT(2I9,3I6,2I10,2I6,I5,I4,I2,A1)                              PRINT332

 6543 continue

      RETURN                                                            PRINT333

      END                                                               PRINT334



