C----------------------------------------------------------------------------
      SUBROUTINE SCLPIC(S)
C     SCALES CURVE MARKER SYMBOLS(DISSPLA)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVBIN,NDEVTXT
C
      WRITE(NDEVTXT,100) 24,S
100   FORMAT(I2,F5.2)
      END
C---------------------------------------------------------------------------
      INTEGER FUNCTION STRIM(C)
C     DETERMINES POSITION OF LAST NONBLANK CHARACTER OF A STRING
      CHARACTER*(*) C
C
      L=LEN(C)
      DO 100 I=L,1,-1
100   IF(C(I:I) .NE. ' ') GO TO 200
      I=0 
200   STRIM=I
      END
C-----------------------------------------------------------------------------
      SUBROUTINE TITLE(A,B,C,D,E,F,G,H) 
C     DEFINES TITLE, AXES LABELS AND LENGTHS OF PLOTS(DISSPLA)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C

      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVBIN,NDEVTXT
C*****THESE 3 ARRAYS NEED TO BE REAL.  IF DECLARED CHAR*40, THE DIRECT
C*****ACCESS READ IN TAPRD WILL CAUSE EXTRA CHARACTERS TO BE PRESENT?!

ccccc      REAL A(4),C(4),E(4)
      character*(*) a,c,e
      integer b,d,f
      DOUBLE PRECISION G,H
C
C*****CHANGED ENTRY TO INCLUDE THE PARAMETER LIST.  MICROSOFT WOULD NOT
C*****COMPILE WITHOUT IT.  JAH.
C
      ENTRY TITLEW (A,B,C,D,E,F,G,H)
      WRITE(NDEVTXT,100) 25,G,H
100   FORMAT(I2,2F6.2)
      CALL TITLTX (A,B)
      CALL TITLTX (C,D)
      CALL TITLTX (E,F)
C
      END
C---------------------------------------------------------------------
      SUBROUTINE TITLTX (ACHAR,B)
C     THIS IS CALLED BY TITLE IN ORDER TO WRITE TO NDEVTXT.
C
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVBIN,NDEVTXT
      CHARACTER*(*) ACHAR
c      LOGICAL FOUND
      INTEGER B
C
c      NMBLK=0
c      FOUND = .FALSE.
      lena = len(achar)
c      DO 10 I=lena,1,-1
c         IF (.NOT.FOUND) THEN
c            IF(ACHAR(I:I).EQ.' ') NMBLK=NMBLK+1
c            IF(ACHAR(I:I).EQ.'$') FOUND = .TRUE.
c         ENDIF
c10    CONTINUE
c      LENA = 40-NMBLK
C
      WRITE(NDEVTXT,200) B,ACHAR(1:lena) !!!!!,I=1,LENA)
200   FORMAT(I5,1X,A)
C
      END
C------------------------------------------------------------------------------
      SUBROUTINE TITLXY(I,J,K,L,M,N,XAXIS,YAXIS)
C
      implicit double precision (a-h,o-z)

      CHARACTER I*(*),K*(*),M*(*),CD*80 
      PARAMETER (NWARSZ=1000) 
      COMMON/WW/ dum(10), MAXW,W(NWARSZ)
      EQUIVALENCE (HITLET,W(75))
C
      F=1.0
C.....Changed from 6.65 inches. Too big for 8.5x11
      XAXIS=5.0

C.....Changed from 6.8.
      YAXIS=5.11

      IF(J.GT.0) GO TO 50
      F=.8
      XAXIS=9.0
      YAXIS=6.0
C
C.....Sets origin of plot to 2.3", 1.66" from LLeft
50    CALL PHYSOR(2.3,1.66)
      CALL NOBRDR
      IF(HITLET.LE.0.0) CALL HEIGHT(F*0.4)
      CALL SCLPIC(1.4)
      CALL TITLEW(CD(I),J,CD(K),L,CD(M),N,XAXIS,YAXIS)
      RETURN
      END
C----------------------------------------------------------------------
      SUBROUTINE IMOVE(JOUT,INPI,N)
C     THIS ROUTINE REPLACES THE ENTRY POINT THAT WAS PART OF DFSYS. JAH.
C     THIS IS MACHINE INDEPENDENT AND THUS DOES NOT NEED TO BE PART OF
C     OF DFSYS.

      INTEGER INPI(*), JOUT(*),N

      DO 10 I=1,N
10    JOUT(I) = INPI(I)
      END
C-----------------------------------------------------------------------
      SUBROUTINE RMOVE(ROUT,RINP,N)
C     THIS ROUTINE REPLACES THE ENTRY POINT THAT WAS PART OF DFSYS. JAH.
  
      DOUBLE PRECISION RINP(*), ROUT(*)
      INTEGER N
  
      DO 10 I=1,N
10    ROUT(I) = RINP(I)
      END 
C-------------------------------------------------------------------------
      FUNCTION GET(Z)

C     Note:  The only reason this function is included for the PROFIL
C	     program is for the SETGET entry point (which is called by
C	     CONBLK).
C     'GET' AND ENTRY 'DOT' PROVIDE A CONTROL METHOD FOR AVOIDING
C     REDUNDANT CALLS TO THE TERRAIN AND RECEIVER MODELS. THE VALUES
C     RETURNED ARE THE FUNCTION VALUES FOR 'F' OR 'G' OR THEIR DERIVATI
C     (VIA 'DOT' ENTRY). UNNECESSARY CALLS ARE ELIMINATED THROUGH USE
C     OF 'TIME OF CALL' VARIABLES WHICH ARE COMPARED WITH THE CURRENT 
C     LAST CALL TIME MAINTAINED BY THE 'RKAM' PROGRAM. WHEN VALUES ARE
C     NOT CURRENT THEY ARE UPDATED BY CALLS TO THE APPROPRIATE ROUTINES
C

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

      DOUBLE PRECISION Z(*),PF(10),PG(10)
C     COMMON DECK "SS" INSERTED HERE
      DOUBLE PRECISION MODSURF
      COMMON/SS/ MODSURF(4)
      COMMON/SS/U,PUR,PURR,PURTH,PURPH
      COMMON/SS/PUTH,PUPH,PUTHTH,PUPHPH,PUTHPH,USELECT,UTIME
C     COMMON DECK "RKAM" INSERTED HERE
      DOUBLE PRECISION KR,KTH,KPH
      COMMON//R,TH,PH,KR,KTH,KPH,RKVARS(14),TPULSE,CSTEP,DRDT(20)
C     COMMON DECK "FNDER" INSERTED HERE 
      COMMON/FNDER/GY(20),NZ,NPZR,NPZRR,NPZRTH,NPZRPH,NPZTH 
      COMMON/FNDER/NPZPH,NPZTHTH,NPZPHPH,NPZTHPH,NSELECT,NTIME
C     COMMON DECK "RR" INSERTED HERE
      DOUBLE PRECISION MODREC
      COMMON/RR/ MODREC(4)
      COMMON/RR/F,PFR,PFRR,PFRTH,PFRPH
      COMMON/RR/PFTH,PFPH,PFTHTH,PFPHPH,PFTHPH,FSELECT,FTIME
C     COMMON DECK "GG" INSERTED HERE
      DOUBLE PRECISION MODG
      COMMON/GG/MODG(4)
      COMMON/GG/G,PGR,PGRR,PGRTH,PGRPH
      COMMON/GG/PGTH,PGPH,PGTHTH,PGPHPH,PGTHPH,GSELECT,GTIME
C     COMMON DECK "RKTIME" INSERTED HERE
      COMMON/CRKTIME/RKTIME
C
C     COMMON DECK "RMACH" INSERTED HERE 
      COMMON/CRMACH/RMACH(5)
      EQUIVALENCE(RKTIME,IRKTIME)
C
C     COMMON DECK "WWR" INSERTED HERE
      PARAMETER (NWARSZ=1000) 
      COMMON/WW/ dum(10), MAXW,W(NWARSZ)
      DOUBLE PRECISION MAXSTP,MAXERR,INTYP,LLAT,LLON
      EQUIVALENCE (EARTHR,W(1)),(RAY,W(2)),(XMTRH,W(3)),(TLAT,W(4)),
     1 (TLON,W(5)),(OW,W(6)),(FBEG,W(7)),(FEND,W(8)),(FSTEP,W(9)),
     2 (AZ1,W(10)),(AZBEG,W(11)),(AZEND,W(12)),(AZSTEP,W(13)),
     3 (BETA,W(14)),(ELBEG,W(15)),(ELEND,W(16)),(ELSTEP,W(17)),
     8   (RUNSUP,W(18)),(RCVRH,W(20)),
     4 (ONLY,W(21)),(HOP,W(22)),(MAXSTP,W(23)),(PLAT,W(24)),(PLON,W(25))
     5,(HMAX,W(26)),(RAYFNC,W(29)),(EXTINC,W(33)),
     6 (HMIN,W(27)),(RGMAX,W(28)),
     8 (INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),
     6 (STEP1,W(44)),(STPMAX,W(45)),(STPMIN,W(46)),(FACTR,W(47)),
     7 (SKIP,W(71)),(RAYSET,W(72)),(PRTSRP,W(74)),(HITLET,W(75))
     9 ,(BINRAY,W(76)),(PAGLN,W(77)),(PLT,W(81)),(PFACTR,W(82)),
     1 (LLAT,W(83)),(LLON,W(84)),(RLAT,W(85)),(RLON,W(86))
     2,(TIC,W(87)),(HB,W(88)),(HT,W(89)),(TICV,W(96))
C
      COMMON/CGET/ZERO
C
      DOUBLE PRECISION PI(10),PJ(10)
      COMMON/TMP1/NC,NSZR    ,NSZRR    ,NSZRTH
     1 ,NSZRPH    ,NSZTH    ,NSZPH    ,NSZTHTH    ,NSZPHPH    ,NSZTHPH
     2 ,NVELECT    ,NWIME
C
      DATA PI,PJ/1.0,9*0.0,1.0,9*0.0/
      DATA NC,NSZR,NSZRR,NSZRTH,NSZRPH,NSZTH,NSZPH,NSZTHTH,NSZPHPH
     1   ,NSZTHPH,NVELECT,NWIME/1,2,3,4,5,6,7,8,9,10,11,12/ 
      DATA FWIME,GWIME,FVELECT,GVELECT/2*-1.0,8HRECEIVER ,7HTERRAIN / 
      DATA UWIME,UVELECT/-1.0,7HSURFACE /
      DATA ZHRO/0.0/
C
      IENTRY=1
      GO TO 5
C
      ENTRY SETGET
C
      CALL RMOVE(PF,PI,10)
      CALL RMOVE(PG,PJ,10)
      CALL IMOVE(NZ,NC,12)
      FTIME=FWIME
      GTIME=GWIME
      FSELECT=FVELECT
      GSELECT=GVELECT
      UTIME=UWIME
      USELECT=UVELECT
      ZERO=ZHRO
C
      RETURN
C
      ENTRY DOT(Z)
      IENTRY=2
5     CONTINUE
C
C     THE FOLLOWING THREE ASSIGNMENT STATEMENTS ARE NEEDED TO REPAIR
C     ARRAY ELEMENTS OVERWRITTEN ON THE CRAY VERSION OF THIS PROGRAM. 
C     THE ADDITIONAL ARRAY 'GY' HAS ALSO BEEN ADDED TO THE /FNDER/
C     LABELED COMMON TO ACT AS A BUFFER AREA.
C     NO CAUSE FOR THIS PROBLEM HAS YET BEEN FOUND. THESE STATEMENTS
C     ARE NOT NEEDED ON OTHER MACHINES AS FAR AS IS KNOWN.
       NZ=1
       NPZR=2
       NPZRR=3
ccccc  IF(ZERO.EQ.0.0) ZERO=EARTHR*RMACH(3)*2.0
C
c      IF(ITEST(Z(NTIME)).EQ.IRKTIME) GO TO 10
C
c      IF(Z(NSELECT).EQ.USELECT) CALL SURFACE
c      IF(Z(NSELECT).EQ.FSELECT) CALL RECEVER
c      IF(Z(NSELECT).EQ.GSELECT) CALL TOPOG
       Z(NTIME)=RKTIME
C     REMOVE MACHINE ROUND OFF NOISE FROM EXACT RECEIVER LOCATIONS
       IF(ABS(Z(NZ)).LE.ZERO) Z(NZ)=0.0
C
10    IF(IENTRY.NE.1) GO TO 20
       GET=Z(NZ)
       RETURN
C
20    GET=Z(NPZR)*DRDT(1)+Z(NPZTH)*DRDT(2)+Z(NPZPH)*DRDT(3)
      RETURN
      END
C---------------------------------------------------------------------
      FUNCTION READW
C
C     READS W ARRAY MAKING ANY NECESSARY CONVERSION OF UNITS.
C     VARIABLE LENGTH 'TABULAR' DATA IS READ BY SUBROUTINE 'READW1'
C     WHICH IS CALLED FOR NEGATIVE W-ARRAY INDICES.
C
      implicit double precision (a-h,o-z)

C     COMMON DECK "CONST" INSERTED HERE 
      COMMON/PCONST/CREF,RGAS,GAMMA
      COMMON/MCONST/PI,PIT2,PID2,DEGS,RAD,ALN10
C     COMMON DECK "WWR" INSERTED HERE
      character*80 id
      common /ident/ id
      PARAMETER (NWARSZ=1000) 
      COMMON/WW/ dum(10), MAXW,W(NWARSZ)
      DOUBLE PRECISION MAXSTP,MAXERR,INTYP,LLAT,LLON
      EQUIVALENCE (EARTHR,W(1)),(RAY,W(2)),(XMTRH,W(3)),(TLAT,W(4)),
     1 (TLON,W(5)),(OW,W(6)),(FBEG,W(7)),(FEND,W(8)),(FSTEP,W(9)),
     2 (AZ1,W(10)),(AZBEG,W(11)),(AZEND,W(12)),(AZSTEP,W(13)),
     3 (BETA,W(14)),(ELBEG,W(15)),(ELEND,W(16)),(ELSTEP,W(17)),
     8   (RUNSUP,W(18)),(RCVRH,W(20)),
     4 (ONLY,W(21)),(HOP,W(22)),(MAXSTP,W(23)),(PLAT,W(24)),(PLON,W(25))
     5,(HMAX,W(26)),(RAYFNC,W(29)),(EXTINC,W(33)),
     6 (HMIN,W(27)),(RGMAX,W(28)),
     8 (INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),
     6 (STEP1,W(44)),(STPMAX,W(45)),(STPMIN,W(46)),(FACTR,W(47)),
     7 (SKIP,W(71)),(RAYSET,W(72)),(PRTSRP,W(74)),(HITLET,W(75))
     9 ,(BINRAY,W(76)),(PAGLN,W(77)),(PLT,W(81)),(PFACTR,W(82)),
     1 (LLAT,W(83)),(LLON,W(84)),(RLAT,W(85)),(RLON,W(86))
     2,(TIC,W(87)),(HB,W(88)),(HT,W(89)),(TICV,W(96))
C     COMMON DECK "B1" INSERTED HERE
      INTEGER UMX,UNTBL,UITBL,UFRMTBL,IDSU(10)
      COMMON/B1/UMX,UNTBL(10),UITBL(10),UFRMTBL(10),UGP(10)
      EQUIVALENCE (UGP,IDSU)
C     COMMON DECK "B2" INSERTED HERE
      INTEGER DUMX,DUNTBL,DUITBL,DUFRMTB,IDSDU(10)
      COMMON/B2/DUMX,DUNTBL(10),DUITBL(10),DUFRMTB(10),DUGP(10)
      EQUIVALENCE (DUGP,IDSDU)
C     COMMON DECK "B3" INSERTED HERE
      INTEGER CMX,CNTBL,CITBL,CFRMTBL,IDSC(10)
      COMMON/B3/CMX,CNTBL(10),CITBL(10),CFRMTBL(10),CGP(512)
      EQUIVALENCE (CGP,IDSC),(ANC,CGP(11))
C     COMMON DECK "B4" INSERTED HERE
      INTEGER DCMX,DCNTBL,DCITBL,DCFRMTB,IDSDC(10)
      COMMON/B4/DCMX,DCNTBL(10),DCITBL(10),DCFRMTB(10),DCGP(10)
      EQUIVALENCE (DCGP,IDSDC)
C     COMMON DECK "B5" INSERTED HERE
      INTEGER TMX,TNTBL,TITBL,TFRMTBL,IDST(10)
      COMMON/B5/TMX,TNTBL(10),TITBL(10),TFRMTBL(10),TGP(262)
      EQUIVALENCE (TGP,IDST),(ANT,TGP(11))
C     COMMON DECK "B6" INSERTED HERE
      INTEGER DTMX,DTNTBL,DTITBL,DTFRMTB,IDSDT(10)
      COMMON/B6/DTMX,DTNTBL(10),DTITBL(10),DTFRMTB(10),DTGP(10)
      EQUIVALENCE (DTGP,IDSDT)
C     COMMON DECK "B7" INSERTED HERE
      INTEGER MMX,MNTBL,MITBL,MFRMTBL,IDSM(10)
      DOUBLE PRECISION MGP
      COMMON/B7/MMX,MNTBL(10),MITBL(10),MFRMTBL(10),MGP(10) 
      EQUIVALENCE (MGP,IDSM)
C     COMMON DECK "B9" INSERTED HERE
      INTEGER GMX,GNTBL,GITBL,GFRMTBL,IDSG(10)
      COMMON/B9/GMX,GNTBL(10),GITBL(10),GFRMTBL(10),GGP(113)
      EQUIVALENCE (GGP,IDSG),(ANG,GGP(11))
C
C     COMMON DECK "B10" INSERTED HERE
      INTEGER DGMX,DGNTBL,DGITBL,DGFRMTB,IDSDG(10)
      COMMON/B10/DGMX,DGNTBL(10),DGITBL(10),DGFRMTB(10),DGGP(10)
      EQUIVALENCE (DGGP,IDSDG)
C
C     COMMON DECK "B8" INSERTED HERE
      INTEGER RMX,RNTBL,RITBL,RFRMTBL,IDSR(10)
      COMMON/B8/RMX,RNTBL(10),RITBL(10),RFRMTBL(10),RGP(10) 
      EQUIVALENCE (RGP,IDSR)
C
C     COMMON DECK "CB11" INSERTED HERE
      INTEGER SMX,SNTBL,SITBL,SFRMTBL,IDSS(10)
      COMMON/B11/SMX,SNTBL(10),SITBL(10),SFRMTBL(10),SGP(11)
      EQUIVALENCE (SGP,IDSS),(ANS,SGP(11))
C     COMMON DECK "CB12" INSERTED HERE
      INTEGER DSMX,DSNTBL,DSITBL,DSFRMTB,IDSDS(10)
      COMMON/B12/DSMX,DSNTBL(10),DSITBL(10),DSFRMTB(10),DSGP(11)
      EQUIVALENCE (DSGP,IDSDS),(ANDS,DSGP(11))
C     COMMON DECK "CB17" INSERTED HERE
      INTEGER VMX,VNTBL,VITBL,VFRMTBL,IDSV(10)
      COMMON/B17/VMX,VNTBL(10),VITBL(10),VFRMTBL(10),VGP(53)
      EQUIVALENCE (VGP,IDSV),(ANV,VGP(11))
C     COMMON DECK "CB18" INSERTED HERE
      INTEGER DVMX,DVNTBL,DVITBL,DVFRMTB,IDSDV(10)
      COMMON/B18/DVMX,DVNTBL(10),DVITBL(10),DVFRMTB(10),DVGP(11)
      EQUIVALENCE (DVGP,IDSDV),(ANDV,DVGP(11))
C     COMMON DECK "CB19" INSERTED HERE
      INTEGER PRMX,PRNTBL,PRITBL,PRFRMTB,IDSPR(10)
      COMMON/B19/PRMX,PRNTBL(10),PRITBL(10),PRFRMTB(10),PRGP(11)
      EQUIVALENCE (PRGP,IDSPR),(ANP,PRGP(11))
C     COMMON DECK "CB20" INSERTED HERE
      INTEGER DPMX,DPNTBL,DPITBL,DPFRMTB,IDSDP(10)
      COMMON/B20/DPMX,DPNTBL(10),DPITBL(10),DPFRMTB(10),DPGP(11)
      EQUIVALENCE (DPGP,IDSDP),(ANDP,DPGP(11))
C
      PARAMETER (MXCMTS=83)
C*****, BIGVAL=1.E37)
      common /crmach/rmach(5)
      equivalence (bigval,rmach(5))

      CHARACTER*80 LINEX
      CHARACTER*100 STMP1
      INTEGER WCOMTS(MXCMTS)
      CHARACTER*1 DEG,KM,NM,FEET,CYCLE,PER,MSKMS
C
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVBIN,NDEVTXT
      LOGICAL NWOK,AB,UCON
C
C     COMMON DECK "FLAG" INSERTED HERE
      LOGICAL NEWWR,NEWWP,NEWTRC,PENET
      COMMON /FLG/ NTYP,NEWWR,NEWWP,NEWTRC,PENET,LINES,IHOP,HPUNCH
      COMMON/FLGP/NSET
C
      INTEGER XMX,XNTBL(10),XITBL(10),XFRMTBL(10)
      DOUBLE PRECISION XGP(11)
C
      DATA XMX/2/
      DATA XNTBL/1,11,12,7*0/
      DATA XITBL/1,9*0/
      DATA XFRMTBL/1,2,8*0/
C
      DATA WCOMTS/MXCMTS*1/
C
      AB=.FALSE.
      READW=0.d0
C
      IF(NDEVTMP.GT.0) REWIND NDEVTMP
C
      READ(NRYIND,1000,IOSTAT=IOS) ID
      IF (IOS.GT.0) THEN
         write(6,*)'READ ERROR:  STATUS = ',IOS
	 STOP 'Check status code in FORTRAN Reference Manual.'
      ENDIF
1000	   FORMAT (A)

C.....Handle End-of-file.

      IF (IOS.LT.0) then
	   READW=1.0
           write(6,*)'end of input data reached'

C..........Added the following RETURN.  NFRMAT is set to -1 by CONBLK
C          anyhow, so the net effect is the same.  This also allows
C          us to eliminate the call to ENDPLT which means that subroutine
C          RAYPLT is not needed.

           RETURN

CCCCC	   IF(NFRMAT.LT.0) RETURN
C
CCCCC	   PRINT 1040
CCCCC1040	   FORMAT(' END OF INPUT DATA')
CCCCC	   CALL ENDPLT
CCCCC	   IF(PLT.NE.0.0) CALL DDEND
CCCCC	   STOP
      endif

      IF(NDEVTMP.GT.0) WRITE(NDEVTMP,1000) ID
C
C
40    READ(NRYIND,'(A)',END=10001) STMP1
C
      READ(STMP1,1100) NW,WWW,LINEX
1100  FORMAT (BZ,I3,E14.7,A)
      IF(NDEVTMP.GT.0.AND.(NFRMAT.NE.-2.OR.NW.LT.0))
     1      WRITE(NDEVTMP,'(A)') STMP1
ccccc       write(6,*)'NW, www = ',NW,www

C When NW = 0, the end of a set is indicated.  AB = FALSE indicates that
C everything is ok.

10001 IF (NW.EQ.0) then
	   readw=0.d0
           ab = .false.
	   IF(.NOT.AB) RETURN
	   PRINT 1200
1200  FORMAT(' A DATA FORMATTING ERROR PREVENTS CONTINUED EXECUTION')
	   STOP
      endif

      IF(NW.GT.MAXW) then
	   PRINT 4000, NW
4000	   FORMAT(I3,' IS AN INVALID VALUE FOR THE W-ARRAY.')
	   STOP
      endif
C
      IF (NW.LE.MAXW .AND. NW.GT.0) GO TO 50
C     TABULAR INPUT DATA
      NWOK=.FALSE.
C 'OPEN' THE TEMP FILE
1150  FORMAT(I3,T18,A)
      NWP=-NW
      IF(NFRMAT.EQ.-2) THEN
C     USE DUMMY ARRAYS TO ABSORB TABULAR DATA
         CALL READW1(AB,NWOK,NW,XMX,XNTBL,XITBL,XFRMTBL,XGP)
      ELSEIF(NWP.EQ.1) THEN
         CALL READW1(AB,NWOK,NW,UMX,UNTBL,UITBL,UFRMTBL,UGP)
      ELSEIF(NWP.EQ.2) THEN
         CALL READW1(AB,NWOK,NW,DUMX,DUNTBL,DUITBL,DUFRMTB,DUGP)
      ELSEIF(NWP.EQ.3) THEN
         CALL READW1(AB,NWOK,NW,CMX,CNTBL,CITBL,CFRMTBL,CGP)
      ELSEIF(NWP.EQ.4) THEN
         CALL READW1(AB,NWOK,NW,DCMX,DCNTBL,DCITBL,DCFRMTB,DCGP)
      ELSEIF(NWP.EQ.5) THEN
            CALL READW1(AB,NWOK,NW,TMX,TNTBL,TITBL,TFRMTBL,TGP)
      ELSEIF(NWP.EQ.6) THEN
         CALL READW1(AB,NWOK,NW,DTMX,DTNTBL,DTITBL,DTFRMTB,DTGP)
      ELSEIF(NWP.EQ.7) THEN
         CALL READW1(AB,NWOK,NW,MMX,MNTBL,MITBL,MFRMTBL,MGP)
      ELSEIF(NWP.EQ.8) THEN
         CALL READW1(AB,NWOK,NW,RMX,RNTBL,RITBL,RFRMTBL,RGP)
      ELSEIF(NWP.EQ.9) THEN
         CALL READW1(AB,NWOK,NW,GMX,GNTBL,GITBL,GFRMTBL,GGP)
      ELSEIF(NWP.EQ.10) THEN
         CALL READW1(AB,NWOK,NW,DGMX,DGNTBL,DGITBL,DGFRMTB,DGGP)
      ELSEIF(NWP.EQ.11) THEN
         CALL READW1(AB,NWOK,NW,SMX,SNTBL,SITBL,SFRMTBL,SGP)
      ELSEIF(NWP.EQ.12) THEN
         CALL READW1(AB,NWOK,NW,DSMX,DSNTBL,DSITBL,DSFRMTB,DSGP)
      ELSEIF(NWP.EQ.17) THEN
         CALL READW1(AB,NWOK,NW,VMX,VNTBL,VITBL,VFRMTBL,VGP)
      ELSEIF(NWP.EQ.18) THEN
         CALL READW1(AB,NWOK,NW,DVMX,DVNTBL,DVITBL,DVFRMTB,DVGP)
      ELSEIF(NWP.EQ.19) THEN
         CALL READW1(AB,NWOK,NW,PRMX,PRNTBL,PRITBL,PRFRMTB,PRGP)
      ELSEIF(NWP.EQ.20) THEN
         CALL READW1(AB,NWOK,NW,DPMX,DPNTBL,DPITBL,DPFRMTB,DPGP)
      ELSE
         CALL SREAD1(AB,NWOK,NW)
      ENDIF

      IF (NWOK) then
	   go to 40
      else
	   PRINT 4000, NW
      endif
C
C
50    READ(LINEX,777) DEG,KM,NM,FEET,CYCLE,PER,MSKMS
777   FORMAT(7A)
ccccc	    PRINT*,'WWW = ',WWW

      W(NW)=WWW
C
C     CHECK FOR A 'TERRAIN RELATIVE' HEIGHT SPECIFICATION.
C     IF SO ADD FLAG VALUE 10**40 TO BE TESTED FOR LATER IN 'RAYTRC'
C
C*****Don't set the flags for Profile data (NW = 90).

      if (nw .ne. 90) then
	   IF(MSKMS.EQ.'T' .AND. WWW.EQ.0.0) W(NW)=1.E-38
	   IF(WWW.EQ.0.0) GO TO 40
	   IF(MSKMS.EQ.'T') WWW=WWW*1.E37
      endif

C     CHECK FOR KEYWORD UNITS SPECIFICATION, IF SO PERFORM CONVERSION
C
      IF(.NOT.UCON(KU,LINEX(:10),CONV)) then
	   IF (DEG.EQ.'1') WWW=WWW*RAD
	   IF (KM.EQ.'1') WWW=WWW/EARTHR
	   IF (NM.EQ.'1') WWW=WWW*1.852
	   IF (FEET.EQ.'1') WWW=WWW*3.048006096E-4
	   IF(CYCLE.EQ.'1') WWW=WWW*PIT2
	   IF(PER.EQ.'1') WWW=PIT2/WWW
	   IF(MSKMS.EQ.'1') WWW=WWW*1.E-3
	   W(NW)=WWW
	   go to 40
      endif

      IF(CONV.GE.0.0) THEN
         W(NW)=WWW*CONV
      ELSEIF(W(NW).NE.0.0) THEN
         W(NW)=-CONV/W(NW)
      ENDIF
      GO TO 40
C
C
      ENTRY SETW
C     THIS ENTRY IS CALLED ONCE BEFORE THE FIRST RUN SET IS READ
C
C INITIALIZE SOME MATHEMATICAL CONSTANTS
      PI=4.0*ATAN(1.0)
      PIT2=2.*PI
      PID2=PI/2.
      DEGS=180./PI
      RAD=PI/180.
      ALN10=ALOG(10.)
CC********* INITIALIZE SOME VARIABLES IN THE W ARRAY
      MAXW=NWARSZ
      CALL CLEAR(W,MAXW)
      PLON=0.
      PLAT=PID2
      EARTHR=6370.
      INTYP=3.
      MAXERR=1.E-4
      ERATIO=50.
      STEP1=1.
      STPMAX=100.
      STPMIN=1.E-8
      FACTR=0.5
      HITLET=.15
      MAXSTP=1000.0
      HOP=1.
      HMAX=500.0
      EXTINC=999.999
      PAGLN=66.0
C
      CALL SETUCON
C
C.....Set the function value to 1.0.  Formerly SETW was called with a
C     "CALL" statement.  MicroSoft FORTRAN does not allow you to CALL an
C     an entry point within FUNCTION.  So the CALL was removed and re-
C     placed with "IF SETW() .EQ. 1".

      setw = 1.0
      RETURN
C
      ENTRY SETOVR
C     THIS ENTRY IS CALLED AFTER EACH RUN SET IS READ
C
C     PERFORM OVERRIDE ASSIGNMENTS TO W-ELEMENTS
      CALL OVERRD(MAXSTP,0.d0,1000.0d0,WCOMTS(23),2,1)
      CALL OVERRD(ERATIO,0.d0,50.0d0,WCOMTS(43),2,1)
      CALL OVERRD(FACTR,0.d0,0.5d0,WCOMTS(47),2,1)
      CALL OVERRD(SKIP,0.d0,BIGVAL,WCOMTS(71),2,1)
      CALL OVERRD(HITLET,0.d0,.15d0,WCOMTS(75),2,1)
      IF(PAGLN.LT.30.0) PAGLN=0.0
      CALL OVERRD(PAGLN,0.d0,66.0d0,WCOMTS(77),2,1)
      CALL OVERRD(PFACTR,0.d0,1.0d0,WCOMTS(82),2,1)

C.....See comment above for SETW.
      setovr = 1.0
      RETURN
C
      END
