      PROGRAM RAYTRC                                                    RAYTRC 2

c

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

c

C     MAIN PROGRAM FOR THE RAY TRACING PACKAGE.                         RAYTRC 3

C          SETS THE INITIAL CONDITIONS FOR EACH RAY AND CALLS TRACE     RAYTRC 4

C                                                                       RAYTRC 5

C     COMMON DECK "RAYDEV" INSERTED HERE                                CRAYDEV2

C     DEVICE ASSIGNED TO RAYTRC INPUT FILE                              CRAYDEV4

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

      LOGICAL WCHANGE,FIRST                                             RAYTRC 7

      REAL*8 WS(400)                                                    RAYTRC 8

C     COMMON DECK "FILEC" INSERTED HERE                                 CFILEC 2

      COMMON /FILEC/NPLTDP                                              CFILEC 4

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 "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     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

      real*8 modrin

      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 "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 "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 "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                                                                       RAYTRC19

      CHARACTER TMP80*80                                                RAYTRC20

C                                                                       RAYTRC21

      DATA FIRST/.TRUE./                                                RAYTRC22

C                                                                       RAYTRC23

C     INITIALIZE FILES , SET CONTANTS AND MAKE SYSTEM CALLS             RAYTRC24

      CALL STDINI                                                       RAYTRC25

C     INITIALIZE LINE COUNTS FOR CURRENT AND LAST HEADER                RAYTRC26

      LINES=0                                                           RAYTRC27

      LHDRPG=0                                                          RAYTRC28

C                                                                       RAYTRC29

      REWIND NRYIND                                                     RAYTRC30

C  INITIALIZE RAYSET FILE                                               RAYTRC31

5     READ(NRYIND,'(A)',END=8) TMP80                                    RAYTRC32

      WRITE(9,'(A)') TMP80                                              RAYTRC33

      GO TO 5                                                           RAYTRC34

C                                                                       RAYTRC35

8     WRITE(9,'(A)') '****SOFT EOF***+++++'                             RAYTRC36

      REWIND NRYIND                                                     RAYTRC37

C     READ IN USERS NAME AND TELEPHONE EXTENSION FOR IDENTIFYING        RAYTRC38

C     MICROFILM PLOTS.                                                  RAYTRC39

C                                                                       RAYTRC40

C     REPOSITION DINP AFTER IDENTIFIER                                  RAYTRC41

      READ(NRYIND,'(A)',END=6000) TMP80                                 RAYTRC42

C                                                                       RAYTRC43

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

      IRUN=0                                                            RAYTRC45

      NSET=0                                                            RAYTRC46

C                                                                       RAYTRC47

10    CALL READW                                                        RAYTRC48

      NSET=NSET+1                                                       RAYTRC49

      ICODE=ND2B(INT(RAYFNC))                                           RAYTRC50

C PROCESS RAYPATH CALCULATIONS ONLY IF W(29) IS BEING USED              RAYTRC51

      IF((RAYFNC.NE.0.).AND.(IAND(ICODE,4).EQ.0)) GO TO 10              RAYTRC52

C                                                                       RAYTRC53

C********* LET ROUTINES PRINTR AND RAYPLT KNOW THERE IS A NEW W ARRAY   RAYTRC54

      NEWWP=.TRUE.                                                      RAYTRC55

      NEWWR=.TRUE.                                                      RAYTRC56

      IRUN=IRUN+1                                                       RAYTRC57

C                                                                       RAYTRC58

C     SET BINARY RAY FILE UNIT TO ZERO IF NO OUTPUT WANTED              RAYTRC59

      NPLTDP=0                                                          RAYTRC60

      IF(BINRAY.NE.0.0) NPLTDP=NDEVBIN                                  RAYTRC61

C                                                                       RAYTRC62

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

      CALL IDISPER                                                      RAYTRC64

C                                                                       RAYTRC65

      IF(FIRST.AND.PLT.NE.0.) CALL DDINIT(8,INITID)                     RAYTRC66

      IF(PLT.NE.0.) FIRST=.FALSE.                                       RAYTRC67

C                                                                       RAYTRC68

C     PREVENT RERUNNING SAME MODEL CASES                                RAYTRC69

      IF(IRUN.EQ.1) GO TO 12                                            RAYTRC70

      IF(.NOT.WCHANGE(WS(1),W(1))) GO TO 10                             RAYTRC71

      PRINT *,'PROCESSING FOR RUNSET #',NSET                            RAYTRC72

C                                                                       RAYTRC73

12    CALL RMOVE(WS,W,400)                                              RAYTRC74

C                                                                       RAYTRC75

      OW=0.                                                             RAYTRC76

      BETA=0.                                                           RAYTRC77

      AZ1=0.                                                            RAYTRC78

C                                                                       RAYTRC79

      CALL HEADER1                                                      RAYTRC80

C                                                                       RAYTRC81

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

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

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

      SP=SIN (PLAT)                                                     RAYTRC85

      CP=SIN (PID2-PLAT)                                                RAYTRC86

      SDPH=SIN (TLON-PLON)                                              RAYTRC87

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

      SL=SIN (TLAT)                                                     RAYTRC89

      CL=SIN (PID2-TLAT)                                                RAYTRC90

      ALPHA=DATAN2(-SDPH*CP,-CDPH*CP*SL+SP*CL)                          RAYTRC91

      TH0=DACOS (CDPH*CP*CL+SP*SL)                                      RAYTRC92

      PH0=DATAN2(SDPH*CL,CDPH*SP*CL-CP*SL)                              RAYTRC93

C                                                                       RAYTRC94

      R=EARTHR                                                          RAYTRC95

      TH=TH0                                                            RAYTRC96

      PH=PH0                                                            RAYTRC97

      CALL TOPOG                                                        RAYTRC98

C                                                                       RAYTRC99

C     OBTAIN ABSOLUTE HEIGHT OF THE TRANSMITTER.                        RAYTR100

C     IF IT WAS SPECIFIED AS RELATIVE TO THE TERRAIN, THEN REMOVE       RAYTR101

C     THE FLAG VALUE 10**40 WHICH WAS ADDED AT INPUT.                   RAYTR102

C                                                                       RAYTR103

      TMP=XMTRH                                                         RAYTR104

      IF(XMTRH .EQ. 1.E-10) XMTRH=0.0                                   RAYTR105

      IF(DABS(XMTRH) .GE. 1.E10 ) XMTRH=XMTRH*1.E-10                    RAYTR106

      IF(TMP.NE.XMTRH) XMTRH=XMTRH-G/PGR                                RAYTR107

C                                                                       RAYTR108

C     CHECK THAT TRANSMITTER IS ABOVE TERRAIN.                          RAYTR109

C                                                                       RAYTR110

      IF(-G/PGR .LE. XMTRH) GO TO 655                                   RAYTR111

C                                                                       RAYTR112

      PRINT 640, IRUN                                                   RAYTR113

      WRITE(3,640) IRUN                                                 RAYTR114

640   FORMAT('0****** TRANSMITTER BELOW TERRAIN. RUN ',I3               RAYTR115

     1 ,' TERMINATED.'/'SEE W-ARRAY PRINTOUT. INPUT CONTINUES.'//)      RAYTR116

      CALL SETOVR                                                       RAYTR117

      CALL PRINTW                                                       RAYTR118

      GO TO 10                                                          RAYTR119

C                                                                       RAYTR120

655   CALL SETOVR                                                       RAYTR121

      CALL PRINTW                                                       RAYTR122

      CALL IPRINTR                                                      RAYTR123

C******** INITIALIZE PRINT CONTROL PARAMTERS                            RAYTR124

      LINSPP=PAGLN                                                      RAYTR125

      LNPHPG=LINSPP/2                                                   RAYTR126

      IF(LNPHPG.LT.40) LNPHPG=LINSPP                                    RAYTR127

C                                                                       RAYTR128

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

      NFREQ=1                                                           RAYTR130

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

      NAZ=1                                                             RAYTR132

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

      NBETA=1                                                           RAYTR134

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

      DO 50 NF=1,NFREQ                                                  RAYTR136

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

      DO 45 J=1,NAZ                                                     RAYTR138

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

      AZA=AZ1*DEGS                                                      RAYTR140

      GAMMA1=PI-AZ1+ALPHA                                               RAYTR141

      SGAMMA=SIN (GAMMA1)                                               RAYTR142

      CGAMMA=SIN (PID2-GAMMA1)                                          RAYTR143

      DO 40 I=1,NBETA                                                   RAYTR144

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

      EL=BETA*DEGS                                                      RAYTR146

      CBETA=SIN (PID2-BETA)                                             RAYTR147

      R=EARTHR+XMTRH                                                    RAYTR148

      TH=TH0                                                            RAYTR149

      PH=PH0                                                            RAYTR150

      KR=SIN (BETA)                                                     RAYTR151

      KTH=CBETA*CGAMMA                                                  RAYTR152

      KPH=CBETA*SGAMMA                                                  RAYTR153

      TPULSE=0.                                                         RAYTR154

      RSTART=1.                                                         RAYTR155

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

      SGN=1.0                                                           RAYTR157

C********* CALL MODELS                                                  RAYTR158

      CALL DISPER                                                       RAYTR159

C                                                                       RAYTR160

      LINPG=LINES-LHDRPG                                                RAYTR161

      IF(I.EQ.1  .OR.  LINPG.GE.LINSPP-20) THEN                         RAYTR162

C                                                                       RAYTR163

C     PUT OUT SUBHEADERS FROM MEDIA AND PRINTR ROUTINES                 RAYTR164

         CALL HEADER2                                                   RAYTR165

         CALL PRNHD1(' ')                                               RAYTR166

C                                                                       RAYTR167

C     COMPUTE LINE COUNT OF THIS HEADER                                 RAYTR168

         LHDRPG=LINES/LINSPP*LINSPP                                     RAYTR169

      ELSEIF(LINPG.GE.LNPHPG-10 .AND. LINPG.LE.LNPHPG) THEN             RAYTR170

C     PUT OUT PAGE FEED WITH SUBHEADER IF AT HALF PAGE                  RAYTR171

         CALL PRNHD2('1')                                               RAYTR172

      ELSE                                                              RAYTR173

C     PUT OUT SUBHEADER                                                 RAYTR174

         CALL PRNHD2(' ')                                               RAYTR175

      ENDIF                                                             RAYTR176

C                                                                       RAYTR177

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

      WRITE(3,2900) OMEGMIN,OMEGMAX                                     RAYTR179

 2900 FORMAT (58H0TRANSMITTER IN EVANESCENT REGION, TRANSMISSION IMPOSSIRAYTR180

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

      GO TO 44                                                          RAYTR182

30    r999 = renorm(kr,kay2,3)

c30   CALL RENORM(KR,KAY2,3)                                            RAYTR183

      CALL CLEAR(RKVARS,NEQS-6)                                         RAYTR184

      CALL TOPOG                                                        RAYTR185

      IF(NERG.GT.0) RKVARS(NERG)=G                                      RAYTR186

      IF(NERR.GT.0) RKVARS(NERR)=PGR                                    RAYTR187

      IF(NERT.GT.0) RKVARS(NERT)=PGTH                                   RAYTR188

      IF(NERP.GT.0) RKVARS(NERP)=PGPH                                   RAYTR189

C                                                                       RAYTR190

C     CALCULATE ONE RAY PATH                                            RAYTR191

      CALL TRACE                                                        RAYTR192

      OSEC=SEC                                                          RAYTR193

      CALL SYSSEC(SEC)                                                  RAYTR194

      DIFF=SEC-OSEC                                                     RAYTR195

C                                                                       RAYTR196

C     ADD TO LINES COUNT FOR ELAPSED TIME REPORT                        RAYTR197

      LINES=LINES+2                                                     RAYTR198

      WRITE(3,3500) DIFF                                                RAYTR199

3500  FORMAT (/T93,'THIS RAY CALCULATION TOOK ',F8.3,' SEC')            RAYTR200

C                                                                       RAYTR201

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

   40 CONTINUE                                                          RAYTR203

44    IF(PLT.GT.0.AND.(NAZ.LE.1.OR.NBETA.GT.1)) CALL ENDPLT             RAYTR204

   45 CONTINUE                                                          RAYTR205

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

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

     1 GO TO 55                                                         RAYTR208

   50 CONTINUE                                                          RAYTR209

  55  IF (RAYSET.NE.0.) WRITE(9,5000)                                   RAYTR210

 5000 FORMAT (78X,1H-)                                                  RAYTR211

      GO TO 10                                                          RAYTR212

6000  PRINT *,'DINP EMPTY OR NOT FOUND'                                 RAYTR213

      STOP                                                              RAYTR214

      END                                                               RAYTR215





      BLOCK DATA SETALL

c

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

c

c

      real*8 mgp

      integer idsu(20),idsdu(20),idsc(20),idsdc(20)

      integer idst(20),idsdt(20),idsm(20),idsg(20)

      integer idsdg(20),idsv(20),idsdv(20),idspr(20)

      integer idsdp(20),idsr(20),idsp(20),idss(20)

      real*8 moda,modp,modsurf,modg,modrec,modc,modm,modt,modu

      real*8 modrin

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

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

C     COMMON DECK "GG" INSERTED HERE                                    CGG    2

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

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

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

C     COMMON DECK "UU" INSERTED HERE                                    CUU    2

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

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

      CHARACTER PCV*3,CNVC*2                                            CUCON  5

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

C                                                                       CONBLK19

C     COMMON DECK "SS" INSERTED HERE                                    CSS    2

c     REAL MODSURF                                                      CSS    4

      COMMON/SS/ MODSURF(4)                                             CSS    5

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

      COMMON/SS/PUTH,PUPH,PUTHTH,PUPHPH,PUTHPH,USELECT,UTIME            CSS    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 "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

C     COMMON DECK "B9" INSERTED HERE                                    CB8    2

      INTEGER GMX,GNTBL,GITBL,GFRMTBL                                   CB8    4

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

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

C     COMMON DECK "B2" INSERTED HERE                                    CB2    2

      INTEGER DUMX,DUNTBL,DUITBL,DUFRMTB                                CB2    4

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

      EQUIVALENCE (DUGP,IDSDU)                                          CB2    6

C     COMMON DECK "B4" INSERTED HERE                                    CB4    2

      INTEGER DCMX,DCNTBL,DCITBL,DCFRMTB                                CB4    4

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

      EQUIVALENCE (DCGP,IDSDC)                                          CB4    6

C     COMMON DECK "B6" INSERTED HERE                                    CB6    2

      INTEGER DTMX,DTNTBL,DTITBL,DTFRMTB                                CB6    4

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

      EQUIVALENCE (DTGP,IDSDT)                                          CB6    6

C     COMMON DECK "B1" INSERTED HERE                                    CB1    2

      INTEGER UMX,UNTBL,UITBL,UFRMTBL                                   CB1    4

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

      EQUIVALENCE (UGP,IDSU)                                            CB1    6

C     COMMON DECK "B3" INSERTED HERE                                    CB3    2

      INTEGER CMX,CNTBL,CITBL,CFRMTBL                                   CB3    4

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

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

C     COMMON DECK "B5" INSERTED HERE                                    CB5    2

      INTEGER TMX,TNTBL,TITBL,TFRMTBL                                   CB5    4

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

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

C     COMMON DECK "B7" INSERTED HERE                                    CB7    2

      INTEGER MMX,MNTBL,MITBL,MFRMTBL                                   CB7    4

C     REAL MGP                                                          CB7    5

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

      EQUIVALENCE (MGP,IDSM)                                            CB7    7

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

      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 "MM" INSERTED HERE                                    CMM    2

      real*8 m

c     REAL M,MODM                                                       CMM    4

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

C     COMMON DECK "PP" INSERTED HERE                                    CPP    2

c     REAL MODP                                                         CPP    4

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

C     COMMON DECK "AA" INSERTED HERE                                    CAA    2

c     REAL MODA                                                         CAA    4

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

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

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

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

C     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 "RKTIME" INSERTED HERE                                CRKTIME2

      COMMON/CRKTIME/RKTIME                                             CRKTIME4

C                                                                       CONBLK37

      COMMON/RAYCON/MCONP                                               CONBLK38

C                                                                       CONBLK39

      EQUIVALENCE(RKTIME,IRKTIME)                                       CONBLK40

C                                                                       CONBLK41

C     COMMON DECK "B10" INSERTED HERE                                   CB9    2

      INTEGER DGMX,DGNTBL,DGITBL,DGFRMTB                                CB9    4

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

      EQUIVALENCE (DGGP,IDSDG)                                          CB9    6

C     COMMON DECK "B8" INSERTED HERE                                    CB10   2

      INTEGER RMX,RNTBL,RITBL,RFRMTBL                                   CB10   4

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

      EQUIVALENCE (RGP,IDSR)                                            CB10   6

C     COMMON DECK "CB17" INSERTED HERE                                  CB17   2

      INTEGER VMX,VNTBL,VITBL,VFRMTBL                                   CB17   4

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

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

C     COMMON DECK "CB18" INSERTED HERE                                  CB18   2

      INTEGER DVMX,DVNTBL,DVITBL,DVFRMTB                                CB18   4

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

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

C     COMMON DECK "CB19" INSERTED HERE                                  CB19   2

      INTEGER PRMX,PRNTBL,PRITBL,PRFRMTB                                CB19   4

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

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

C     COMMON DECK "CB20" INSERTED HERE                                  CB20   2

      INTEGER DPMX,DPNTBL,DPITBL,DPFRMTB                                CB20   4

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

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

      REAL*8 KVECT(22)                                                  CONBLK48

      REAL*8 VSET(20)                                                   CONBLK49

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

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

      EQUIVALENCE (PF,PFR), (PG,PGR)                                    GBL    2

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

      CHARACTER*10 ANOTES,HNOTES                                        ANNOT  4

      COMMON/ANNCTL/LENA(4),LENHA(3)                                    ANNOT  5

      COMMON/ANNCTC/ANOTES(2,4),HNOTES(4,3)                             ANNOT  6

C     COMMON DECK "CB21" INSERTED HERE                                  CB21   2

      INTEGER SMX,SNTBL,SITBL,SFRMTBL                                   CB21   4

      COMMON/B21/SMX,SNTBL(10),SITBL(10),SFRMTBL(10),SGP(11)            CB21   5

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

      COMMON/CGET/ZERO                                                  GET   81

c

C                                                                       DFCNST10

C     COMMON DECK "RMACH" INSERTED HERE                                 CRMACH 2

      COMMON/CRMACH/RMACH(5)                                            CRMACH 4

C                                                                       DFCNST35

       INTEGER SMALL(2)                                                 DFCNST36

       INTEGER LARGE(2)                                                 DFCNST37

       INTEGER RIGHT(2)                                                 DFCNST38

       INTEGER DIVER(2)                                                 DFCNST39

       INTEGER LOG10(2)                                                 DFCNST40

CC                                                                      DFCNST41

       EQUIVALENCE (RMACH(1),SMALL(1))                                  DFCNST42

       EQUIVALENCE (RMACH(2),LARGE(1))                                  DFCNST43

       EQUIVALENCE (RMACH(3),RIGHT(1))                                  DFCNST44

       EQUIVALENCE (RMACH(4),DIVER(1))                                  DFCNST45

       EQUIVALENCE (RMACH(5),LOG10(1))                                  DFCNST46

C                                                                       DFCNST47

C                                                                       CONBLK51

      DATA KVECT/22*0.0/                                                CONBLK52

      DATA RAYNAME/6*1H /                                               CONBLK53

      DATA VSET/20*0.0/                                                 CONBLK54

      DATA OMEGMIN,OMEGMAX/0.0,0.0/                                     CONBLK55

      DATA POLAR,LPOLAR/(0.0,0.0),(1.0,0.0)/                            CONBLK56

C                                                                       CONBLK57

      data rktime/0.0/

c     DATA IRKTIME/0/                                                   CONBLK58

      DATA MCONP/0/                                                     CONBLK59

      DATA CREF,GAMMA,RGAS/1.0,1.4,8.31436E-3/                          CONBLK60

      DATA NRYIND,NDEVTMP,NFRMAT,NDEVGRP,NDEVBIN/8,4,0,10,11/           CONBLK61

      DATA PCV/'AN','LN','FQ',' '/                                      CONBLK62

      DATA CNVC/'RD' ,'KM' ,'RD' ,' '                                   CONBLK63

     1        ,'DG' ,' M' ,'HZ' ,' '                                    CONBLK64

     2        ,'KM' ,'FT' ,'KH' ,' '                                    CONBLK65

     3        ,'  ' ,'NM' ,'DG' ,' '/                                   CONBLK66

      DATA CNVV /16*1.0 /                                               CONBLK67

C                                                                       CONBLK68

      DATA IDSDC,IDSDT,IDSDU,IDSC,IDSM,IDST,IDSU,IDSG/160*1H /          CONBLK69

      DATA IDSDG,IDSV,IDSDV,IDSPR,IDSDP,IDSR/120*1H /                   CONBLK70

      DATA MODG/7HNO MODL,0.0,7HNO MODL,0.0/                            CONBLK71

      DATA MODREC/7HNO MODL,0.0,7HNO MODL,0.0/                          CONBLK72

      DATA MODU/7HNO MODL,0.0,7HNO MODL,0.0/                            CONBLK76

      DATA MODC/7HNO MODL,0.0,7HNO MODL,0.0/                            CONBLK77

      DATA MODT/7HNO MODL,0.0,7HNO MODL,0.0/                            CONBLK78

      DATA MODM/7HNO MODL,0.0,7HNO MODL,0.0/                            CONBLK79

      DATA MODP/7HNO MODL,0.0,7HNO MODL,0.0/                            CONBLK80

      DATA MODA/7HNO MODL,0.0,7HNO MODL,0.0/                            CONBLK81

C

      DATA MODRIN/8HACOUSTIC ,8H WAVE ** ,8H* WITH W ,8HIND ****        AWWBL  2

     1  ,8H** WITH  ,6HLOSSES ,2*1H /                                   AWWBL  3

      DATA DISPM/'AWWWL'/                                               AWWBL  4

      DATA TYPE/3*1H3 /                                                 AWWBL  5

C

      DATA UMX/1/                                                       UGZ2BL 2

      DATA UNTBL/1,11,8*0/                                              UGZ2BL 3

      DATA UITBL/1,9*0/                                                 UGZ2BL 4

      DATA UFRMTBL/1,9*0/                                               UGZ2BL 5

C

      DATA DUMX/1/                                                      NINDBL 2

      DATA DUNTBL/1,11,8*0/                                             NINDBL 3

      DATA DUITBL/1,9*0/                                                NINDBL 4

      DATA DUFRMTB/1,9*0/                                               NINDBL 5

C

      DATA CMX/1/                                                       GRTDMBL2

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

      DATA CITBL/1,9*0/                                                 GRTDMBL4

      DATA CFRMTBL/1,9*0/                                               GRTDMBL5

C

      DATA DCMX/1/                                                      COB2BL 2

      DATA DCNTBL/1,11,8*0/                                             COB2BL 3

      DATA DCITBL/1,9*0/                                                COB2BL 4

      DATA DCFRMTB/1,9*0/                                               COB2BL 5

C

      DATA ANT/0.0/                                                     TNH5BL 2

      DATA TMX/2/                                                       TNH5BL 3

      DATA TNTBL/1,11,72,7*0/                                           TNH5BL 4

      DATA TITBL/1,20,8*0/                                              TNH5BL 5

      DATA TFRMTBL/1,2,8*0/                                             TNH5BL 6

C

      DATA DTMX/1/                                                      TOB2BL 2

      DATA DTNTBL/1,11,8*0/                                             TOB2BL 3

      DATA DTITBL/1,9*0/                                                TOB2BL 4

      DATA DTFRMTB/1,9*0/                                               TOB2BL 5

C

      DATA MMX/1/                                                       MNSTBL 2

      DATA MNTBL/1,11,8*0/                                              MNSTBL 3

      DATA MITBL/1,9*0/                                                 MNSTBL 4

      DATA MFRMTBL/1,9*0/                                               MNSTBL 5

C

      DATA GMX/1/                                                       GRENZBL2

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

      DATA GITBL/1,9*0/                                                 GRENZBL4

      DATA GFRMTBL/1,9*0/                                               GRENZBL5

C

      DATA DGMX/1/                                                      NERRBL 2

      DATA DGNTBL/1,11,8*0/                                             NERRBL 3

      DATA DGITBL/1,9*0/                                                NERRBL 4

      DATA DGFRMTB/1,9*0/                                               NERRBL 5

C

      DATA VMX/1/                                                       MRDCBL 2

      DATA VNTBL/1,11,8*0/                                              MRDCBL 3

      DATA VITBL/1,9*0/                                                 MRDCBL 4

      DATA VFRMTBL/1,9*0/                                               MRDCBL 5

C

      DATA DVMX/1/                                                      NBSRBL 2

      DATA DVNTBL/1,11,8*0/                                             NBSRBL 3

      DATA DVITBL/1,9*0/                                                NBSRBL 4

      DATA DVFRMTB/1,9*0/                                               NBSRBL 5

C

      DATA PRMX/1/                                                      PPBL   2

      DATA PRNTBL/1,11,8*0/                                             PPBL   3

      DATA PRITBL/1,9*0/                                                PPBL   4

      DATA PRFRMTB/1,9*0/                                               PPBL   5

C

      DATA DPMX/1/                                                      NRESBL 2

      DATA DPNTBL/1,11,8*0/                                             NRESBL 3

      DATA DPITBL/1,9*0/                                                NRESBL 4

      DATA DPFRMTB/1,9*0/                                               NRESBL 5

C

      DATA RMX/1/                                                       RRBL   2

      DATA RNTBL/1,11,8*0/                                              RRBL   3

      DATA RITBL/1,9*0/                                                 RRBL   4

      DATA RFRMTBL/1,9*0/                                               RRBL   5

C

      DATA SMX/1/                                                       NRFBL  2

      DATA SNTBL/1,11,8*0/                                              NRFBL  3

      DATA SITBL/1,9*0/                                                 NRFBL  4

      DATA SFRMTBL/1,9*0/                                               NRFBL  5

C

      DATA LENA,ANOTES                                                  FANNBL 2

     1  /4*2,'DEPTH (#M!',')','DEPTH (#KM','!)',                        FANNBL 3

     2'HEIGHT (#M','!)','HEIGHT (#K','M!)'/                             FANNBL 4

      DATA LENHA,HNOTES                                                 FANNBL 5

     1  /3,2,4, 'RANGE AT S','EA LEVEL (','#KM!)',' '                   FANNBL 6

     2       ,'RANGE (#DE','G!)',2*' '                                  FANNBL 7

     3       ,'CROSS RANG','E AT SEA L','EVEL (#KM!',')'/               FANNBL 8

C

      DATA LIST/MXLIST*0/                                               SAD1BL 2

      DATA PMX/2/                                                       SAD1BL 3

      DATA PNTBL/1,NCHPG1,NSPGP,7*0/                                    SAD1BL 4

      DATA PITBL/1,NWPV,8*0/                                            SAD1BL 5

      DATA PFRMTBL/1,2,8*0/                                             SAD1BL 6

C

      DATA PF,PG/1.0,9*0.0,1.0,9*0.0/                                   GBL    3

      DATA NZ,NPZR,NPZRR,NPZRTH,NPZRPH,NPZTH,NPZPH,NPZTHTH              GBL    4

     1   ,NPZPHPH,NPZTHPH,NSELECT,NTIME                                 GBL    5

     2  /1,2,3,4,5,6,7,8,9,10,11,12/                                    GBL    6

      DATA FTIME,GTIME/-1.0,-1.0/

c     DATA FSELECT,GSELECT/8HRECEIVER,7HTERRAIN/                        GBL    7

      DATA ZERO/0.0/                                                    GBL    8

c

                                                                        DFCNST66

      DATA SMALL(1), SMALL(2) /        128,           0 /               DFCNST67 

      DATA LARGE(1), LARGE(2) /     -32769,          -1 /               DFCNST68

      DATA RIGHT(1), RIGHT(2) /       9344,           0 /               DFCNST69

      DATA DIVER(1), DIVER(2) /       9472,           0 /               DFCNST70

      DATA LOG10(1), LOG10(2) /  546979738,  -805796613 /               DFCNST71

c                                                                       DFCNST72

c

      end











      SUBROUTINE DFSYS                                                  DFSYS  2

c

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

c

      CHARACTER DAT*(*),DATX*10                                         DFSYS  3

      CHARACTER TIM*(*),TIMX*10                                         DFSYS  4

      REAL*8 X(N),Y(N)                                                  DFSYS 14

C                                                                       DFSYS  5

C     ALL ROUTINES WHICH RELY ON SYSTEM BASED FUNCTIONS, SUCH AS TIME   DFSYS  6

C     OF DAY OR MAY BENEFIT FROM SYSTEM AVAILABLE ROUTINES FOR BETTER   DFSYS  7

C     PERFORMANCE, SUCH AS 'RMOVE' HAVE BEEN COLLECTED IN THIS ROUTINE. DFSYS  8

C                                                                       DFSYS  9

      ENTRY RMOVE(X,Y,N)                                                DFSYS 10

C     MOVE 'N' COMPONENTS OF ARRAY 'Y' TO ARRAY 'X'.                    DFSYS 11

C     THIS LOGIC WILL HANDLE OVERLAP CASES ONLY FOR X(M)=X(M+N1)        DFSYS 12

C     WITH N1>0, M=1,N.                                                 DFSYS 13

C                                                                       DFSYS 15

      IF(N.LE.0) RETURN                                                 DFSYS 16

C     USE CYBER BUILT-IN ROUTINE                                        DFSYS 17

C      CALL MOVLEV(Y,X,N)                                               DFSYS 18

C                                                                       DFSYS 19

C     THE EQUIVALENT FORTRAN CODING FOR THIS ROUTINE ARE THE FOLLOWING  DFSYS 20

C     TWO LINES.                                                        DFSYS 21

      DO 10 I=1,N                                                       DFSYS 22

10    X(I)=Y(I)                                                         DFSYS 23

C                                                                       DFSYS 24

      RETURN                                                            DFSYS 25

C

      ENTRY SYSSEC(SECS)                                                DFSYS 26

C                                                                       DFSYS 27

C     OBTAIN CURENT TIME OF DAY IN SECONDS FROM SYSTEM ROUTINE          DFSYS 28

      SECS=0                                                            DFSYS 29

C     SYSTEM CALL NEEDED FOR THE CYBER NOS OP SYS                       DFSYS 30

C      CALL SECOND(SECS)                                                DFSYS 31

C     SYSTEM CALL NEEDED FOR CRAY COMPUTER UNDER CTSS                   DFSYS 32

C      CALL TIMEUSED(ICPU,IO,ISYS,MEM)                                  DFSYS 33

C      SECS=ICPU/1.E6                                                   DFSYS 34

c   MS FORTRAN V4.01 CALL TO GET SYSTEM TIME:

c

      call gettim(ihr,imin,isec,i100th)

      xhr = float(ihr)

      xmin = float(imin)

      secs = float(isec)

      x100th = float(i100th)/100.

      secs = secs + x100th

      secs = secs + 60.*xmin

      secs = secs + 3600.*xhr

c       

      RETURN                                                            DFSYS 35

C                                                                       DFSYS 36

      ENTRY SYSTIM(TIM)                                                 DFSYS 37

C                                                                       DFSYS 38

C     OBTAIN CURENT TIME OF DAY AS A CHARACTER STRING FROM SYSTEM ROUTI DFSYS 39

c     TIM='TIME'                                                        DFSYS 40

C     SYSTEM CALL NEEDED FOR THE CYBER NOS OP SYS                       DFSYS 41

C      CALL TIME(TIM)                                                   DFSYS 42

C     SYSTEM CALL NEEDED FOR THE CRAY CTSS OP SYS                       DFSYS 43

C     CALL TIMEDATE(TIM,DATX,MACH)                                      DFSYS 44

c   USING THE MS FORTRAN V4.01 SYSTEM TIME CALL

c

      call gettim(ihr,imin,iday,i100th)

      write (tim,'(i2,2x,i2,2x,i2)') ihr,imin,iday

c 

      RETURN                                                            DFSYS 45

C                                                                       DFSYS 46

      ENTRY SYSDAT(DAT)                                                 DFSYS 47

C                                                                       DFSYS 48

C     OBTAIN CURENT DATE AS A CHARACTER STRING FROM SYSTEM ROUTINE      DFSYS 49

      DAT='DATE'                                                        DFSYS 50

C     SYSTEM CALL NEEDED FOR THE CYBER NOS OP SYS                       DFSYS 51

C      CALL DATE(DAT)                                                   DFSYS 52

C     SYSTEM CALL NEEDED FOR THE CRAY CTSS OP SYS                       DFSYS 53

C     CALL TIMEDATE(TIMX,DAT,MACH)                                      DFSYS 54

c   USE MS FORTRAN V4.01 CALL TO GET SYSTEM DATE

c

      call getdat (iyr,imon,iday)

      write (dat,'(i2,2x,i2,2x,i2)') iyr,imon,iday

c

      RETURN                                                            DFSYS 55

      ENTRY MORTEM                                                      DFSYS 56

      STOP 'POST MORTEM'                                                DFSYS 57

      END                                                               DFSYS 58











c     SUBROUTINE DFCNST                                                 DFCNST 3

C                                                                       DFCNST 6

C     THIS MODULE PROVIDES CONSTANTS WHICH ARE EXPLICITLY DEPENDENT     DFCNST 7

C     ON MACHINE ARCHITECTURE AND SHOULD BE EXAMINED WHEN MAKING ANY    DFCNST 8

C     MIGRATION OF THE RAY TRACING ROUTINES.                            DFCNST 9

C                                                                       DFCNST10

C     COMMON DECK "RMACH" INSERTED HERE                                 CRMACH 2

c     COMMON/CRMACH/RMACH(5)                                            CRMACH 4

C                                                                       DFCNST12

C     SINGLE PRECISION MACHINE CONSTANTS                                DFCNST13

C      (SEE DIGITAL SIGNAL PROCESSING, IEEE PRESS 1979 P S-7)           DFCNST14

C                                                                       DFCNST15

C     THE CONSTANTS ARE DERIVED FROM THE FOLLOWING                      DFCNST16

C     FORM FOR FLOATING POINT NUMBERS:                                  DFCNST17

C                                                                       DFCNST18

C        SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )                   DFCNST19

C     FOR MOST MACHINES THE BASE B=2.                                   DFCNST20

C     FOR THE CYBER 60-BIT MACHINES                                     DFCNST21

C        T=48, EMIN=-974 AND EMAX=1070.                                 DFCNST22

C     FOR THE PDP-11 AND VAX-11 MACHINES                                DFCNST23

C        T=24, EMIN=-127 AND EMAX=127                                   DFCNST24

C                                                                       DFCNST25

C     RMACH(1)  SMALLEST POSITIVE MAGNITUDE = B**(EMIN-1)               DFCNST26

C     RMACH(2)  LARGEST MAGNITUDE           = B**EMAX*(1-B**(-T))       DFCNST27

C     RMACH(3)  SMALLEST RELATIVE SPACING   = B**(-T)                   DFCNST28

C     RMACH(4)  LARGEST RELATIVE SPACING    = B**(1-T)                  DFCNST29

C     RMACH(5)                              = LOG10(B=2)                DFCNST30

C                                                                       DFCNST31

C     CONSTANTS HERE ARE FOR CDC 6000/7000/CYBER SERIES COMPUTERS       DFCNST32

C     PLEASE SUBSTITUTE FOR OTHER MACHINES                              DFCNST33

C                                                                       DFCNST34

C                                                                       DFCNST35

C      INTEGER SMALL(2)                                                 DFCNST36

C      INTEGER LARGE(2)                                                 DFCNST37

C      INTEGER RIGHT(2)                                                 DFCNST38

C      INTEGER DIVER(2)                                                 DFCNST39

C      INTEGER LOG10(2)                                                 DFCNST40

CC                                                                      DFCNST41

C      EQUIVALENCE (RMACH(1),SMALL(1))                                  DFCNST42

C      EQUIVALENCE (RMACH(2),LARGE(1))                                  DFCNST43

C      EQUIVALENCE (RMACH(3),RIGHT(1))                                  DFCNST44

C      EQUIVALENCE (RMACH(4),DIVER(1))                                  DFCNST45

C      EQUIVALENCE (RMACH(5),LOG10(1))                                  DFCNST46

C                                                                       DFCNST47

C     MACHINE CONSTANTS FOR CYBER 170/180 COMPUTERS                     DFCNST48

C                                                                       DFCNST49

c     DATA RMACH(1) / O"00014000000000000000" /                         DFCNST50

c     DATA RMACH(2) / O"37767777777777777777" /                         DFCNST51

c     DATA RMACH(3) / O"16404000000000000000" /                         DFCNST52

c     DATA RMACH(4) / O"16414000000000000000" /                         DFCNST53

c     DATA RMACH(5) / O"17164642023241175720" /                         DFCNST54

C                                                                       DFCNST55

C***REFERENCES  FOX, P.A., HALL, A.D., SCHRYER, N.L, *FRAMEWORK FOR     DFCNST56

C                 A PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHE-       DFCNST57

C                 MATICAL SOFTWARE, VOL. 4, NO. 2, JUNE 1978,           DFCNST58

C                 PP. 177-188.                                          DFCNST59

C***ROUTINES CALLED  XERROR                                             DFCNST60

C***END PROLOGUE  R1MACH                                                DFCNST61

C     MACHINE CONSTANTS FOR VAX 11/780                                  DFCNST62

C     (EXPRESSED IN INTEGER AND HEXADECIMAL)                            DFCNST63

C    ***THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSYEMS***    DFCNST64

C    *** THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS***            DFCNST65

C                                                                       DFCNST66

C     DATA SMALL(1), SMALL(2) /        128,           0 /               DFCNST67

C     DATA LARGE(1), LARGE(2) /     -32769,          -1 /               DFCNST68

C     DATA RIGHT(1), RIGHT(2) /       9344,           0 /               DFCNST69

C     DATA DIVER(1), DIVER(2) /       9472,           0 /               DFCNST70

C     DATA LOG10(1), LOG10(2) /  546979738,  -805796613 /               DFCNST71

C                                                                       DFCNST72

C     DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 /                  DFCNST73

C     DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF /                  DFCNST74

C     DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 /                  DFCNST75

C     DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 /                  DFCNST76

C     DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB /                  DFCNST77

C                                                                       DFCNST78

C   MACHINE CONSTANTS FOR VAX 11/780 (G-FLOATING)                       DFCNST79

C     (EXPRESSED IN INTEGER AND HEXADECIMAL)                            DFCNST80

C    ***THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSYEMS***    DFCNST81

C    *** THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS***            DFCNST82

C                                                                       DFCNST83

C     DATA SMALL(1), SMALL(2) /         16,           0 /               DFCNST84

C     DATA LARGE(1), LARGE(2) /     -32769,          -1 /               DFCNST85

C     DATA RIGHT(1), RIGHT(2) /      15552,           0 /               DFCNST86

C     DATA DIVER(1), DIVER(2) /      15568,           0 /               DFCNST87

C     DATA LOG10(1), LOG10(2) /  1142112243, 2046775455 /               DFCNST88

C                                                                       DFCNST89

C     DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 /                  DFCNST90

C     DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF /                  DFCNST91

C     DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 /                  DFCNST92

C     DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 /                  DFCNST93

C     DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F /                  DFCNST94

C     MACHINE CONSTANTS FOR THE CRAY 1                                  DFCNST95

C                                                                       DFCNST96

C     DATA SMALL(1) / 201354000000000000000B /                          DFCNST97

C     DATA SMALL(2) / 000000000000000000000B /                          DFCNST98

C                                                                       DFCNST99

C     DATA LARGE(1) / 577767777777777777777B /                          DFCNS100

C     DATA LARGE(2) / 000007777777777777774B /                          DFCNS101

C                                                                       DFCNS102

C     DATA RIGHT(1) / 376434000000000000000B /                          DFCNS103

C     DATA RIGHT(2) / 000000000000000000000B /                          DFCNS104

C                                                                       DFCNS105

C     DATA DIVER(1) / 376444000000000000000B /                          DFCNS106

C     DATA DIVER(2) / 000000000000000000000B /                          DFCNS107

C                                                                       DFCNS108

C     DATA LOG10(1) / 377774642023241175717B /                          DFCNS109

C     DATA LOG10(2) / 000007571421742254654B /                          DFCNS110

C                                                                       DFCNS111

C                                                                       DFCNS112

c     END                                                               DFCNS113











      SUBROUTINE READW1(AB,NWOK,MSET,MX,NTBL,ITBL,FRMTBL,GP)            READW1 2

c

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

c

C     HANDLES INPUT OF TABULAR DATA REQUIRED BY SOME MODELS.            READW1 3

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

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

      CHARACTER PCV*3,CNVC*2                                            CUCON  5

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

C     COMMON DECK "CONST" INSERTED HERE                                 CCONST 2

      COMMON/PCONST/CREF,RGAS,GAMMA                                     CCONST 4

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

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

      LOGICAL NWOK,AB                                                   READW1 8

C                                                                       READW1 9

      CHARACTER LINE*80,ALPHA*3,FBUF*3                                  READW110

      PARAMETER (NVAR=6,ALPHA='  A',NACDE=-1,NFIELD=13)                 READW111

      INTEGER IPV(NVAR),NTBL(10),ITBL(10),FRMTBL(10)                    READW112

      CHARACTER*8 PU(NVAR)                                              READW113

      REAL*8     V(NVAR),CONV(NVAR)                                     READW114

c

      real*8 gp(*)

C                                                                       READW115

      LOGICAL UUUCCC, UCON

C                                                                       READW115

C     THE DATA STRUCTURE EXPECTED BY THIS PROGRAM FOR A DATA BLOCK IS   READW116

C     SPECIFIED FOR A GIVEN MODEL BY THE THREE ARRAYS NTBL,ITBL,FRMTBL. READW117

C     THE TYPE OF DATA EXPECTED FOR A GIVEN FORMAT GROUP IS TAKEN FROM  READW118

C     ARRAY FRMTBL. IT MUST HAVE AN ENTRY FOR A GIVEN TYPE OF FORMAT    READW119

C     WHICH IS EITHER ZERO, IF THAT FORMAT IS NOT ALLOWED OR AN ENTRY   READW120

C     WHOSE VALUE IS EQUAL TO THAT FORMAT TYPE. CURRENTLY ONLY TWO      READW121

C     FORMAT TYPES ARE ALLOWED, 1 FOR ALPHA AND 2 FOR NUMERIC.          READW122

C     TO ALLOW MORE FLEXIBLITY IN THE INPUT FILE THE NUMERIC FORMAT     READW123

C     TYPE IN TURN ALLOWS FOR 3 DIFFERENT DATA FORMATS, SEE BELOW.      READW124

C                                                                       READW125

C     OFFSETS INTO THE GENERAL ARRAY 'GP' FOR EACH FORMAT ARE GIVEN     READW126

C     IN THE ARRAY 'NTBL'. THE SPACING BETWEEN DATA VALUES IN EACH LINE READW127

C     READ IS GIVEN IN ARRAY 'ITBL'. THIS SCHEME DOES NOT ALLOW FOR X,Y READW128

C     ,Z CYCLES BUT RATHER SEPARATE ARRAYS OF X VALUES, THEN Y VALUES,  READW129

C     AND THEN Z VALUES(ETC. UP TO 'NVAR' VARIABLES).                   READW130

C                                                                       READW131

      NWOK=.TRUE.                                                       READW132

C                                                                       READW133

C     INITIALIZE ANY ALPHANUMERIC ARRAYS TO BLANKS                      READW134

      IF(FRMTBL(1).EQ.1) CALL SET2(GP(NTBL(1)),1H ,NTBL(2)-NTBL(1))     READW135

C                                                                       READW136

C     BEGIN MULTI-FORMAT LOOP                                           READW137

5     READ(NRYIND,'(A,A)',END=200) FBUF,LINE                            READW138

      IF(NDEVTMP.GT.0) WRITE(NDEVTMP,'(A,A)') FBUF,LINE                 READW139

      IF(FBUF.EQ.ALPHA) THEN                                            READW140

         NFRM=NACDE                                                     READW141

      ELSE                                                              READW142

         READ(FBUF,10) NFRM                                             READW143

      ENDIF                                                             READW144

10    FORMAT(BZ,I3,A)                                                   READW145

      IF(NFRM .EQ. 0) RETURN                                            READW146

C                                                                       READW147

C     FORMAT #1 IS ASSIGNED TO ALPHANUMERIC INPUT AND LARGER NUMBERS    READW148

C     FOR NUMERIC INPUT.                                                READW149

C                                                                       READW150

C     CHECK NOW FOR NUMERICAL FORMATS.                                  READW151

C     THESE ARE PROVIDED FOR EASE OF INPUT OF TABULATED DATA            READW152

C     AND ARE PARTLY 'TRANSPARENT' TO THE MODEL INVOLVED. I.E.          READW153

C     THE USER HAS THE OPTION OF SPECIFING THE NUMBER OF DATA COLUMNS.  READW154

C     INPUT FORMAT NUMBER SPECIFIES THE NUMBER OF COLUMNS OF INPUT DATA READW155

C     I.E. FOR VALUE 1 A SINGLE DATA COLUMN IS EXPECTED, FOR A VALUE    READW156

C     2 TWO DATA COLUMNS ARE EXPECTED, ETC.                             READW157

C                                                                       READW158

C     DETERMINE FORMAT NUMBER                                           READW159

      IF(NFRM.EQ.NACDE) THEN                                            READW160

         IT=1                                                           READW161

C     ALPHANUMERIC FORMATS MUST BE FIRST IN LIST                        READW162

C     SINCE NO OFFSET SPECIFIER IS ALLOWED IN A FULL ALPHA LINE         READW163

         IF(FRMTBL(1).EQ.1) GO TO 100                                   READW164

      ELSE                                                              READW165

         READ(LINE,'(I2)') IT                                           READW166

         IT=MAX0(IT,2)                                                  READW167

         IF(IT.LE.MX) GO TO 100                                         READW168

      ENDIF                                                             READW169

C                                                                       READW170

15    AB=.TRUE.                                                         READW171

      PRINT 20, MSET,NFRM,MX                                            READW172

20    FORMAT(' FOR SET',I5,' FORMAT NUMBER',I5,' EXCEEDS LIMIT OF',I5)  READW173

C      ERROR IN INPUT DATA , STOP HERE                                  READW174

      STOP                                                              READW175

C                                                                       READW176

C     THE 'NTBL' TABLE PROVIDES A LIST OF OFFSETS TO VARIABLE GROUPS IN READW177

C     MODEL ARRAYS, 'ITBL' GIVES ELEMENT SEPARATION TO ALLOW FOR 2-     READW178

C     DIMENSIONAL ARRAYS AND 'FRMTBL' SPECIFIES THE INPUT FORMAT.       READW179

C                                                                       READW180

100   N1=NTBL(IT)                                                       READW181

      N3=ITBL(IT)                                                       READW182

      N2=NTBL(IT+1)-N3                                                  READW183

C                                                                       READW184

      IF(NFRM.NE.NACDE) GO TO 110                                       READW185

C                                                                       READW186

      READ(LINE,1010)((GP(I+J-1),I=N1,N2,N3),J=1,N3)                    READW187

1010  FORMAT(10A8)                                                      READW188

      GO TO 5                                                           READW189

C                                                                       READW190

110   IF(NFRM.LT.1 .OR. NFRM.GT.NVAR) GO TO 200                         READW191

C     HANDLE NUMERIC FORMATS                                            READW192

C                                                                       READW193

C     N1 IS STARTING ELEMENT WHICH WILL BE AFTER THE DATA COUNT         READW194

C     VALUE(NEED NELS*N3+1 TOTAL ELEMENTS)                              READW195

      N1=N1+1                                                           READW196

      N=0                                                               READW197

C                                                                       READW198

C     # ELEMENTS IS EQUAL TO FORMAT NUMBER                              READW199

      NELS=NFRM                                                         READW100

C     READ UNITS CONVERSION SPECIFICATION LINE                          READW101

      READ(LINE,1018) (PU(I),I=1,3)                                     READW102

      IF(PU(2).NE.' ') READ(LINE,2024) DELIM                            READW103

      IF(PU(2).EQ.' ') READ(LINE,1020) DELIM,(PU(I),I=1,NELS)           READW104

C                                                                       READW105

C  ALLOW FOR BLANK CONVERSION LINE PRODUCED BY EIGENRAY ROUTINE         READW106

      IF(DELIM.EQ.0) READ(LINE,2024) DELIM                              READW107

C                                                                       READW108

C     READ NEXT LINE AND EXTRACT UNIT CONVERSION SPECS IF PRESENT       READW109

C     IN FLOATING FORMAT                                                READW110

      READ(NRYIND,'(A)') LINE                                           READW111

      CALL GTUNIT(LINE,PU,NFIELD,NELS, NCARY)                           READW112

C     CARRY COUNT IS ZERO IF LINE CONTAINED UNITS SPECIFIERS            READW113

      IF(NCARY.EQ.0.AND.NDEVTMP.GT.0) WRITE(NDEVTMP,'(A)') LINE         READW114

C                                                                       READW115

1018  FORMAT(10(A,5X))                                                  READW116

1020  FORMAT(BZ,3X,G10.3,8X,10A)                                        READW117

2024  FORMAT(T43,G10.3)                                                 READW118

1025  FORMAT(BZ,10G13.6)                                                READW119

C                                                                       READW120

C     LOOK UP CONVERSION CONSTANTS                                      READW121

      DO 2030 I=1,NELS                                                  READW122

2030  UUUCCC = UCON(IPV(I),PU(I),CONV(I))                               READW123

C                                                                       READW124

C     DELIMITOR TESTING REQUIRES THE INNER LOOP BE EXECUTED             READW125

C     AT LEAST ONCE                                                     READW126

      NX=MAX0(1,N3)                                                     READW127

      N2=MAX0(N2,N1)                                                    READW128

C     BEGIN SINGLE DATA FORMAT LOOP                                     READW129

      DO 150 J=0,10000                                                  READW130

         IF(NELS.GT.1) THEN                                             READW131

            IF(NCARY.EQ.0) READ(NRYIND,'(A)') LINE                      READW132

            NCARY=0                                                     READW133

            IF(NDEVTMP.GT.0) WRITE(NDEVTMP,'(A)') LINE                  READW134

            READ(LINE,1025) (V(I),I=1,NELS)                             READW135

         ENDIF                                                          READW136

         K=0                                                            READW137

         DO 145 I=N1+J,N2+J,NX                                          READW138

               K=K+1                                                    READW139

               IF(NELS.EQ.1) THEN                                       READW140

                  IF(NCARY.EQ.0) READ(NRYIND,'(A)',END=10000) LINE      READW141

                  NCARY=0                                               READW142

                  IF(NDEVTMP.GT.0) WRITE(NDEVTMP,'(A)') LINE            READW143

C     FOR SINGLE COLUMN CASE READ NOW                                   READW144

                  READ(LINE,1020) V(K)                                  READW145

               ENDIF                                                    READW146

               IF(V(K) .EQ. DELIM) GO TO 160                            READW147

C                                                                       READW148

C           APPLY ANY SCALING CONVERSIONS                               READW149

               V(K)=V(K)*CONV(K)                                        READW150

               IF(J.LT.N3) GP(I)=V(K)                                   READW151

145            N=N+1                                                    READW152

150   CONTINUE                                                          READW153

C                                                                       READW154

10000 CONTINUE

      AVAL = FLOAT(MSET)

      IF(V(1).NE.DELIM) CALL RERROR('READW1','NO DELIM',   AVAL    )    READW155

C                                                                       READW156

C     SAVE NUMBER OF VALUES AND ELEMENTS(AS FRACTIONAL PART)            READW157

160   IF(N1.GT.1) GP(N1-1)=N+NELS/10.                                   READW158

C                                                                       READW159

C     CONTINUE MULTI-FORMAT LOOP                                        READW160

      GO TO 5                                                           READW161

C                                                                       READW162

200   CONTINUE

      AVAL = FLOAT(MSET)

      CALL RERROR('READW1','BAD FORMAT',   AVAL    )                    READW163

C                                                                       READW164

      END                                                               READW165











      SUBROUTINE GTUNIT(LINE,PU,NFIELD,NVAR, LN)                        READW166

c

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

c

C     GTUNIT IS USED TO EXTRACT UNIT CONVERSION SPECIFIERS FROM TABULAR READW167

C     DATA INPUT.                                                       READW168

C     CONVERSION SPECIFICATIONS ARE TAKEN FROM 'LINE' INPUT STRING.     READW169

C     A FLOATING FORMAT FALLING WITHIN SUCCESSIVE FIELDS OF             READW170

C     LENGTH 'NFIELD' IS PROVIDED FOR.                                  READW171

C     OUTPUT IS TO UNIT SPECIFIER ARRAY 'PU' FOR A MAXIMUM OF 'NVAR'    READW172

C     FIELDS. FOR A SUCCESS/FAIL RETURN VALUE, 'LN' GIVES THE NUMBER    READW173

C     OF NON-BLANK CHARACTERS USEFUL FOR UNIT DECODING, ZERO IMPLIES    READW174

C     NO USEFUL UNIT INFORMATION WAS FOUND.                             READW175

C                                                                       READW176

      PARAMETER (MAXLN=130)                                             READW177

      CHARACTER*(*) LINE,PU(NVAR),TMP*(MAXLN),TMP1*(MAXLN)              READW178

      INTEGER STRIM                                                     READW179

C                                                                       READW180

      LN=STRIM(LINE)                                                    READW181

      IF(LN.LT.1) THEN                                                  READW182

         DO 5 I=1,NVAR                                                  READW183

5           PU(I)=' '                                                   READW184

         RETURN                                                         READW185

      ENDIF                                                             READW186

C                                                                       READW187

      TMP=' '                                                           READW188

      CALL SFILTR(LINE,TMP,' 0123456789+-.E')                           READW189

      IF(STRIM(TMP).LT.1) RETURN                                        READW190

C     SIGNIFY WE CONSUMED THIS LINE                                     READW191

      LN=0                                                              READW192

C                                                                       READW193

      TMP1=LINE                                                         READW194

C     PLACE INTER-SPECIFIER DELIMITORS                                  READW195

      DO 10 I=NFIELD,NFIELD*NVAR,NFIELD                                 READW196

         IF(TMP1(I:I).NE.' ') THEN                                      READW197

            IF(TMP1(I+1:I+1).NE.' ') THEN                               READW198

C     IF NO ROOM FOR A BLANK, ITS AN ERROR                              READW199

               VVAALL = FLOAT(I)

               CALL RERROR('GTUNIT','FORMAT ER1', VVAALL )              READW200

            ELSE                                                        READW201

               TMP1(I+1:I+1)='#'                                        READW202

            ENDIF                                                       READW203

         ELSE                                                           READW204

            TMP1(I:I)='#'                                               READW205

         ENDIF                                                          READW206

10    CONTINUE                                                          READW207

C                                                                       READW208

C     NOW SQUEEZE OUT THE BLANKS                                        READW209

      CALL SFILTR(TMP1,TMP,' ')                                         READW210

C     HOPEFULLY SOMETHING LEFT                                          READW211

C                                                                       READW212

      NL=STRIM(TMP)                                                     READW213

      ILIN=1                                                            READW214

      DO 20 I=1,NVAR                                                    READW215

C     CHECK FOR EMPTY CONVERSIONS                                       READW216

         IF(TMP(ILIN:ILIN).EQ.'#') THEN                                 READW217

            ILIN=ILIN+1                                                 READW218

            PU(I)=' '                                                   READW219

            GO TO 20                                                    READW220

         ENDIF                                                          READW221

C     GET NEXT UNIT TYPE                                                READW222

         PU(I)(1:2)=TMP(ILIN:ILIN+1)                                    READW223

C     GET NEXT PHYSICAL UNIT(BLANKS HAVE BEEN REMOVED)                  READW224

C     SHORT PHRASE IF A BLANK WAS REMOVED                               READW225

         IF(TMP(ILIN+3:ILIN+3).NE.'#') THEN                             READW226

            IF(TMP(ILIN+4:ILIN+4).NE.'#') THEN                          READW227

C     IF INCORRECT GROUPING OF LETTERS, ITS AN ERROR                    READW228

               VVAALL = FLOAT(ILIN)

               CALL RERROR('GTUNIT','FORMAT ER2',  VVAALL   )           READW229

            ELSE                                                        READW230

C     ADD TWO LETTER UNIT                                               READW231

               PU(I)(3:5)=' '//TMP(ILIN+2:ILIN+3)                       READW232

               ILIN=ILIN+5                                              READW233

            ENDIF                                                       READW234

         ELSE                                                           READW235

C     ADD ONE LETTER UNIT                                               READW236

            PU(I)(3:5)='  '//TMP(ILIN+2:ILIN+2)                         READW237

            ILIN=ILIN+4                                                 READW238

         ENDIF                                                          READW239

20    CONTINUE                                                          READW240

C                                                                       READW241

C     SHOULD HAVE USED UP ALL THE TEXT BY NOW                           READW242

      VVAALL = FLOAT(ILIN)

      IF(ILIN.LE.NL) CALL RERROR('GTUNIT','FORMAT ER3',   VVAALL  )     READW243

      END                                                               READW244











      SUBROUTINE SREAD1(AB,NWOK,NW)                                     SREAD1 9

c

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

c

C     THIS IS THE FALLTHROUGH FEATURE FOR READW WHEN ENCOUNTERING       SREAD110

C     A NON STANDARD LABELED COMMON BLOCK. SREAD1 WILL ADD TABULAR      SREAD111

C     DATA TO THE DEFAULT GP ARRAY PGP AND INCLUDE INDEX OFFSET         SREAD112

C     VALUES TO A LOOKUP ARRAY 'LIST'.                                  SREAD113

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

      logical ab,nwok

C                                                                       SREAD115

      CHARACTER ITOC*7                                                  SREAD116

C                                                                       SREAD117

C                                                                       SREAD120

      NWA=IABS(NW)-(MNGRP-2)                                            SREAD121

      IF(NWA.LT.2 .OR. NWA.GT.MXLIST) CALL STOPIT                       SREAD122

     1  ( 'SREAD1 NW='//ITOC(NW)//',LIST(1)='//ITOC(LIST(1)) )          SREAD123

C                                                                       SREAD124

      CALL READW1(AB,NWOK,NW,PMX,PNTBL,PITBL,PFRMTBL,PGP)               SREAD125

C                                                                       SREAD126

C     UPDATE THE LIST, LIST(1)=MAXIMUM USED ELEMENT                     SREAD127

      LIST(1)=MAX0(LIST(1),NWA)                                         SREAD128

      LIST(NWA)=PNTBL(1)                                                SREAD129

C                                                                       SREAD130

C     GET NEXT NUMERICAL INDEX FROM THE POINTER ARRAY                   SREAD131

      NLN=PNTBL(2)                                                      SREAD132

C                                                                       SREAD133

C     NUMBER OF VALUES IS INTEGRAL PART OF FIRST ELEMENT                SREAD134

      NPTS=PGP(NLN)                                                     SREAD135

C     NUMBER OF ROWS IS KEPT AS FRACTIONAL PART                         SREAD136

      VVAALL = FLOAT(NPTS)

      NELS=(PGP(NLN)-   VVAALL   )*10.+.5                               SREAD137

      N2=NPTS/NELS                                                      SREAD138

      NMX=PITBL(2)                                                      SREAD139

C     MAKE ADJUSTMENTS TO LENGTHS AND OFFSETS                           SREAD140

      PITBL(2)=NMX-N2-(NCHPG1-1)                                        SREAD141

      NUP=NPTS+NCHPG1                                                   SREAD142

      PNTBL(1)=PNTBL(1)+NUP                                             SREAD143

      PNTBL(2)=PNTBL(2)+NUP                                             SREAD144

      NLN=NLN+1                                                         SREAD145

C                                                                       SREAD146

C     LOOP TO MOVE NELS-1 ROWS OF PGP(NMX,NELS) TO PGP(N2,NELS)         SREAD147

C     THUS MAKING PGP A CONTIGUOUS ARRAY                                SREAD148

      NTO=NLN+N2                                                        SREAD149

      NFRM=NLN+NMX                                                      SREAD150

      DO 100 I=2,NELS                                                   SREAD151

      IF(NTO.GT.0 .AND. NFRM+N2-1.LE.NSPGP)                             SREAD152

     1        CALL RMOVE(PGP(NTO),PGP(NFRM),N2)                         SREAD153

      NTO=NTO+N2                                                        SREAD154

100   NFRM=NFRM+NMX                                                     SREAD155

      END                                                               SREAD156





      function itoc(n)

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







      SUBROUTINE READW                                                  READW  2

c

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

c

c

      real*8 mgp

c

C     READS W ARRAY MAKING ANY NECESSARY CONVERSION OF UNITS.           READW  3

C     VARIABLE LENGTH 'TABULAR' DATA IS READ BY SUBROUTINE 'READW1'     READW  4

C     WHICH IS CALLED FOR NEGATIVE W-ARRAY INDICES.                     READW  5

C                                                                       READW  6

C     COMMON DECK "CONST" INSERTED HERE                                 CCONST 2

      COMMON/PCONST/CREF,RGAS,GAMMA                                     CCONST 4

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

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

      EXTERNAL UCON

      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 "B1" INSERTED HERE                                    CB1    2

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

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

      EQUIVALENCE (UGP,IDSU)                                            CB1    6

C     COMMON DECK "B2" INSERTED HERE                                    CB2    2

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

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

      EQUIVALENCE (DUGP,IDSDU)                                          CB2    6

C     COMMON DECK "B3" INSERTED HERE                                    CB3    2

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

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

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

C     COMMON DECK "B4" INSERTED HERE                                    CB4    2

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

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

      EQUIVALENCE (DCGP,IDSDC)                                          CB4    6

C     COMMON DECK "B5" INSERTED HERE                                    CB5    2

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

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

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

C     COMMON DECK "B6" INSERTED HERE                                    CB6    2

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

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

      EQUIVALENCE (DTGP,IDSDT)                                          CB6    6

C     COMMON DECK "B7" INSERTED HERE                                    CB7    2

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

c     REAL MGP                                                          CB7    5

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

      EQUIVALENCE (MGP,IDSM)                                            CB7    7

C     COMMON DECK "B9" INSERTED HERE                                    CB8    2

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

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

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

C                                                                       READW 17

C     COMMON DECK "B10" INSERTED HERE                                   CB9    2

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

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

      EQUIVALENCE (DGGP,IDSDG)                                          CB9    6

C                                                                       READW 19

C     COMMON DECK "B8" INSERTED HERE                                    CB10   2

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

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

      EQUIVALENCE (RGP,IDSR)                                            CB10   6

C                                                                       READW 21

C     COMMON DECK "CB17" INSERTED HERE                                  CB17   2

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

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

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

C     COMMON DECK "CB18" INSERTED HERE                                  CB18   2

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

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

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

C     COMMON DECK "CB19" INSERTED HERE                                  CB19   2

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

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

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

C     COMMON DECK "CB20" INSERTED HERE                                  CB20   2

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

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

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

C                                                                       READW 26

c  bigval was 1.e30, too big for the Z248

      PARAMETER (MXCMTS=83,BIGVAL=1.D9)                                 READW 27

      CHARACTER*38 WFRMT,WNOTES(2)                                      READW 28

      CHARACTER*80 LINEX,NUMSTG                                         READW 29

      CHARACTER*100 STMP1,STMP2                                         READW 30

      INTEGER STRIM,WCOMTS(MXCMTS)                                      READW 31

      CHARACTER*1 DEG,KM,NM,FEET,CYCLE,PER,MSKMS                        READW 32

C     COMMON DECK "RAYDEV" INSERTED HERE                                CRAYDEV2

C     DEVICE ASSIGNED TO RAYTRC INPUT FILE                              CRAYDEV4

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

      LOGICAL NWOK,AB,UCON,UUCON                                        READW 34

C                                                                       READW 35

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                                                                       READW 37

      CHARACTER PC*1                                                    READW 38

C                                                                       READW 39

      INTEGER XMX,XNTBL(10),XITBL(10),XFRMTBL(10)                       READW 40

      real*8 xgp

c     REAL XGP(11)                                                      READW 41

C                                                                       READW 42

      DATA XMX/2/                                                       READW 43

      DATA XNTBL/1,11,12,7*0/                                           READW 44

      DATA XITBL/1,9*0/                                                 READW 45

      DATA XFRMTBL/1,2,8*0/                                             READW 46

C                                                                       READW 47

      DATA WCOMTS,WNOTES/MXCMTS*1, ' ',' INPUT OVERRIDDEN'/             READW 48

C                                                                       READW 49

      AB=.FALSE.                                                        READW 50

      reedw = 0.0

c     READW=0.0                                                         READW 51

C                                                                       READW 52

      IF(NDEVTMP.GT.0) REWIND NDEVTMP                                   READW 53

C                                                                       READW 54

      READ(NRYIND,1000,END=3) ID                                        READW 55

      write(6,1000) id

 1000 FORMAT (BZ,10A8)                                                  READW 56

      IF(NDEVTMP.GT.0) WRITE(NDEVTMP,1000) ID                           READW 57

      GO TO 4                                                           READW 58

C                                                                       READW 59

3     reedw = 1.0 

c3    READW=1.0                                                         READW 60

      IF(NFRMAT.LT.0) RETURN                                            READW 61

C                                                                       READW 62

      PRINT 1040                                                        READW 63

      WRITE(3,1040)                                                     READW 64

1040  FORMAT(' END OF INPUT DATA')                                      READW 65

      CALL ENDPLT                                                       READW 66

33    IF(PLT.NE.0.0) CALL DDEND                                         READW 67

      STOP                                                              READW 68

C                                                                       READW 69

4     READ(NRYIND,'(A)',END=10001) STMP1                                READW 70

C                                                                       READW 71

      READ(STMP1,1100) NW,WWW,LINEX                                     READW 72

1100  FORMAT (BZ,I3,E14.7,A)                                            READW 73

      IF(NDEVTMP.GT.0.AND.(NFRMAT.NE.-2.OR.NW.LT.0))                    READW 74

     1      WRITE(NDEVTMP,'(A)') STMP1                                  READW 75

10001 IF (NW.EQ.0) GO TO 10                                             READW 76

      IF(NW.GT.MAXW) GO TO 3400                                         READW 77

C                                                                       READW 78

      IF (NW.LE.MAXW .AND. NW.GT.0) GO TO 5                             READW 79

C     TABULAR INPUT DATA                                                READW 80

      NWOK=.FALSE.                                                      READW 81

C 'OPEN' THE TEMP FILE                                                  READW 82

1150  FORMAT(I3,T18,A)                                                  READW 83

      NWP=-NW                                                           READW 84

      IF(NFRMAT.EQ.-2) THEN                                             READW 85

C     USE DUMMY ARRAYS TO ABSORB TABULAR DATA                           READW 86

         CALL READW1(AB,NWOK,NW,XMX,XNTBL,XITBL,XFRMTBL,XGP)            READW 87

      ELSEIF(NWP.EQ.1) THEN                                             READW 88

         CALL READW1(AB,NWOK,NW,UMX,UNTBL,UITBL,UFRMTBL,UGP)            READW 89

      ELSEIF(NWP.EQ.2) THEN                                             READW 90

         CALL READW1(AB,NWOK,NW,DUMX,DUNTBL,DUITBL,DUFRMTB,DUGP)        READW 91

      ELSEIF(NWP.EQ.3) THEN                                             READW 92

         CALL READW1(AB,NWOK,NW,CMX,CNTBL,CITBL,CFRMTBL,CGP)            READW 93

      ELSEIF(NWP.EQ.4) THEN                                             READW 94

         CALL READW1(AB,NWOK,NW,DCMX,DCNTBL,DCITBL,DCFRMTB,DCGP)        READW 95

      ELSEIF(NWP.EQ.5) THEN                                             READW 96

            CALL READW1(AB,NWOK,NW,TMX,TNTBL,TITBL,TFRMTBL,TGP)         READW 97

      ELSEIF(NWP.EQ.6) THEN                                             READW 98

         CALL READW1(AB,NWOK,NW,DTMX,DTNTBL,DTITBL,DTFRMTB,DTGP)        READW 99

      ELSEIF(NWP.EQ.7) THEN                                             READW100

         CALL READW1(AB,NWOK,NW,MMX,MNTBL,MITBL,MFRMTBL,MGP)            READW101

      ELSEIF(NWP.EQ.8) THEN                                             READW102

         CALL READW1(AB,NWOK,NW,RMX,RNTBL,RITBL,RFRMTBL,RGP)            READW103

      ELSEIF(NWP.EQ.9) THEN                                             READW104

         CALL READW1(AB,NWOK,NW,GMX,GNTBL,GITBL,GFRMTBL,GGP)            READW105

      ELSEIF(NWP.EQ.10) THEN                                            READW106

         CALL READW1(AB,NWOK,NW,DGMX,DGNTBL,DGITBL,DGFRMTB,DGGP)        READW107

      ELSEIF(NWP.EQ.17) THEN                                            READW108

         CALL READW1(AB,NWOK,NW,VMX,VNTBL,VITBL,VFRMTBL,VGP)            READW109

      ELSEIF(NWP.EQ.18) THEN                                            READW110

         CALL READW1(AB,NWOK,NW,DVMX,DVNTBL,DVITBL,DVFRMTB,DVGP)        READW111

      ELSEIF(NWP.EQ.19) THEN                                            READW112

         CALL READW1(AB,NWOK,NW,PRMX,PRNTBL,PRITBL,PRFRMTB,PRGP)        READW113

      ELSEIF(NWP.EQ.20) THEN                                            READW114

         CALL READW1(AB,NWOK,NW,DPMX,DPNTBL,DPITBL,DPFRMTB,DPGP)        READW115

      ELSE                                                              READW116

         CALL SREAD1(AB,NWOK,NW)                                        READW117

      ENDIF                                                             READW118

      IF(NWOK) GO TO 4                                                  READW119

C                                                                       READW120

3400  WRITE(3,4000) NW,MAXW                                             READW121

4000  FORMAT(15H1THE SUBSCRIPT ,I3,  ' ON THE W-ARRAY INPUT IS OUT OF BOREADW122

     1UNDS.  ALLOWABLE VALUES ARE -8 THROUGH,',I4,'.' )                 READW123

      STOP 4000                                                         READW124

C                                                                       READW125

5     READ(LINEX,70) DEG,KM,NM,FEET,CYCLE,PER,MSKMS                     READW126

70    FORMAT(7A)                                                        READW127

      W(NW)=WWW                                                         READW128

C                                                                       READW129

C     CHECK FOR A 'TERRAIN RELATIVE' HEIGHT SPECIFICATION.              READW130

C     IF SO ADD FLAG VALUE 10**40 TO BE TESTED FOR LATER IN 'RAYTRC'    READW131

C                                                                       READW132

      IF(MSKMS.EQ.'T' .AND. WWW.EQ.0.0) W(NW)=1.E-10                    READW133

      IF(WWW.EQ.0.0) GO TO 4                                            READW134

      IF(MSKMS.EQ.'T') WWW=WWW*1.E10                                    READW135

C                                                                       READW136

C     CHECK FOR KEYWORD UNITS SPECIFICATION, IF SO PERFORM CONVERSION   READW137

C                                                                       READW138

      UUCON=UCON(KU,LINEX(:10),CONV)

      IF(.NOT.UUCON) GO TO 60

C     IF(.NOT.UCON(KU,LINEX(:10),CONV)) GO TO 60                        READW139

75    W(NW)=WWW*CONV                                                    READW140

      GO TO 4                                                           READW141

C                                                                       READW142

60    IF (DEG.EQ.'1') WWW=WWW*RAD                                       READW143

      IF (KM.EQ.'1') WWW=WWW/EARTHR                                     READW144

      IF (NM.EQ.'1') WWW=WWW*1.852                                      READW145

      IF (FEET.EQ.'1') WWW=WWW*3.048006096E-4                           READW146

      IF(CYCLE.EQ.'1') WWW=WWW*PIT2                                     READW147

      IF(PER.EQ.'1') WWW=PIT2/WWW                                       READW148

      IF(MSKMS.EQ.'1') WWW=WWW*1.E-3                                    READW149

      W(NW)=WWW                                                         READW150

      GO TO 4                                                           READW151

C                                                                       READW152

10    IF(.NOT.AB) RETURN                                                READW153

      PRINT 1200                                                        READW154

1200  FORMAT(' A DATA FORMATTING ERROR PREVENTS CONTINUED EXECUTION')   READW155

      STOP 1200                                                         READW156

C                                                                       READW157

      ENTRY SETW                                                        READW158

C     THIS ENTRY IS CALLED ONCE BEFORE THE FIRST RUN SET IS READ        READW159

C                                                                       READW160

C INITIALIZE SOME MATHEMATICAL CONSTANTS                                READW161

      PI=4.0*DATAN(1.0)                                                 READW162

      PIT2=2.*PI                                                        READW163

      PID2=PI/2.                                                        READW164

      DEGS=180./PI                                                      READW165

      RAD=PI/180.                                                       READW166

      ALN10=DLOG(10.)                                                   READW167

CC********* INITIALIZE SOME VARIABLES IN THE W ARRAY                    READW168

      MAXW=NWARSZ                                                       READW169

      CALL CLEAR(W,MAXW)                                                READW170

      PLON=0.                                                           READW171

      PLAT=PID2                                                         READW172

      EARTHR=6370.                                                      READW173

      INTYP=3.                                                          READW174

      MAXERR=1.E-4                                                      READW175

      ERATIO=50.                                                        READW176

      STEP1=1.                                                          READW177

      STPMAX=100.                                                       READW178

      STPMIN=1.E-8                                                      READW179

      FACTR=0.5                                                         READW180

      HITLET=.15                                                        READW181

      MAXSTP=1000.0                                                     READW182

      HOP=1.                                                            READW183

      HMAX=500.0                                                        READW184

      EXTINC=999.999                                                    READW185

      PAGLN=66.0                                                        READW186

C                                                                       READW187

      CALL SETUCON                                                      READW188

C                                                                       READW189

      RETURN                                                            READW190

C                                                                       READW191

      ENTRY SETOVR                                                      READW192

C     THIS ENTRY IS CALLED AFTER EACH RUN SET IS READ                   READW193

C                                                              IS CALLED AFTER EACH RUN SET IS READ                   READW193

C                                                                       READW194

C     PERFORM OVERRIDE ASSIGNMENTS TO W-ELEMENTS                        READW195

      BVL = 0.0

      AVL = 1000.0

      CALL OVERRD(MAXSTP,BVL, AVL  ,WCOMTS(23),2,1)                     READW196

      AVL = 50.0

      CALL OVERRD(ERATIO,BVL, AVL,WCOMTS(43),2,1)                       READW197

      AVL = 0.5

      CALL OVERRD(FACTR,BVL,AVL,WCOMTS(47),2,1)                         READW198

      CALL OVERRD(SKIP,BVL,BIGVAL,WCOMTS(71),2,1)                       READW199

      AVL = 0.15

      CALL OVERRD(HITLET,BVL,AVL,WCOMTS(75),2,1)                        READW200

      IF(PAGLN.LT.30.0) PAGLN=0.0                                       READW201

      AVL = 66.0

      CALL OVERRD(PAGLN,BVL,AVL ,WCOMTS(77),2,1)                        READW202

      AVL = 1.0

      CALL OVERRD(PFACTR,BVL,AVL,WCOMTS(82),2,1)                        READW203

      RETURN                                                            READW204

C                                                                       READW205

      ENTRY PRINTW                                                      READW206

C     THIS ENTRY IS CALLED AFTER EACH RUN SET IS READ                   READW207

C     TO PRINT VALUES OF THE W-ARRAY IN A FORMAT WHICH SHOWS            READW208

C     FULL ACCURACY AND THE EFFECTS OF ANY CONVERSIONS OR OVERRIDES.    READW209

C                                                                       READW210

C     GO TO NEXT PAGE, PUT OUT COPY OF INPUT DATA FOR THIS RUN SET      READW211

C     ASSUMING WE HAD A TEMPORARY FILE TO USE                           READW212

C                                                                       READW213

      IF(NDEVTMP.LE.0) GO TO 1065                                       READW214

      CALL NEWPAG(NPAG,INT(PAGLN),PC)                                   READW215

      LNSXPG=LINES+INT(PAGLN)                                           READW216

      CALL PUTHDR(3,PC,NPAG)                                            READW217

      CALL PUTDVR(3)                                                    READW218

      CALL PUTKBK(3,1)                                                  READW219

      CALL PUTKCT(3,'INPUT DATA FILE FOR RUN SET NUMBER'                READW220

     1  //NUMSTG(NSET,1,'(I5)'))                                        READW221

      CALL PUTKBK(3,1)                                                  READW222

      CALL PUTDVR(3)                                                    READW223

      CALL PUTKBK(3,1)                                                  READW224

      REWIND NDEVTMP                                                    READW225

C                                                                       READW226

1060  READ(NDEVTMP,'(A)',END=1065) LINEX                                READW227

      IF(LINES.GE.LNSXPG) THEN                                          READW228

         CALL NEWPAG(NPAG,INT(PAGLN),PC)                                READW229

         LNSXPG=LINES+INT(PAGLN)                                        READW230

         CALL PUTHDR(3,PC,NPAG)                                         READW231

         CALL PUTKBK(3,1)                                               READW232

      ENDIF                                                             READW233

      CALL PUTKST(3,' '//LINEX)                                         READW234

      GO TO 1060                                                        READW235

1065  CONTINUE                                                          READW236

C                                                                       READW237

C     GO TO NEXT PAGE, PUT OUT W-ELEMENTS SHOWING FULL PRECISION        READW238

C     USE A TWO COLUMN FORMAT                                           READW239

C                                                                       READW240

      CALL NEWPAG(NPAG,INT(PAGLN),PC)                                   READW241

      CALL PUTHDR(3,PC,NPAG)                                            READW242

      CALL PUTDVR(3)                                                    READW243

      CALL PUTKBK(3,1)                                                  READW244

      CALL PUTKCT(3,'INITIAL VALUES FOR THE W ARRAY')                   READW245

      CALL PUTKCT(3,'ONLY NONZERO VALUES PRINTED'                       READW246

     1  //' -- ALL ANGLES IN RADIANS')                                  READW247

      CALL PUTKBK(3,1)                                                  READW248

      CALL PUTDVR(3)                                                    READW249

      LINSPP=INT(PAGLN)-7                                               READW250

C                                                                       READW251

      WFRMT='(BZ,I3,E14.7,A)'                                           READW252

      IF(NFRMAT.EQ.0) WFRMT='(I4,E24.15,A)'                             READW253

C                                                                       READW254

      NWE=0                                                             READW255

C     ALLOW MAXIMUM OF 10 PAGES OF OUTPUT(1 IS ENOUGH)                  READW256

      DO 18 NPGS=1,10                                                   READW257

C     ALLOW 3 LINES FOR INSIDE HEADER(SEE BELOW)                        READW258

         LINSPP=LINSPP-3                                                READW259

C     NEXT ELEMENT TO SCAN IS ONE MORE THAN LAST ONE                    READW260

         LWE=NWE+1                                                      READW261

C                                                                       READW262

C     INITIALIZE SECOND COLUMN START INDEX                              READW263

         NXCL=0                                                         READW264

C     INITIALIZE TOTAL ELEMENT COUNTER                                  READW265

         NELS=0                                                         READW266

C     LOOP TO FIND BREAK POINTS FOR FIRST/SECOND COLUMNS                READW267

         DO 14 I=LWE,MAXW                                               READW268

            IF(W(I).EQ.0.0) GO TO 14                                    READW269

            NWE=I                                                       READW270

            NELS=NELS+1                                                 READW271

            IF(NELS.EQ.LINSPP) NXCL=I                                   READW272

            IF(NELS.EQ.2*LINSPP) GO TO 15                               READW273

14       CONTINUE                                                       READW274

15    IF(NELS.EQ.0) GO TO 22                                            READW275

C                                                                       READW276

         IF(NPGS.GT.1) THEN                                             READW277

            CALL NEWPAG(NPAG,INT(PAGLN),PC)                             READW278

            CALL PUTHDR(3,PC,NPAG)                                      READW279

            LINSPP=INT(PAGLN)-1                                         READW280

         ENDIF                                                          READW281

C                                                                       READW282

C     INSERT 'INNER' HEADER                                             READW283

         CALL PUTKBK(3,2)                                               READW284

         STMP1=' N              W(N)'                                   READW285

         CALL PUTKST(3,STMP1(:65)//' '//STMP1)                          READW286

C                                                                       READW287

       NX=NXCL-1                                                        READW288

       IF(NX.LT.LWE) NX=NWE                                             READW289

       DO 17 NW=LWE,NX                                                  READW290

       NCOMT=MIN0(NW,MXCMTS)                                            READW291

       IF(W(NW).NE.0) THEN                                              READW292

         WRITE(STMP1,WFRMT) NW,W(NW),WNOTES(WCOMTS(NCOMT))              READW293

         STMP2=' '                                                      READW294

         IF(NXCL.EQ.0) GO TO 23                                         READW295

         DO 19 I=NXCL,MAXW                                              READW296

         IF(W(I).NE.0) THEN                                             READW297

           NCOMT=MIN0(I,MXCMTS)                                         READW298

           WRITE(STMP2,WFRMT) I,W(I),WNOTES(WCOMTS(NCOMT))              READW299

           NXCL=I+1                                                     READW300

           GO TO 23                                                     READW301

         ENDIF                                                          READW302

19       CONTINUE                                                       READW303

23       CALL PUTKST(3,STMP1(:65)//' '//STMP2)                          READW304

       ENDIF                                                            READW305

17     CONTINUE                                                         READW306

      IF(NELS.EQ.0) GO TO 22                                            READW307

18    CONTINUE                                                          READW308

C                                                                       READW309

22    CONTINUE                                                          READW310

      END                                                               READW311







