C file CONBLK2.FOR - version from ray tracing program, from S2.FOR
C ----------------------------------------------------------------------!-------
! 25 Aug 2011 - Changes recommended by Larry Baker
C 16 Mar 2010 - Increased dimension of ..GP.. arrays to 611
C 15 Mar 2010 - Added common blocks B21,B22,B23,B24 
C  1 May 2009 - replaced REAL*8 with DOUBLE PRECISION
C 20 Mar 2008 - Corrected units conversion of a frequency as a period in seconds
C 19 Mar 2009 - Added units conversion for a central Earth angle in nautical
C               miles
C 27 Aug 2008 - Commented out "call mach"
C 14 Mar 2008 - Corrected the usage of KVECT
C 13 Mar 2008 - Corrected length in common block /PCONST/
C 13 Mar 2008 - Corrected length in common block /RIN/
C 13 Mar 2008 - Corrected length in common block /MM/
C  5 Mar 2007 - Added molecular fractions to common block /MM/
C 16 Mar 2006 - Added kzb to /RIN/
C 16 Mar 2006 - Changed kz2 to kz2a
C ----------------------------------------------------------------------!-------
C  2 Jun 2004 - SUBROUTINE CONBLK - Hollerith constants to character strings
C 10 Jun 2003 - added line (SUBROUTINE CONBLK) fixes data statement for CUEF
C 10 Jun 2003 - (SUBROUTINE CONBLK) fixed some Hollerith constants
C 10 Jun 2003 - (SUBROUTINE CONBLK) Holl. const. to char strings
C ----------------------------------------------------------------------!-------
      SUBROUTINE CONBLK
C ----------------------------------------------------------------------!-------
C     DATA INITIALIZATION AND FILE OPENING SERVICE ROUTINE
C
C     COMMON DECK "RMACH" INSERTED HERE
 
      implicit double precision (a-h,o-z)
 
      COMMON/CRMACH/rmach(9)
C     COMMON DECK "HDR" INSERTED HERE
      CHARACTER*10 INITID*80,DAT,TOD,dinpname*12   !Rev 7/13/90
      COMMON/HDR/SEC,stsec                         !Rev 7/13/90
      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)         ! 25 Aug 2011
      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 "CC" INSERTED HERE
      DOUBLE PRECISION MODC
      COMMON/CC/MODC(4),CS,PCST,PCSR,PCSTH,PCSPH

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,NDEVGRP,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

      COMMON/WW/DUM(10),MAXW,W(1000)
      DOUBLE PRECISION MAXSTP,MAXERR,INTYP,LLAT,LLON
      EQUIVALENCE (EARTHR,W(1)),(RAY,W(2)),(XMTRH,W(3)),(TLAT,W(4)),
     1 (TLON,W(5)),(OW,W(6)),(FBEG,W(7)),(FEND,W(8)),(FSTEP,W(9)),
     2 (AZ1,W(10)),(AZBEG,W(11)),(AZEND,W(12)),(AZSTEP,W(13)),
     3 (BETA,W(14)),(ELBEG,W(15)),(ELEND,W(16)),(ELSTEP,W(17)),
     8   (RUNSUP,W(18)),(RCVRH,W(20)),
     4 (ONLY,W(21)),(HOP,W(22)),(MAXSTP,W(23)),(PLAT,W(24)),(PLON,W(25))
     5,(HMAX,W(26)),(RAYFNC,W(29)),(EXTINC,W(33)),
     6 (HMIN,W(27)),(RGMAX,W(28)),
     8 (INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),
     6 (STEP1,W(44)),(STPMAX,W(45)),(STPMIN,W(46)),(FACTR,W(47)),
     7 (SKIP,W(71)),(RAYSET,W(72)),(PRTSRP,W(74)),(HITLET,W(75))
     9 ,(BINRAY,W(76)),(PAGLN,W(77)),(PLT,W(81)),(PFACTR,W(82)),
     1 (LLAT,W(83)),(LLON,W(84)),(RLAT,W(85)),(RLON,W(86))
     2,(TIC,W(87)),(HB,W(88)),(HT,W(89)),(TICV,W(96))

C     COMMON DECK "B9" INSERTED HERE
      INTEGER GMX,GNTBL,GITBL,GFRMTBL,IDSG(20) 
      COMMON/B9/GMX,GNTBL(10),GITBL(10),GFRMTBL(10),GGP(611) 
      EQUIVALENCE (GGP,IDSG),(ANG,GGP(11)) 

C     COMMON DECK "B2" INSERTED HERE
      INTEGER DUMX,DUNTBL,DUITBL,DUFRMTB,IDSDU(20) 
      COMMON/B2/DUMX,DUNTBL(10),DUITBL(10),DUFRMTB(10),DUGP(611) 
      EQUIVALENCE (DUGP,IDSDU) 

C     COMMON DECK "B4" INSERTED HERE
      INTEGER DCMX,DCNTBL,DCITBL,DCFRMTB,IDSDC(20) 
      COMMON/B4/DCMX,DCNTBL(10),DCITBL(10),DCFRMTB(10),DCGP(611) 
      EQUIVALENCE (DCGP,IDSDC) 

C     COMMON DECK "B6" INSERTED HERE
      INTEGER DTMX,DTNTBL,DTITBL,DTFRMTB,IDSDT(20) 
      COMMON/B6/DTMX,DTNTBL(10),DTITBL(10),DTFRMTB(10),DTGP(611) 
      EQUIVALENCE (DTGP,IDSDT) 

C     COMMON DECK "B1" INSERTED HERE
      INTEGER UMX,UNTBL,UITBL,UFRMTBL,IDSU(20) 
      COMMON/B1/UMX,UNTBL(10),UITBL(10),UFRMTBL(10),UGP(611) 
      EQUIVALENCE (UGP,IDSU) 

C     COMMON DECK "B3" INSERTED HERE
      INTEGER CMX,CNTBL,CITBL,CFRMTBL,IDSC(20) 
      COMMON/B3/CMX,CNTBL(10),CITBL(10),CFRMTBL(10),CGP(611) 
      EQUIVALENCE (CGP,IDSC),(ANC,CGP(11)) 

C     COMMON DECK "B5" INSERTED HERE
      INTEGER TMX,TNTBL,TITBL,TFRMTBL,IDST(20) 
      COMMON/B5/TMX,TNTBL(10),TITBL(10),TFRMTBL(10),TGP(611) 
      EQUIVALENCE (TGP,IDST),(ANT,TGP(11)) 

C     COMMON DECK "B7" INSERTED HERE
      INTEGER MMX,MNTBL,MITBL,MFRMTBL,IDSM(20) 
      DOUBLE PRECISION MGP
      COMMON/B7/MMX,MNTBL(10),MITBL(10),MFRMTBL(10),MGP(611) 
      EQUIVALENCE (MGP,IDSM) 

C     COMMON DECK "RINPLEX" INSERTED HERE
      DOUBLE PRECISION KAY2,KAY2I 
     & , kz2a,kz2ai,kzb,kzbi                         ! 16 Mar 2006 ! 13 Mar 2008
      COMPLEX*16 PNP,POLAR,LPOLAR
      LOGICAL SPACE
      CHARACTER DISPM*6,modrin*64
      COMMON/RINPL/DISPM
      COMMON /RIN/ MODRIN,RAYNAME(2,3),TYPE(3),SPACE
      COMMON/RIN/OMEGMIN,OMEGMAX,KAY2,KAY2I 
     & , kz2a,kz2ai,kzb,kzbi                         ! 16 Mar 2006 ! 13 Mar 2008
      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
     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(611) 
      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(611) 
      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
      COMMON/RAYCON/MCONP

C     COMMON DECK "B10" INSERTED HERE
      INTEGER DGMX,DGNTBL,DGITBL,DGFRMTB,IDSDG(20) 
      COMMON/B10/DGMX,DGNTBL(10),DGITBL(10),DGFRMTB(10),DGGP(611) 
      EQUIVALENCE (DGGP,IDSDG) 

C     COMMON DECK "B8" INSERTED HERE
      INTEGER RMX,RNTBL,RITBL,RFRMTBL,IDSR(20) 
      COMMON/B8/RMX,RNTBL(10),RITBL(10),RFRMTBL(10),RGP(611) 
      EQUIVALENCE (RGP,IDSR) 

C     COMMON DECK "CB17" INSERTED HERE
      INTEGER VMX,VNTBL,VITBL,VFRMTBL,IDSV(20) 
      COMMON/B17/VMX,VNTBL(10),VITBL(10),VFRMTBL(10),VGP(611) 
      EQUIVALENCE (VGP,IDSV),(ANV,VGP(11)) 

C     COMMON DECK "CB18" INSERTED HERE
      INTEGER DVMX,DVNTBL,DVITBL,DVFRMTB,IDSDV(20) 
      COMMON/B18/DVMX,DVNTBL(10),DVITBL(10),DVFRMTB(10),DVGP(611) 
      EQUIVALENCE (DVGP,IDSDV),(ANDV,DVGP(11)) 

C     COMMON DECK "CB19" INSERTED HERE
      INTEGER PRMX,PRNTBL,PRITBL,PRFRMTB,IDSPR(20) 
      COMMON/B19/PRMX,PRNTBL(10),PRITBL(10),PRFRMTB(10),PRGP(611) 
      EQUIVALENCE (PRGP,IDSPR),(ANP,PRGP(11)) 

C     COMMON DECK "CB20" INSERTED HERE
      INTEGER DPMX,DPNTBL,DPITBL,DPFRMTB,IDSDP(20) 
      COMMON/B20/DPMX,DPNTBL(10),DPITBL(10),DPFRMTB(10),DPGP(611) 
      EQUIVALENCE (DPGP,IDSDP),(ANDP,DPGP(11)) 

C     COMMON DECK "CB21" INSERTED HERE                            ! 15 Mar 2010
      INTEGER MX21,NTBL21,ITBL21,FRMTB21,IDS21(20) 
      COMMON/B21/MX21,NTBL21(10),ITBL21(10),FRMTB21(10),GP21(611) 
      EQUIVALENCE (GP21,IDS21),(AN21,GP21(11)) 

C     COMMON DECK "CB22" INSERTED HERE                            ! 15 Mar 2010
      INTEGER MX22,NTBL22,ITBL22,FRMTB22,IDS22(20) 
      COMMON/B22/MX22,NTBL22(10),ITBL22(10),FRMTB22(10),GP22(611) 
      EQUIVALENCE (GP22,IDS22),(AN22,GP22(11)) 

C     COMMON DECK "CB23" INSERTED HERE                            ! 15 Mar 2010
      INTEGER MX23,NTBL23,ITBL23,FRMTB23,IDS23(20) 
      COMMON/B23/MX23,NTBL23(10),ITBL23(10),FRMTB23(10),GP23(611) 
      EQUIVALENCE (GP23,IDS23),(AN23,GP23(11)) 

C     COMMON DECK "CB24" INSERTED HERE                            ! 15 Mar 2010
      INTEGER MX24,NTBL24,ITBL24,FRMTB24,IDS24(20) 
      COMMON/B24/MX24,NTBL24(10),ITBL24(10),FRMTB24(10),GP24(611) 
      EQUIVALENCE (GP24,IDS24),(AN24,GP24(11)) 

      COMMON/KNKN/KNBP,KNVC,KNDT
      COMMON/DDLIM/MXIX,MXIY,MNIX,MNIY
C
      DOUBLE PRECISION KVECT(20)                                   ! 14 Mar 2008
      DOUBLE PRECISION VSET(20)
      EQUIVALENCE(KVECT,PNP),(VSET,V)                              ! 14 Mar 2008
C
      DOUBLE PRECISION CUEF(3)
      INTEGER NUYIND(5)
C
      CHARACTER PFV(5)*3,CQVC(5,4)*2
C this sets the pconst common cref, rgas and gamma
C      DATA CUEF/1.d0,1.4d0,8.31436d-3/
	DATA CUEF/1.d0,8.31436d-3,1.4d0/ ! 10 Jun 2003
      DATA NUYIND/8,4,0,10,11/
      DATA PFV/'AN','LN','FQ','AM',' '/
      DATA CQVC/'RD' ,'KM' ,'RD' ,'DB',' '
     1        ,'DG' ,' M' ,'HZ' ,'NP',' '
     2        ,'KM' ,'FT' ,'KH' ,2*' '
     3        ,'NM' ,'NM' ,' S' ,2*' '/             ! 19 Mar 2009 ! 20 Mar 2009
C
      KAY2 = 0.D0                                                 ! 14 Mar 2008 
      KAY2I = 0.D0                                                ! 14 Mar 2008 
      CALL SET2(KVECT,0.d0,20)                                    ! 14 Mar 2008
      dummy=' '                                                   !  2 Jun 2004
      CALL SET2(RAYNAME,dummy, 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
      rktime=0.d0
C     SET TRACE-BACKUP VARIABLES
      CALL SETTRC
      MCONP=0
      POLAR=0.d0
      LPOLAR=1.d0
      CALL RMOVE(CREF,CUEF,3)
      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  ! 10 Jun 2003
      MODU(2)=0.d0
      MODU(3)=' ' ! 2 Jun 2004
      MODU(4)=0.d0
      MODL(1)=' ' ! 2 Jun 2004
      MODL(2)=0.d0
      MODL(3)=' ' ! 2 Jun 2004
      MODL(4)=0.d0
C
C     INITIALIZE MODEL DESCRIPTIONS TO BLANKS
      CALL ISET2(IDSDC,' ' ,10) ! 10 Jun 2003
      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)
      CALL ISET2(IDS21,' ',10)                                    ! 15 Mar 2010
      CALL ISET2(IDS22,' ',10)                                    ! 15 Mar 2010
      CALL ISET2(IDS23,' ',10)                                    ! 15 Mar 2010
      CALL ISET2(IDS24,' ',10)                                    ! 15 Mar 2010
C
C     GET MACHINE CONSTANTS
C%      CALL DFCNST(RMACH,5)
C 27 Aug 2008      call mach
      RETURN
C
C ----------------------------------------------------------------------!-------
      ENTRY STDINI
C ----------------------------------------------------------------------!-------
      CALL OPNREP(NDEVTMP,'TAPE4')
      CALL OPNURP(NDEVBIN,'TAPE6')
      CALL OPNREP(9,'PUNCH')
C
C ----------------------------------------------------------------------!-------
      ENTRY STDINT
C ----------------------------------------------------------------------!-------
      write (*,888)
888   format (' NAME OF INPUT DATA FILE [DINP]: ',$)
      READ (*,'(A12)')dinpname
      if (dinpname.eq.'            ')dinpname='dinp'
      OPEN(UNIT=NRYIND,FILE=dinpname,STATUS='OLD',ERR=1000)
      REWIND NRYIND
C%      CALL OPNREP(2,'OUTPUT')
      CALL OPNREP(3,'DOUTP')
      CALL opnrep(NDEVGRP,'TAPE5')
C
C  INITIALIZE RAYSET FILE
      READ(NRYIND,'(A)',END=1000) INITID
C%      CALL SETW
      xyz=setw(xyz)
      zzz= SETGET(x)
      CALL SYSDAT(DAT)
      CALL SYSTIM(TOD)
      CALL SYSSEC(SEC)
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 'DINP FORMAT ERROR'
C ----------------------------------------------------------------------!-------
      END SUBROUTINE CONBLK
C ----------------------------------------------------------------------!-------
