      SUBROUTINE CONBLK
C     DATA INITIALIZATION AND FILE OPENING SERVICE ROUTINE
C
      implicit double precision (a-h,o-z)

C     COMMON DECK "RMACH" INSERTED HERE
      COMMON/CRMACH/RMACH(5)
C     COMMON DECK "HDR" INSERTED HERE
      CHARACTER*10 INITID*80,DAT,TOD
      COMMON/HDR/SEC
      COMMON/HDRC/INITID,DAT,TOD
C
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     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 "TT" INSERTED HERE
      DOUBLE PRECISION MODT
      COMMON/TT/MODT(4), T,PTT,PTR,PTTH,PTPH
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
C     COMMON DECK "RAYDEV" INSERTED HERE
C     DEVICE ASSIGNED TO RAYTRC INPUT FILE
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVBIN,NDEVTXT
C     COMMON DECK "CUCON" INSERTED HERE
      COMMON/UCONV/CNVV(5,4)
      CHARACTER PCV*3,CNVC*2
      COMMON/UCONC/PCV(5),CNVC(5,4)
C
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 "CONST" INSERTED HERE 
      COMMON/PCONST/CREF,RGAS,GAMMA
      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))
C     COMMON DECK "B9" INSERTED HERE
      INTEGER GMX,GNTBL,GITBL,GFRMTBL,IDSG(10)
      COMMON/B9/GMX,GNTBL(10),GITBL(10),GFRMTBL(10),GGP(113)
      EQUIVALENCE (GGP,IDSG),(ANG,GGP(11))
C     COMMON DECK "B2" INSERTED HERE
      INTEGER DUMX,DUNTBL,DUITBL,DUFRMTB,IDSDU(10)
      COMMON/B2/DUMX,DUNTBL(10),DUITBL(10),DUFRMTB(10),DUGP(10)
      EQUIVALENCE (DUGP,IDSDU)
C     COMMON DECK "B4" INSERTED HERE
      INTEGER DCMX,DCNTBL,DCITBL,DCFRMTB,IDSDC(10)
      COMMON/B4/DCMX,DCNTBL(10),DCITBL(10),DCFRMTB(10),DCGP(10)
      EQUIVALENCE (DCGP,IDSDC)
C     COMMON DECK "B6" INSERTED HERE
      INTEGER DTMX,DTNTBL,DTITBL,DTFRMTB,IDSDT(10)
      COMMON/B6/DTMX,DTNTBL(10),DTITBL(10),DTFRMTB(10),DTGP(10)
      EQUIVALENCE (DTGP,IDSDT)
C     COMMON DECK "B1" INSERTED HERE
      INTEGER UMX,UNTBL,UITBL,UFRMTBL,IDSU(10)
      COMMON/B1/UMX,UNTBL(10),UITBL(10),UFRMTBL(10),UGP(10) 
      EQUIVALENCE (UGP,IDSU)
C     COMMON DECK "B3" INSERTED HERE
      INTEGER CMX,CNTBL,CITBL,CFRMTBL,IDSC(10)
      COMMON/B3/CMX,CNTBL(10),CITBL(10),CFRMTBL(10),CGP(512)
      EQUIVALENCE (CGP,IDSC),(ANC,CGP(11))
C     COMMON DECK "B5" INSERTED HERE
      INTEGER TMX,TNTBL,TITBL,TFRMTBL,IDST(10)
      COMMON/B5/TMX,TNTBL(10),TITBL(10),TFRMTBL(10),TGP(262)
      EQUIVALENCE (TGP,IDST),(ANT,TGP(11))
C     COMMON DECK "B7" INSERTED HERE
      INTEGER MMX,MNTBL,MITBL,MFRMTBL,IDSM(10)
      DOUBLE PRECISION MGP
      COMMON/B7/MMX,MNTBL(10),MITBL(10),MFRMTBL(10),MGP(10) 
      EQUIVALENCE (MGP,IDSM)
C     COMMON DECK "RINPLEX" INSERTED HERE
      DOUBLE PRECISION KAY2,KAY2I
      COMPLEX PNP,POLAR,LPOLAR
      LOGICAL SPACE 
      CHARACTER DISPM*6
      COMMON/RINPL/DISPM
      COMMON /RIN/ MODRIN(8),RAYNAME(2,3),TYPE(3),SPACE
      COMMON/RIN/OMEGMIN,OMEGMAX,KAY2,KAY2I
      COMMON/RIN/PNP(10),POLAR,LPOLAR,SGN
C     COMMON DECK "MM" INSERTED HERE
      DOUBLE PRECISION M,MODM
      COMMON/MM/MODM(4),M,PMT,PMR,PMTH,PMPH
C     COMMON DECK "PP" INSERTED HERE
      DOUBLE PRECISION MODP
      COMMON/PP/MODP(4),P,PPT,PPR,PPTH,PPPH
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 "CB11" INSERTED HERE
      INTEGER SMX,SNTBL,SITBL,SFRMTBL,IDSS(10)
      COMMON/B11/SMX,SNTBL(10),SITBL(10),SFRMTBL(10),SGP(11)
      EQUIVALENCE (SGP,IDSS),(ANS,SGP(11))
C     COMMON DECK "CB12" INSERTED HERE
      INTEGER DSMX,DSNTBL,DSITBL,DSFRMTB,IDSDS(10)
      COMMON/B12/DSMX,DSNTBL(10),DSITBL(10),DSFRMTB(10),DSGP(11)
      EQUIVALENCE (DSGP,IDSDS),(ANDS,DSGP(11))
C     COMMON DECK "LL" INSERTED HERE
      DOUBLE PRECISION MODL
      COMMON/LL/MODL(4),APH,APHPT,APHPR,APHPTH,APHPPH
C     COMMON DECK "FLAG" INSERTED HERE
      LOGICAL NEWWR,NEWWP,NEWTRC,PENET
      COMMON /FLG/ NTYP,NEWWR,NEWWP,NEWTRC,PENET,LINES,IHOP,HPUNCH
      COMMON/FLGP/NSET
C     COMMON DECK "RKTIME" INSERTED HERE
      COMMON/CRKTIME/RKTIME
C
      COMMON/RAYCON/MCONP
C
      EQUIVALENCE(RKTIME,IRKTIME)
C
C     COMMON DECK "B10" INSERTED HERE
      INTEGER DGMX,DGNTBL,DGITBL,DGFRMTB,IDSDG(10)
      COMMON/B10/DGMX,DGNTBL(10),DGITBL(10),DGFRMTB(10),DGGP(10)
      EQUIVALENCE (DGGP,IDSDG)
C     COMMON DECK "B8" INSERTED HERE
      INTEGER RMX,RNTBL,RITBL,RFRMTBL,IDSR(10)
      COMMON/B8/RMX,RNTBL(10),RITBL(10),RFRMTBL(10),RGP(10) 
      EQUIVALENCE (RGP,IDSR)
C     COMMON DECK "CB17" INSERTED HERE
      INTEGER VMX,VNTBL,VITBL,VFRMTBL,IDSV(10)
      COMMON/B17/VMX,VNTBL(10),VITBL(10),VFRMTBL(10),VGP(53)
      EQUIVALENCE (VGP,IDSV),(ANV,VGP(11))
C     COMMON DECK "CB18" INSERTED HERE
      INTEGER DVMX,DVNTBL,DVITBL,DVFRMTB,IDSDV(10)
      COMMON/B18/DVMX,DVNTBL(10),DVITBL(10),DVFRMTB(10),DVGP(11)
      EQUIVALENCE (DVGP,IDSDV),(ANDV,DVGP(11))
C     COMMON DECK "CB19" INSERTED HERE
      INTEGER PRMX,PRNTBL,PRITBL,PRFRMTB,IDSPR(10)
      COMMON/B19/PRMX,PRNTBL(10),PRITBL(10),PRFRMTB(10),PRGP(11)
      EQUIVALENCE (PRGP,IDSPR),(ANP,PRGP(11))
C     COMMON DECK "CB20" INSERTED HERE
      INTEGER DPMX,DPNTBL,DPITBL,DPFRMTB,IDSDP(10)
      COMMON/B20/DPMX,DPNTBL(10),DPITBL(10),DPFRMTB(10),DPGP(11)
      EQUIVALENCE (DPGP,IDSDP),(ANDP,DPGP(11))
      COMMON/KNKN/KNBP,KNVC,KNDT
      COMMON/DDLIM/MXIX,MXIY,MNIX,MNIY
C
      DOUBLE PRECISION KVECT(22)
      DOUBLE PRECISION VSET(20)
      EQUIVALENCE(KVECT,KAY2),(VSET,V)
C
      DOUBLE PRECISION CUEF(3)
      INTEGER NUYIND(5)
C
      CHARACTER PFV(5)*3,CQVC(5,4)*2
C
C.....Added the following for input file OPENing.
      LOGICAL found
      CHARACTER*80 fname

      DATA CUEF/1.0,1.4,8.31436E-3/
      DATA NUYIND/8,4,0,11,13/

C*****  THE ABOVE DATA STATEMENT SETS THE VALUES FOR EACH OF THE
C*****  I/O DEVICE UNIT NUMBERS AS FOLLOWS:
C*****
C*****  NRYIND    8  INPUT 'DINP' FILE.
C*****
C*****  NDEVTMP   0  SCRATCH FILE, 'TAPE4', CONTAINS TEXT OUTPUT OF SOME
C*****               OF THE INPUT DATA WHEN SET TO NONZERO.
C*****
C*****  NFRMAT    0  USED FOR INTERNAL WRITES.  MAY BE SET LATER TO NONZERO
C*****
C*****  NDEVBIN  11  NOT USED BY PROFILE PROGRAM.
C*****
C*****  NDEVTXT  13  TEXT OUTPUT, 'TXTOUT', FORM OF THE GRAPHICS COMMANDS


      DATA PFV/'AN','LN','FQ','AM',' '/
      DATA CQVC/'RD' ,'KM' ,'RD' ,'DB',' '
     1        ,'DG' ,' M' ,'HZ' ,'NP',' '
     2        ,'KM' ,'FT' ,'KH' ,2*' '
     3        ,'  ' ,'NM' ,'DG' ,2*' '/
C
      CALL SET2(KVECT,0.d0,22)
      CALL SET2(RAYNAME,1H , 6)
      CALL SET2(VSET,0.d0,20)
      CALL SET2(OMEGMIN,0.d0,2)
      MXIX=-1000
      MXIY=-1000
      MNIX=1000
      MNIY=1000
      KNBP=0
      KNVC=0
      KNDT=0
      IRKTIME=0
C     SET TRACE-BACKUP VARIABLES
      CALL SETTRC
      MCONP=0
      POLAR=0.0
      LPOLAR=1.0
      CALL RMOVE(CREF,CUEF,3)
C
C*****NOTE:  THE FOLLOWING IMOVE ASSIGNS VALUES TO EACH OF THE LOGICAL
C*****       UNITS IN THE RAYDEV COMMON E.G. NRYIND,NDEVBIN,NDEVTXT ETC.
C*****       THE VALUES ARE HARD-CODED BY THE DATA STATEMENT FOR NUYIND
C*****       WHICH IS EXPLAINED ABOVE.

      CALL IMOVE(NRYIND,NUYIND,5)
      CALL SET2(CNVV,1.d0,20)
      DO 10 I=1,5
        PCV(I)=PFV(I)
        DO 10 J=1,4
10       CNVC(I,J)=CQVC(I,J)
C     DEFAULT WIND AND ABSORBSION IDENTIFIERS
      MODU(1)=1H
      MODU(2)=0.0d0
      MODU(3)=1H
      MODU(4)=0.0d0
      MODL(1)=1H
      MODL(2)=0.0d0
      MODL(3)=1H
      MODL(4)=0.0d0
C
C     INITIALIZE MODEL DESCRIPTIONS TO BLANKS
C     NOTE:  The Hollerith constant, "1H ", must have the space after the
C            H since SET2 is simply filling the arrays with 10 spaces.
C
      CALL ISET2(IDSDC,1H ,10)
      CALL ISET2(IDSDT,1H ,10)
      CALL ISET2(IDSDU,1H ,10)
      CALL ISET2(IDSC,1H ,10)
      CALL ISET2(IDSM,1H ,10)
      CALL ISET2(IDST,1H ,10)
      CALL ISET2(IDSU,1H ,10)
      CALL ISET2(IDSG,1H ,10)
      CALL ISET2(IDSDG,1H ,10)
      CALL ISET2(IDSV,1H ,10)
      CALL ISET2(IDSDV,1H ,10)
      CALL ISET2(IDSPR,1H ,10)
      CALL ISET2(IDSDP,1H ,10)
      CALL ISET2(IDSR,1H ,10)
      CALL ISET2(IDSS,1H ,10)
      CALL ISET2(IDSDS,1H ,10)
C
C     GET MACHINE CONSTANTS
      CALL DFCNST(RMACH,5)
      RETURN
C
C--------------------------------------------------------------------------
      ENTRY STDINI

      CALL OPNREP(NDEVTMP,'TAPE4')
      CALL OPNURP(NDEVBIN,'TAPE6')
C
C---------------------------------------------------------------------------
      ENTRY STDINT

      WRITE (*,*)
      WRITE (*,*)
      WRITE (*,*)'                *************************************'
      WRITE (*,*)'                ********    EIGEN PROGRAM   *********'
      WRITE (*,*)'                *************************************'
      WRITE (*,*)

      INQUIRE (FILE = 'DINP', EXIST = found)
      if (found) then
           OPEN(UNIT=NRYIND,FILE='DINP',STATUS='OLD',IOSTAT=IST)
           IF (IST.LT.0) THEN
	        STOP 'Unexpected end of input file during OPEN.'
           ELSE IF (IST.GT.0) THEN
                PRINT 111,IST
111	        FORMAT ('ERROR OPENING INPUT FILE.  ERROR:  ',I3)
	        STOP 'Check error code in FORTRAN Reference Manual.'
           ENDIF
      else
           WRITE (*,*)' No DINP file exists for EIGEN program.'
20         WRITE (*,222)
222        FORMAT ('  Enter filename on next line >>>>>>')
           READ (*,333) fname
333        FORMAT (A)
           INQUIRE (FILE = fname, EXIST = found)
           if (.not. found) then
                WRITE (*,*)' Could not find file: ',fname
                go to 20
           endif
           OPEN(UNIT=NRYIND,FILE= fname,STATUS='OLD',IOSTAT=IST)
           IF (IST.LT.0) THEN
	        STOP 'Unexpected end of input file during OPEN.'
           ELSE IF (IST.GT.0) THEN
                PRINT 111,IST
	        STOP 'Check error code in FORTRAN Reference Manual.'
           ENDIF
           WRITE (*,*)' Using file: ',fname(1:len(fname))

      endif
      REWIND NRYIND
C
      CALL OPNREP(NDEVTXT,'TXTOUT')
      CALL OPNREP(NDEVTMP,'TAPE4')
C
C  INITIALIZE RAYSET FILE
      READ(NRYIND,'(A)',ERR=1000) INITID
      CALL SETW
      CALL SETGET
C*****CALL SYSDAT(DAT)  THESE ARE CALLS TO SYSTEM DATE ROUTINES
C*****CALL SYSTIM(TOD)                     SYSTEM TIME
C*****CALL SYSSEC(SEC)                     SYSTEM CPU SECONDS
C     INITIALIZE POINT MODEL LIST
      LIST(1)=1
      LIST(2)=0
C     FILL FORMAT CONTROL ARRAYS
      PNTBL(1)=1
C     ALLOW FOR AN 80 CHARACTER IDENT STRING(A8)
      PNTBL(2)=NCHPG1
C     ALLOW MAXIMUM 250 WORD PER VARIABLE
      PITBL(2)=NWPV
C     FOR BOTH X AND Y PLUS 1 FOR NUMBER OF VARIABLES
      PNTBL(3)=NSPGP
      RETURN
1000  STOP 'ERROR: In DINP Format.'
      END
C----------------------------------------------------------------------------
      SUBROUTINE GRACE(X)
C     DEFINE MARGIN AROUND PLOTTING AREA(DISSPLA)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVBIN,NDEVTXT
C
      WRITE(NDEVTXT,100) 21,X
100   FORMAT(I2,F4.2)
      END
c----------------------------------------------------------------------------
      SUBROUTINE GRAFB(A,B,C,D,E,F)
C     ROUTINE WHICH ESTABLISHES BOXED X AND Y AXES(DISSPLA)
C     THIS IS A PSEUDO CALL WHICH USES SEVERAL OTHER DISSPLA CALLS
C     IT IS ASSUMED THAT A PREVIOUS CALL TO TITLE HAS BEEN MADE
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C
      DOUBLE PRECISION a,b,c,d,e,f
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVBIN,NDEVTXT
C
      WRITE(NDEVTXT,100) 39,A,B,C,D,E,F
100   FORMAT(I2,6E13.7)
      END
C----------------------------------------------------------------------------
      SUBROUTINE HEIGHT(H)
C     SETS REFERENCE CHARACTER HEIGHT IN INCHES(DISSPLA)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C
      implicit double precision (a-h,o-z)

      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVBIN,NDEVTXT
C
      WRITE(NDEVTXT,100) 13,H
100   FORMAT(I2,F4.2)
      END
C----------------------------------------------------------------------------
      FUNCTION ITEST(I)
C     USED TO PASS INTEGER VALUES THROUGH FOR VARIABLES TYPED REAL
C     (AS IN MIXED REAL/INTEGER ARRAYS)
      ITEST=I
      END
C----------------------------------------------------------------------------
      FUNCTION ITOC(N)
C     RETURN 7 CHARACTER STRING REPRESENTATION OF INTEGER N
C     IF NUMBER IS TOO LARGE OR SMALL USE FLOATING POINT FORMAT
      CHARACTER ITOC*7
      IF(N.LT.-9999.OR.N.GT.99999) GO TO 100
      ITOC=' '
      WRITE(ITOC,'(I7)',ERR=100) N
      RETURN
100   WRITE(ITOC,'(2PG7.0)') FLOAT(N)
      END
C--------------------------------------------------------------------------
      SUBROUTINE FULANN
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
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(S,C)
      C=S
      END
C-------------------------------------------------------------------------------
      SUBROUTINE SCMPLX
C     SPECIFY USE OF SIMPLEX CHARACTER SET(DISSPLA)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVBIN,NDEVTXT
C
      WRITE(NDEVTXT,100) 10
100   FORMAT(I2)
      END
C----------------------------------------------------------------------------
      SUBROUTINE SET2(A,V,N)
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 (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
      END
C-----------------------------------------------------------------------
      SUBROUTINE SREAD1(AB,NWOK,NW)
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
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)
      END
