      SUBROUTINE PLOTAL(PLTMODE,PLTCNT,TLTS,NP,MP,WK,FG,XN,YN,MARK)

C

      CHARACTER*(*) TLTS(4)

      DOUBLE PRECISION WK(NP,2)

      INTEGER PLTCNT

C

C*****"PLTMODE" IS A LOGICAL ARRAY.  SEE SUBROUTINE PRFPLT.  JAH.

      LOGICAL PLTMODE(12)

C

      EXTERNAL REARTH,TOPV,COLAT,SPEEDV,ISPEDV,ITEMPV,TEMPV

      EXTERNAL WNMAGV,WNVRTV,WNSTHV,WNESTV,IWINDV

      EXTERNAL PTPLTX,PTPLTY,IPTPLT,ITOPV



C.....Added the following entry points in PRFSUP for east, south, vertical

C     components of current velocity.



      external ieastv, isoutv, ivertv

C

C.....Just to re-iterate (see the blank input data forms for profiles

C     for more information),

C

C     PLTCNT (aka W(90)) Value                Type of Profile

C

C           1                                   Sound Speed

C           2                                   Current Speed

C           3,4,5                               Vertical,Southward,Eastward

C                                                  Current Components

C           6                                   Bottom Topography

C           7                                   Temperature

C

C

      GO TO (1,2,3,4,5,6,7) PLTCNT

C

      CALL PRFPLT(PLTMODE,IPTPLT,PTPLTX,PTPLTY,TLTS,NP,MP,WK,FG,XN,YN,

     &            MARK)

      RETURN

C

1     CALL PRFPLT(PLTMODE,ISPEDV,REARTH,SPEEDV,TLTS,NP,MP,WK,FG,XN,YN,

     &            MARK)

      RETURN

2     CALL PRFPLT(PLTMODE,IWINDV,REARTH,WNMAGV,TLTS,NP,MP,WK,FG,XN,YN,

     &            MARK)

      RETURN

3     CALL PRFPLT(PLTMODE,IVERTV,REARTH,WNVRTV,TLTS,NP,MP,WK,FG,XN,YN,

     &            MARK)

      RETURN

4     CALL PRFPLT(PLTMODE,ISOUTV,REARTH,WNSTHV,TLTS,NP,MP,WK,FG,XN,YN,

     &            MARK)

      RETURN

5     CALL PRFPLT(PLTMODE,IEASTV,REARTH,WNESTV,TLTS,NP,MP,WK,FG,XN,YN,

     &            MARK)

      RETURN

6     CALL PRFPLT(PLTMODE,ITOPV,COLAT,TOPV,TLTS,NP,MP,WK,FG,XN,YN,

     &            MARK)

      RETURN

7     CALL PRFPLT(PLTMODE,ITEMPV,REARTH,TEMPV,TLTS,NP,MP,WK,FG,XN,YN,

     &            MARK)

      END 

C-----------------------------------------------------------------------------

      SUBROUTINE PLOTINI(DHITE,SYMRED)

C+P   (PLOTTING) INITIALIZE PLOTTING FOR EIGEN PROGRAM

C

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



C     COMMON DECK "HDR" INSERTED HERE

      CHARACTER*10 INITID*80,DAT,TOD

      COMMON/HDR/SEC

      COMMON/HDRC/INITID,DAT,TOD

C

      CALL COMPRS

      CALL GRACE(0.)

      CALL PHYSOR(2.,1.3)

      CALL PAGE(12.,10.)

      CALL HEIGHT(DHITE)

      CALL SETANN

      S=SYMRED

C  DEFAULT TO 15% REDUCTION ON POINT SIZE OVER DISSPLAY'S DEFAULT

      IF(S.EQ.0.0) S=.15

      CALL SCLPIC(S)

      END

C-----------------------------------------------------------------------------

      SUBROUTINE PLTINI



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



C     COMMON DECK "WWE" INSERTED HERE

      PARAMETER (NWARSZ=1000)

      COMMON/WW/ dum(10), MAXW,W(NWARSZ)

      DOUBLE PRECISION NRSLMI

      EQUIVALENCE (W(80),APOG) ,(W(401),PTYP) ,(W(403),ELMIN)

     1   ,(W(404),ELMAX) ,(W(405),ELVINC) ,(W(406),RGINC)

     2   ,(W(407),HOPLME) ,(W(408),NRSLME)

     3   ,(W(409),GAPLO), (W(410),GAPHI), (W(411),SYMRED)

     4   ,(W(428),GRPMIN) ,(W(429),GRPMAX) ,(W(430),GRPVINC)

     5   ,(W(432),HOPLMG) ,(W(433),NRSLMG)

     6   ,(W(434),RFSPEED) ,(W(435),TMFT) ,(W(436),RMAX)

     7   ,(W(453),RCRNG) ,(W(454),SLPCUT)

     8   ,(W(456),HOPLMI) ,(W(457),NRSLMI) ,(W(458),ESET)

C

C Added "d0" to signify double precision constant.



      CALL PLOTINI(.3d0,SYMRED)

C

      END

C--------------------------------------------------------------------------

      SUBROUTINE PSCALE(AM,AX,AI,NTICKS,AXIS)

C THIS SUBROUTINE CHOOSES THE SCALE FOR AN AXIS BASED ON THE

C MINIMUM (AM) AND MAXIMUM (AX) VALUES FURNISHED.



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



      DOUBLE PRECISION S(5)

      INTEGER NTM(5)

      DATA NPTS/5/

C

      DATA S/1.0,2.0,5.0,10.0,20.0/

      DATA NTM/5,4,5,5,4/

      DATA SLOP/0.01/

C

C If the maximum is less than the minimum, then things are hosed.



      if (ax .lt. am) then

	   PRINT*, 'ERROR: The minimum value exceeds the maximum value'

	   STOP    '       in WORK array in subroutine PRFPLT.'

      endif



C If the minimum value = the maximum value, then all values are the same

C for this coordinate of the plot (i.e. a straight line)

C Also, we set the increment to 1, if it was zero, in order to avoid

C division by zero in PRFPLT.



      IF(AX.eq.AM) then

	  ax = ax + 1

	  am = am - 1

	  if (ai .eq. 0) ai = 1

	  NTICKS = 3

	  RETURN

      endif

C

      NTICKS=1

      IF(NCLOSE(AM,AX,AI,NTICKS,AXIS).EQ.1) RETURN

C

      D=10.0**(dint(dlog10(AX-AM))-1.0)

      AI=1.E30

      U=AI

      DO 100 I=1,NPTS

      T=S(I)*D

      AM1=dINT(AM/T+SLOP)*T

      IF(AM.LT.0.0) AM1=AM1-T

      AX1=dINT(AX/T+1.0-SLOP)*T

      IF(AX.LT.0.0) AX1=AX1-T

      TMP=(AX1-AM1)/T

      IF( (I.LT.NPTS.OR.AI.NE.U).AND.(T.GT.AI .OR. TMP.GT.6.5))

     1     GO TO 100

      NTICKS=NTM(I)

      AI=T

      AX2=AX1

      AM2=AM1

100   CONTINUE

      IF(AX.GT.AX2+AI/10.) AX2=AX2+AI

      AX=AX2

      IF(AM.LT.AM2-AI/10.) AM2=AM2-AI

      AM=AM2

      IF(NTICKS.GT.0) RETURN

C

      N=NCLOSE(AM,AX,AI,NTICKS,AXIS)

      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

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

C

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

C

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

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

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

      Z(NTIME)=RKTIME

C     REMOVE MACHINE ROUND OFF NOISE FROM EXACT RECEIVER LOCATIONS

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

      SUBROUTINE GRACE(X)

C     DEFINE MARGIN AROUND PLOTTING AREA(DISSPLA)

C     WRITE PARAMETERS TO GRAPHICS CALLS FILE

C

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

C

      WRITE(NDEVTXT,100) 21,X

100   FORMAT(I2,F4.2)

      END

c----------------------------------------------------------------------------

      SUBROUTINE GRAFB(A,B,C,D,E,F)

C     ROUTINE WHICH ESTABLISHES BOXED X AND Y AXES(DISSPLA)

C     THIS IS A PSEUDO CALL WHICH USES SEVERAL OTHER DISSPLA CALLS

C     IT IS ASSUMED THAT A PREVIOUS CALL TO TITLE HAS BEEN MADE

C     WRITE PARAMETERS TO GRAPHICS CALLS FILE

C

      DOUBLE PRECISION a,b,c,d,e,f

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

C

      WRITE(NDEVTXT,100) 39,A,B,C,D,E,F

100   FORMAT(I2,6E13.7)

      END

C----------------------------------------------------------------------------

      SUBROUTINE HEIGHT(H)

C     SETS REFERENCE CHARACTER HEIGHT IN INCHES(DISSPLA)

C     WRITE PARAMETERS TO GRAPHICS CALLS FILE

C

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



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

C

      WRITE(NDEVTXT,100) 13,H

100   FORMAT(I2,F4.2)

      END

C----------------------------------------------------------------------------

      FUNCTION ITEST(I)

C     USED TO PASS INTEGER VALUES THROUGH FOR VARIABLES TYPED REAL

C     (AS IN MIXED REAL/INTEGER ARRAYS)

      ITEST=I

      END

C----------------------------------------------------------------------------

      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)

      END



