C file S6.FOR
C ----------------------------------------------------------------------!-------
! 27 Jun 2016 - Added terms to the /GV/ common block for Coriolis terms
!  1 Jul 2011 - Corrected range relative to transmitter when transmitter is left
!               of plotting region
! 13 Apr 2011 - Added printing of desired pulse travel time
! 10 Mar 2011 - Added 3 more digits for printing frequency in LABPLT
!  2 Nov 2010 - Corrected error calculating units in SUBROUTINE PLTANOT
C  3 Nov 2009 - Corrected deg tick mark values in cross range in PLTANH
C 23 Jun 2009 - Changed the default character size for DDTEXT calls to 1.
C 22 Jun 2009 - Added intensity, italics, and size to ddtext
C 30 Apr 2009 - replaced REAL*8 with DOUBLE PRECISION
C 10 Sep 2008 - Made data types consistent.
C 13 Mar 2008 - Corrected length in common block /PCONST/
C 12 Mar 2008 - Corrected length in block /GV/
C 10 Mar 2008 - Added common block /ww/ to SUBROUTINE PLTANOT
C 19 Apr 2007 - corrections to PLOT - flush IXTMP & IYTMP when entering 
C               plotting region
C  5 Mar 2007 - Added molecular fractions to common block /MM/
C  9 Nov 2006 - lengthened format for decimal plot labels in PLTLB
C 20 Jul 2006 - Raised printing of models to avoid collision with date.
C 24 Mar 2006 - Moved ARCTIC from contour1
C 24 Mar 2006 - Moved ARCTIC from S4
C 16 Mar 2006 - Added kzb to /RIN/
C 16 Mar 2006 - Changed kz2 to kz2a
C 14 Mar 2006 - Added kz2 to /RIN/
C  3 Mar 2006 - Moved DDVC back from S4
C  2 Mar 2006 - Moved DDVC, MX1ALF, and MX2ALF back to S4.for
C  2 Mar 2006 - Moved from S4.for
C ----------------------------------------------------------------------!-------
Contains PLOT, LABPLT, PLTHLB, PLTANH, SETXY, TIKLINE, PLTANOT, DRAWTIKS,
C PLTLB, ARCTIC, DDINIT, DDBP, DDVC, DDTEXT, DDTAB, DDFR, DDEND, DASH, RESET,
C HEIGHT, SCMPLX
C ----------------------------------------------------------------------!-------
C 21Feb 2006 - Added 2 more digits for printing frequency in LABPLT
C  3 Feb 2006 - Added printing of gravity and density models
C 13 September 2005 - Added digits to printing of lat/long coordinates
C 18 August 2005 - Changed test for labeling/using vertical axis M or KM
C 18 August 2005 - Increased range for which KM is printed (from 10 to 15 deg)
C 18 August 2005 - CHANGED I4 TO I5 FORMAT ON VERTICAL AXIS LABELS
C 26 Sep 2004 - Correctly made range relative to transmitter
C 20 Sep 2004 - Made range relative to transmitter
C 6 Jul 2004 - CORRECTED CONVERSION IN PLTLB
C 6 Jul 2004 - CHANGED TRUNCATION TO ROUNDING
C 6 Jul 2004 - CHANGED MAY 1991 CORRECTION
C 6 Jul 2004 - ADDED .D0 TO LINE 953
C 2 Jul 2004 - CHANGED I3 TO I4 FORMAT ON VERTICAL AXIS LABELS
C 2 Jul 2004 - ADDED "-LLON"
C Note: changes marked as "10 Jun 2003" were not made to this file on that date.
C They are the changes in the 10 Jun 2003 version of the raytracing program.
C 10 Jun 2003 - added lines 87 & 88 (SUBROUTINE PLOT)
C 30 Oct 2003 - line 501 (SUBROUTINE LABPLT), loop for 9 instead of 8
C                                             added 7,8,9
C 1 Nov 2003 - line 945 (SUBROUTINE PLTLB) changed axis labeling
C 2 Nov 2003 - line 963 (SUBROUTINE PLTLB) changed axis labeling
C ----------------------------------------------------------------------!-------
      SUBROUTINE PLOT (X,Y,NEW)
C ----------------------------------------------------------------------!-------
C     PLOTS ONE VECTOR FROM CURRENT PLOT POSITION TO POINT(X,Y)
C     TAKING BORDER CROSSINGS INTO ACCOUNT.
C%    NEW = 0 means draw a line to X,Y; 
C%    NEW .ne. 0 means move to X,Y without drawing a line.

      implicit double precision (a-h,o-z)
 
      COMMON /PLT/ XMIN0,XMAX0,YMIN0,YMAX0,RESET
      COMMON/PLT/RMIN,RMAX,ALPHA,APLT
      INTEGER REZFLG
      PARAMETER (REZFLG=2001)
      COMMON/DDREZ/DDHIX,DDHIY
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVGRP,NDEVBIN
      COMMON /DD/ INT,IOR,IT,IS,IC,ICC,IX,IY

C**** The following variables were added to handle the "buffering" of all
C     the "lineto" data i.e. calls to DDVC_ACUM.
C     After each "moveto", the x and y values for the "lineto"s
C     will be stored in IXTMP and IYTMP.  Then, a single write to NDEVGRP
c     is performed which writes all NUMPTS values.  NUMPTS is then reset
C     and the process starts over.

      integer*2 numpts, ixtmp(3000), iytmp(3000)

      character*12 lastcmd
      logical outrange

      data lastcmd/'            '/

c      PRINT*,'x = ',x
c      PRINT*,'y = ',y

C DEFINE NOMINAL PLOTTING AREA(ZERO SUFFIXES) AND AN
C OUTER CLIPPING BOUNDARY BEYOND WHICH NO VECTORS EXTEND.
      DATA XOLD,YOLD/0.0,0.0/
C 90% FOR Y RANGE
C
C          COMPUTE SCALE FACTORS

    1 IF (RESET.EQ.0.d0) GO TO 5
      RESET=0.d0
      IF(APLT.EQ.2.d0) THEN
         MRNGE=723
         MINX0=165
         MINY0=140
      ELSE
         MRNGE=813
         MINX0=165
         MINY0=140
      ENDIF
      if(aplt.eq.4.d0) miny0=80
C
      MAXX0=MINX0+MRNGE
      MAXY0=MINY0+MRNGE
C
      XSCALE=(MAXX0-MINX0)/(XMAX0-XMIN0)
      YSCALE=(MAXY0-MINY0)/(YMAX0-YMIN0)
      XMIN=XMIN0
      YMIN=YMIN0
      XMAX=XMAX0
      YMAX=YMAX0
      IF(APLT.EQ.2.d0) GO TO 5
C
      XMIN=-ALPHA
      XMAX=ALPHA
      YMIN=RMIN
      YMAX=RMAX
      IF(APLT.NE.4.d0) GO TO 5
      YSCALE=.85d0*YSCALE
      MINY0=MINY0+60
C
C          START A NEW LINE
5     XS=X-XOLD
      YS=Y-YOLD
      S=1.d0
      IF(NEW.EQ.0) GO TO 10

      IF(X.GE.XMIN.AND.X.LE.XMAX.AND.Y.GE.YMIN.AND.Y.LE.YMAX) then
           GO TO 48
      else
           print*,'x or y out of range.'
		 print *,'X = ',X,' XMIN = ',XMIN,' XMAX = ',XMAX
	     print *,'Y = ',Y,' YMIN = ',YMIN,' YMAX = ',YMAX
           outrange=.true.

           GO TO 50
      endif
C
C          HORIZONTAL DISPLACEMENT
10    IF (XS) 11,12,16
C          NEGATIVE
   11 X1=XMAX
      X2=XMIN
      GO TO 20
C          ZERO
   12 IF (YS) 13,50,14
   13 S1=(YMAX-YOLD)/YS
      S2=(YMIN-YOLD)/YS
      GO TO 40
   14 S1=(YMIN-YOLD)/YS
      S2=(YMAX-YOLD)/YS
      GO TO 40
C          POSITIVE
   16 X1=XMIN
      X2=XMAX
C
C          VERTICAL DISPLACEMENT
   20 IF (YS) 21,22,26
C          NEGATIVE
   21 Y1=YMAX
      Y2=YMIN
      GO TO 30
C          ZERO
   22 S1=(X1-XOLD)/XS
      S2=(X2-XOLD)/XS
      GO TO 40
C          POSITIVE
   26 Y1=YMIN
      Y2=YMAX
C
   30 S1=DMAX1((X1-XOLD)/XS,(Y1-YOLD)/YS)
      S2=DMIN1((X2-XOLD)/XS,(Y2-YOLD)/YS)
C
C          PLOT LINE -- CHECKING FOR BORDER CROSSINGS
40    IF (S2.LT.0.d0.OR.S1.GT.1.d0) then
           GO TO 50
      endif
      IF (S1.LT.0.d0) GO TO 42
C          PREVIOUS POINT OFF GRAPH
      XP=XOLD+XS*S1
      YP=YOLD+YS*S1
      IF(APLT.EQ.2.d0.OR.APLT.EQ.4.d0) GO TO 41
      T=XP
      XP=YP*dSIN(T)
      YP=YP*dCOS(T)
C
41    DDHIX=MINX0+(XP-XMIN0)*XSCALE+0.5d0
      DDHIY=MINY0+(YP-YMIN0)*YSCALE+0.5d0
c      print*,'ddhix= ',ddhix
c      print*,'ddhiy= ',ddhiy
C     USE SPECIAL HI-REZ MODE
      IX=REZFLG
ccccc      CALL DDBP     !!!!! COMMENT OUT OR NOT ?????
      CALL DDBP   !  19 Apr 2007

C     !  19 Apr 2007
C I copied into here the programming to flush IXTMP and IYTMP from below
C

C.........If we have accumulated any points, flush IXTMP, IYTMP.

          if (numpts .gt.0) then
              WRITE (ndevgrp,444) lastcmd    ! the moveto command
	      WRITE (ndevgrp,99) numpts
	      nremain = MOD(numpts,8)
	      if (numpts .ge. 8) then
	       	  do ii = 1, numpts-7, 8
		       WRITE (ndevgrp,111)(ixtmp(j),iytmp(j),j=ii,ii+7)
		  enddo
	      endif

C............if NUMPTS was not evenly divisible by 8, then the
C............remaining points are written to the file one per line.

	     if (nremain.gt.0) then
		  WRITE (ndevgrp,222)
     &		    (ixtmp(k),iytmp(k),k=numpts-nremain+1,numpts)
	     endif
	  endif

C.........Store the moveto command whenever NUMPTS = 0, or
C         whenever NEW is not 0 (i.e. a moveto occurs).  Either way, reset
C         NUMPTS.
C.........We write the moveto to a character string which is later written
C         to NDEVGRP.

          WRITE (lastcmd,333) 1,idint(1.d1*ddhix), idint(1.d1*ddhiy)

          numpts = 0   ! reset for DDVC_ACUM

C
C end of the programming to flush IXTMP and IYTMP !  19 Apr 2007


      if (outrange .and. lastcmd.eq.'            ') then
        WRITE (lastcmd,333) 1,idint(1.d1*ddhix),
     &                               idint(1.d1*ddhiy)
ccccc        print*,'lastcmd before goto 48 = ',lastcmd
      else
ccccc          print*,'outrange = ',outrange
ccccc          print*,'lastcmd = ',lastcmd
      endif
      GO TO 48
C
42    IF (S2.GT.1.d0) GO TO 48
C          CURRENT POINT OFF GRAPH
      S=S2
C          CURRENT POINT ON GRAPH
48    XP=XOLD+XS*S
      YP=YOLD+YS*S
      IF(APLT.EQ.2.d0.OR.APLT.EQ.4.d0) GO TO 49
      T=XP
      XP=YP*dSIN(T)
      YP=YP*dCOS(T)
49    DDHIX=MINX0+(XP-XMIN0)*XSCALE+0.5d0
      DDHIY=MINY0+(YP-YMIN0)*YSCALE+0.5d0
c      print*,'ddhix= ',ddhix
c      print*,'ddhiy= ',ddhiy
      
C     USE SPECIAL HI-REZ MODE
      IX=REZFLG
ccccc	IF(NEW.EQ.0) CALL DDVC

C The basic idea here is that when NEW = 0,
C the program accumulates "lineto" (i.e. DDVC) commands in IXTMP,IYTMP.
C Then, when NEW is not equal to 0, we are beginning a new line.  This
C requires a "moveto" (i.e."1 ix iy") command.  It is necessary, when a new
C "moveto" occurs that all "lineto"s that have been accumulated be
C "flushed".
C Occasionally, the plotting routines write some redundant "moveto"s, i.e.
C a "moveto" followed immediately by another "moveto" (sometimes to the
C same location!) with NO intervening "lineto"s.  This results in NUMPTS = 0.
C We ignore these movetos and do not flush.
C

C.....Handle very large plots.	The IXTMP, IYTMP arrays are only dimensioned
C     to 3000.	This reduces the size of the executable file, decreases
C     the amount of memory used and increases execution speed.
C     Therefore, when 3000 is reached and the line is not yet finished,
C     write the 3000 pairs that have been accumulated.
C     NOTE:  It is possible (I know it seems stupid) that there may be
C            3000 "lineto"s with no previous "moveto".

      if (new.eq.0 ) then
	   call DDVC_ACUM (numpts,ixtmp,iytmp)
           if (numpts .eq. 3000) then
                WRITE (ndevgrp,444) lastcmd
   	        WRITE (ndevgrp,99) 3000
                do ii = 1, 3000-7,8               !  3000/8 pairs per row = 375 rows
	            WRITE (ndevgrp,111) (ixtmp(j),iytmp(j),j=ii,ii+7)
	        enddo

C...............Save the last point as a moveto command in LASTCMD so we can
C               pick up where we left off.
                WRITE (lastcmd,333) 1,ixtmp(3000),iytmp(3000)
	        numpts = 0
          endif
      endif


C
C.....The call to DDBP only sets values of DDHIX,DDHIY, IX, IY.
C     It does not write to NDEVGRP.

      IF(NEW.NE.0) then
          call DDBP

C.........If we have accumulated any points, flush IXTMP, IYTMP.

          if (numpts .gt.0) then
              WRITE (ndevgrp,444) lastcmd    ! the moveto command
	      WRITE (ndevgrp,99) numpts
	      nremain = MOD(numpts,8)
	      if (numpts .ge. 8) then
	       	  do ii = 1, numpts-7, 8
		       WRITE (ndevgrp,111)(ixtmp(j),iytmp(j),j=ii,ii+7)
		  enddo
	      endif

C............if NUMPTS was not evenly divisible by 8, then the
C............remaining points are written to the file one per line.

	     if (nremain.gt.0) then
		  WRITE (ndevgrp,222)
     &		    (ixtmp(k),iytmp(k),k=numpts-nremain+1,numpts)
	     endif
	  endif

C.........Store the moveto command whenever NUMPTS = 0, or
C         whenever NEW is not 0 (i.e. a moveto occurs).  Either way, reset
C         NUMPTS.
C.........We write the moveto to a character string which is later written
C         to NDEVGRP.

          WRITE (lastcmd,333) 1,idint(1.d1*ddhix), idint(1.d1*ddhiy)

          numpts = 0   ! reset for DDVC_ACUM

      endif  !	new .ne. 0

99    FORMAT (I5)
111   FORMAT (8(2I5))
222   FORMAT (2I5)
333   FORMAT (I2,2I5)
444   format (a)
555   format (1x,a)

C          EXIT ROUTINE
   50 XOLD=X
      YOLD=Y
      if (outrange .and.new.ne.0)then
           if (numpts.gt.0) then
               WRITE (ndevgrp,444) lastcmd
               WRITE (ndevgrp,99) numpts
               nremain = MOD(numpts,8)
               if (numpts .ge. 8) then
	           do ii = 1, numpts-7, 8
	              WRITE (ndevgrp,111)(ixtmp(j),iytmp(j),j=ii,ii+7)
	           enddo
	       endif

C..........if NUMPTS was not evenly divisible by 8, then the
C..........remaining points are written to the file one per line.

	       if (nremain.gt.0) then
	           WRITE (ndevgrp,222)
     &		    (ixtmp(k),iytmp(k),k=numpts-nremain+1,numpts)
	       endif
               numpts = 0
               lastcmd = '            '
          endif
      endif
      RETURN
C
C          TERMINATE THE CURRENT PLOT
C ----------------------------------------------------------------------!-------
      entry pltend
C ----------------------------------------------------------------------!-------
C      ENTRY PLTEND(X,Y,NEW)
      CALL DDFR
C
      RETURN
C ----------------------------------------------------------------------!-------
         END SUBROUTINE PLOT
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE LABPLT
C ----------------------------------------------------------------------!-------
C          LABEL THE CURRENT PLOT
 
      implicit double precision (a-h,o-z)
 
      CHARACTER*80 LABEL,CHID,id
      CHARACTER*4 ANGRANG,ANOTE

C     COMMON DECK "LL" INSERTED HERE
      DOUBLE PRECISION MODL
      COMMON/LL/MODL(4),APH,APHPT,APHPR,APHPTH,APHPPH

C     COMMON DECK "SS" INSERTED HERE
      DOUBLE PRECISION MODSURF
      common/ident/id
      COMMON/SS/ MODSURF(4)
      COMMON/SS/U,PUR,PURR,PURTH,PURPH
      COMMON/SS/PUTH,PUPH,PUTHTH,PUPHPH,PUTHPH,USELECT,UTIME

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 "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 "UU" INSERTED HERE
      DOUBLE PRECISION MODU
      COMMON/UU/MODU(4)
     1  ,V  ,PVT  ,PVR  ,PVTH  ,PVPH
     2  ,VR ,PVRT ,PVRR ,PVRTH ,PVRPH
     3  ,VTH,PVTHT,PVTHR,PVTHTH,PVTHPH
     4  ,VPH,PVPHT,PVPHR,PVPHTH,PVPHPH

C     COMMON DECK "CC" INSERTED HERE
      DOUBLE PRECISION MODC
      COMMON/CC/MODC(4),CS,PCST,PCSR,PCSTH,PCSPH

C     COMMON DECK "TT" INSERTED HERE
      DOUBLE PRECISION MODT
      COMMON/TT/MODT(4), T,PTT,PTR,PTTH,PTPH

C     COMMON DECK "MM" INSERTED HERE
      DOUBLE PRECISION M,MODM
      COMMON/MM/MODM(4),M,PMT,PMR,PMTH,PMPH
     1 ,XO2,XN2,XO,XN,XH2O,XO3 ! 5 Mar 2007

C     COMMON DECK "GV" INSERTED HERE                               !  3 Feb 2006   
      DOUBLE PRECISION MODGV                                       !  3 Feb 2006
!      COMMON/GV/MODGV(4), GV,PGVT,PGVR,PGVTH,PGVPH,STUFF(15)      ! 12 Mar 2008
      COMMON/GV/MODGV(4), GV,PGVT,PGVR,PGVTH,PGVPH,STUFF(35)       ! 27 Jun 2016

C     COMMON DECK "DS" INSERTED HERE                               !  3 Feb 2006   
      DOUBLE PRECISION MODDS                                       !  3 Feb 2006
      COMMON/DS/MODDS(4), DS,PDST,PDSR,PDSTH,PDSPH                 !  3 Feb 2006

C     COMMON DECK "HDR" INSERTED HERE
      CHARACTER*10 INITID*80,DAT,TOD
      COMMON/HDR/SEC,stsec                        !Rev 7/13/90
      COMMON/HDRC/INITID,DAT,TOD

C     COMMON DECK "RINPLEX" INSERTED HERE
      DOUBLE PRECISION KAY2,KAY2I 
     & , kz2a,kz2ai,kzb,kzbi                                    ! 16 Mar 2006
      COMPLEX*16 PNP,POLAR,LPOLAR
      LOGICAL SPACE
      CHARACTER DISPM*6,modrin*64
      COMMON/RINPL/DISPM
      COMMON /RIN/ MODRIN,RAYNAME(2,3),TYPE(3),SPACE
      COMMON/RIN/OMEGMIN,OMEGMAX,KAY2,KAY2I 
     & , kz2a,kz2ai,kzb,kzbi                ! 16 Mar 2006
      COMMON/RIN/PNP(10),POLAR,LPOLAR,SGN

      COMMON /DD/ INT,IOR,IT,IS,IC,ICC,IX,IY

C     COMMON DECK "CONST" INSERTED HERE
      COMMON/PCONST/CREF,RGAS,GAMMA
     1 ,MO2,MN2,MO,MN,MH2O,MO3                        ! 9 Mar 2007 ! 13 Mar 2008
      DOUBLE PRECISION MO2,MN2,MO,MN,MH2O,MO3                      ! 13 Mar 2008
      COMMON/MCONST/PI,PIT2,PID2,DEGS,RAD,ALN10

C     COMMON DECK "FLAG" INSERTED HERE
      LOGICAL NEWWR,NEWWP,NEWTRC,PENET
      COMMON /FLG/ NTYP,NEWWR,NEWWP,NEWTRC,PENET,LINES,IHOP,HPUNCH
      COMMON/FLGP/NSET

      COMMON/WW/dum(10),MAXW,W(1000)
      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))
     & ,(plusplot,W(78))                                           ! 13 Apr 2011

      DOUBLE PRECISION MMODEL,MFORM,MID
C
C     WIND        100-124
      EQUIVALENCE (W(100),UMODEL),(W(101),UFORM),(W(102),UID)
C
C     DELTA WIND        125-149
      EQUIVALENCE (W(125),DUMODEL),(W(126),DUFORM),(W(127),DUID)
C
C     SOUND SPEED 150-174
      EQUIVALENCE (W(150),CMODEL),(W(151),CFORM),(W(152),CID)
      EQUIVALENCE (W(153),REFC)
C
C     DELTA SOUND SPEED 175-199
      EQUIVALENCE (W(175),DCMODEL),(W(176),DCFORM),(W(177),DCID)
C
C     TEMPERATURE    200-224
      EQUIVALENCE (W(200),TMODEL),(W(201),TFORM),(W(202),TID)
C
C     DELTA TEMPERATURE    225-249
      EQUIVALENCE (W(225),DTMODEL),(W(226),DTFORM),(W(227),DTID)
C
C     MOLECULAR   250-274
      EQUIVALENCE (W(250),MMODEL),(W(251),MFORM),(W(252),MID)
C
C     RECEIVER HEIGHT   275-299
      EQUIVALENCE (W(275),RMODEL),(W(276),RFORM),(W(277),RID)
C
C     TOPOGRAPHY   300-324
      EQUIVALENCE (W(300),GMODEL),(W(301),GFORM),(W(302),GID)
C
C     DELTA TOPOGRAPHY   325-349
      EQUIVALENCE (W(325),GUMODEL),(W(326),GUFORM),(W(327),GUID)
C
C     ATMOSPHERIC SURFACE TOPOGRAPHY   350-374
      EQUIVALENCE (W(350),SMODEL),(W(351),SFORM),(W(352),SID)
C
C     ATMOSPHERIC SURFACE TOPOGRAPHY   375-399
      EQUIVALENCE (W(375),SUMODEL),(W(376),SUFORM),(W(377),SUID)
C     PLOT ENHANCEMENTS CONTROL PARAMETERS
C
      EQUIVALENCE (W(490),XFQMDL),(W(491),YFQMDL)
C     ABSORPTION        500-524
      EQUIVALENCE (W(500),AMODEL),(W(501),AFORM),(W(502),AID)
C
C     DELTA ABSORPTION        525-549
      EQUIVALENCE (W(525),DAMODEL),(W(526),DAFORM),(W(527),DAID)
C
C     PRESSURE        550-574
      EQUIVALENCE (W(550),PMODEL),(W(551),PFORM),(W(552),PID)
C
C     DELTA PRESSURE        575-599
      EQUIVALENCE (W(575),DPMODEL),(W(576),DPFORM),(W(577),DPID)
C
C
C     COMMON DECK "AA" INSERTED HERE
      DOUBLE PRECISION MODA
      DOUBLE PRECISION MU,MUPT,MUPR,MUPTH,MUPPH
      DOUBLE PRECISION KAP,KAPPT,KAPPR,KAPPTH,KAPPPH
      COMMON/AA/MODA(4),MU,MUPT,MUPR,MUPTH,MUPPH
      COMMON/AA/KAP,KAPPT,KAPPR,KAPPTH,KAPPPH

C     COMMON DECK "PP" INSERTED HERE
      DOUBLE PRECISION MODP
      COMMON/PP/MODP(4),P,PPT,PPR,PPTH,PPPH
C
C*    WRITE(LABEL,900) ID
      WRITE(LABEL,'(a)') ID
900   FORMAT(10A8)
      CHID=LABEL
      LABEL=CHID(5:)
      IOR=0
      IT=0
      IS=2
      IS=1                                                        ! 23 Jun 2009
      IX=400
      IY=1500
      CALL DDTEXT (8,LABEL)
      IX=1050
      IY=150   !!!!! was 350 JAH.
      CALL DDTEXT (2,DAT) 
      IY=1023
      F=OW/PIT2
      NANGLE=10
      ANGRANG='El ='
      ANOTE='Az ='
      ANEL=0.d0
      IF(ELSTEP.NE.0.d0) ANEL=(ELEND-ELBEG)/ELSTEP+1.5d0
      IF(ANEL.GT.1.d0.OR.PLT.LT.0.d0) GO TO 100
         ANGRANG='Az ='
         ANOTE='El ='
         NANGLE=14
100   WRITE(LABEL,1300)  CHID(1:3),SNGL(F),ANOTE,SNGL(W(NANGLE)*DEGS)
c1300  FORMAT (2x,'Model = ',A,',  Freq =',F9.3,' Hz, ',A,F7.3,' deg')
c1300  FORMAT (2x,'Model = ',A,',  Freq =',F11.5,' Hz, ',A,F7.3,' deg')!21Feb2006
1300  FORMAT(2x,'Model = ',A,', Freq =',F14.8,' Hz, ',A,F7.3,' deg')!10 Mar 2011
C ----------------------------------------------------------------------!-------
      IX=0
      IY=IY-34   !!!!! Changed 34 to 41. JAH
      CALL DDTEXT (7,LABEL)
C
C INDEX OF OPPOSITE ANGLE
      NANGLE=(10+14-NANGLE)+1
      NANGLE2=NANGLE+2
      WRITE(LABEL,1400) ANGRANG,(SNGL(W(I)*DEGS),I=NANGLE,NANGLE2)
1400  FORMAT(2x,A,F7.2,' deg to',F7.2,' deg,  Step =',F7.2,' deg')
      IY=IY-34   !!!!! 34  to 41
      CALL DDTEXT (7,LABEL)
C
      WRITE(LABEL,1500)SNGL(XMTRH),SNGL(TLAT*DEGS),SNGL(TLON*DEGS)
1500  FORMAT(2x,'Xmtr ht =',F6.2,' Km, Lat =',F6.2,' deg, Long ='
     1   ,F6.2,' deg')
      IY=IY-34    !!!! 34 to 41
      CALL DDTEXT (7,LABEL)
      IY=IY-34    ! 34 to 41
      WRITE(LABEL,"(2X,'Pulse travel time = ',F9.0,' sec')")
     & sngl(plusplot)                                              ! 13 Apr 2011
      IF(plusplot.ne.0.d0)  CALL DDTEXT(4,LABEL)                   ! 13 Apr 2011
C%      WRITE(LABEL,'(A)')  MODRIN
C*      WRITE(LABEL,'(10A8)') MODRIN  ! deleted full dispersion label
C%      CALL DDTEXT(8,LABEL)
C
      IX=1050
      iy = iy +34                                       ! 20 Jul 2006
      CALL DDTEXT(2,'MODELS USED:')
      IY=IY-34   !!!!! Changed 70 to 41.  JAH.
c.....added 'DSP. REL.' on end of disperion model so as to make the label
c     longer than 10 characters so it wouldn't be mistaken for a tick label
c     by the plotting program.  JAH.

      write (label,'(a16)')dispm // ' DSP. REL.'  ! replaced full dispersion label
      call ddtext(2,label)        ! MODRIN with acronym, e.g., AWCWL
      iy=iy-20
C     LOOP FOR 11 MODELS AND PERTURBATIONS (additions 3 February 2006)
      DO 1700 K=1,22 ! 3 Feb 2006
      I=(K-1)/2+1
C     GENERATE ALTERNATING 1,2;3,4 SERIES FOR MODEL AND PERTURBATION
      J1=2*(K+1-I*2)+1
      J2=J1+1
      IF(I.EQ.1) WRITE(LABEL,1600) (MODU(J),J=J1,J2)
      IF(I.EQ.2) WRITE(LABEL,1600) (MODC(J),J=J1,J2)
C
      IF(I.EQ.3) WRITE(LABEL,1600) (MODG(J),J=J1,J2)
      IF(I.EQ.4) WRITE(LABEL,1600) (MODL(J),J=J1,J2)
      IF(I.EQ.5 .AND. J1.EQ.1)
     1     WRITE(LABEL,1600) (MODREC(J),J=J1,J2)
      IF(I.EQ.6) WRITE(LABEL,1600) (MODSURF(J),J=J1,J2)
      IF(I.EQ.7) WRITE(LABEL,1600) (MODT(J),J=J1,J2)
      IF(I.EQ.8 .AND. J1.EQ.1)
     1 WRITE(LABEL,1600) (MODM(J),J=J1,J2)
      IF(I.EQ.9) WRITE(LABEL,1600) (MODP(J),J=J1,J2)
      IF(I.EQ.10) WRITE(LABEL,1600) (MODGV(J),J=J1,J2) ! 3 Feb 2006
      IF(I.EQ.11) WRITE(LABEL,1600) (MODDS(J),J=J1,J2) ! 3 Feb 2006
1600  FORMAT(2(2(A8,2X,F5.1,1X),2X))
C
1610  IF(LABEL(1:1).EQ.' ') GO TO 1700
      IY=IY-34   !!!!! 34 to 41
      CALL DDTEXT(2,LABEL)
1700  LABEL(1:1)=' '
C
C ----------------------------------------------------------------------!-------
         END SUBROUTINE LABPLT
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE PLTHLB(X,Y,NC)
C ----------------------------------------------------------------------!-------
C     HORIZONTAL TICK ANNOTATION ROUTINE FOR RAYPLOT.
C
C
 
      implicit double precision (a-h,o-z)
 
      EXTERNAL PLOT
C
      CALL PLTANH(X,Y,NC,PLOT)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE PLTHLB
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE PLTANH(X,Y,NC,PLOT)
C ----------------------------------------------------------------------!-------
C
C     TICK LABELING FOR HORIZONTAL OR RECTANGULAR PLOT PROJECTION.
C%     Puts tick numbers above, below, or left of axes at the tick 
C%     whose coordinates are X,Y
C%    NC = 1 for horizontal axis; = 2 for vertical axis.
C%    PLOT is a subroutine name passed by the calling sequence,
C%     which in this case is actually the PLOT subroutine.
 
      implicit double precision (a-h,o-z)
 
      CHARACTER ANNOT*10
      COMMON/DD/IN,IOR,IT,IS,IC,ICC,IX,IY
      COMMON/WW/dum(10),MAXW,W(1000)
      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 "CONST" INSERTED HERE
      COMMON/PCONST/CREF,RGAS,GAMMA
     1 ,MO2,MN2,MO,MN,MH2O,MO3                        ! 9 Mar 2007 ! 13 Mar 2008
      DOUBLE PRECISION MO2,MN2,MO,MN,MH2O,MO3                      ! 13 Mar 2008
      COMMON/MCONST/PI,PIT2,PID2,DEGS,RAD,ALN10
      COMMON/LABCLT/PROJCT,THMIN,THMAX,RMIN,RMAX
C
      COMMON/RAYCON/MCONP
C
      DATA LNC/-100/
C
      IF(NC.LE.0 .OR. NC.GT.2) GO TO 100
C
C     NORMALIZE LETTER SIZE FACTOR TO .15
      HLETF=HITLET/.15d0
C
      IF(LNC.NE.NC) LICM=-100
      LNC=NC
C
      CALL PLOT(X,Y,1)
      IX=IX-50*HLETF  !  changed from 80 to 50 to align with ticks
      ICM=IX
      IF(NC.GT.1) THEN
         ICM=IY
         IX=IX-40
      ENDIF
C
C     INSURE THAT OVERLAPS OF ANNOTATIONS DO NOT OCCUR
      IF(IABS(ICM-LICM).LT.INT(80*HLETF)) GO TO 100
C
C........Test Y to see if label is for upper (GT) or lower (LT) axis.
C........Test HB to see if lower axis is above sea level;
C........if so, label lower axis.
C........If plot projection 2 or 4, always label lower axis.
C
      IF (PROJCT.EQ.2.d0) GO TO 25
      IF(HB.GE.0.d0.AND.Y.GT.(RMIN+RMAX)/2.d0) GO TO 100
      IF(HB.LT.0.d0.AND.Y.LT.(RMIN+RMAX)/2.d0.and.projct.ne.4.d0)
     1  GO TO 100
      if(projct.eq.4.d0.and.y.gt.(rmin+rmax)/2.d0) go to 100
C
25    F=DEGS
      TMP=(THMAX-THMIN)*DEGS
c3 Nov 2009      IF(TMP.LT.10.d0) F =EARTHR
      IF(TMP.LT.10.d0.or.projct.eq.2.d0.and.nc.gt.1) F =EARTHR     ! 3 Nov 2009
      FT=F
      IF(PROJCT.EQ.2.d0 .AND. MCONP.EQ.0) F=F/EARTHR
      V=X-THMIN  + llon    ! added "+ llon", so tick labels are correct
                           ! when plotting a subset of the range. JAH.
C
C     THE ABOVE WORKS ONLY IN THE EQUATORIAL PLANE
C     UNTIL WE FIGURE OUT HOW TO DO THIS CORRECTLY, WE WILL DO THE
C     FOLLOWING:
C
      V=V-llon             ! ADDED "-LLON"                            2 JUL 2004
C Range relative to transmitter                                      20 Sep 2004
C Range relative to transmitter (correctly)                          26 Sep 2004
C Range correctly when transmitter left of plot region                1 Jul 2011
C DLR is great circle distance from left side to right side of plotting region
C DLT is great circle distance from left side of plotting region to transmitter
C DRT is great circle distance from right side of plotting region to transmitter
C DTP is great circle distance from transmitter to great circle through L & R
C point P is the projection of transmitter onto great circle through L & R
C DLP is great circle distance from left side of plotting region to point P 
C DRP is great circle distance from right side of plotting region to point P 
      COSDLR=DSIN(LLAT)*DSIN(RLAT)+DCOS(LLAT)*DCOS(RLAT)*DCOS(RLON-LLON)
      SINDLR=DSQRT(1.D0-COSDLR**2)
      COSDLT=DSIN(LLAT)*DSIN(TLAT)+DCOS(LLAT)*DCOS(TLAT)*DCOS(TLON-LLON)
      COSDRT=DSIN(RLAT)*DSIN(TLAT)+DCOS(RLAT)*DCOS(TLAT)*DCOS(TLON-RLON)
      SINDTP=(DCOS(LLAT)*DCOS(RLAT)*DSIN(TLAT)*DSIN(RLON-LLON) +
     1 DCOS(LLAT)*DCOS(TLAT)*DSIN(RLAT)*DSIN(LLON-TLON) +
     2 DCOS(RLAT)*DCOS(TLAT)*DSIN(LLAT)*DSIN(TLON-RLON))/SINDLR
      COSDTP=DSQRT(1.D0-SINDTP**2)
      COSDLP=COSDLT/COSDTP
      COSDRP=COSDRT/COSDTP
C      v=v-dacos(cosdlp)                                            ! 26 Sep 2004
! When the transmitter is not left of the plotting region, formula is OK
      if(COSDRP.GE.COSDLR) v=v-dacos(cosdlp)                        !  1 Jul 2011
! When the transmitter is left of the plotting region, we need a different
! formula 
      if(COSDRP.LT.COSDLR) v=v+dacos(cosdlp)                        !  1 Jul 2011
      IF(NC.GT.1) V=Y-(RMIN+RMAX)/2.d0
      IF(DABS(DMOD(TIC*FT+1.d-4,1.D0)).GT.1.d-3) then
           WRITE(ANNOT,80) SNGL(V*F)  !  writes values with decimal pt.
80         FORMAT(F8.2)
      else      ! write values without decimal pt.
           WRITE(ANNOT,50) IDINT(V*F+DSIGN(.5d0,V))
50         FORMAT(I5)
      endif
C
      LICM=ICM
C     ALLOW 8 RASTERS FOR THE LETTER HEIGHT and decide whether to put
C     range values above or below horizontal axis
      H=HB
      IF(PROJCT.EQ.2.d0.or.projct.eq.4.d0) H=0.d0
      IF(NC.EQ.1) IY=IY-8*HLETF-DSIGN(52.D0,H) 
      IOR=0
      IS=1                                                        ! 23 Jun 2009
C%95    FORMAT(3G13.6,2I5,1X,A10)!not used
C%99    FORMAT(2G13.6,5I5,1X,A10)!not used
      CALL DDTEXT(1,ANNOT)   !  places range values at ticks
C
100   CALL PLOT(X,Y,MIN0(1,NC))
C ----------------------------------------------------------------------!-------
      END SUBROUTINE PLTANH
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE SETXY(PROJ,XMIN,YMIN,XMAX,YMAX)
C ----------------------------------------------------------------------!-------
C     PLOT INITIALIZATION; SETS PROJECTION PARAMETERS
C
 
      implicit double precision (a-h,o-z)
 
      COMMON/LABCLT/PROJCT,THMIN,THMAX,RMIN,RMAX
C
C
C   INITIAL ANNOTATION MODEL
C%      CALL SETANN
C
      PROJCT=PROJ
      THMIN=XMIN
      RMIN=YMIN
      THMAX=XMAX
      RMAX=YMAX
C ----------------------------------------------------------------------!-------
      END SUBROUTINE SETXY
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE TIKLINE(XL1,YB,XL,YT1,TICV,TIKSZ,PLOT)
C ----------------------------------------------------------------------!-------
C     DRAWS STRAIGHT LINE WITH TICKS AT INTERVALS
C
C
 
      implicit double precision (a-h,o-z)
 
      XDF=XL-XL1
      YDF=YT1-YB
      DST=SQRT(XDF*XDF+YDF*YDF)
      TICE=DST
      T=0.d0
      IF(TICV.EQ.0.d0) GO TO 50
      TICE=TICV
      T=TIKSZ/TICV
C
50    TICVX=TICE*XDF/DST
      TICVY=TICE*YDF/DST
      TX=TICVY*T
      TY=-TICVX*T
      NTIC=1+DST/TICE
      CALL PLOT(XL1,YB,-1)
      DO 100 I=0,NTIC-1
        X=XL1+I*TICVX
        Y=YB+I*TICVY
        CALL PLOT(X,Y,0)
        CALL PLOT(X+TX,Y+TY,0)
100   CALL PLOT(X,Y,1)
      CALL PLOT(XL,YT1,0)
      CALL PLOT(XL,YT1,1)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE TIKLINE
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE PLTANOT(ID,FREQ,XMF,YMF,XL,YB,XR,YT
     1    ,DEGS,LLAT,LLON,RLAT,RLON,ALTLOW,ALTHI,PLT,DTICH,DTICV,PLOT)
C ----------------------------------------------------------------------!-------
C     PUTS STANDARD ANNOTATIONS ON PLOTS
      implicit double precision (a-h,o-z)

C common block /ww/ inserted here                                  ! 10 Mar 2008
      COMMON/WW/dum(10),MAXW,W(1000)
      EQUIVALENCE (EARTHR,W(1))

      COMMON/LABCLT/PROJCT,THMIN,THMAX,RMIN,RMAX
      DOUBLE PRECISION LLAT,LLON
      CHARACTER LABEL*80,id*80
      COMMON /DD/ INT,IOR,IT,IS,IC,ICC,IX,IY
C     COMMON DECK "ANNOT" INSERTED HERE
      character*30 anotes(4),hnotes(3)
      integer lena(4),lenha(3)
c%      COMMON/ANNCTL/LENA(4),LENHA(3)
c%      COMMON/ANNCTC/ANOTES(4),HNOTES(3)
C
      data lena,anotes/1,1,2,2,'DEPTH (m)','DEPTH (km)',
     2 'HEIGHT (m)','HEIGHT (km)'/
      data lenha,hnotes/3,2,3, 'RANGE AT SEA LEVEL (km)',
     1       'RANGE (deg)','CROSS RANGE AT SEA LEVEL (km)'/
C
      IF(PLT.EQ.2.d0 .OR. XMF.LE.0.d0 .OR. YMF.LE.0.d0) GO TO 45
      CALL PLOT(XL+XMF*(XR-XL),YB+YMF*(YT-YB),1)
      IF(FREQ.LE.0.d0) GO TO 30
C
      WRITE(LABEL,25) SNGL(FREQ)
25    FORMAT('FREQ =',F9.3)
      IS=1                                                        ! 23 Jun 2009
      CALL DDTEXT(2,LABEL)
      IY=IY+40
C
30    WRITE(LABEL,35) ID
35    FORMAT('MODEL = ',A3)
      CALL DDTEXT(2,LABEL)
C
45    NSPY=97
      IOR=0
C
C FIRST THE left lat/long ANNOTATION
50    CALL PLOT(XL,YB,1)
      IX=IX-155
      IY=IY-NSPY
      WRITE(LABEL,1840)SNGL(DEGS*LLON)
      CALL DDTEXT(2,LABEL)
      WRITE(LABEL,1850)SNGL(DEGS*LLAT)
      IY=IY-32
      CALL DDTEXT(2,LABEL)
C
C NEXT THE RIGHT lat/long ANNOTATION
      CALL PLOT(XR,YB,1)
      IX=IX-130
      IY=IY-NSPY
      WRITE(LABEL,1840) SNGL(DEGS*RLON)
      CALL DDTEXT(2,LABEL)
      WRITE(LABEL,1850) SNGL(DEGS*RLAT)
      IY=IY-32
      CALL DDTEXT(2,LABEL)
C
      XMID=(XL+XR)/2.d0
      IF(PLT.EQ.2.d0) GO TO 55
C
C PUT THE HORIZONTAL TIC LABEL
      Y=YT
      IF(ALTLOW.GE.0.d0.or.plt.eq.4.d0) Y=YB
      CALL PLOT(XMID,Y,1)
C
      IF(ALTLOW.LT.0.d0.and.plt.ne.4.d0) IY=IY+80
      IF(ALTLOW.GE.0.d0.or.plt.eq.4.d0) IY=IY-95
      GO TO 60
C
55    CALL PLOT(XMID,YB,1)
      IY=IY-95
C
60    IX=IX-235
      NOTEA=1
      TMP=(THMAX-THMIN)*DEGS
      IF(TMP.GT.15.d0) NOTEA=2                    ! 18 August 2005
C
      CALL DDTEXT (LENHA(NOTEA),HNOTES(NOTEA))
C
C PUT THE VERTICAL TIC LABEL
      CALL PLOT(XL,(YB+YT)/2.d0,1)
      IOR=1
      IF(PLT.NE.2.d0) GO TO 100
C
C   HORIZONTAL PLOT  PUT Y-AXIS ANNOTATION
C
      IX=IX-125
      IY=200
      CALL DDTEXT (LENHA(3),HNOTES(3))
      GO TO 200
C
100   IX=IX-125
      IY=IY-75
      NOTEA=1
      IF(ALTLOW.GE.0.d0) NOTEA=3
!      print *, ' ALTHI = ', ALTHI
      IF(DMAX1(dABS(ALTHI),dABS(ALTLOW)).GE.1.D0)
     1 NOTEA=NOTEA+1                      ! 18 August 2005 !  2 Nov 2010
C     IF(dABS(ALTHI-ALTLOW).GE.1.d0) NOTEA=NOTEA+1
      CALL DDTEXT (LENA(NOTEA),ANOTES(NOTEA))
C
200   IOR=0
1840  FORMAT(G10.4,' Deg E.')                        ! 13 September 2005
1850  FORMAT(G10.4,' Deg N.')                        ! 13 September 2005
C
C ----------------------------------------------------------------------!-------
      END SUBROUTINE PLTANOT
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE DRAWTKS(DTICH,DTICV,XLPR,XR,YBPR,YT,PLOT)
C ----------------------------------------------------------------------!-------
C
C     HORIZONTAL PLOT PROJECTION SUPPORT ROUTINE.
C     DRAW BOUNDARY TO PLOT AREA, TICS AND TIC LABELS.
C
 
      implicit double precision (a-h,o-z)

      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVGRP,NDEVBIN
      EXTERNAL PLOT
C
      XL=XLPR
      YB=YBPR
      YMID=.5d0*(YB+YT)
      TICX=.01d0*(YT-YB)
      TICY=.01d0*(XR-XL)
C
C  changes transcribed from Cyber NHARPO:
C%      YBP=YB
C%      IF(DTICV.GT.0.d0) YBP=YMID-AINT((YMID-YB)/DTICV)*DTICV
C%      NTICX=(XR-XL)/DTICH
      if(dticv.gt.0.d0)then
         ybp=ymid-aint((ymid-yb)/dticv)*dticv
         nticx=(xr-xl)/dtich+1.5
      else
         ybp=yb
         nticx=2
      endif
C
      nticy=2
      IF(DTICV.GT.0.d0) NTICY=(YT-YBP+DTICV)/DTICV+0.5 ! added .5
C&     PRINT *,"DRAWTKS ",XLPR,XR,YBPR,YBP,YT,DTICH,DTICV,NTICX,NTICY
      IOF=0
C
C     TWO PASSES BOTTOM AND LEFT, THEN TOP AND RIGHT
      DO 100 J=1,2
      CALL PLOT(XL,YBPR,1)
      DO 30 I=1,NTICY
      Y=YBP+(I-1)*DTICV
      CALL PLOT(XL,Y,0)
      CALL PLOT(XL+TICY,Y,0)
30    CALL PLTANH(XL,Y,IOF+2,PLOT)
      CALL PLOT(XL,YT,0)
C
      CALL PLOT(XLPR,YB,1)
C
      DO 40 I=1,NTICX
      X=XLPR+(i-1)*DTICH
      CALL PLOT(X,YB,0)
      CALL PLOT(X,YB+TICX,0)
      CALL PLTANH(X,YB,IOF+1,PLOT)  
40    CALL PLOT(X,YB,1)
      CALL PLOT(XR,YB,0)
      YB=YT
      XL=XR
      TICX=-TICX
      TICY=-TICY
100   IOF=10
C
      CALL PLOT(XLPR,YMID,1)
      CALL PLOT(XR,YMID,0)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE DRAWTKS
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE PLTLB(X,PY,NCP)
C ----------------------------------------------------------------------!-------
C     PUT VERTICAL TIC ANNOTATIONS ON RAY PLOT
C     THIS IS A SPECIAL PURPOSE SUBSTITUTE FOR THE 'PLOT' ROUTINE
C     IT COMPUTES THE NEAREST ROUNDED TIC POSITIONS FOR VERTICAL LINES.
C     WHEN THE NC PARAMETER IS > 0 AN ANNOTATION IS GENERATED
C     AT THE TIC POSITION. THE ADDITIONAL NC VALUE < 0 ALLOWS FOR
C     SIMPLE PEN UP MOTION TO THE X,Y POSITION.
C
 
      implicit double precision (a-h,o-z)
      CHARACTER ANNOT*10
      COMMON/WW/dum(10),MAXW,W(1000)
      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))
      COMMON /DD/ IINT,IOR,IT,IS,IC,ICC,IX,IY
      COMMON/LABCLT/PROJCT,THMIN,THMAX,RMIN,RMAX
C
      DATA LIY/-100/
C
      NC=NCP
      GO TO 10
C
C ----------------------------------------------------------------------!-------
      ENTRY PLTLBN(X,PY,NCP)
C ----------------------------------------------------------------------!-------
      NC=0
C
10    Y=PY
C
      IF(NCP.LT.0) GO TO 200
      F=1.D0                     ! 6 JULY 2004
      RMAXACTUAL = RMIN + (RMAX-RMIN)/PFACTR         ! 18 August 2005
      IF(DMAX1(dABS(RMAXACTUAL-EARTHR),dABS(RMIN-EARTHR)).LT.1.D0)
     1 F=1.D3                    ! 18 August 2005
C     IF(DMAX1(dABS(RMAX-EARTHR),dABS(RMIN-EARTHR)).LT.1.d0) F=1.D3
C     Y=INT((Y-EARTHR)*F+0.5D0)/F+EARTHR             ! 6 JULY 2004
C     Y=INT(((Y-RMIN)/PFACTR+RMIN-EARTHR)*F+0.5D0)/F+EARTHR  ! 6 JULY 2004
C     Y=INT((Y-RMIN+(RMIN-EARTHR)*PFACTR)*F+0.5d0)/F+EARTHR   ! 6 JULY 2004
      IF(NC.EQ.0) GO TO 100
C
      V=Y
ccccc      IF(PROJCT.EQ.3.d0) V=RMIN+(Y-RMIN)/PFACTR
C.....Correction M. Jones, March,1991
ccccc      if (projct .eq. 3.0) v = earthr + (y-earthr)*pfactr
C.....new correction, May 1991
C
      if (projct.eq.3.) v = rmin+(y-rmin)/pfactr
C    &                  /((rmin/(earthr+(rmin-earthr)*pfactr)))  ! 6 JULY 2004

      IF(dABS(AINT(TICV*F)-TICV*F).GT.1.d-3) GO TO 60
C
c     1 November 2003 change:
c      WRITE(ANNOT,50) IDINT(DABS(V-EARTHR)*F)
      WRITE(ANNOT,50) 
     &     IDINT((V-EARTHR)*F*dsign(1.d0,hb) + 
     & dsign(.5d0, (V-EARTHR)*F*dsign(1.d0,hb) ))                  ! 10 Sep 2008
50    FORMAT(I5)             ! 2 JULY 2004   ! 18 August 2005
      GO TO 90
C
c    2 November 2003 change:
c60    WRITE(ANNOT,80)SNGL(DABS(V-EARTHR)*F)
60    WRITE(ANNOT,80) SNGL((V-EARTHR)*F*dsign(1.d0,hb))
C80    FORMAT(F6.2)
80    FORMAT(F7.2)                                            ! 9 Nov 2006
C
90    CALL PLOT(X,PY,1)
      CALL PLOT(X,Y,1)
C     INSURE THAT OVERLAPS OF ANNOTATIONS DO NOT OCCUR
      IF(IABS(IY-LIY).LT.80) GO TO 100
      LIY=IY
      IX=IX-100
      IOR=0
      IS=1                                                        ! 23 Jun 2009
      CALL DDTEXT(1,ANNOT)
C
100   CALL PLOT(X,Y,NC)
      RETURN
C
200   CALL PLOT(X,Y,1)
      RETURN
C ----------------------------------------------------------------------!-------
      END SUBROUTINE PLTLB
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE ARCTIC(THMIN,THMAX,HEIGHT,TICY,PLOT)
C ----------------------------------------------------------------------!-------
C     DRAW RANGE AXIS AND TICKS IN RAY TRACE PLOT. INCLUDES ANY CURVILINEAR
C     PROJECTIONS PROVIDED IN DDGRAPH.
      implicit double precision (a-h,o-z)

      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVGRP,NDEVBIN
      COMMON/WW/dum(10),MAXW,W(1000)
      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))
      COMMON /DDSCALE/ XMIN,XMAX,YMIN,YMAX,MINX,MAXX,MINY,MAXY,SCX,SCY,
     1 NSCX,NXCY,MSCX,MSCY,ISCX,ISCY
C
C         TIC=distance between horizontal tick marks in radians
C         NTIC=total number of horizontal tick marks, including end ones
C         100=minimum number of linear segments in the arc from the left 
C                to right edge of the plot
C         NLINE-2=number of linear segments in the arc between 2 ticks
C         TICN=length in radians of each linear segment of the arc
C
      NTIC=2
C%      IF(TIC.NE.0.d0) NTIC=1+(THMAX-THMIN)/TIC
      IF(TIC.NE.0.d0) NTIC=1.5+(THMAX-THMIN)/TIC
C%      NLINE=MAX0(2,100/NTIC)
      NLINE=MAX0(3,100/NTIC)
C
      TICN=TIC/(NLINE-2)
      DO 10 I=1,NTIC
      X=THMIN+(I-1)*TIC
      CALL PLOT(X,HEIGHT+TICY,1)
      DO 10 J=2,NLINE
      XJ=X+(J-2)*TICN
      IF(XJ.GT.THMAX) GO TO 15
10    CALL PLOT(XJ,HEIGHT,0)
C
15    CALL PLOT(THMAX,HEIGHT,0)
      CALL PLOT(THMAX,HEIGHT+TICY,1)
      RETURN
C ----------------------------------------------------------------------!-------
      END SUBROUTINE ARCTIC
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE DDINIT(N,TEXT)
C ----------------------------------------------------------------------!-------
C     INITIALIZES PLOTTING PROCESS(DDPLOT)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C     COMMON DECK "RAYDEV" INSERTED HERE
C     DEVICE ASSIGNED TO RAYTRC INPUT FILE
 
      implicit double precision (a-h,o-z)
 
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVGRP,NDEVBIN
      CHARACTER TEXT*(*)
C
      DATA IDD/0/
10    FORMAT(5A10)
c      print *, ' NDEVGRP = ', NDEVGRP
      IF(IDD.EQ.0) REWIND NDEVGRP
      IDD=1
c%      WRITE(NDEVGRP) 0,0,0
c%      WRITE(NDEVGRP) SNGL(M),LEN(TEXT),TEXT
      write (ndevgrp,33) 0,n,len(text)
      write (ndevgrp,34) text
33    format (i2,2i3)
34    format (a80)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE DDINIT
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE DDBP
C ----------------------------------------------------------------------!-------
C     SETS A VECTOR ORIGIN(DDPLOT)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C     COMMON DECK "RAYDEV" INSERTED HERE
C     DEVICE ASSIGNED TO RAYTRC INPUT FILE
 
      implicit double precision (a-h,o-z)
 
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVGRP,NDEVBIN
      COMMON/DD/IN,IOR,IT,IS,IC,ICC,IX,IY
      INTEGER REZFLG
      PARAMETER (REZFLG=2001)
      COMMON/DDREZ/DDHIX,DDHIY
      COMMON/KNKN/KNBP,KNVC,KNDT
      COMMON/DDLIM/MXIX,MXIY,MNIX,MNIY
C
C     USE PRE-ASSIGNED FLAG VALUE FOR IX TO DETERMINE USE OF
C     FLOATING POINT RASTER VALUES OF X AND Y USED IN DDBP AND DDVC
C
      IF(IX.EQ.REZFLG) THEN
         IX=DDHIX
         IY=DDHIY
      ELSE
         DDHIX=IX
         DDHIY=IY
      ENDIF
C
      MNIX=MIN0(MNIX,IX)
      MXIX=MAX0(MXIX,IX)
      MNIY=MIN0(MNIY,IY)
      MXIY=MAX0(MXIY,IY)
      IF(IX.LT.0.OR.IX.GT.1023.OR.IY.LT.0.OR.IY.GT.1023
     1  ) PRINT 10,'DDBP ',KNBP,IX,IY
10    FORMAT(A10,3I5)
      KNBP=KNBP+1
c%      WRITE(NDEVGRP) 1,SNGL(DDHIX),SNGL(DDHIY)
ccccc  commented out the following 2 lines.  This is now done in subroutine
ccccc  PLOT.  JAH.
ccccc      write (ndevgrp,33)1,int(1.d1*ddhix),int(1.d1*ddhiy)
ccccc33    format (i2,2i5)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE DDBP
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE DDVC
C ----------------------------------------------------------------------!-------
C     PLOTS A VECTOR(DDPLOT)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C     COMMON DECK "RAYDEV" INSERTED HERE
C     DEVICE ASSIGNED TO RAYTRC INPUT FILE
 
      implicit double precision (a-h,o-z)
 
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVGRP,NDEVBIN
      COMMON/DD/IN,IOR,IT,IS,IC,ICC,IX,IY
      INTEGER REZFLG
      PARAMETER (REZFLG=2001)
      COMMON/DDREZ/DDHIX,DDHIY
      COMMON/KNKN/KNBP,KNVC,KNDT
      COMMON/DDLIM/MXIX,MXIY,MNIX,MNIY
      integer*2 numpts, ixtmp(3000), iytmp(3000)
C
C     USE PRE-ASSIGNED FLAG VALUE FOR IX TO DETERMINE USE OF
C     FLOATING POINT RASTER VALUES OF X AND Y USED IN DDBP AND DDVC
C
      entry DDVC_ACUM (numpts, ixtmp, iytmp)
      IF(IX.EQ.REZFLG) THEN
         IX=DDHIX
         IY=DDHIY
      ELSE
         DDHIX=IX
         DDHIY=IY
      ENDIF
C
      MNIX=MIN0(MNIX,IX)
      MXIX=MAX0(MXIX,IX)
      MNIY=MIN0(MNIY,IY)
      MXIY=MAX0(MXIY,IY)
      IF(IX.LT.0.OR.IX.GT.1023.OR.IY.LT.0.OR.IY.GT.1023) then
C           PRINT 10,'DDVC ',KNVC,IX,IY
c           PRINT*,'DDVC ',KNVC,IX,IY
           return
      endif
10    FORMAT(A10,3I5)
      KNVC=KNVC+1
c%      WRITE(NDEVGRP) 2,SNGL(DDHIX),SNGL(DDHIY)
c      write(ndevgrp,33)2,int(1.d1*ddhix),int(1.d1*ddhiy)
c33    format (i2/2i5)
      numpts = numpts + 1

      ixtmp(numpts) = int(1.d1*ddhix)
      iytmp(numpts) = int(1.d1*ddhiy)

C ----------------------------------------------------------------------!-------
      END SUBROUTINE DDVC
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE DDTEXT(N,TEXT)
C ----------------------------------------------------------------------!-------
C     WRITES A CHARACTER ARRAY PACKED A10(DDPLOT)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C     COMMON DECK "RAYDEV" INSERTED HERE
C     DEVICE ASSIGNED TO RAYTRC INPUT FILE
 
      implicit double precision (a-h,o-z)
 
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVGRP,NDEVBIN
      CHARACTER TEXT*(*)
      COMMON/DD/IN,IOR,IT,IS,IC,ICC,IX,IY
      COMMON/KNKN/KNBP,KNVC,KNDT

c      print*,'text = ',text
c      print*,'ix, iy = ',ix,iy

100   FORMAT(A10,2I5,I2,1X,8A10)
      KNDT=KNDT+1
c%      WRITE(NDEVGRP) 3,IX,IY
      write (ndevgrp,33)3,ix,iy
33    format (i2,2i4)
      LN=MIN0(N*10,LEN(TEXT))
      IF(LN.EQ.N*10) THEN
c%         WRITE(NDEVGRP) IOR,N,N*10,(TEXT(I:I),I=1,LN)
C      write (ndevgrp,34)ior,n*10,(text(i:i),i=1,ln)
      write (ndevgrp,34)ior,n*10,in,it,is,(text(i:i),i=1,ln)      ! 22 Jun 2009
c34    format (2i3/80a1)
34    format (5i3/80a1)                                           ! 22 Jun 2009
      ELSE
C%         WRITE(NDEVGRP)IOR,N,N*10,(TEXT(I:I),I=1,LN)
c%     1   ,(' ',I=LN+1,N*10)
c      write (ndevgrp,35)ior,n*10,(text(i:i),i=1,ln)
c     1     ,(' ',i=ln+1,n*10)
      write (ndevgrp,35)ior,n*10,in,it,is,(text(i:i),i=1,ln) 
     1     ,(' ',i=ln+1,n*10)                                     ! 22 Jun 2009
c35    format (2i3/80a1/80a1)
35    format (5i3/80a1/80a1)                                      ! 22 Jun 2009
      ENDIF
C ----------------------------------------------------------------------!-------
      END SUBROUTINE DDTEXT
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE DDTAB
C ----------------------------------------------------------------------!-------
C     INITIALIZES TABULAR PLOTTING(DDPLOT)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C     COMMON DECK "RAYDEV" INSERTED HERE
C     DEVICE ASSIGNED TO RAYTRC INPUT FILE
 
      implicit double precision (a-h,o-z)
 
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVGRP,NDEVBIN
C ----------------------------------------------------------------------!-------
      END SUBROUTINE DDTAB
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE DDFR
C ----------------------------------------------------------------------!-------
C     ADVANCE ONE PLOTTING FRAME(DDPLOT)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C     COMMON DECK "RAYDEV" INSERTED HERE
C     DEVICE ASSIGNED TO RAYTRC INPUT FILE
 
      implicit double precision (a-h,o-z)
 
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVGRP,NDEVBIN
10    FORMAT(A10)
c%      WRITE(NDEVGRP) -2,0,0
      write (ndevgrp,33)-2,0,0
33    format (3i2)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE DDFR
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE DDEND
C ----------------------------------------------------------------------!-------
C     EMPTIES PLOT BUFFER AND RELEASES PLOTTING COMMAND FILE(DDPLOT)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C     COMMON DECK "RAYDEV" INSERTED HERE
C     DEVICE ASSIGNED TO RAYTRC INPUT FILE
 
      implicit double precision (a-h,o-z)
 
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVGRP,NDEVBIN
      COMMON/KNKN/KNBP,KNVC,KNDT
      COMMON/DDLIM/MXIX,MXIY,MNIX,MNIY
10    FORMAT(3A10,5I5)
c%      WRITE(NDEVGRP) -1,0,0
      write (ndevgrp,33)-1,0,0
33    format (3i2)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE DDEND
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE DASH
C ----------------------------------------------------------------------!-------
C     ACTIVATE DASHED LINE CONNECTIONS(DISSPLA)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C     COMMON DECK "RAYDEV" INSERTED HERE
C     DEVICE ASSIGNED TO RAYTRC INPUT FILE
 
      implicit double precision (a-h,o-z)
 
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVGRP,NDEVBIN
c%      WRITE(NDEVGRP) 37,0,0
      write (ndevgrp,33)37,0,0
33    format (i2/2i2)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE DASH
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE RESET(S)
C ----------------------------------------------------------------------!-------
C     RESETS AN OPTION TO ITS DEFAULT VALUE(DISSPLA)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C     COMMON DECK "RAYDEV" INSERTED HERE
C     DEVICE ASSIGNED TO RAYTRC INPUT FILE
 
      implicit double precision (a-h,o-z)
 
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVGRP,NDEVBIN
      CHARACTER S*10
c%      WRITE(NDEVGRP) 38,0,0
c%      WRITE(NDEVGRP) S
      write (ndevgrp,33)38,0,0
33    format (i2/2i2)
      write (ndevgrp,34)s
34    format (a10)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE RESET
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE HEIGHT(H)
C ----------------------------------------------------------------------!-------
C     SETS REFERENCE CHARACTER HEIGHT IN INCHES(DISSPLA)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C     COMMON DECK "RAYDEV" INSERTED HERE
C     DEVICE ASSIGNED TO RAYTRC INPUT FILE
 
      implicit double precision (a-h,o-z)
 
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVGRP,NDEVBIN
c%      WRITE(NDEVGRP) 13,SNGL(H),0
      write (ndevgrp,33)13,int(1.d1*h),0
33    format(i2/i6,i2)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE HEIGHT
C ----------------------------------------------------------------------!-------
 
 
 
 
 
C ----------------------------------------------------------------------!-------
      SUBROUTINE SCMPLX
C ----------------------------------------------------------------------!-------
C     SPECIFY USE OF SIMPLEX CHARACTER SET(DISSPLA)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C     COMMON DECK "RAYDEV" INSERTED HERE
C     DEVICE ASSIGNED TO RAYTRC INPUT FILE
 
      implicit double precision (a-h,o-z)
 
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVGRP,NDEVBIN
c%      WRITE(NDEVGRP) 10,0,0
      write (ndevgrp,33)10,0,0
33    format (i2/2i2)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE SCMPLX
C ----------------------------------------------------------------------!-------



