C file contour2.for
C**********************************************************************
! 25 Aug 2011 - Changes recommended by Larry Baker
C 27 Aug 2008 - Commented out "call mach"
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 14 Mar 2008 - Corrected the usage of KVECT
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  7 Mar 2008 - Changed some single precision constants to double precision
C 6 Sept 2006 - Added call to MACH, removed call to DFCNST
C**********************************************************************
C 28 Mar 2006 - Fixed order of RGAS/GAMMA constants in common block PCONST
C 27 Mar 2006 - Added arguments to SETW and SETUCON calls
C 27 Mar 2006 - Changed Hollerith constants to character string constants
C 25 Mar 2006 - /CRMACH/RMACH(5) --> (9)
C 16 Mar 2006 - Added kz2a and kzb to /RIN/
C 23 December 2005 - Added double precision to PI, PIT2, and PID2
C********************************************************************** 
      SUBROUTINE CONBLK
C     DATA INITIALIZATION AND FILE OPENING SERVICE ROUTINE
C
      implicit double precision (a-h,o-z)

C     COMMON DECK "RMACH" INSERTED HERE
C     COMMON/CRMACH/RMACH(5) ! 25 Mar 2006
      COMMON/CRMACH/RMACH(9) ! 25 Mar 2006
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
C     COMMON DECK "CPROCFL" INSERTED HERE
      INTEGER PMX,PNTBL,PITBL,PFRMTBL,IDSP(10)
C     PARAMETER DECK "PGROUPS"
      PARAMETER (NCHPG1=11,NWPV=500,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,NDEVTXT,NDEVBIN
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
     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))
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
     & , 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
C
      DOUBLE PRECISION KVECT(20)                                   ! 14 Mar 2008
      DOUBLE PRECISION VSET(20)
      EQUIVALENCE(KVECT,PNP),(VSET,V)                              ! 14 Mar 2008

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 "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 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

      character*1 astrsk(80)
      data astrsk /80*'*'/

c      DATA CUEF/1.0,1.4,8.31436E-3/
      DATA CUEF/1.d0,8.31436D-3,1.4d0/                     ! 28 Mar 2006
      DATA NUYIND/8,-2,-1,13,11/

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  -2  SCRATCH FILE, 'TAPE4', CONTAINS TEXT OUTPUT OF SOME
C*****               OF THE INPUT DATA WHEN SET TO NONZERO.
C*****
C*****  NFRMAT   -1  USED FOR INTERNAL WRITES.  MAY BE SET LATER TO NONZERO
C*****
C*****  NDEVTXT  13  TEXT OUTPUT, 'TXTOUT', FORM OF THE GRAPHICS COMMANDS
C*****
C*****  NDEVBIN  11  NOT USED BY PROFILE PROGRAM.
C*****


      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
      KAY2 = 0.D0                                                  ! 14 Mar 2008 
      KAY2I = 0.D0                                                 ! 14 Mar 2008 
      CALL SET2(KVECT,0.d0,20)                                     ! 14 Mar 2008
      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,NDEVTMP,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)=' '
      MODU(2)=0.0d0
      MODU(3)=' '
      MODU(4)=0.0d0
      MODL(1)=' '
      MODL(2)=0.0d0
      MODL(3)=' '
      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,' ',10)    ! 27 Mar 2006
      CALL ISET2(IDSDT,' ',10)
      CALL ISET2(IDSDU,' ',10)
      CALL ISET2(IDSC,' ',10)
      CALL ISET2(IDSM,' ',10)
      CALL ISET2(IDST,' ',10)
      CALL ISET2(IDSU,' ',10)
      CALL ISET2(IDSG,' ',10)
      CALL ISET2(IDSDG,' ',10)
      CALL ISET2(IDSV,' ',10)
      CALL ISET2(IDSDV,' ',10)
      CALL ISET2(IDSPR,' ',10)
      CALL ISET2(IDSDP,' ',10)
      CALL ISET2(IDSR,' ',10)
      CALL ISET2(IDSS,' ',10)
      CALL ISET2(IDSDS,' ',10)
C
C     GET MACHINE CONSTANTS
C     CALL DFCNST(RMACH,5)
C 27 Aug 2008      CALL MACH  ! 6 Sept 2006
      RETURN
C
C--------------------------------------------------------------------------
      ENTRY STDINI

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

C.....Note that for ASTRSK, use 79 since a *,* WRITE statement always adds
C     an extra blank.

      WRITE (*,*)
      WRITE (*,*) (astrsk(jj),jj=1,78)
      WRITE (*,444)
444   FORMAT (9X,
     &'*********************   CONTOUR PROGRAM   ********************')
      WRITE (*,*)
      WRITE (*,*) (astrsk(jj),jj=1,78)
      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.'
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')
C
C  INITIALIZE RAYSET FILE
      READ(NRYIND,'(A)',ERR=1000) INITID
      if (setw(azaz) .ne. 1.0) then                 ! 27 Mar 2006
           STOP 'ERROR CALLING SETW'
      endif

CCCCC      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 500 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********************************************************************** 
      FUNCTION READW_test
C
C     READS W ARRAY MAKING ANY NECESSARY CONVERSION OF UNITS.
C     VARIABLE LENGTH 'TABULAR' DATA IS READ BY SUBROUTINE 'READW1'
C     WHICH IS CALLED FOR NEGATIVE W-ARRAY INDICES.
C
      implicit double precision (a-h,o-z)

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

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

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

      IF (IOS.LT.0) then
           write(6,*)'end of file reached'
	   READW_test=1.0
C..........Added the following RETURN.  NFRMAT is set to -1 by CONBLK
C          anyhow, so the net effect is the same.  This also allows
C          us to eliminate the call to ENDPLT which means that subroutine
C          RAYPLT is not needed.

           RETURN

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

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

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

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

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

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

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

      if (nw .ne. 90) then
	   IF(MSKMS.EQ.'T' .AND. WWW.EQ.0.0) W(NW)=1.D-38 ! 7 Mar 2008
	   IF(WWW.EQ.0.0) GO TO 40
	   IF(MSKMS.EQ.'T') WWW=WWW*1.D37 ! 7 Mar 2008
      endif

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

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

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

C.....See comment above for SETW.
      setovr = 1.0
      RETURN
C
      END
C--------------------------------------------------------------------
      SUBROUTINE READW1_test(AB,NWOK,MSET,MX,NTBL,ITBL,FRMTBL,GP)
C
C     HANDLES INPUT OF TABULAR DATA REQUIRED BY SOME MODELS.
C
      implicit double precision (a-h,o-z)

      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVTXT,NDEVBIN
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))
      LOGICAL NWOK,AB
C
      logical uflag,ucon

      CHARACTER LINE*80,ALPHA*3,FBUF*3
      PARAMETER (NVAR=6,ALPHA='  A',NACDE=-1,NFIELD=13)
      INTEGER IPV(NVAR),NTBL(10),ITBL(10),FRMTBL(10)
      CHARACTER*8 PU(NVAR)
      DOUBLE PRECISION GP(*),V(NVAR),CONV(NVAR)
C
C     THE DATA STRUCTURE EXPECTED BY THIS PROGRAM FOR A DATA BLOCK IS 
C     SPECIFIED FOR A GIVEN MODEL BY THE THREE ARRAYS NTBL,ITBL,FRMTBL.
C     THE TYPE OF DATA EXPECTED FOR A GIVEN FORMAT GROUP IS TAKEN FROM
C     ARRAY FRMTBL. IT MUST HAVE AN ENTRY FOR A GIVEN TYPE OF FORMAT
C     WHICH IS EITHER ZERO, IF THAT FORMAT IS NOT ALLOWED OR AN ENTRY
C     WHOSE VALUE IS EQUAL TO THAT FORMAT TYPE. CURRENTLY ONLY TWO
C     FORMAT TYPES ARE ALLOWED, 1 FOR ALPHA AND 2 FOR NUMERIC.
C     TO ALLOW MORE FLEXIBLITY IN THE INPUT FILE THE NUMERIC FORMAT
C     TYPE IN TURN ALLOWS FOR 3 DIFFERENT DATA FORMATS, SEE BELOW.
C
C     OFFSETS INTO THE GENERAL ARRAY 'GP' FOR EACH FORMAT ARE GIVEN
C     IN THE ARRAY 'NTBL'. THE SPACING BETWEEN DATA VALUES IN EACH LINE
C     READ IS GIVEN IN ARRAY 'ITBL'. THIS SCHEME DOES NOT ALLOW FOR X,Y
C     ,Z CYCLES BUT RATHER SEPARATE ARRAYS OF X VALUES, THEN Y VALUES,
C     AND THEN Z VALUES(ETC. UP TO 'NVAR' VARIABLES).
C
      NWOK=.TRUE.
C
C     INITIALIZE ANY ALPHANUMERIC ARRAYS TO BLANKS
      IF(FRMTBL(1).EQ.1) CALL SET2(GP(NTBL(1)),1H ,NTBL(2)-NTBL(1))
C
C     BEGIN MULTI-FORMAT LOOP
C
5     READ(NRYIND,'(A,A)',END=200) FBUF,LINE
      IF(NDEVTMP.GT.0) WRITE(NDEVTMP,'(A,A)') FBUF,LINE
      IF(FBUF.EQ.ALPHA) THEN
         NFRM=NACDE
      ELSE
         READ(FBUF,10) NFRM
      ENDIF
10    FORMAT(BZ,I3,A)
      IF(NFRM .EQ. 0) RETURN
C
C     FORMAT #1 IS ASSIGNED TO ALPHANUMERIC INPUT AND LARGER NUMBERS
C     FOR NUMERIC INPUT.
C
C     CHECK NOW FOR NUMERICAL FORMATS.
C     THESE ARE PROVIDED FOR EASE OF INPUT OF TABULATED DATA
C     AND ARE PARTLY 'TRANSPARENT' TO THE MODEL INVOLVED. I.E.
C     THE USER HAS THE OPTION OF SPECIFING THE NUMBER OF DATA COLUMNS.
C     INPUT FORMAT NUMBER SPECIFIES THE NUMBER OF COLUMNS OF INPUT DATA
C     I.E. FOR VALUE 1 A SINGLE DATA COLUMN IS EXPECTED, FOR A VALUE
C     2 TWO DATA COLUMNS ARE EXPECTED, ETC.
C
C     DETERMINE FORMAT NUMBER
      IF(NFRM.EQ.NACDE) THEN
         IT=1
C     ALPHANUMERIC FORMATS MUST BE FIRST IN LIST
C     SINCE NO OFFSET SPECIFIER IS ALLOWED IN A FULL ALPHA LINE
         IF(FRMTBL(1).EQ.1) GO TO 100
      ELSE
         READ(LINE,'(I1)') IT
         IT=MAX0(IT,2)
         IF(IT.LE.MX) GO TO 100
      ENDIF
C
15    AB=.TRUE.
      PRINT 20, MSET,NFRM,MX
20    FORMAT(' FOR W-VALUE',I5,' NUMBER OF COLUMNS',I5,
     &       ' EXCEEDS LIMIT OF', I5)
      PRINT*,'FOR PROFILE POINT PLOTS:  '
      PRINT*,'     NEGATIVE W-VALUES MUST BE < -40 and >= -62.'
C      ERROR IN INPUT DATA , STOP HERE
      STOP
C
C     THE 'NTBL' TABLE PROVIDES A LIST OF OFFSETS TO VARIABLE GROUPS IN
C     MODEL ARRAYS, 'ITBL' GIVES ELEMENT SEPARATION TO ALLOW FOR 2-
C     DIMENSIONAL ARRAYS AND 'FRMTBL' SPECIFIES THE INPUT FORMAT.
C
100   N1=NTBL(IT)
      N3=ITBL(IT)
      N2=NTBL(IT+1)-N3
C
      IF(NFRM.NE.NACDE) GO TO 110
C
      READ(LINE,1010)((GP(I+J-1),I=N1,N2,N3),J=1,N3)
1010  FORMAT(10A8)
      GO TO 5
C
110   IF(NFRM.LT.1 .OR. NFRM.GT.NVAR) GO TO 200
C     HANDLE NUMERIC FORMATS
C
C     N1 IS STARTING ELEMENT WHICH WILL BE AFTER THE DATA COUNT
C     VALUE(NEED NELS*N3+1 TOTAL ELEMENTS)
      N1=N1+1
      N=0
C
C     # ELEMENTS IS EQUAL TO FORMAT NUMBER
      NELS=NFRM
C     READ UNITS CONVERSION SPECIFICATION LINE
      READ(LINE,1018) (PU(I),I=1,3)
      IF(PU(2).NE.' ') READ(LINE,2024) DELIM
      IF(PU(2).EQ.' ') READ(LINE,1020) DELIM,(PU(I),I=1,NELS)
C
C  ALLOW FOR BLANK CONVERSION LINE PRODUCED BY EIGENRAY ROUTINE
      IF(DELIM.EQ.0) READ(LINE,2024) DELIM
C
C     READ NEXT LINE AND EXTRACT UNIT CONVERSION SPECS IF PRESENT
C     IN FLOATING FORMAT
      READ(NRYIND,'(A)') LINE
      CALL GTUNIT(LINE,PU,NFIELD,NELS, NCARY)
C     CARRY COUNT IS ZERO IF LINE CONTAINED UNITS SPECIFIERS
      IF(NCARY.EQ.0.AND.NDEVTMP.GT.0) WRITE(NDEVTMP,'(A)') LINE
C
1018  FORMAT(10(A,5X))
ccccc1020  FORMAT(BZ,3X,G10.3,8X,10A)
1020  FORMAT(BZ,G10.3,8X,10A)
2024  FORMAT(T43,G10.3)
1025  FORMAT(BZ,10G13.6)
C
C     LOOK UP CONVERSION CONSTANTS
      DO 2030 I=1,NELS
2030  uflag = UCON(IPV(I),PU(I),CONV(I))  !!!!! was CALL UCON
C
C     DELIMITOR TESTING REQUIRES THE INNER LOOP BE EXECUTED
C     AT LEAST ONCE
      NX=MAX0(1,N3)
      N2=MAX0(N2,N1)
C     BEGIN SINGLE DATA FORMAT LOOP
      DO 150 J=0,10000
         IF(NELS.GT.1) THEN
            IF(NCARY.EQ.0) READ(NRYIND,'(A)') LINE
            NCARY=0
            IF(NDEVTMP.GT.0) WRITE(NDEVTMP,'(A)') LINE
            READ(LINE,1025) (V(I),I=1,NELS)
         ENDIF
         K=0
         DO 145 I=N1+J,N2+J,NX
               K=K+1
               IF(NELS.EQ.1) THEN
                  IF(NCARY.EQ.0) READ(NRYIND,'(A)',END=10000) LINE
                  NCARY=0
                  IF(NDEVTMP.GT.0) WRITE(NDEVTMP,'(A)') LINE
C     FOR SINGLE COLUMN CASE READ NOW
                  READ(LINE,1020) V(K)
               ENDIF
               IF(V(K) .EQ. DELIM) GO TO 160
C
C           APPLY ANY SCALING CONVERSIONS
               IF(CONV(K).GE.0.0) THEN
                  V(K)=V(K)*CONV(K)
               ELSEIF(V(K).NE.0.0) THEN
                  V(K)=-CONV(K)/V(K)
      ENDIF
               IF(J.LT.N3) GP(I)=V(K)
145            N=N+1
150   CONTINUE
C
10000 IF(V(1).NE.DELIM) THEN
           PRINT*,' Tabular data delimiter does not match ',
     &            'for set: ',mset
           STOP
      ENDIF
C
C     SAVE NUMBER OF VALUES AND ELEMENTS(AS FRACTIONAL PART)
160   IF(N1.GT.1) GP(N1-1)=N+NELS/10.
C
C     CONTINUE MULTI-FORMAT LOOP

      GO TO 5
C
200   PRINT*,' Bad format in tabular data for set: ',mset
C
      END
C-----------------------------------------------------------

      subroutine plot_test (x,y,new)
C.....STUB routine to satisfy external references.  Some of the routines
C     in CONTOUR call "PLOT".  However, these are calls to generic PLOT
C     i.e. "plot" was a formal argument.  The actual argument may be
C     PLOTXY or PLTANH but is never actually PLOT.
      return
      end
