C  contour1.for 
C ----------------------------------------------------------------------!-------
Contains CONHEAD, DFCNST, ENDPLT
C ----------------------------------------------------------------------!-------
C 10 Nov 2009 - Added:     double precision d1mach
C 23 Jun 2009 - Changed the default character size for DDTEXT calls to 1.
C  4 May 2009 - replaced REAL*8 with DOUBLE PRECISION
C 26 Aug 2008 - Replaced using rmach() with direct calls to 
C                I1mach(), R1mach(), or D1mach()
C 15 Mar 2008 - Corrected length in common block /RIN/
C 13 Mar 2008 - Corrected length in common block /MM/
C 13 Mar 2008 - Correction to common block /HDR/
C 13 Mar 2008 - Corrected length in common block /PCONST/
C 13 Mar 2008 - Corrected length in common block /RIN/
C  1 Nov 2006 - Added printing of date and time
C 25 Mar 2006 - /CRMACH/RMACH(5) --> (9)
C 24 Mar 2006 - Moved DDCON, PLOTXY, MX1ALF, MX2ALF, DDSC, DDST, FULANN, PLOTHB,
C               PLOTLB to S8
C 24 Mar 2006 - Moved COPYVL, CROSSP, CTRIM, SETUP, IZPZ, ZPZ, GCIRCLE, MATRIXM,
C               NORMV to S7
C 24 Mar 2006 - Moved ARCTIC to S6
C 24 Mar 2006 - Moved GET to S5
C 16 Mar 2006 - Added kz2a and kzb to /RIN/
C  3 Mar 2006 - Removed outflag from calls to DDVC_ACUM for compatibility with
C               PCHARPO
C  2 Mar 2006 - Copied SUBROUTINE ENDPLT from pcplot4.for
C  2 Mar 2006 - Using local versions of DDVC, MX1ALF, and MX2ALF again
C  2 Mar 2006 - Added an argument to SETW, and made it a function
C  2 Mar 2006 - Added an argument to SETGET
C  2 Mar 2006 - Using most of the routines from S5 and S6 in pcharpo
C ----------------------------------------------------------------------!-------
C Now contains ARCTIC, CONHEAD, COPYVL, CROSSP, CTRIM, DDCON, PLOTXY, SETUP, 
C IZPZ, ZPZ, DDVC, MX1ALF, MX2ALF DDSC, DDST, DFCNST, FULANN, GCIRCLE, GET, 
C MATRIXM, NORMV, PLOTHB, PLOTLB, ENDPLT
C ----------------------------------------------------------------------!-------
C  23 June 2005 - Fixed vertical ticks plotting error (I3-->I4)
C               - Range at Sea Level and graph overlap fixed
C  19 April 2005 - changing ALOG to  LOG
C ----------------------------------------------------------------------!-------
      FUNCTION ALCOSH_test(X)
C ----------------------------------------------------------------------!-------
      implicit double precision (a-h,o-z)

C     COMPUTE LOG(COSH(X)) AND USE LARGE ARGUMENT APPROXIMATION
C     WHEN POSSIBLE.
      DATA ALOG2 /.6931471806/
C
      IF(ABS(X).GT.50.0) GO TO 10
      EX=EXP(X)
C      ALCOSH=ALOG((EX+1.0/EX)*0.5) ! 19 April 2005
      ALCOSH=LOG((EX+1.0/EX)*0.5) ! 19 April 2005
      RETURN
10    ALCOSH=ABS(X)-ALOG2
C ----------------------------------------------------------------------!-------
      END FUNCTION ALCOSH_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE ARCTIC_test(THMIN,THMAX,HEIGHT,TICY,PLOT)
C ----------------------------------------------------------------------!-------
C     DRAW RANGE AXIS IN RAY TRACE PLOT. INCLUDES ANY CURVILINEAR
C     PROJECTIONS PROVIDED IN DDGRAPH.

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

C     COMMON DECK "WWR" INSERTED HERE
      PARAMETER (NWARSZ=1000)
      COMMON/WW/dum(10),MAXW,W(NWARSZ)
      EQUIVALENCE (TIC,W(87)),(HB,W(88)),(HT,W(89)),(TICV,W(96))

C.....The following statement makes the DDSCALE common size compatible
C     with later routines which have QQQ(8) as the first 8 elements.

C      real xmin,xmax,ymin,ymax,scx,scy
      DOUBLE PRECISION xmin,xmax,ymin,ymax,scx,scy                 ! 27 Mar 2006
      COMMON /DDSCALE/ XMIN,XMAX,YMIN,YMAX,MINX,MAXX,MINY,MAXY,SCX,SCY,
     1                 NSCX,NXCY,MSCX,MSCY,ISCX,ISCY
C
      NTIC=2
      IF(TIC.NE.0.) NTIC = 1+(THMAX-THMIN)/TIC
      NLINE=MAX0(2,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_test
C ----------------------------------------------------------------------!-------
      SUBROUTINE SETTRC_test
C ----------------------------------------------------------------------!-------
C     INITIALIZE /TRAC/ LABELED COMMON

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

C     COMMON DECK "TRAC" INSERTED HERE
      LOGICAL GROUND,SURF,PERIGE,THERE,MINDIS,NEWRAY
      COMMON /TRAC/ GROUND,SURF,PERIGE,THERE,MINDIS,NEWRAY,SMT,OSMT
      COMMON/TRAC/ROLD(20),DROLD(20),TOLD,ZDOT,D2Z,RAD,RAD1
      GROUND=.FALSE.
      SURF=.FALSE.
C ----------------------------------------------------------------------!-------
      END SUBROUTINE SETTRC_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE CONHEAD(CL1,CL2,IOFF,NMD,MODEL1,MODEL2,MODEL3
     1  ,MODEL4,labelcon,lencon,ocean)
C ----------------------------------------------------------------------!-------

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

C
C.....Added LABELCON which contains the contour max,min and interval

      CHARACTER*(*) CL1,CL2
      CHARACTER*80 labelcon
      CHARACTER*50 CT1,CT2
      INTEGER CTRIM
ccccc      INTEGER MODEL1(4),MODEL2(4),MODEL3(4),MODEL4(4)
      double precision MODEL1(4),MODEL2(4),MODEL3(4),MODEL4(4)
C
C     PUT HEADERS ON CONTOUR PLOTS.
C
C     COMMON DECK "WWR" INSERTED HERE
      character*80 id
      common /ident/ id

C.....Set true when at or below sea level.  Prevents use of MODEL3 which
C     is the molecular weight model which only applies to atmosphere contours.

      logical ocean

      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 "HDR" INSERTED HERE
      CHARACTER*10 INITID*80,DAT,TOD
      COMMON/HDR/SEC,stsec                            !Rev 7/13/90 ! 13 Mar 2008
      COMMON/HDRC/INITID,DAT,TOD
      COMMON/DD/IN,IOR,IT,IS,IC,ICC,IX,IY
      CHARACTER*80 LABEL
C
      IX=0
      IOR=0
      IT=0
      IS=2
      IS=1                                                        ! 23 Jun 2009
      IY=IOFF
      IF(IOFF.NE.0) GO TO 10
      IY=1023
      CT1=CL1
      CT2=CL2
      L1=CTRIM(CT1)
      L2=CTRIM(CT2)
C.....Set length to 5, then DDTEXT will always have enough characters
C     5 --> 50 in DDTEXT.  Used to be (L1+L2)/2 but this leads to
C     truncation!!

      CALL DDTEXT(5 , CT1(:L1)//CT2)
CCCCC      IX=1090
CCCCC      CALL DDTEXT (2,DAT)  ! DAT is the DATE from SYSDAT
      IX=0
      DTIC=TIC*EARTHR
C
10    KLM=3
      IF(NMD.GE.3) KLM=4

C.....51 will cause the ID to be on line 2 of the screen.

      iy = iy-51
      WRITE(LABEL,1000) ID
      CALL DDTEXT (8,LABEL)

C.....Put LABELCON (contour max,min,interval) on next line.
      iy = iy-34

      call ddtext (lencon/10 +1,labelcon)

C.....Put "MODELS" on the same line near the end of the line.
      ix=1050
C
C     NMD is number of models = 4 for sound speed contours;
C                             = 2 for wind/current (and components);
C                             = 1 for terrain contours.
C     There are probably more compact ways of doing the following, but
C     this way is easy to read and understand.

C     34 puts each model on a different line. 51 skips a line.

      write (label,1000) 'MODELS USED:'
      call ddtext (8,LABEL)
      iy=iy-51
      write (label,1700) model1(1),model1(2)
      CALL DDTEXT (8,LABEL)
      write (label,1700) model1(3),model1(4)
      iy = iy-34
      CALL DDTEXT (8,LABEL)
C
C.....RETURN if only 1 model i.e. for terrain contours.

      if (nmd .eq. 1) then 
         iy = iy-34                !  1 Nov 2006
         CALL DDTEXT (2,DAT)       !  1 Nov 2006
         iy = iy-34                !  1 Nov 2006
         CALL DDTEXT (2,TOD)       !  1 Nov 2006
         RETURN
      endif

      write (label,1700) model2(1),model2(2)
      iy = iy-34
      CALL DDTEXT (8,LABEL)
      write (label,1700) model2(3),model2(4)
      iy = iy-34
      CALL DDTEXT (8,LABEL)

C.....RETURN if only doing 2 models i.e. wind/current contours.

      if (nmd .eq. 2) then
         iy = iy-34                !  1 Nov 2006
         CALL DDTEXT (2,DAT)       !  1 Nov 2006
         iy = iy-34                !  1 Nov 2006
         CALL DDTEXT (2,TOD)       !  1 Nov 2006
         RETURN
      endif

C.....Only write the molec.wt. model if doing atmos. contours.
      if (.not. ocean) then
           write (label,1700) model3(1),model3(2)
           iy = iy-34
           CALL DDTEXT (8,LABEL)
           write (label,1700) model3(3),model3(4)
           iy = iy-34
           CALL DDTEXT (8,LABEL)
      endif
      write (label,1700) model4(1),model4(2)
      iy = iy-34
      CALL DDTEXT (8,LABEL)
      write (label,1700) model4(3),model4(4)
      iy = iy-34
      CALL DDTEXT (8,LABEL)
      iy = iy-34                !  1 Nov 2006
      CALL DDTEXT (2,DAT)       !  1 Nov 2006
      iy = iy-34                !  1 Nov 2006
      CALL DDTEXT (2,TOD)       !  1 Nov 2006

      RETURN

1000  FORMAT (A)
1550  FORMAT('HEIGHT=',F8.2,' KM.')
1600  FORMAT(4(2(A8,F5.1,1X),2X))  !changed 10 to 8
1700  FORMAT((A8,F5.1,1X),2X)  !testing
C ----------------------------------------------------------------------!-------
      END SUBROUTINE CONHEAD
C ----------------------------------------------------------------------!-------

C ----------------------------------------------------------------------!-------
      LOGICAL FUNCTION UCON_test(JC1,U,CONV)
C ----------------------------------------------------------------------!-------

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

      LOGICAL SETUCON
C     PROVIDES KEYWORD UNITS CONVERSION FOR W-ARRAY INPUT.
C     UNITS SPECIFICATION MUST BE IN THE FORM 'DV UN' WHERE DV IS THE
C     TYPE OF VARIABLE(SUCH AS AN FOR ANGLE) AND UN IS THE UNITS CHOICE
C     SUCH AS RD FOR RADIANS). RETURN VALUE IS THE CONVERSION FACTOR.
C     COMMON DECK "CUCON" INSERTED HERE
      COMMON/UCONV/CNVV(5,4)
      CHARACTER PCV*3,CNVC*2
      COMMON/UCONC/PCV(5),CNVC(5,4)
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 "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))
      CHARACTER U*(*),PU*3,PV*2
C
      DATA NPV,NPU/5,4/
      UCON=.FALSE.
      CONV=1.0
C
      READ(U,100) PU,PV
100   FORMAT(A,A)
C
      DO 2010 J=1,NPV
2010     IF(PU.EQ.PCV(J)) GO TO 2015
      JC1=4
      RETURN
2015  JC1=J
      DO 2020 K=1,NPU
2020     IF(PV.EQ.CNVC(J,K)) GO TO 2025
      JC1=4
      RETURN
2025  UCON=.TRUE.
      CONV=CNVV(JC1,K)
      IF(CONV.EQ.-1.0) CONV=1.0/EARTHR
      RETURN
C
C     INITIAL CONVERSION CONSTANTS
C ----------------------------------------------------------------------!-------
      ENTRY SETUCON_test !!!!!(JC1,U,CONV)
C ----------------------------------------------------------------------!-------
      SETUCON=.TRUE.
C
      CNVV(1,2) = RAD
C     USE TAG -1 FOR DYNAMIC USE OF EARTHR
      CNVV(1,3) = -1.0
      CNVV(2,2) = 1.0E-3
      CNVV(2,3) = 3.048006096E-4
      CNVV(2,4) = 1.852
      CNVV(3,2) = PIT2
      CNVV(3,3) = PIT2*1.0E3
      CNVV(3,4) = -PIT2
      CNVV(4,1) = 1.0/4.3429448
C ----------------------------------------------------------------------!-------
      END FUNCTION UCON_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE DDINIT_test(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,ndevtxt,NDEVBIN
      CHARACTER TEXT*(*)
C
      DATA IDD/0/
10    FORMAT(5A10)
      IF(IDD.EQ.0) REWIND ndevtxt
      IDD=1
c%      WRITE(NDEVGRP) 0,0,0
c%      WRITE(NDEVGRP) SNGL(M),LEN(TEXT),TEXT
      write (ndevtxt,33) 0,n,len(text)
      write (ndevtxt,34) text
33    format (i2,2i3)
34    format (a80)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE DDINIT_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE DDBP_test
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,ndevtxt,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 *,'DDBP knbp,ix,iy,ddhix,ddhiy',KNBP,IX,IY,ddhix,ddhiy
ccccc10    FORMAT(A10,3I5)
      KNBP=KNBP+1
      write (ndevtxt,33)1,int(1.d1*ddhix),int(1.d1*ddhiy)
33    format (i2,2i5)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE DDBP_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE DDVC_test
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,ndevtxt,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(2000), iytmp(2000)

C.....Set OUTFLAG to true when a plotting coordinate is out of bounds
C     This can happen if the DINP file contains a large expansion factor
C     or a large geographical area.

      logical outflag
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_test (numpts, ixtmp, iytmp, outflag)
      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  ) outflag = .true.  !!!!! PRINT *,'DDVC ',KNVC,IX,IY
ccccc10    FORMAT(A10,3I5)
      KNVC=KNVC+1
c%      WRITE(NDEVGRP) 2,SNGL(DDHIX),SNGL(DDHIY)
c      write(ndevtxt,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_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE DDTEXT_test(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,ndevtxt,NDEVBIN
      CHARACTER TEXT*(*)
      COMMON/DD/IN,IOR,IT,IS,IC,ICC,IX,IY
      COMMON/KNKN/KNBP,KNVC,KNDT
100   FORMAT(A10,2I5,I2,1X,8A10)
      KNDT=KNDT+1
c%      WRITE(NDEVGRP) 3,IX,IY
      write (ndevtxt,33)3,ix,iy
33    format (i2,2i4)
      LN=MIN0(N*10,LEN(TEXT))
      IF(LN.EQ.N*10) THEN
           write (ndevtxt,34)ior,n*10,(text(i:i),i=1,len(text))
34         format (2i3/80a1)
      ELSE
           write (ndevtxt,35)ior,n*10,(text(i:i),i=1,len(text))
     1     ,(' ',i=ln+1,n*10)
35         format (2i3/80a1/80a1)
      ENDIF
C ----------------------------------------------------------------------!-------
      END SUBROUTINE DDTEXT_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE DDFR_test
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,ndevtxt,NDEVBIN
10    FORMAT(A10)
c%      WRITE(NDEVGRP) -2,0,0
      write (ndevtxt,33)-2
33    format (i2)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE DDFR_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE DDEND_test
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,ndevtxt,NDEVBIN
      COMMON/KNKN/KNBP,KNVC,KNDT
      COMMON/DDLIM/MXIX,MXIY,MNIX,MNIY
10    FORMAT(3A10,5I5)
c%      WRITE(NDEVGRP) -1,0,0
      write (ndevtxt,33)-1
33    format (i2)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE DDEND_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE CLEAR_test(A,N)
C ----------------------------------------------------------------------!-------
C     SET N ELEMENTS OF ARRAY A TO ZERO
      DOUBLE PRECISION A(N)
      IF(N.LE.0) RETURN
      DO    10 I=1,N
10    A(I)=0.0
      RETURN
      END SUBROUTINE CLEAR_test
C----------------------------------------------------------------------------
      SUBROUTINE MX1ALF_test(T1,T2)
C     SPECIFY USE OF ALTERNATE CHARACTER SET NUMBER 1(DISSPLA)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVTXT,NDEVBIN
      CHARACTER*10 T1,T2

      WRITE(NDEVTXT,100) 11, T1, T2
100   FORMAT(I2,TR1,A,1X,A1)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE MX1ALF_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE MX2ALF_test(T1,T2)
C ----------------------------------------------------------------------!-------
C     SPECIFY USE OF ALTERNATE CHARACTER SET NUMBER 2(DISSPLA)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVTXT,NDEVBIN
      CHARACTER*10 T1,T2

      WRITE(NDEVTXT,200) 12,T1,T2
200   FORMAT(I2,TR1,A,1X,A1)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE MX2ALF_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE OPNREP_test(IUN,FNAME)
C ----------------------------------------------------------------------!-------
C     THIS OPEN OPERATION ALLOWS FOR AN EXISTING VERSION OF
C     A FILE. IF THE FILE EXISTS IT IS OVERWRITTEN.
C     THE LOGIC USED IS HOPEFULLY MACHINE INDEPENDENT.
      CHARACTER*(*) FNAME
      CALL ZAPFIL(IUN,FNAME)
      OPEN(IUN,FILE=FNAME,STATUS='NEW')
      REWIND IUN
      RETURN
      ENTRY OPNURP_test(IUN,FNAME)
      CALL ZAPFIL(IUN,FNAME)
      OPEN(IUN,FILE=FNAME,STATUS='NEW',FORM='FORMATTED')
      REWIND IUN
C ----------------------------------------------------------------------!-------
      END SUBROUTINE OPNREP_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE ZAPFIL_test(IUN,FNAME)
C ----------------------------------------------------------------------!-------
C     TEST FOR EXISTENCE OF FILE AND DELETE
      CHARACTER FNAME*(*)
      LOGICAL EX
      INQUIRE(FILE=FNAME,EXIST=EX)
      IF(EX) THEN
         OPEN(UNIT=IUN,FILE=FNAME,STATUS='OLD')
         CLOSE(UNIT=IUN,STATUS='DELETE')
      ENDIF
C ----------------------------------------------------------------------!-------
      END SUBROUTINE ZAPFIL_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE HEIGHT_test(H)
C ----------------------------------------------------------------------!-------
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,NDEVTXT,NDEVBIN
C
      WRITE(NDEVTXT,100) 13,H
100   FORMAT(I2,F4.2)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE HEIGHT_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      FUNCTION ITEST_test(I)
C ----------------------------------------------------------------------!-------
C     USED TO PASS INTEGER VALUES THROUGH FOR VARIABLES TYPED REAL
C     (AS IN MIXED REAL/INTEGER ARRAYS)
      ITEST=I
C ----------------------------------------------------------------------!-------
      END FUNCTION ITEST_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE GTUNIT_test(LINE,PU,NFIELD,NVAR, LN)
C ----------------------------------------------------------------------!-------
C     GTUNIT IS USED TO EXTRACT UNIT CONVERSION SPECIFIERS FROM TABULAR
C     DATA INPUT.
C     CONVERSION SPECIFICATIONS ARE TAKEN FROM 'LINE' INPUT STRING.
C     A FLOATING FORMAT FALLING WITHIN SUCCESSIVE FIELDS OF
C     LENGTH 'NFIELD' IS PROVIDED FOR.
C     OUTPUT IS TO UNIT SPECIFIER ARRAY 'PU' FOR A MAXIMUM OF 'NVAR'
C     FIELDS. FOR A SUCCESS/FAIL RETURN VALUE, 'LN' GIVES THE NUMBER
C     OF NON-BLANK CHARACTERS USEFUL FOR UNIT DECODING, ZERO IMPLIES
C     NO USEFUL UNIT INFORMATION WAS FOUND.
C
      PARAMETER (MAXLN=130)
      CHARACTER*(*) LINE,PU(NVAR),TMP*(MAXLN),TMP1*(MAXLN)
      INTEGER STRIM 
C
      LN=STRIM(LINE)
      IF(LN.LT.1) THEN
         DO 5 I=1,NVAR
5           PU(I)=' '
         RETURN
      ENDIF
C
      TMP=' '
      CALL SFILTR(LINE,TMP,' 0123456789+-.E')
      IF(STRIM(TMP).LT.1) RETURN
C     SIGNIFY WE CONSUMED THIS LINE
      LN=0
C
      TMP1=LINE
C     PLACE INTER-SPECIFIER DELIMITORS
      DO 10 I=NFIELD,NFIELD*NVAR,NFIELD
         IF(TMP1(I:I).NE.' ') THEN
            IF(TMP1(I+1:I+1).NE.' ') THEN
C     IF NO ROOM FOR A BLANK, ITS AN ERROR
               PRINT*,'Format error in units specifier of tabular data.'
               STOP
            ELSE
               TMP1(I+1:I+1)='#'
            ENDIF
         ELSE
            TMP1(I:I)='#'
         ENDIF
10    CONTINUE
C
C     NOW SQUEEZE OUT THE BLANKS
      CALL SFILTR(TMP1,TMP,' ')
C     HOPEFULLY SOMETHING LEFT
C
      NL=STRIM(TMP) 
      ILIN=1
      DO 20 I=1,NVAR
C     CHECK FOR EMPTY CONVERSIONS
         IF(TMP(ILIN:ILIN).EQ.'#') THEN 
            ILIN=ILIN+1
            PU(I)=' '
            GO TO 20
         ENDIF
C     GET NEXT UNIT TYPE
         PU(I)(1:2)=TMP(ILIN:ILIN+1)
C     GET NEXT PHYSICAL UNIT(BLANKS HAVE BEEN REMOVED)
C     SHORT PHRASE IF A BLANK WAS REMOVED
         IF(TMP(ILIN+3:ILIN+3).NE.'#') THEN
            IF(TMP(ILIN+4:ILIN+4).NE.'#') THEN
C     IF INCORRECT GROUPING OF LETTERS, ITS AN ERROR
               PRINT*,'Format error in units specifier of tabular data.'
               STOP
            ELSE
C     ADD TWO LETTER UNIT
               PU(I)(3:5)=' '//TMP(ILIN+2:ILIN+3) 
               ILIN=ILIN+5
            ENDIF
         ELSE
C     ADD ONE LETTER UNIT
            PU(I)(3:5)='  '//TMP(ILIN+2:ILIN+2)
            ILIN=ILIN+4
         ENDIF
20    CONTINUE
C
C     SHOULD HAVE USED UP ALL THE TEXT BY NOW
      IF(ILIN.LE.NL) then
           PRINT*,'Format error in units specifier of tabular data.'
           STOP
      endif
C ----------------------------------------------------------------------!-------
      END SUBROUTINE GTUNIT_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE DFCNST(DRMACH,MAX)
C ----------------------------------------------------------------------!-------
      implicit double precision (a-h,o-z)

      DOUBLE PRECISION DRMACH(MAX)
C     RETURN MAX MACHINE CONSTANTS(OR THE NUMBER AVAILABLE)
C     IN ARRAY DRMACH.

C     THIS MODULE PROVIDES CONSTANTS WHICH ARE EXPLICITLY DEPENDENT
C     ON MACHINE ARCHITECTURE AND SHOULD BE EXAMINED WHEN MAKING ANY
C     MIGRATION OF THE RAY TRACING ROUTINES.
C
C
C     DOUBLE PRECISION RMACH(5) ! 25 Mar 2006
      DOUBLE PRECISION RMACH(9) ! 25 Mar 2006
C
C     SINGLE PRECISION MACHINE CONSTANTS
C      (SEE DIGITAL SIGNAL PROCESSING, IEEE PRESS 1979 P S-7)
C
C     THE CONSTANTS ARE DERIVED FROM THE FOLLOWING
C     FORM FOR FLOATING POINT NUMBERS:
C
C        SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
C     FOR MOST MACHINES THE BASE B=2.
C     FOR THE CYBER 60-BIT MACHINES
C        T=48, EMIN=-974 AND EMAX=1070.
C     FOR THE PDP-11 AND VAX-11 MACHINES
C        T=24, EMIN=-127 AND EMAX=127
C
C     RMACH(1)  SMALLEST POSITIVE MAGNITUDE = B**(EMIN-1)
C     RMACH(2)  LARGEST MAGNITUDE           = B**EMAX*(1-B**(-T))
C     RMACH(3)  SMALLEST RELATIVE SPACING   = B**(-T)
C     RMACH(4)  LARGEST RELATIVE SPACING    = B**(1-T)
C     RMACH(5)                              = LOG10(B=2)
C
C     CONSTANTS HERE ARE FOR CDC 6000/7000/CYBER SERIES COMPUTERS
C     PLEASE SUBSTITUTE FOR OTHER MACHINES
C
C
C      INTEGER SMALL(2)
C      INTEGER LARGE(2)
C      INTEGER RIGHT(2)
C      INTEGER DIVER(2)
C      INTEGER LOG10(2)
CC
C      EQUIVALENCE (RMACH(1),SMALL(1))
C      EQUIVALENCE (RMACH(2),LARGE(1))
C      EQUIVALENCE (RMACH(3),RIGHT(1))
C      EQUIVALENCE (RMACH(4),DIVER(1))
C      EQUIVALENCE (RMACH(5),LOG10(1))
C
C     MACHINE CONSTANTS FOR CYBER 170/180 COMPUTERS
C
ccccc      DATA RMACH(1) / O"00014000000000000000" /
ccccc      DATA RMACH(2) / O"37767777777777777777" /
ccccc      DATA RMACH(3) / O"16404000000000000000" /
ccccc      DATA RMACH(4) / O"16414000000000000000" /
ccccc      DATA RMACH(5) / O"17164642023241175720" /
C
C***REFERENCES  FOX, P.A., HALL, A.D., SCHRYER, N.L, *FRAMEWORK FOR
C                 A PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHE-
C                 MATICAL SOFTWARE, VOL. 4, NO. 2, JUNE 1978,
C                 PP. 177-188.
C***ROUTINES CALLED  XERROR
C***END PROLOGUE  R1MACH
C     MACHINE CONSTANTS FOR VAX 11/780
C     (EXPRESSED IN INTEGER AND HEXADECIMAL)
C    ***THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSYEMS***
C    *** THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS***
C
C     DATA SMALL(1), SMALL(2) /        128,           0 /
C     DATA LARGE(1), LARGE(2) /     -32769,          -1 /
C     DATA RIGHT(1), RIGHT(2) /       9344,           0 /
C     DATA DIVER(1), DIVER(2) /       9472,           0 /
C     DATA LOG10(1), LOG10(2) /  546979738,  -805796613 /
C
C     DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 /
C     DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF /
C     DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 /
C     DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 /
C     DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB /
C
C   MACHINE CONSTANTS FOR VAX 11/780 (G-FLOATING)
C     (EXPRESSED IN INTEGER AND HEXADECIMAL)
C    ***THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSYEMS***
C    *** THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS***
C
C     DATA SMALL(1), SMALL(2) /         16,           0 /
C     DATA LARGE(1), LARGE(2) /     -32769,          -1 /
C     DATA RIGHT(1), RIGHT(2) /      15552,           0 /
C     DATA DIVER(1), DIVER(2) /      15568,           0 /
C     DATA LOG10(1), LOG10(2) /  1142112243, 2046775455 /
C
C     DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 /
C     DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF /
C     DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 /
C     DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 /
C     DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F /
C
C     MACHINE CONSTANTS FOR THE CRAY 1
C
C     DATA SMALL(1) / 201354000000000000000B /
C     DATA SMALL(2) / 000000000000000000000B /
C
C     DATA LARGE(1) / 577767777777777777777B /
C     DATA LARGE(2) / 000007777777777777774B /
C
C     DATA RIGHT(1) / 376434000000000000000B /
C     DATA RIGHT(2) / 000000000000000000000B /
C
C     DATA DIVER(1) / 376444000000000000000B /
C     DATA DIVER(2) / 000000000000000000000B /
C
C     DATA LOG10(1) / 377774642023241175717B /
C     DATA LOG10(2) / 000007571421742254654B /
C
ccccc      CALL RMOVE(DRMACH,RMACH,MIN0(MAX,5))
C
C ----------------------------------------------------------------------!-------
      END SUBROUTINE DFCNST
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE DRAWTKS_test(DTICH,DTICV,XLPR,XR,YBPR,YT,PLOT)
C ----------------------------------------------------------------------!-------
C
C     HORIZONTAL PLOT PROJECTION (W(81) = 2) SUPPORT ROUTINE.
C     DRAW BOUNDARY of PLOT AREA, ticks AND tick LABELS.
C
      implicit double precision (a-h,o-z)

      EXTERNAL PLOT
C
      XL=XLPR
      YB=YBPR
      YMID=.5*(YB+YT)
      TICX=.01*(YT-YB)
      TICY=.01*(XR-XL)
      IF(DTICV.GT.0.) THEN
         YBP=YMID-dINT((YMID-YB)/DTICV)*DTICV
         NTICX=(XR-XL)/DTICH
      ELSE
         YBP=YB
         NTICX=1
      ENDIF
      NTICY=1
      IF(DTICV.GT.0.) then
           NTICY = (YT-YBP+DTICV)/DTICV
      endif
C&     PRINT *,"DRAWTKS ",XLPR,XR,YBPR,YBP,YT,DTICH,DTICV,NTICX,NTICY
      IOF=0
C
C     TWO PASSES: BOTTOM AND LEFT axes THEN TOP AND RIGHT axes
C
      DO 100 J=1,2

C..........Moveto the lower left corner of boundary.

           CALL PLOT(XL,YBPR,1)

C..........Make the linetos to form the boundary and lineto to form the
C          tick mark.  Then label the tick mark via PLTANH.

           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)

C..........Make the vertical line from the LL corner to UL corner.
           CALL PLOT(XL,yT,0)  !!!!! was YT
C
C..........Moveto the LL (or UR when J=2) corner again.
           CALL PLOT(XLPR,YB,1)
C
           DO 40 I=1,NTICX
                X=XLPR+I*DTICH
                CALL PLOT(X,YB,0)
                CALL PLOT(X,YB+TICX,0)
                CALL PLTANH(X,YB,IOF+1,PLOT)  !!!!! was YB
40              CALL PLOT(X,YB,1)

C..........Make the horizontal line to close the distance from the last
C          tick mark to the right boundary.

                CALL PLOT(XR,YB,0)

C..........Now change things to do the right Y axis and the top X axis.

           YB=YT
           XL=XR
           TICX=-TICX
           TICY=-TICY
100        IOF=10
C
C.....Make the horizontal line across the middle of the plot.

      CALL PLOT(XLPR,YMID,1)
      CALL PLOT(XR,YMID,0)
      RETURN
C ----------------------------------------------------------------------!-------
      END SUBROUTINE DRAWTKS_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE FULANN_test
C ----------------------------------------------------------------------!-------
C     ANNOTATION MODEL SUITED FOR PUBLICATION QUALITY LETTERING
C
      implicit double precision (a-h,o-z)

      CHARACTER*(*) S,C
C
C     INITIALIZES PLOT IN PUBLICATION-QUALITY MODE(REQUIRES DISSPLA)
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 DECK "ANNOT" INSERTED HERE 
ccccc      CHARACTER*10 ANOTES,HNOTES
      character*13 anotes
      character*32 hnotes
      COMMON/ANNCTL/LENA(4),LENHA(4)
      COMMON/ANNCTC/ANOTES(4),HNOTES(4)
C
      INTEGER LHNA(4) ,LHNHA(4)
ccccc      CHARACTER*10 AQOTES(2,4),HQOTES(4,3)
      character*13 aqotes(4)
      character*32 hqotes(4)
C
ccccc      DATA LHNA,AQOTES/4*2,'DEPTH (#M!',')','DEPTH (#KM','!)',
ccccc     2'HEIGHT (#M','!)','HEIGHT (#K','M!)'/
      DATA LHNA,AQOTES/4*2,
     &                  'DEPTH (#M!)  ',
     &                  'DEPTH (#KM!) ',
     &                  'HEIGHT (#M!) ',
     &                  'HEIGHT (#KM!)'/

ccccc      DATA LHNHA,HQOTES/3,2,4, 'RANGE AT SEA LEVEL (#KM!)',' '
ccccc     2       ,'RANGE (#DE','G!)',2*' '
ccccc     3       ,'CROSS RANG','E AT SEA L','EVEL (#KM!',')'/
      DATA LHNHA,HQOTES/3,2,4,4,
     &                  'RANGE AT SEA LEVEL (#KM!)      ',
     &                  'RANGE (#DEG!)                  ',
     &                  'CROSS RANGE AT SEA LEVEL (#KM!)',
     &                  'CROSS RANGE AT SEA LEVEL (#DEG!)'/

C
      ENTRY SETANN_test
C
      CALL SCMPLX
C
C*****  PUT TRAILING BLANKS ON THE ARGUMENTS SO THAT NO EXTRANEOUS
C       CHARACTERS MAY BE INTRODUCED.  JAH.
C       THE ARGUMENTS ARE CHARACTER*10 IN MX1ALF,MX2ALF.  ESSENTIAL
C       FOR THE CYBER OPERATION.
C
      CALL MX1ALF('STAND     ','!')
      CALL MX2ALF('L/CSTD    ','#')
      CALL HEIGHT(HITLET)
C
      CALL IMOVE(LENA,LHNA,4) 
      CALL IMOVE(LENHA,LHNHA,4)  !!!! added a 4th element
ccccc DO 10 I=1,2
         DO 10 J=1,4
10       ANOTES(J)=AQOTES(J)
      DO 20 I=1,4  !!!!! added a 4th element
ccccc    DO 20 J=1,3
20       HNOTES(i)=HQOTES(i)
C
      RETURN
C

      ENTRY ANNFIL_test(S,C)
      C=S
C ----------------------------------------------------------------------!-------
      END SUBROUTINE FULANN_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE SCMPLX_test
C ----------------------------------------------------------------------!-------
C     SPECIFY USE OF SIMPLEX CHARACTER SET(DISSPLA)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVTXT,NDEVBIN
C
      WRITE(NDEVTXT,100) 10
100   FORMAT(I2)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE SCMPLX_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE SET2_test(A,V,N)
C ----------------------------------------------------------------------!-------
C     SETS N COMPONENTS OF VECTOR 'A' TO SINGLE VALUE V
C

      DOUBLE PRECISION a(n),v
      integer ia(n)

C
      DO 100 I=1,N
100	  A(I)=V
      RETURN

C ----------------------------------------------------------------------!-------
      ENTRY ISET2_test (IA,IV,N)
C
C     SPECIAL ENTRY FOR INTEGER ARRAYS FOR MACHINES HAVING DIFFERENT
C     WORD SIZES FOR INTEGERS THAN DOUBLE PRECISION.
C

      DO 200 I=1,N
200	 IA(I) = IV
      RETURN
C ----------------------------------------------------------------------!-------
      END SUBROUTINE SET2_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE SETXY_test(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
      CALL SETANN
C
      PROJCT=PROJ
      THMIN=XMIN
      RMIN=YMIN
      THMAX=XMAX
      RMAX=YMAX
C ----------------------------------------------------------------------!-------
      END SUBROUTINE SETXY_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE SFILL_test(STG,LN,C)
C ----------------------------------------------------------------------!-------
C     FILLS A STRING WITH N SPECIFIED CHARACTERS
      CHARACTER STG*(*),C*1
C
      DO 10 I=1,LN
10    STG(I:I)=C
      RETURN
C ----------------------------------------------------------------------!-------
      END SUBROUTINE SFILL_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE SFILTR_test(C,S,KSET)
C ----------------------------------------------------------------------!-------
C     FILTERS EXTRANEOUS CHARACTERS FROM PLOT LABELS
      CHARACTER*(*) C,S,KSET
C
      LN=LEN(C)
      J=0 
      DO 10 I=1,LN
        IF(INDEX(KSET,C(I:I)).EQ.0) THEN
           J=J+1
           S(J:J)=C(I:I)
        ENDIF
10    CONTINUE
      RETURN
C ----------------------------------------------------------------------!-------
      END SUBROUTINE SFILTR_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE SREAD1_test(AB,NWOK,NW)
C ----------------------------------------------------------------------!-------
C     THIS IS THE FALLTHROUGH FEATURE FOR READW WHEN ENCOUNTERING
C     A NON STANDARD LABELED COMMON BLOCK. SREAD1 WILL ADD TABULAR
C     DATA TO THE DEFAULT GP ARRAY PGP AND INCLUDE INDEX OFFSET
C     VALUES TO A LOOKUP ARRAY 'LIST'.

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

C     COMMON DECK "CPROCFL" INSERTED HERE
      INTEGER PMX,PNTBL,PITBL,PFRMTBL,IDSP(10)
C     PARAMETER DECK "PGROUPS"
      PARAMETER (NCHPG1=11,NWPV=250,NSPGP=NCHPG1+2*NWPV+1)
      PARAMETER (MNGRP=9,MXGRP=69,MXLIST=MXGRP-MNGRP+2)
      COMMON/PROCFL/LIST(MXLIST)
      COMMON/PROCFL/PMX,PNTBL(10),PITBL(10),PFRMTBL(10),PGP(NSPGP)
      EQUIVALENCE (PGP,IDSP)
C
C
      INTEGER PPX    ,PQTBL(10),PLTBL(10),PIRMTBL(10)
C
      DATA PPX/2/
      DATA PQTBL/1,NCHPG1,NSPGP,7*0/
      DATA PLTBL/1,NWPV,8*0/
      DATA PIRMTBL/1,2,8*0/
C
      NWA=IABS(NW)-(MNGRP-2)
      IF(NWA.LT.2 .OR. NWA.GT.MXLIST) then
           PRINT*,'ERROR: Invalid W-ARRAY Value.',NW
           PRINT*,' Value must be >= 2 and <= 62.'
           STOP
      endif
C
      CALL READW1(AB,NWOK,NW,PMX,PNTBL,PITBL,PFRMTBL,PGP)
C
C     UPDATE THE LIST, LIST(1)=MAXIMUM USED ELEMENT
      LIST(1)=MAX0(LIST(1),NWA)
      LIST(NWA)=PNTBL(1)
C
C     GET NEXT NUMERICAL INDEX FROM THE POINTER ARRAY
      NLN=PNTBL(2)
C
C     NUMBER OF VALUES IS INTEGRAL PART OF FIRST ELEMENT
      NPTS=PGP(NLN) 
C     NUMBER OF ROWS IS KEPT AS FRACTIONAL PART
      NELS=(PGP(NLN)-NPTS)*10.+.5
      N2=NPTS/NELS
      NMX=PITBL(2)
C     MAKE ADJUSTMENTS TO LENGTHS AND OFFSETS
      PITBL(2)=NMX-N2-(NCHPG1-1)
      NUP=NPTS+NCHPG1
      PNTBL(1)=PNTBL(1)+NUP
      PNTBL(2)=PNTBL(2)+NUP
      NLN=NLN+1
C
C     LOOP TO MOVE NELS-1 ROWS OF PGP(NMX,NELS) TO PGP(N2,NELS)
C     THUS MAKING PGP A CONTIGUOUS ARRAY
      NTO=NLN+N2
      NFRM=NLN+NMX
      DO 100 I=2,NELS
      IF(NTO.GT.0 .AND. NFRM+N2-1.LE.NSPGP)
     1        CALL RMOVE(PGP(NTO),PGP(NFRM),N2)
      NTO=NTO+N2
100   NFRM=NFRM+NMX 
      RETURN
C
      ENTRY SETSRD_test
C***** CHANGED "ISET2" TO "SET2".  SEE SET2 SUBROUTINE.
C*****	CALL SET2(LIST,0,MXLIST)
C***** changed to a loop rather than writing an integer version of SET2
C***** SET2 is for DOUBLE PRECISION*8.

      do 10 ii = 1,mxlist
10	   list(ii) = 0

      PMX=PPX
      CALL IMOVE(PNTBL,PQTBL,10)
      CALL IMOVE(PITBL,PLTBL,10)
      CALL IMOVE(PFRMTBL,PIRMTBL,10)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE SREAD1_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      INTEGER FUNCTION STRIM_test(C)
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
C ----------------------------------------------------------------------!-------
      END FUNCTION STRIM_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE IMOVE_test(JOUT,INPI,N)
C ----------------------------------------------------------------------!-------
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)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE IMOVE_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE RMOVE_test(ROUT,RINP,N)
C ----------------------------------------------------------------------!-------
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)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE RMOVE_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      FUNCTION GET1_test(Z)
C ----------------------------------------------------------------------!-------
C     FUNCTIONALLY THE SAME AS 'GET' PROGRAM, SEE DOCUMENTATION THERE
C     NEEDED BECAUSE RECEIVER MODELS WILL CALL GET TO OBTAIN TERRAIN VA
C     BUT THEY THEMSELVES ARE CALLED VIA GET. HENCE HAVE RE-ENTRANCE
C     PROBLEM.
C
      implicit double precision (a-h,o-z)

      double precision d1mach                                     ! 10 Nov 2009
      DOUBLE PRECISION Z(*)
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
C     COMMON/CRMACH/RMACH(5) ! 25 Mar 2006
      COMMON/CRMACH/RMACH(9) ! 25 Mar 2006
      EQUIVALENCE(RKTIME,IRKTIME)
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
      IENTRY=1
      GO TO 5
C
      ENTRY DOT1_test(Z)
      IENTRY=2
5     CONTINUE
C 26 Aug 2008      IF(ZERO.EQ.0.0) ZERO=EARTHR*RMACH(3)*2.0
      IF(ZERO.EQ.0.0) ZERO=EARTHR*D1MACH(3)*2.0                    ! 26 Aug 2008
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
      GET1=Z(NZ)
      RETURN
C
20    GET1=Z(NPZR)*DRDT(1)+Z(NPZTH)*DRDT(2)+Z(NPZPH)*DRDT(3)
      RETURN
C ----------------------------------------------------------------------!-------
      END FUNCTION GET1_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      FUNCTION GET_test(Z)
C ----------------------------------------------------------------------!-------
C     'GET' AND ENTRY 'DOT' PROVIDE A CONTROL METHOD FOR AVOIDING
C     REDUNDANT CALLS TO THE TERRAIN AND RECEIVER MODELS. THE VALUES
C     RETURNED ARE THE FUNCTION VALUES FOR 'F' OR 'G' OR THEIR DERIVATI
C     (VIA 'DOT' ENTRY). UNNECESSARY CALLS ARE ELIMINATED THROUGH USE
C     OF 'TIME OF CALL' VARIABLES WHICH ARE COMPARED WITH THE CURRENT
C     LAST CALL TIME MAINTAINED BY THE 'RKAM' PROGRAM. WHEN VALUES ARE
C     NOT CURRENT THEY ARE UPDATED BY CALLS TO THE APPROPRIATE ROUTINES
C
      implicit double precision (a-h,o-z)

      double precision d1mach                                     ! 10 Nov 2009
      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
C     COMMON/CRMACH/RMACH(5) ! 25 Mar 2006
      COMMON/CRMACH/RMACH(9) ! 25 Mar 2006
      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_test(z)                            ! 2 Mar 2006
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_test(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
C 26 Aug 2008      IF(ZERO.EQ.0.0) ZERO=EARTHR*RMACH(3)*2.0
      IF(ZERO.EQ.0.0) ZERO=EARTHR*D1MACH(3)*2.0                    ! 26 Aug 2008
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
C ----------------------------------------------------------------------!-------
      END FUNCTION GET_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      FUNCTION ITOC_test(N)
C ----------------------------------------------------------------------!-------
C     RETURN 7 CHARACTER STRING REPRESENTATION OF INTEGER N
C     IF NUMBER IS TOO LARGE OR SMALL USE FLOATING POINT FORMAT
      CHARACTER ITOC*7
      IF(N.LT.-9999.OR.N.GT.99999) GO TO 100
      ITOC=' '
      WRITE(ITOC,'(I7)',ERR=100) N
      RETURN
100   WRITE(ITOC,'(2PG7.0)') FLOAT(N)
C ----------------------------------------------------------------------!-------
      END FUNCTION ITOC_test
C ----------------------------------------------------------------------!-------

C ----------------------------------------------------------------------!-------
      SUBROUTINE LABPLT_test
C ----------------------------------------------------------------------!-------
C          LABEL THE CURRENT PLOT
      implicit double precision (a-h,o-z)

      CHARACTER*80 LABEL,CHID
      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/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 ! 13 Mar 2008

C     COMMON DECK "HDR" INSERTED HERE
      CHARACTER*10 INITID*80,DAT,TOD
      COMMON/HDR/SEC,stsec                            !Rev 7/13/90 ! 13 Mar 2008
      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                                  ! 13 Mar 2008
      LOGICAL SPACE
      CHARACTER DISPM*6,modrin*64                                  ! 13 Mar 2008
      COMMON/RINPL/DISPM
      COMMON /RIN/ MODRIN,RAYNAME(2,3),TYPE(3),SPACE               ! 15 Mar 2008
      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
      character*80 id
      common /ident/ id
C     COMMON DECK "WW" 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))
      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
      WRITE(LABEL,900) ID
900   FORMAT(10A8)
      CHID=LABEL
      LABEL=CHID(5:)
      IOR=0
      IT=0
      IS=2
      IS=1                                                        ! 23 Jun 2009
      IX=0
      IY=1023
      CALL DDTEXT (8,LABEL)
      IX=1090
      IY=0
      CALL DDTEXT (2,DAT)
      IY=1023
      F=OW/PIT2
      NANGLE=10
      ANGRANG='EL ='
      ANOTE='AZ ='
      ANEL=0.
      IF(ELSTEP.NE.0.0) ANEL=(ELEND-ELBEG)/ELSTEP+1.5
      IF(ANEL.GT.1.0.OR.PLT.LT.0.0) GO TO 100
         ANGRANG='AZ ='
         ANOTE='EL ='
         NANGLE=14
100   WRITE(LABEL,1300)  CHID(1:3),F,ANOTE,W(NANGLE)*DEGS
1300  FORMAT ('MODEL = ',A,'  ,FREQ =',F9.3,' HZ, ',A,F7.3,' DEG')
      IX=0
      IY=IY-32
      CALL DDTEXT (7,LABEL)
C
C INDEX OF OPPOSITE ANGLE
      NANGLE=(10+14-NANGLE)+1
      NANGLE2=NANGLE+2
      WRITE(LABEL,1400) ANGRANG,(W(I)*DEGS,I=NANGLE,NANGLE2)
1400  FORMAT(A,F7.2,' DEG TO',F7.2,' DEG, STEP =',F7.2,' DEG')
      IY=IY-32
      CALL DDTEXT (7,LABEL)
C
      WRITE(LABEL,1500) XMTRH,TLAT*DEGS,TLON*DEGS
1500  FORMAT('XMTR HT =',F6.2,' KM ,LAT =',F6.2,' DEG, LONG ='
     1   ,F6.2,' DEG')
      IY=IY-32
      CALL DDTEXT (7,LABEL)
C
      IY=IY-32
      WRITE(LABEL,'(A)') MODRIN                                    ! 15 Mar 2008
      CALL DDTEXT(8,LABEL)
C
      IX=1050
      CALL DDTEXT(1,'MODELS')
      IY=IY-15
C     LOOP FOR 8 MODELS AND PERTURBATIONS
      DO 1700 K=1,12
      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)
1600  FORMAT(2(2(A8,2X,F5.1,1X),2X))
C
1610  IF(LABEL(1:1).EQ.' ') GO TO 1700
      IY=IY-32
      CALL DDTEXT(2,LABEL)
1700  LABEL(1:1)=' '
C
C ----------------------------------------------------------------------!-------
         END SUBROUTINE LABPLT_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      FUNCTION ND2B_test(INDEC)
C ----------------------------------------------------------------------!-------
C
C     CONVERT A NUMERIC DECIMAL DIGIT STRING TO A BIT STRING
C     WITH EACH BIT SET BY A CORRESPONDING DECIMAL DIGIT.
C
      ND2B=0
      IF(INDEC.LE.0) RETURN
      M=INDEC
      MB=1
C
10    IF(MOD(M,10).NE.0) ND2B=ND2B+MB
      MB=MB*2
      M=M/10
      IF(M.GT.0) GO TO 10
C ----------------------------------------------------------------------!-------
      END FUNCTION ND2B_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      FUNCTION NUMSTG_test(V,N,FRM)
C ----------------------------------------------------------------------!-------
C     CONVERTS A NUMERIC VALUE TO A STRING
C     USING FORMAT PROVIDED IN CALL
      CHARACTER NUMSTG*80,FRM*(*)
      INTEGER V(N)
C
      NUMSTG=' '
      WRITE(NUMSTG,FRM) V
      RETURN
C ----------------------------------------------------------------------!-------
      END FUNCTION NUMSTG_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE OVERRD_test(VAR,TST,DEFT,NFLG,NFVLEQ,NFVLNE)
C ----------------------------------------------------------------------!-------
C
C
C     OVERRIDE SUPPORT ROUTINE
C     TEST 'VAR' AGAINST 'TST', IF EQUAL SET TO DEFAULT 'DEFT'
C     AND ALSO SET INTEGER FLAG 'NFLG' TO VALUE 'NFVLEQ' ELSE 'NFVLNE'

      implicit double precision (a-h,o-z)
C
      IF(VAR.EQ.TST) THEN
         VAR=DEFT
         NFLG=NFVLEQ
      ELSE
         NFLG=NFVLNE
      ENDIF
      RETURN
C ----------------------------------------------------------------------!-------
      END SUBROUTINE OVERRD_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE ENDPLT
C ----------------------------------------------------------------------!-------

C.....This is a stub routine that exists solely to satisfy the call
C     in READW.  It was desired that READW not be changed in any sig-
C     nificant way since it is also used by other programs e.g. HARPO.

      RETURN
C ----------------------------------------------------------------------!-------
      END SUBROUTINE ENDPLT
C ----------------------------------------------------------------------!-------
