C**********************************************************************

      FUNCTION REFLECT(Z)

C**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

 

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

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

C

      REAL*8 Z(12),KPARLEL,KNORM

C     COMMON DECK "CC" INSERTED HERE

      real*8 MODC

      integer*2 nrow,ncol

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

      COMMON/WW/DUM(10),MAXW,W(1000)

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

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

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

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

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

     8   (RUNSUP,W(18)),(RCVRH,W(20)),

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

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

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

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

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

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

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

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

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

C     COMMON DECK "RKAM" INSERTED HERE

      REAL*8 KR,KTH,KPH

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

C     COMMON DECK "UU" INSERTED HERE

      real*8 MODU

      COMMON/UU/MODU(4)

     1  ,V  ,PVT  ,PVR  ,PVTH  ,PVPH

     2  ,VR ,PVRT ,PVRR ,PVRTH ,PVRPH

     3  ,VTH,PVTHT,PVTHR,PVTHTH,PVTHPH

     4  ,VPH,PVPHT,PVPHR,PVPHTH,PVPHPH

C     COMMON DECK "FNDER" INSERTED HERE

      COMMON/FNDER/GY(20),NZ,NPZR,NPZRR,NPZRTH,NPZRPH,NPZTH

      COMMON/FNDER/NPZPH,NPZTHTH,NPZPHPH,NPZTHPH,NSELECT,NTIME

C

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

      real *8 anr(3)

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

C

      IENTRY=1

      REFLECT=0.d0

      GO TO 5

C

C**********************************************************************

      ENTRY KPARLEL(Z)

C**********************************************************************

      KPARLEL=0.d0

      IENTRY=2

      GO TO 5

C

C**********************************************************************

      ENTRY KNORM(Z)

C**********************************************************************

      KNORM=0.d0

      IENTRY=3

C

5     zholdr=get(z)

      Z(1)=zholdr

      NR=Z(NPZR)

      NTH=Z(NPZTH)/R

      NPH=Z(NPZPH)/(R*dSIN(TH))

C

      r999=renorm(anr,1.d0,3)

C      CALL RENORM(NR,1.d0,3)

C     COMPUTE THE NORMAL COMPONENT OF K-VECTOR TO SURFACE

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

      IF(IENTRY.NE.3) GO TO 8

C     IF ENTRY 3 THEN WE ARE DONE

      REFLECT=KRNR

      RETURN

C

C     COMPUTE THE PARALLEL VECTOR COMPONENT

8     KPARR=KR-KRNR*NR

      KPARTH=KTH-KRNR*NTH

      KPARPH=KPH-KRNR*NPH

C

      IF(IENTRY.NE.2) GO TO 10

      REFLECT=dABS(KPARR)+dABS(KPARTH)+dABS(KPARPH)

      RETURN

C

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

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

C

      FCTR=2.d0*(KRNR+OWIPAR*VNR/(CS-VNR*VNR))

      KR=KR-FCTR*NR

      KTH=KTH-FCTR*NTH

      KPH=KPH-FCTR*NPH

      END

 

 

 

 

 

C**********************************************************************

      SUBROUTINE FIT(Z,ZOLD,ZDOLD)

C**********************************************************************

C     COMPUTES THREE TYPES OF PARABOLIC FITS TO RAY PATH RELATIVE

C     TO TERRAIN.

C

 

      implicit double precision (a-h,o-z)

 

      REAL*8 Z(12)

      REAL*8 KR,KTH,KPH

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

C     COMMON DECK "TRAC" INSERTED HERE

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

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

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

C     COMMON DECK "FNDER" INSERTED HERE

      COMMON/FNDER/GY(20),NZ,NPZR,NPZRR,NPZRTH,NPZRPH,NPZTH

      COMMON/FNDER/NPZPH,NPZTHTH,NPZPHPH,NPZTHPH,NSELECT,NTIME

C

      REAL*8 D2(3)

C

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

C     WEIGHTED ESTIMATE OF 1ST DERIVATIVE.

C

      IENTRY=1

      GO TO 5

C

C     USE MODIFIED FIT REQUIRING HEIGHTS OF PARABOLA VERTICES FROM

C     CURRENT AND PREVIOUS RAY POINTS.

C**********************************************************************

      ENTRY FIT2(Z,ZOLD,ZDOLD)

C**********************************************************************

      IENTRY=2

      GO TO 5

C

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

C**********************************************************************

      ENTRY FIT3(Z,ZOLD,ZDOLD)

C**********************************************************************

      IENTRY=3

C

5     ZDOT=DOT(Z)

C

      DTI=1.d0/(TPULSE-TOLD)

      DO 10 I=1,3

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

C

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

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

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

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

     1   +2.d0*(Z(NPZRTH)*DRDT(1)*DRDT(2)

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

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

C

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

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

C

      IF(IENTRY.NE.2) GO TO 30

      SMT=0.d0

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

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

      OSMT=0.d0

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

      GO TO 2000

C

C     IMPLEMENTATION OF FIT FOR EQUATION J.1

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

      ZDOTM=.5d0*(ZDOT+ZDOLD)

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

      IF(dABS(ZDOTM).LE.5.d-2*dABS(ZDOT)) GO TO 1000

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

      D2Z=FCTR*D2Z

      ZDOT=FCTR*ZDOT

C     END FIT

C

C     COMMON CODE FOR FIT AND FIT3

1000  RAD=ZDOT*ZDOT-2.d0*Z(NZ)*D2Z

      RAD1=DSQRT(DMAX1(RAD,0.d0))

C

2000  CONTINUE

C

      END

 

 

 

 

 

C**********************************************************************

      FUNCTION GET1(Z)

C**********************************************************************

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

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

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

C     PROBLEM.

C

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

 

      REAL*8 PF(10),PG(10),z(12)

C     COMMON DECK "SS" INSERTED HERE

      real*8 MODSURF

      COMMON/SS/ MODSURF(4)

      COMMON/SS/U,PUR,PURR,PURTH,PURPH

      COMMON/SS/PUTH,PUPH,PUTHTH,PUPHPH,PUTHPH,USELECT,UTIME

C     COMMON DECK "RKAM" INSERTED HERE

      REAL*8 KR,KTH,KPH

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

C     COMMON DECK "FNDER" INSERTED HERE

      COMMON/FNDER/GY(20),NZ,NPZR,NPZRR,NPZRTH,NPZRPH,NPZTH

      COMMON/FNDER/NPZPH,NPZTHTH,NPZPHPH,NPZTHPH,NSELECT,NTIME

C     COMMON DECK "RR" INSERTED HERE

      real*8 MODREC

      COMMON/RR/ MODREC(4)

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

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

C     COMMON DECK "GG" INSERTED HERE

      real*8 MODG

      COMMON/GG/MODG(4)

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

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

C     COMMON DECK "RKTIME" INSERTED HERE

      COMMON/CRKTIME/RKTIME

C     COMMON DECK "RMACH" INSERTED HERE

      COMMON/CRMACH/rmach(9)

      COMMON/WW/DUM(10),MAXW,W(1000)

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

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

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

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

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

     8   (RUNSUP,W(18)),(RCVRH,W(20)),

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

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

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

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

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

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

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

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

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

C

      COMMON/CGET/ZERO

C

      IENTRY=1

      GO TO 5

C

C**********************************************************************

      ENTRY DOT1(Z)

C**********************************************************************

      IENTRY=2

5     CONTINUE

      IF(ZERO.EQ.0.d0) ZERO=EARTHR*RMACH(3)*2.d0

C

      IF(Z(NTIME).EQ.RKTIME) GO TO 10

C

      IF(Z(NSELECT).EQ.USELECT) CALL SURFACE

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

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

      Z(NTIME)=RKTIME

C     REMOVE MACHINE ROUND OFF NOISE FROM EXACT RECEIVER LOCATIONS

      IF(dABS(Z(NZ)).LE.ZERO) Z(NZ)=0.d0

C

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

      GET1=Z(NZ)

      RETURN

C

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

      dot1=get1

      RETURN

      END

C

C

C**********************************************************************

      FUNCTION GET(Z)

C**********************************************************************

 

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

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

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

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

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

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

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

 

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

 

      real*8 Z(12),PF(10),PG(10),pu(10)

C     COMMON DECK "SS" INSERTED HERE

      real*8 MODSURF

      COMMON/SS/ MODSURF(4)

      COMMON/SS/U,PUR,PURR,PURTH,PURPH

      COMMON/SS/PUTH,PUPH,PUTHTH,PUPHPH,PUTHPH,USELECT,UTIME

C     COMMON DECK "RKAM" INSERTED HERE

      REAL*8 KR,KTH,KPH

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

C     COMMON DECK "FNDER" INSERTED HERE

      COMMON/FNDER/GY(20),NZ,NPZR,NPZRR,NPZRTH,NPZRPH,NPZTH

      COMMON/FNDER/NPZPH,NPZTHTH,NPZPHPH,NPZTHPH,NSELECT,NTIME

C     COMMON DECK "RR" INSERTED HERE

      real*8 MODREC

      COMMON/RR/ MODREC(4)

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

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

C     COMMON DECK "GG" INSERTED HERE

      real*8 MODG

      COMMON/GG/MODG(4)

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

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

C     COMMON DECK "RKTIME" INSERTED HERE

      COMMON/CRKTIME/RKTIME

C

C     COMMON DECK "RMACH" INSERTED HERE

      COMMON/CRMACH/rmach(9)

      COMMON/WW/DUM(10),MAXW,W(1000)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

C

      COMMON/CGET/ZERO

C

      REAL*8 PI(10),PJ(10)

c%      COMMON/TMP1/NC,NSZR    ,NSZRR    ,NSZRTH

c%     1 ,NSZRPH    ,NSZTH    ,NSZPH    ,NSZTHTH    ,NSZPHPH    ,NSZTHPH

c%     2 ,NVELECT    ,NWIME

C

      equivalence (pf,pfr),(pg,pgr),(pu,pur)

      DATA PI,PJ,pk/1.d0,9*0.d0,1.d0,9*0.d0,1.d0,9*0.d0/

c%    DATA NC,NSZR,NSZRR,NSZRTH,NSZRPH,NSZTH,NSZPH,NSZTHTH,NSZPHPH

c%   1   ,NSZTHPH,NVELECT,NWIME/1,2,3,4,5,6,7,8,9,10,11,12/

c%    DATA FWIME,GWIME,FVELECT,GVELECT/2*-1.d0,'RECEIVER','TERRAIN' /

c%    DATA UWIME,UVELECT/-1.d0,'SURFACE' /

c%    DATA ZHRO/0.d0/

C

      IENTRY=1

      GO TO 5

 

C**********************************************************************

      ENTRY SETGET (x)

C**********************************************************************

      CALL RMOVE(PF,PI,10)

      CALL RMOVE(PG,PJ,10)

      call rmove(pu,pk,10)

c%    CALL IMOVE(NZ,NC,12)

      rktime=0.d0

      fselect='RECEIVER'

      gselect='TERRAIN'

      uselect='SURFACE'

      ftime=-1.d0

      utime=-1.d0

      gtime=-1.d0

      zero=0.d0

      nz=1

      npzr=2

      npzrr=3

      npzrth=4

      npzrph=5

      npzth=6

      npzph=7

      npzthth=8

      npzphph=9

      npzthph=10

      nselect=11

      ntime=12

      RETURN

C

C**********************************************************************

      ENTRY DOT(Z)

C**********************************************************************

      IENTRY=2

5     CONTINUE

c diagnostic      print *,ftime,gtime,utime

      IF(ZERO.EQ.0.d0) ZERO=EARTHR*RMACH(3)*2.d0

      IF(Z(NTIME).EQ.RKTIME) GO TO 10

C

      IF(Z(NSELECT).EQ.USELECT) CALL SURFACE

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

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

      Z(NTIME)=RKTIME

C     REMOVE MACHINE ROUND OFF NOISE FROM EXACT RECEIVER LOCATIONS

      IF(dABS(Z(NZ)).LE.ZERO) Z(NZ)=0.d0

C

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

      GET=Z(NZ)

      RETURN

C

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

      dot=get

      RETURN

      END

 

 

 

 

C**********************************************************************

      FUNCTION ITEST(I)

C**********************************************************************

C     USED TO PASS INTEGER VALUES THROUGH FOR VARIABLES TYPED REAL

C     (AS IN MIXED REAL/INTEGER ARRAYS)

 

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

 

      ITEST=I

      END

 

 

 

 

 

C**********************************************************************

      FUNCTION ITOC(N)

C**********************************************************************

C     RETURN 7 CHARACTER STRING REPRESENTATION OF INTEGER N

C     IF NUMBER IS TOO LARGE OR SMALL USE FLOATING POINT FORMAT

      CHARACTER ITOC*7

      IF(N.LT.-9999.OR.N.GT.99999) GO TO 100

      ITOC=' '

      WRITE(ITOC,'(I7)',ERR=100) N

      RETURN

100   WRITE(ITOC,'(2PG7.0)') FLOAT(N)

      return

      END

 

 

 

 

C**********************************************************************

      SUBROUTINE CONBLK

C**********************************************************************

C     DATA INITIALIZATION AND FILE OPENING SERVICE ROUTINE

C

C     COMMON DECK "RMACH" INSERTED HERE

 

      implicit double precision (a-h,o-z)

 

      COMMON/CRMACH/rmach(9)

C     COMMON DECK "HDR" INSERTED HERE

      CHARACTER*10 INITID*80,DAT,TOD,dinpname*12   !Rev 7/13/90

      COMMON/HDR/SEC,stsec                         !Rev 7/13/90

      COMMON/HDRC/INITID,DAT,TOD

C

C     COMMON DECK "CPROCFL" INSERTED HERE

      INTEGER PMX,PNTBL,PITBL,PFRMTBL,IDSP(10)

C     PARAMETER DECK "PGROUPS"

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

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

      COMMON/PROCFL/LIST(MXLIST)

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

      EQUIVALENCE (PGP,IDSP)

C     COMMON DECK "CC" INSERTED HERE

      real*8 MODC

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

C     COMMON DECK "GG" INSERTED HERE

      real*8 MODG

      COMMON/GG/MODG(4)

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

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

C     COMMON DECK "RR" INSERTED HERE

      real*8 MODREC

      COMMON/RR/ MODREC(4)

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

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

C     COMMON DECK "TT" INSERTED HERE

      REAL*8 MODT

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

C     COMMON DECK "UU" INSERTED HERE

      real*8 MODU

      COMMON/UU/MODU(4)

     1  ,V  ,PVT  ,PVR  ,PVTH  ,PVPH

     2  ,VR ,PVRT ,PVRR ,PVRTH ,PVRPH

     3  ,VTH,PVTHT,PVTHR,PVTHTH,PVTHPH

     4  ,VPH,PVPHT,PVPHR,PVPHTH,PVPHPH

C

C     COMMON DECK "RAYDEV" INSERTED HERE

C     DEVICE ASSIGNED TO RAYTRC INPUT FILE

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

C     COMMON DECK "CUCON" INSERTED HERE

      COMMON/UCONV/CNVV(5,4)

      CHARACTER PCV*3,CNVC*2

      COMMON/UCONC/PCV(5),CNVC(5,4)

C

C     COMMON DECK "SS" INSERTED HERE

      real*8 MODSURF

      COMMON/SS/ MODSURF(4)

      COMMON/SS/U,PUR,PURR,PURTH,PURPH

      COMMON/SS/PUTH,PUPH,PUTHTH,PUPHPH,PUTHPH,USELECT,UTIME

C     COMMON DECK "CONST" INSERTED HERE

      COMMON/PCONST/CREF,RGAS,GAMMA

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

      COMMON/WW/DUM(10),MAXW,W(1000)

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

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

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

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

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

     8   (RUNSUP,W(18)),(RCVRH,W(20)),

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

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

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

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

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

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

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

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

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

C     COMMON DECK "B9" INSERTED HERE

      INTEGER GMX,GNTBL,GITBL,GFRMTBL,IDSG(20)

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

      EQUIVALENCE (GGP,IDSG),(ANG,GGP(11))

C     COMMON DECK "B2" INSERTED HERE

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

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

      EQUIVALENCE (DUGP,IDSDU)

C     COMMON DECK "B4" INSERTED HERE

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

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

      EQUIVALENCE (DCGP,IDSDC)

C     COMMON DECK "B6" INSERTED HERE

      INTEGER DTMX,DTNTBL,DTITBL,DTFRMTB,IDSDT(20)

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

      EQUIVALENCE (DTGP,IDSDT)

C     COMMON DECK "B1" INSERTED HERE

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

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

      EQUIVALENCE (UGP,IDSU)

C     COMMON DECK "B3" INSERTED HERE

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

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

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

C     COMMON DECK "B5" INSERTED HERE

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

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

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

C     COMMON DECK "B7" INSERTED HERE

      INTEGER MMX,MNTBL,MITBL,MFRMTBL,IDSM(20)

      REAL*8 MGP

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

      EQUIVALENCE (MGP,IDSM)

C     COMMON DECK "RINPLEX" INSERTED HERE

      REAL*8 KAY2,KAY2I

      COMPLEX*16 PNP,POLAR,LPOLAR

      LOGICAL SPACE

      CHARACTER DISPM*6,modrin*64

      COMMON/RINPL/DISPM

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

      COMMON/RIN/OMEGMIN,OMEGMAX,KAY2,KAY2I

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

C     COMMON DECK "MM" INSERTED HERE

      REAL*8 M,MODM

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

C     COMMON DECK "PP" INSERTED HERE

      REAL*8 MODP

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

C     COMMON DECK "AA" INSERTED HERE

      REAL*8 MODA

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

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

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

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

C     COMMON DECK "CB11" INSERTED HERE

      INTEGER SMX,SNTBL,SITBL,SFRMTBL,IDSS(10)

      COMMON/B11/SMX,SNTBL(10),SITBL(10),SFRMTBL(10),SGP(11)

      EQUIVALENCE (SGP,IDSS),(ANS,SGP(11))

C     COMMON DECK "CB12" INSERTED HERE

      INTEGER DSMX,DSNTBL,DSITBL,DSFRMTB,IDSDS(10)

      COMMON/B12/DSMX,DSNTBL(10),DSITBL(10),DSFRMTB(10),DSGP(11)

      EQUIVALENCE (DSGP,IDSDS),(ANDS,DSGP(11))

C     COMMON DECK "LL" INSERTED HERE

      real*8 MODL

      COMMON/LL/MODL(4),APH,APHPT,APHPR,APHPTH,APHPPH

C     COMMON DECK "FLAG" INSERTED HERE

      LOGICAL NEWWR,NEWWP,NEWTRC,PENET

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

      COMMON/FLGP/NSET

C     COMMON DECK "RKTIME" INSERTED HERE

      COMMON/CRKTIME/RKTIME

      COMMON/RAYCON/MCONP

C     COMMON DECK "B10" INSERTED HERE

      INTEGER DGMX,DGNTBL,DGITBL,DGFRMTB,IDSDG(20)

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

      EQUIVALENCE (DGGP,IDSDG)

C     COMMON DECK "B8" INSERTED HERE

      INTEGER RMX,RNTBL,RITBL,RFRMTBL,IDSR(20)

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

      EQUIVALENCE (RGP,IDSR)

C     COMMON DECK "CB17" INSERTED HERE

      INTEGER VMX,VNTBL,VITBL,VFRMTBL,IDSV(20)

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

      EQUIVALENCE (VGP,IDSV),(ANV,VGP(11))

C     COMMON DECK "CB18" INSERTED HERE

      INTEGER DVMX,DVNTBL,DVITBL,DVFRMTB,IDSDV(20)

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

      EQUIVALENCE (DVGP,IDSDV),(ANDV,DVGP(11))

C     COMMON DECK "CB19" INSERTED HERE

      INTEGER PRMX,PRNTBL,PRITBL,PRFRMTB,IDSPR(20)

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

      EQUIVALENCE (PRGP,IDSPR),(ANP,PRGP(11))

C     COMMON DECK "CB20" INSERTED HERE

      INTEGER DPMX,DPNTBL,DPITBL,DPFRMTB,IDSDP(20)

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

      EQUIVALENCE (DPGP,IDSDP),(ANDP,DPGP(11))

      COMMON/KNKN/KNBP,KNVC,KNDT

      COMMON/DDLIM/MXIX,MXIY,MNIX,MNIY

C

      REAL*8 KVECT(22)

      REAL*8 VSET(20)

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

C

      REAL*8 CUEF(3)

      INTEGER NUYIND(5)

C

      CHARACTER PFV(5)*3,CQVC(5,4)*2

C

      DATA CUEF/1.d0,1.4d0,8.31436d-3/

      DATA NUYIND/8,4,0,10,11/

      DATA PFV/'AN','LN','FQ','AM',' '/

      DATA CQVC/'RD' ,'KM' ,'RD' ,'DB',' '

     1        ,'DG' ,' M' ,'HZ' ,'NP',' '

     2        ,'KM' ,'FT' ,'KH' ,2*' '

     3        ,'  ' ,'NM' ,'DG' ,2*' '/

C

      CALL SET2(KVECT,0.d0,22)

      dummy=1h 

      CALL SET2(RAYNAME,dummy, 6)

      CALL SET2(VSET,0.d0,20)

      CALL SET2(OMEGMIN,0.d0,2)

      MXIX=-1000

      MXIY=-1000

      MNIX=1000

      MNIY=1000

      KNBP=0

      KNVC=0

      KNDT=0

      rktime=0.d0

C     SET TRACE-BACKUP VARIABLES

      CALL SETTRC

      MCONP=0

      POLAR=0.d0

      LPOLAR=1.d0

      CALL RMOVE(CREF,CUEF,3)

      CALL IMOVE(NRYIND,NUYIND,5)

      CALL SET2(CNVV,1.d0,20)

      DO 10 I=1,5

        PCV(I)=PFV(I)

        DO 10 J=1,4

10       CNVC(I,J)=CQVC(I,J)

C     DEFAULT WIND AND ABSORBSION IDENTIFIERS

      MODU(1)=1H

      MODU(2)=0.d0

      MODU(3)=1H

      MODU(4)=0.d0

      MODL(1)=1H

      MODL(2)=0.d0

      MODL(3)=1H

      MODL(4)=0.d0

C

C     INITIALIZE MODEL DESCRIPTIONS TO BLANKS

      CALL ISET2(IDSDC,1H ,10)

      CALL ISET2(IDSDT,1H ,10)

      CALL ISET2(IDSDU,1H ,10)

      CALL ISET2(IDSC,1H ,10)

      CALL ISET2(IDSM,1H ,10)

      CALL ISET2(IDST,1H ,10)

      CALL ISET2(IDSU,1H ,10)

      CALL ISET2(IDSG,1H ,10)

      CALL ISET2(IDSDG,1H ,10)

      CALL ISET2(IDSV,1H ,10)

      CALL ISET2(IDSDV,1H ,10)

      CALL ISET2(IDSPR,1H ,10)

      CALL ISET2(IDSDP,1H ,10)

      CALL ISET2(IDSR,1H ,10)

      CALL ISET2(IDSS,1H ,10)

      CALL ISET2(IDSDS,1H ,10)

C

C     GET MACHINE CONSTANTS

C%      CALL DFCNST(RMACH,5)

      call mach

      RETURN

C

C**********************************************************************

      ENTRY STDINI

C**********************************************************************

      CALL OPNREP(NDEVTMP,'TAPE4')

      CALL OPNURP(NDEVBIN,'TAPE6')

      CALL OPNREP(9,'PUNCH')

C

C**********************************************************************

      ENTRY STDINT

C**********************************************************************

      write (*,888)

888   format (' NAME OF INPUT DATA FILE [DINP]: ',$)

      READ (*,'(A12)')dinpname

      if (dinpname.eq.'            ')dinpname='dinp'

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

      REWIND NRYIND

C%      CALL OPNREP(2,'OUTPUT')

      CALL OPNREP(3,'DOUTP')

      CALL opnrep(NDEVGRP,'TAPE5')

C

C  INITIALIZE RAYSET FILE

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

C%      CALL SETW

      xyz=setw(xyz)

      zzz= SETGET(x)

      CALL SYSDAT(DAT)

      CALL SYSTIM(TOD)

      CALL SYSSEC(SEC)

C     INITIALIZE POINT MODEL LIST

      LIST(1)=1

      LIST(2)=0

C     FILL FORMAT CONTROL ARRAYS

      PNTBL(1)=1

C     ALLOW FOR AN 80 CHARACTER IDENT STRING(A8)

      PNTBL(2)=NCHPG1

C     ALLOW MAXIMUM 250 WORD PER VARIABLE

      PITBL(2)=NWPV

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

      PNTBL(3)=NSPGP

      RETURN

1000  STOP 'DINP FORMAT ERROR'

      END

 

 

 

 

 

C**********************************************************************

      SUBROUTINE SETTRC

C**********************************************************************

C     INITIALIZE /TRAC/ LABELED COMMON

C     COMMON DECK "TRAC" INSERTED HERE

 

      implicit double precision (a-h,o-z)

 

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

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

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

      GROUND=.FALSE.

      SURF=.FALSE.

      END

 

 

 

 

 

C**********************************************************************

      LOGICAL FUNCTION WCHANGE(W1,W2)

C**********************************************************************

 

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

 

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

C

C WCHANGE PROVIDES A TEST AGAINST TWO W-ARRAYS

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

C     IS <FALSE>.

C

      INTEGER NDX(8)

C

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

C

      WCHANGE=.FALSE.

      DO 20 N=1,NGRPS,2

         N1=NDX(N)

         N2=NDX(N+1)

      DO 20 I=N1,N2

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

          IF(WCHANGE) RETURN

20    CONTINUE

      END

 

 

 

 

 

C**********************************************************************

      FUNCTION RENORM(VECTOR,NNORM,NCOMPS)

C**********************************************************************

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

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

 

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

 

      REAL*8 NNORM,VECTOR(*)

C

      RENORM=0.d0

      IF(NNORM.LE.0.d0) RETURN

C

      RENORM=0.d0

      DO 10 I=1,NCOMPS

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

      IF(RENORM.EQ.0.d0) RETURN

C

      RENORM=DSQRT(NNORM/RENORM)

      DO 20 I=1,NCOMPS

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

C

      RETURN

      END

 

 

 

 

 

C**********************************************************************

      SUBROUTINE SET2(A,V,N)

C**********************************************************************

C     SETS N COMPONENTS OF VECTOR A TO SINGLE VALUE V

      REAL*8 A(N),v

      INTEGER NA(N)

      CHARACTER NV

      DO 100 I=1,N

100   A(I)=V

      RETURN

C**********************************************************************

      ENTRY ISET2(NA,NV,N)

C**********************************************************************

C     SPECIAL ENTRY FOR INTEGER ARRAYS FOR MACHINES HAVING DIFFERENT

C     WORD SIZES FOR INTEGERS THAN REALS.

      DO 200 I=1,N

200   NA(I)=NV

      RETURN

      END

 

 

 

 

C**********************************************************************

      SUBROUTINE PRINTR(EVENT,CARD)

C**********************************************************************

C

 

      implicit double precision (a-h,o-z)

 

      CHARACTER EVENT*9,NWHY*8,CC*1,PC*1,TMP*9,id*80

C

C     PRINTS OUTPUT AND OUTPUTS RAYSETS(MACHINE READABLE OUTPUT)

C     WHEN 'CARD' ARGUMENT NONZERO.

      REAL*8 KNORM

      DIMENSION G0(3,3),G1(3,3)

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

      DIMENSION RPRINT(20),NPR(20)

C     COMMON DECK "RK" INSERTED HERE

C     DEFINE SIZE REQUIRED FOR RAY STATE SAVE ARRAY

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

      PARAMETER (NRKSAV=NXRKMS+MXEQPT-1)

      common/ident/id

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

C     COMMON DECK "CERR" INSERTED HERE

      COMMON/ERR/NERG,NERR,NERT,NERP

C     COMMON DECK "GG" INSERTED HERE

      real*8 MODG

      COMMON/GG/MODG(4)

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

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

C     COMMON DECK "CONST" INSERTED HERE

      COMMON/PCONST/CREF,RGAS,GAMMA

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

C     COMMON DECK "FLAG" INSERTED HERE

      LOGICAL NEWWR,NEWWP,NEWTRC,PENET

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

      COMMON/FLGP/NSET

C     COMMON DECK "RINPLEX" INSERTED HERE

      REAL*8 KAY2,KAY2I

      COMPLEX*16 PNP,POLAR,LPOLAR

      LOGICAL SPACE

      CHARACTER DISPM*6,modrin*64

      COMMON/RINPL/DISPM

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

      COMMON/RIN/OMEGMIN,OMEGMAX,KAY2,KAY2I

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

C     COMMON DECK "RKAM" INSERTED HERE

      REAL*8 KR,KTH,KPH

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

      COMMON/WW/DUM(10),MAXW,W(1000)

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

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

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

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

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

     8   (RUNSUP,W(18)),(RCVRH,W(20)),

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

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

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

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

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

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

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

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

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

      REAL*8 MMODEL,MFORM,MID

C

C     WIND        100-124

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

C

C     DELTA WIND        125-149

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

C

C     SOUND SPEED 150-174

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

      EQUIVALENCE (W(153),REFC)

C

C     DELTA SOUND SPEED 175-199

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

C

C     TEMPERATURE    200-224

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

C

C     DELTA TEMPERATURE    225-249

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

C

C     MOLECULAR   250-274

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

C

C     RECEIVER HEIGHT   275-299

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

C

C     TOPOGRAPHY   300-324

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

C

C     DELTA TOPOGRAPHY   325-349

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

C

C     ATMOSPHERIC SURFACE TOPOGRAPHY   350-374

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

C

C     ATMOSPHERIC SURFACE TOPOGRAPHY   375-399

      EQUIVALENCE (W(375),SUMODEL),(W(376),SUFORM),(W(377),SUID)

C     PLOT ENHANCEMENTS CONTROL PARAMETERS

C

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

C     ABSORPTION        500-524

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

C

C     DELTA ABSORPTION        525-549

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

C

C     PRESSURE        550-574

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

C

C     DELTA PRESSURE        575-599

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

C

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

c

      real*8 gtoo(12)

      equivalence (gtoo(1),g)

 

      DATA

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

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

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

      DATA  HEADRS(10)/' PATH LENGTH'/,UNITS(10)/'   KM '/

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

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

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

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

C

C      ROUND-OFF FUNCTION

      ROUND(X)=dSIGN(dABS(X)+0.5d0,X)

C

      NWHY=EVENT(2:)

      if (event.eq.'RRCVR    ') write (nwhy,'(a4,i4)')event(2:5),ihop

      GO TO 10

C

C     INITIALIZATION ENTRY POINT FOR PRINTR. CALLED FOR EACH NEW

C     W-ARRAY.

C**********************************************************************

      ENTRY IPRINTR

C**********************************************************************

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

      NEWWP=.FALSE.

      SPL=dSIN (PLON-TLON)

      CPL=dSIN (PID2-(PLON-TLON))

      SP=dSIN (PLAT)

      CP=dSIN (PID2-PLAT)

      SL=dSIN (TLAT)

      CL=dSIN (PID2-TLAT)

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

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

      G0(1,2)=SPL*SP

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

      G0(2,1)=-SPL*CL

      G0(2,2)=CPL

      G0(2,3)=SL*SPL

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

      G0(3,2)=CP*SPL

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

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

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

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

      if (denm .eq. 0.d0) stop 'denm=0. in PRINTR'

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

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

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

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

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

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

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

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

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

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

      R0=EARTHR+XMTRH

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

      XR=R0*G0(1,1)

      YR=R0*G0(2,1)

      ZR=R0*G0(3,1)

      CTHR=G0(3,1)

      STHR=dSIN (dACOS (CTHR))

      PHIR=dATAN2(YR,XR)

      ALPH=dATAN2(G0(3,2),G0(3,3))

C*********

      NR=0

      NP=0

      NERG=0

      NERR=0

      NERT=0

      NERP=0

C     INSURE NO GARBLE IN HEADERS

      HEAD(1)=' '

      UNIT(1)=' '

C

      DO 7 NN=7,20

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

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

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

      NR=NR+1

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

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

      IF(NN.EQ.11) NERG=NR

      IF(NN.EQ.12) NERR=NR

      IF(NN.EQ.13) NERT=NR

      IF(NN.EQ.14) NERP=NR

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

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

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

C********* PRINTED

      NP=NP+1

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

      NPR(NP)=NR

      HEAD(NP)=HEADRS(NN)

      HEAD(NP)=HEADRS(NN)

      UNIT(NP)=UNITS(NN)

    7 CONTINUE

      NPM=MIN0(NP,3)

      NP1=NPM+1

      P=0.d0

      ABSORB=0.d0

      DOPP=0.d0

      NEQS=NR+6

      RETURN

C

C**********************************************************************

      ENTRY PRNHD1(CC)

C**********************************************************************

C     PRINT PRINTR HEADER 1

C   IF NO OUTPUT NEEDED EXIT NOW

      IF(PRTSRP.NE.0.d0) RETURN

C

C     ADD NUMBER OF LINES NEEDED FOR THIS HEADER

      PC=CC

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

      LINES=LINES+3

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

C

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

C

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

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

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

     5  'PULSE TIME',3A12)

C

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

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

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

C

      RETURN

C

C**********************************************************************

      ENTRY PRNHD2(CC)

C**********************************************************************

C     PRINT PRINTR HEADER 1

C   IF NO OUTPUT NEEDED EXIT NOW

      IF(PRTSRP.NE.0.0) RETURN

C     PAGE BY HALF LENGTH

      LINSPP=PAGLN/2

      IF(LINSPP.LT.40) LINSPP=PAGLN

      PC=CC

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

C     ADD NUMBER OF LINES NEEDED FOR THIS SUBHEADER

      LINES=LINES+1

C

      IF(ELEND.GE.ELBEG+ELSTEP) THEN

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

     1    ,F10.4,'' DEG'')') PC,BETA*DEGS  !Rev 7/16/90  remove SNGL

      ELSEIF(AZEND.GE.AZBEG+AZSTEP) THEN

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

     1    ,F10.4,'' DEG'')') PC,AZ1*DEGS   !Rev 7/16/90  remove SNGL

      ENDIF

      RETURN

C

C     IF PRINTING SUPPRESSED AND RAYSETS OFF NOTHING TO DO

10    IF(PRTSRP.NE.0.d0 .AND. CARD.EQ.0.d0) RETURN

      CALL DISPER

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

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

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

C           OUTPUT AT CODE 'PUNCH A RAYSET' BELOW.

C

      TLOND=TLON*DEGS

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

      TLATD=TLAT*DEGS

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

      AZ=AZ1*DEGS

      EL=BETA*DEGS

      NHOP=HOP

      NXMTRH=ROUND(XMTRH*1.d4)

      NTLATD=ROUND(TLATD*1.d3)

       NTLOND=ROUND(TLOND*1.d3)

      NRCVRH=ROUND(RCVRH*1.d4)

       NF=ROUND(OW*1.d4)

      NAZ=ROUND(AZ*1.d5)

       NEL=ROUND(EL*1.d5)

      NPOLAR1=ROUND(DREAL(POLAR)*1.D2)

       NPOLAR2=ROUND(DIMAG(POLAR)*1.D2)

      WRITE(9,1201)ID(:3),TYPE(NTYP),NXMTRH,NTLATD,NTLOND,NRCVRH,NF,NAZ

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

 1201 FORMAT(A3,A1,I9,2I6,2I9,2I10,4X,I5,I4,i3,A1)

C*********

12    V=1.d10

C     OBTAIN THE WORST ERROR OF THOSE ENABLED.

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

      ERT=1HK

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

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

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

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

C

      H=R-EARTHR

      STH=dSIN (THETA)

      CTH=dSIN (PID2-THETA)

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

      XP=R*STH*dSIN (PID2-PHI)-XR

      YP=R*STH*dSIN (PHI)-YR

      ZP=R*CTH-ZR

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

C********* ROTATED

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

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

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

      RCE2=ETA**2+ZETA**2

      RCE=dSQRT (RCE2)

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

      RANGE=EARTHR*dATAN2(RCE,EARTHR+EPS+XMTRH)

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

      ELL=dATAN2(KR,dSQRT (KTH*kth+KPH*kph))*DEGS

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

      SR=dSQRT (RCE2+EPS*eps)

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

      GRH=GET(gtoo)/PGR

C     REPORT GROUP TIME AS FIRST 'OPTION'

      RPRINT(1)=T

      IF (NP1.LT.2) GO TO 16

C     ADD MORE OPTIONS IF REQUESTED

      DO 15 I=2,NP1

      NN=NPR(I-1)

   15 RPRINT(I)=RKVARS(NN)

C

c%16    IF(V.GE.0.d0) THEN

c%         WRITE(TMP,'(A1,0PE7.1)') ERT,V

c%      ELSE

16         WRITE(TMP,'(A1,0PE7.1)') ERT,V

c%      ENDIF

C     DETERMINE WHERE TO PUT A SPACE

C     AT BEGINNING OR END OF 1ST 2 VALUES

      KT=1

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

C

      if(prtsrp.eq.0.) write (*,222)tmp(kt:9),nwhy,h,range,beta*degs

222   format (2x,2a8,f10.4,f11.4,27x,'ELEV.= ',f7.3)

C     TEST IF NEED NEW PAGE

      CALL TSTPAG(3)

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

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

C********* TRANSMITTER

      IF(PRTSRP.EQ.0.d0)        !Rev 7/16/90 remove SNGL below

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

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

C     SET RAYSET VARIABLES TO UNDEFINDED VALUES FOR FLAGS

      AZDEV=999.d0

      AZA=999.d0

      GO TO 40

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

   20 EL=dATAN2(EPS,RCE)*DEGS

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

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

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

      IF(PRTSRP.EQ.0.d0)    !Rev 7/16/90 remove SNGL below      

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

     2   NN=1,NP1)

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

     1 4F12.4)

      GO TO 40

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

   30 ANGA=dATAN2(ETA,ZETA)

      AZDEV=180.d0-DMOD(540.d0-(AZ1-ANGA)*DEGS,360.D0)

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

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

C********* CALCULATED

      IF(PRTSRP.EQ.0.d0)    !Rev 7/16/90 remove SNGL below

     1 WRITE(3,3000)TMP(KT:9),NWHY,H,GRH,RANGE,

     1 AZDEV,EL,ELL,(RPRINT(NN),NN=1,NP1)

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

     1 4F12.4)

      GO TO 40

   34 ANA=ANGA-ALPH

      SANA=dSIN (ANA)

      SPHI=SANA*STHR/STH

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

     1 *CTHR

      AZA=180.d0-DMOD(540.d0-(DATAN2(SPHI,CPHI)-DATAN2(KPH,KTH))*DEGS,

     1 360.D0)

      IF(PRTSRP.EQ.0.d0)   !Rev 7/16/90 remove SNGL below

     1  WRITE(3,3500)TMP(KT:9),NWHY,H,GRH,RANGE,

     1  AZDEV,AZA,EL,ELL

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

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

     1 4F12.4)

C*********

   40 LINES=LINES+1

      IF (NP.LE.3) GO TO 45

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

C********* VARIABLES

      IF(PRTSRP.EQ.0.d0)   !Rev 7/16/90 remove SNGL below

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

 4000 FORMAT (99X,3F12.4)

      LINES=LINES+1

C

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

C

45    IF (CARD.EQ.0.d0 .OR. IHOP.LT.1) RETURN

C

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

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

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

      NR=0

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

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

      NR=NR+1

      P=RKVARS(NR)

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

C********* ABSORPTION

      NR=NR+1

      ABSORB=RKVARS(NR)

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

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

      NHPUNCH=ROUND(HPUNCH*1.d4)

       NRANGE=ROUND(RANGE*1.d4)

      NAZDEV=ROUND(AZDEV*1.d3)

       NAZA=ROUND(AZA*1.d3)

       NELL=ROUND(ELL*1.d3)

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

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

     2   *DEGS*1.d3)

      NABSORB=DMIN1(999999.D0,ROUND(ABSORB*1.D3))

      NDOPP=ROUND(DOPP*1.D3)

      NPOLAR1=ROUND(DREAL(POLAR)*1.D2)

      NPOLAR2=ROUND(DIMAG(POLAR)*1.D2)

      JP=ROUND(P*1.D5)

      JT=ROUND(T*1.D5)

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

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

 4501 FORMAT(2I9,3I6,2I10,2I6,2i4,i3,A1)

      RETURN

      END

 

 







