C file ATMOSHD.FOR
C ----------------------------------------------------------------------!-------
!  9 Mar 2012 - Changed formula for NTYP in terms of RAY and what is printed
! 15 Mar 2011 - Increased number of decimal points for printing frequency
C  1 May 2009 - replaced REAL*8 with DOUBLE PRECISION
C 13 Mar 2008 - Corrected length in common block /PCONST/
C 13 Mar 2008 - Corrected length in common block /MM/
C 12 Mar 2008 - Corrected length in block /GV/
C 26 Jul 2006 - correction
C 16 Mar 2006 - Added kzb to /RIN/
C 16 Mar 2006 - Changed kz2 to kz2a
C 14 Mar 2006 - Added kz2 to /RIN/
C 21 Feb 2006 - Added more printing of models
C 21 Feb 2006 - Fixed some errors
C  3 Feb 2006 - Added printing of gravity and density models to raysets
C  2 Feb 2006 - Added printing of gravity and density models
C  2 Feb 2006 - Added common decks GV and DS
C  2 Feb 2006 - Added common decks B13, B14, B15, and B16
C 5 June 2004 - made many changes to modernize by comparing with OCNHD.FOR
C ----------------------------------------------------------------------!-------
      SUBROUTINE ATMOSHD                                                ATMOSHD2
C ----------------------------------------------------------------------!-------
C     PRINTS PAGE HEADINGS FOR RAY TRACING IN THE ATMOSPHERE            ATMOSHD3
C     IF W(72) IS NEGATIVE, ONLY ONE HEADER OUTPUT INCLUDED IN RAYSET   ATMOSHD4
 
      implicit double precision (a-h,o-z)                           ! 5 Jun 2004
 
      CHARACTER PCC*(*),PC*1,BLANKS*100,DIVIDR*132,BANNER(10)*80 !5Jun04ATMOSHD5
      CHARACTER NUMSTG*80,STMP*80,typ*20,id*80,strg5*200 ! 5 Jun 2004   ATMOSHD6
      LOGICAL NOPUNCH                                                   ATMOSHD7
      INTEGER STRIM                                                     ATMOSHD8
C                                                                       ATMOSHD9
C     TWO ENTRY POINTS ARE PROVIDED. ONE FOR THE FIRST PAGE HEADER      ATMOSH10
C     OF THE COMPUTATIONAL PRINTOUT AND FOR THE RAYSET FILE. THE        ATMOSH11
C     SECOND ENTRY IS FOR ALL SUBSEQUENT PAGES OF THE COMPUTATIONAL     ATMOSH12
C     PRINTOUT.                                                         ATMOSH13
C                                                                       ATMOSH14
C     COMMON DECK "AA" INSERTED HERE                                    CAA    2
C     REAL MODA                                            ! 5 Jun 2004 CAA    4
C     REAL MU,MUPT,MUPR,MUPTH,MUPPH                        ! 5 Jun 2004 CAA    5
C     REAL KAP,KAPPT,KAPPR,KAPPTH,KAPPPH                   ! 5 Jun 2004 CAA    6
C     COMMON/AA/MODA(4),MU,MUPT,MUPR,MUPTH,MUPPH           ! 5 Jun 2004 CAA    7
C     COMMON/AA/KAP,KAPPT,KAPPR,KAPPTH,KAPPPH              ! 5 Jun 2004 CAA    8
C                                                                   ! 5 Jun 2004
C     COMMON DECK "LL" INSERTED HERE                                ! 5 Jun 2004
      DOUBLE PRECISION MODL                                         ! 5 Jun 2004
      COMMON/LL/MODL(4),APH,APHPT,APHPR,APHPTH,APHPPH               ! 5 Jun 2004
      common/ident/id                                               ! 5 Jun 2004
C                                                                   ! 5 Jun 2004
C     COMMON DECK "PP" INSERTED HERE                                    CPP    2
      DOUBLE PRECISION MODP                                ! 5 Jun 2004 CPP    4
      COMMON/PP/MODP(4),P,PPT,PPR,PPTH,PPPH                             CPP    5
C                                                                       ATMOSH17
C     COMMON DECK "SS" INSERTED HERE                                    CSS    2
      DOUBLE PRECISION MODSURF                             ! 5 Jun 2004 CSS    4
      COMMON/SS/ MODSURF(4)                                             CSS    5
      COMMON/SS/U,PUR,PURR,PURTH,PURPH                                  CSS    6
      COMMON/SS/PUTH,PUPH,PUTHTH,PUPHPH,PUTHPH,USELECT,UTIME            CSS    7
C     COMMON DECK "CONST" INSERTED HERE                                 CCONST 2
      COMMON/PCONST/CREF,RGAS,GAMMA                                     CCONST 4
     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                         CCONST 5
C     COMMON DECK "WWR" INSERTED HERE                                   CWWR   2
      PARAMETER (NWARSZ=1000)                                           CWW1   3
      COMMON/WW/dum(10),MAXW,W(NWARSZ)                     ! 5 Jun 2004 CWW1   4
      DOUBLE PRECISION MAXSTP,MAXERR,INTYP,LLAT,LLON       ! 5 Jun 2004 CWW2   2
      EQUIVALENCE (EARTHR,W(1)),(RAY,W(2)),(XMTRH,W(3)),(TLAT,W(4)),    CWW2   3
     1 (TLON,W(5)),(OW,W(6)),(FBEG,W(7)),(FEND,W(8)),(FSTEP,W(9)),      CWW2   4
     2 (AZ1,W(10)),(AZBEG,W(11)),(AZEND,W(12)),(AZSTEP,W(13)),          CWW2   5
     3 (BETA,W(14)),(ELBEG,W(15)),(ELEND,W(16)),(ELSTEP,W(17)),         CWW2   6
     8   (RUNSUP,W(18)),(RCVRH,W(20)),                                  5Jun2004
     4 (ONLY,W(21)),(HOP,W(22)),(MAXSTP,W(23)),(PLAT,W(24)),(PLON,W(25))CWW2   8
     5,(HMAX,W(26)),(RAYFNC,W(29)),(EXTINC,W(33)),                      CWW2   9
     6 (HMIN,W(27)),(RGMAX,W(28)),                                      CWW2  10
     8 (INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),                     CWW2  11
     6 (STEP1,W(44)),(STPMAX,W(45)),(STPMIN,W(46)),(FACTR,W(47)),       CWW2  12
     7 (SKIP,W(71)),(RAYSET,W(72)),(PRTSRP,W(74)),(HITLET,W(75))        CWW2  13
     9 ,(BINRAY,W(76)),(PAGLN,W(77)),(PLT,W(81)),(PFACTR,W(82)),        CWW2  14
     1 (LLAT,W(83)),(LLON,W(84)),(RLAT,W(85)),(RLON,W(86))              CWW2  15
     2,(TIC,W(87)),(HB,W(88)),(HT,W(89)),(TICV,W(96))                   CWW2  16

C     COMMON DECK "GG" INSERTED HERE                                    CGG    2
      DOUBLE PRECISION MODG                                             5Jun2004
      COMMON/GG/MODG(4)                                                 CGG    5
      COMMON/GG/G,PGR,PGRR,PGRTH,PGRPH                                  CGG    6
      COMMON/GG/PGTH,PGPH,PGTHTH,PGPHPH,PGTHPH,GSELECT,GTIME            CGG    7

C     COMMON DECK "RR" INSERTED HERE                                    CRR    2
      DOUBLE PRECISION MODREC                                           5Jun2004
      COMMON/RR/ MODREC(4)                                              CRR    5
      COMMON/RR/F,PFR,PFRR,PFRTH,PFRPH                                  CRR    6
      COMMON/RR/PFTH,PFPH,PFTHTH,PFPHPH,PFTHPH,FSELECT,FTIME            CRR    7

C     COMMON DECK "B9" INSERTED HERE                                    CB8    2
      INTEGER GMX,GNTBL,GITBL,GFRMTBL,IDSG(20) ! 5 Jun 2004             CB8    4
      COMMON/B9/GMX,GNTBL(10),GITBL(10),GFRMTBL(10),GGP(113)            CB8    5
      EQUIVALENCE (GGP,IDSG),(ANG,GGP(11))                              CB8    6

C     COMMON DECK "B2" INSERTED HERE                                    CB2    2
      INTEGER DUMX,DUNTBL,DUITBL,DUFRMTB,IDSDU(20) ! 5 Jun 2004         CB2    4
      COMMON/B2/DUMX,DUNTBL(10),DUITBL(10),DUFRMTB(10),DUGP(10)         CB2    5
      EQUIVALENCE (DUGP,IDSDU)                                          CB2    6

C     COMMON DECK "B4" INSERTED HERE                                    CB4    2
      INTEGER DCMX,DCNTBL,DCITBL,DCFRMTB,IDSDC(20) ! 5 Jun 2004         CB4    4
      COMMON/B4/DCMX,DCNTBL(10),DCITBL(10),DCFRMTB(10),DCGP(10)         CB4    5
      EQUIVALENCE (DCGP,IDSDC)                                          CB4    6

C     COMMON DECK "B6" INSERTED HERE                                    CB6    2
      INTEGER DTMX,DTNTBL,DTITBL,DTFRMTB,IDSDT(20) ! 5 Jun 2004         CB6    4
      COMMON/B6/DTMX,DTNTBL(10),DTITBL(10),DTFRMTB(10),DTGP(10)         CB6    5
      EQUIVALENCE (DTGP,IDSDT)                                          CB6    6

C     COMMON DECK "B1" INSERTED HERE                                    CB1    2
      INTEGER UMX,UNTBL,UITBL,UFRMTBL,IDSU(20) ! 5 Jun 2004             CB1    4
      COMMON/B1/UMX,UNTBL(10),UITBL(10),UFRMTBL(10),UGP(10)             CB1    5
      EQUIVALENCE (UGP,IDSU)                                            CB1    6

C     COMMON DECK "B3" INSERTED HERE                                    CB3    2
      INTEGER CMX,CNTBL,CITBL,CFRMTBL,IDSC(20) ! 5 Jun 2004             CB3    4
      COMMON/B3/CMX,CNTBL(10),CITBL(10),CFRMTBL(10),CGP(512)            CB3    5
      EQUIVALENCE (CGP,IDSC),(ANC,CGP(11))                              CB3    6

C     COMMON DECK "B5" INSERTED HERE                                    CB5    2
      INTEGER TMX,TNTBL,TITBL,TFRMTBL,IDST(20) ! 5 Jun 2004             CB5    4
      COMMON/B5/TMX,TNTBL(10),TITBL(10),TFRMTBL(10),TGP(262)            CB5    5
      EQUIVALENCE (TGP,IDST),(ANT,TGP(11))                              CB5    6

C     COMMON DECK "B7" INSERTED HERE                                    CB7    2
      INTEGER MMX,MNTBL,MITBL,MFRMTBL,IDSM(20) ! 5 Jun 2004             CB7    4
      DOUBLE PRECISION MGP                                 ! 5 Jun 2004 CB7    5
      COMMON/B7/MMX,MNTBL(10),MITBL(10),MFRMTBL(10),MGP(10)             CB7    6
      EQUIVALENCE (MGP,IDSM)                                            CB7    7

C     COMMON DECK "HDR" INSERTED HERE                                   CHDR   2
      CHARACTER INITID*80,DAT*10,TOD*10                    ! 5 Jun 2004 CHDR   4
      COMMON/HDR/SEC,stsec                                 ! 5 Jun 2004 CHDR   5
      COMMON/HDRC/INITID,DAT,TOD                                        CHDR   6

C     COMMON DECK "RINPLEX" INSERTED HERE                               CRINPLE2
      DOUBLE PRECISION KAY2,KAY2I                          ! 5 Jun 2004 CRINPLE4
     & , kz2a,kz2ai,kzb,kzbi               ! 16 Mar 2006
      COMPLEX*16 PNP,POLAR,LPOLAR                          ! 5 Jun 2004 CRINPLE5
      LOGICAL SPACE                                                     CRINPLE6
      CHARACTER DISPM*6,modrin*64                          ! 5 Jun 2004 CRINPLE7
      COMMON/RINPL/DISPM                                                CRINPLE8
      COMMON /RIN/ MODRIN,RAYNAME(2,3),TYPE(3),SPACE       ! 5 Jun 2004 CRINPLE9
      COMMON/RIN/OMEGMIN,OMEGMAX,KAY2,KAY2I                             CRINPL10
     & , kz2a,kz2ai,kzb,kzbi       ! 16 Mar 2006
      COMMON/RIN/PNP(10),POLAR,LPOLAR,SGN                               CRINPL11

C     COMMON DECK "CC" INSERTED HERE                                    CCC    2
      DOUBLE PRECISION MODC                                ! 5 Jun 2004 CCC    4
      COMMON/CC/MODC(4),CS,PCST,PCSR,PCSTH,PCSPH                        CCC    5

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

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

C     COMMON DECK "TT" INSERTED HERE                                    CTT    2
      DOUBLE PRECISION MODT                                ! 5 Jun 2004 CTT    4
      COMMON/TT/MODT(4), T,PTT,PTR,PTTH,PTPH                            CTT    5

C     COMMON DECK "UU" INSERTED HERE                                    CUU    2
      DOUBLE PRECISION MODU                                ! 5 Jun 2004 CUU    4
      COMMON/UU/MODU(4)                                                 CUU    5
     1  ,V  ,PVT  ,PVR  ,PVTH  ,PVPH                                    CUU    6
     2  ,VR ,PVRT ,PVRR ,PVRTH ,PVRPH                                   CUU    7
     3  ,VTH,PVTHT,PVTHR,PVTHTH,PVTHPH                                  CUU    8
     4  ,VPH,PVPHT,PVPHR,PVPHTH,PVPHPH                                  CUU    9
C                                                                    
C     COMMON DECK "GV" INSERTED HERE                               !  2 Feb 2006   
      DOUBLE PRECISION MODGV                                       !  2 Feb 2006
      COMMON/GV/MODGV(4), GV,PGVT,PGVR,PGVTH,PGVPH,STUFF(15)       ! 12 Mar 2008

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

C     COMMON DECK "B10" INSERTED HERE                                   CB9    2
      INTEGER DGMX,DGNTBL,DGITBL,DGFRMTB,IDSDG(20) ! 5 Jun 2004         CB9    4
      COMMON/B10/DGMX,DGNTBL(10),DGITBL(10),DGFRMTB(10),DGGP(10)        CB9    5
      EQUIVALENCE (DGGP,IDSDG)                                          CB9    6

C     COMMON DECK "B8" INSERTED HERE                                    CB10   2
      INTEGER RMX,RNTBL,RITBL,RFRMTBL,IDSR(20) ! 5 Jun 2004             CB10   4
      COMMON/B8/RMX,RNTBL(10),RITBL(10),RFRMTBL(10),RGP(10)             CB10   5
      EQUIVALENCE (RGP,IDSR)                                            CB10   6

C     COMMON DECK "CB11" INSERTED HERE                              ! 5 Jun 2004
      INTEGER SMX,SNTBL,SITBL,SFRMTBL,IDSS(20)                      ! 5 Jun 2004
      COMMON/B11/SMX,SNTBL(10),SITBL(10),SFRMTBL(10),SGP(11)        ! 5 Jun 2004
      EQUIVALENCE (SGP,IDSS),(ANS,SGP(11))                          ! 5 Jun 2004

C     COMMON DECK "CB12" INSERTED HERE                              ! 5 Jun 2004
      INTEGER DSMX,DSNTBL,DSITBL,DSFRMTB,IDSDS(20)                  ! 5 Jun 2004
      COMMON/B12/DSMX,DSNTBL(10),DSITBL(10),DSFRMTB(10),DSGP(11)    ! 5 Jun 2004
      EQUIVALENCE (DSGP,IDSDS),(ANDS,DSGP(11))                      ! 5 Jun 2004

C     COMMON DECK "CB13" INSERTED HERE                           ! 2 Feb 2006
      INTEGER AMX,ANTBL,AITBL,AFRMTBL,IDSA(20)                   ! 2 Feb 2006
      COMMON/B13/AMX,ANTBL(10),AITBL(10),AFRMTBL(10),AGP(11)     ! 2 Feb 2006
      EQUIVALENCE (AGP,IDSA),(ANA,AGP(11))                       ! 2 Feb 2006

C     COMMON DECK "CB14" INSERTED HERE                           ! 2 Feb 2006
      INTEGER DAMX,DANTBL,DAITBL,DAFRMTB,IDSDA(20)               ! 2 Feb 2006
      COMMON/B14/DAMX,DANTBL(10),DAITBL(10),DAFRMTB(10),DAGP(11) ! 2 Feb 2006
      EQUIVALENCE (DAGP,IDSDA),(ANDA,DAGP(11))                   ! 2 Feb 2006

C     COMMON DECK "CB15" INSERTED HERE                           ! 2 Feb 2006
      INTEGER DMX,DNTBL,DITBL,DFRMTBL,IDSD(20)                   ! 2 Feb 2006
      COMMON/B15/DMX,DNTBL(10),DITBL(10),DFRMTBL(10),DGP(11)     ! 2 Feb 2006
      EQUIVALENCE (DGP,IDSD),(AND,DGP(11))                       ! 2 Feb 2006

C     COMMON DECK "CB16" INSERTED HERE                           ! 2 Feb 2006
      INTEGER DDMX,DDNTBL,DDITBL,DDFRMTB,IDSDD(20)               ! 2 Feb 2006
      COMMON/B16/DDMX,DDNTBL(10),DDITBL(10),DDFRMTB(10),DDGP(11) ! 2 Feb 2006
      EQUIVALENCE (DDGP,IDSDD),(ANDD,DDGP(11))                   ! 2 Feb 2006

C     COMMON DECK "CB17" INSERTED HERE                                  CB17   2
      INTEGER VMX,VNTBL,VITBL,VFRMTBL,IDSV(20) ! 5 Jun 2004             CB17   4
      COMMON/B17/VMX,VNTBL(10),VITBL(10),VFRMTBL(10),VGP(53)            CB17   5
      EQUIVALENCE (VGP,IDSV),(ANV,VGP(11))                              CB17   6

C     COMMON DECK "CB18" INSERTED HERE                                  CB18   2
      INTEGER DVMX,DVNTBL,DVITBL,DVFRMTB,IDSDV(20) ! 5 Jun 2004         CB18   4
      COMMON/B18/DVMX,DVNTBL(10),DVITBL(10),DVFRMTB(10),DVGP(11)        CB18   5
      EQUIVALENCE (DVGP,IDSDV),(ANDV,DVGP(11))                          CB18   6

C     COMMON DECK "CB19" INSERTED HERE                                  CB19   2
      INTEGER PRMX,PRNTBL,PRITBL,PRFRMTB,IDSPR(20) ! 5 Jun 2004         CB19   4
      COMMON/B19/PRMX,PRNTBL(10),PRITBL(10),PRFRMTB(10),PRGP(11)        CB19   5
      EQUIVALENCE (PRGP,IDSPR),(ANP,PRGP(11))                           CB19   6

C     COMMON DECK "CB20" INSERTED HERE                                  CB20   2
      INTEGER DPMX,DPNTBL,DPITBL,DPFRMTB,IDSDP(20) ! 5 Jun 2004         CB20   4
      COMMON/B20/DPMX,DPNTBL(10),DPITBL(10),DPFRMTB(10),DPGP(11)        CB20   5
      EQUIVALENCE (DPGP,IDSDP),(ANDP,DPGP(11))                          CB20   6
C                                                                       ATMOSH45
      PARAMETER (NBNRLS=10,NBLNS=10)                       ! 5 Jun 2004 ATMOSH46
C                                                                       ATMOSH47
      DATA BLANKS/' '/                                                  ATMOSH48
      DATA BANNER/                                                      ATMOSH49
     1  '***** H A R P A *****'                                         ATMOSH50
     2 ,'HAMILTONIAN ACOUSTIC RAY-TRACING PROGRAM FOR THE ATMOSPHERE'   ATMOSH51
     3 ,' '                                                             ATMOSH52
     4 ,'BY'                                                            ATMOSH53
     5 ,'R. M. JONES,  J. P. RILEY  AND  T. M. GEORGES'                 ATMOSH54
     6 ,'WAVE PROPAGATION LABORATORY'                                   ATMOSH55
     7 ,'NATIONAL OCEANIC AND ATMOSPHERIC ADMINISTRATION'               ATMOSH56
     8 ,'BOULDER, COLORADO 80303'                                       ATMOSH57
     9 ,' '                                                             5Jun2004
     1 ,'PC VERSION 7/1/90 BY T. M. GEORGES, R. M. JONES AND R. S. LAWRE5Jun2004
     2NCE'/                                                             5Jun2004
      DATA NOPUNCH/.FALSE./                                             ATMOSH58
      DATA IBLK/1H /                                                    ATMOSH59
C                                                                       ATMOSH60
C ----------------------------------------------------------------------!-------
      ENTRY HEADER1                                                     ATMOSH61
C ----------------------------------------------------------------------!-------
C                                                                       ATMOSH62
C     COMPUTE EFFECTIVE LINES COUNT BASED ON FIXED PAGE SIZE            ATMOSH63
      CALL NEWPAG(NPAG,INT(PAGLN),PC)                                   ATMOSH64
      CALL SFILL(DIVIDR,LEN(DIVIDR),'-')                                ATMOSH65
      DIVIDR(1:1)=' '                                                   ATMOSH66
!  9 Mar 2012      NTYP=2                                               ATMOSH67
!  9 Mar 2012      IF(RAY.NE.0.D0) NTYP=2.D0+DSIGN(1.D0,RAY)!5 Jun 2004 ATMOSH68
      NTYP=3.D0+RAY                                                !  9 Mar 2012
C                                                                       ATMOSH69
1600  FORMAT(2(2(A8,F7.1,1X),2X))                                       ATMOSH70
C%      CALL PUTKST(3,'1'                                  ! 5 Jun 2004 ATMOSH71
C%     1  //DAT//TOD//BLANKS(:100)//'PAGE'//NUMSTG(NPAG,1,'(I5)'))  ! 5 Jun 2004
      call pcodes (pc,typ)                                          ! 5 Jun 2004
      call putkst(3,typ//pc)                                        ! 5 Jun 2004
      strg5=blanks(:3)//dat//tod//blanks(:100)//'PAGE'              ! 5 Jun 2004
     1 //numstg(npag,1,'(i4)')                                      ! 5 Jun 2004
      call putkst(3,strg5)                                          ! 5 Jun 2004
      CALL PUTKST(3,DIVIDR)                                             ATMOSH73
      CALL PUTKBK(3,1)                                                  ATMOSH74
      DO 15 I=1,NBNRLS                                                  ATMOSH75
15    CALL PUTKCT(3,BANNER(I))                                          ATMOSH76
      CALL PUTKBK(3,1)                                                  ATMOSH77
      CALL PUTKST(3,DIVIDR)                                             ATMOSH78
      CALL PUTKBK(3,NBLNS)                                              ATMOSH79
C                                                                       ATMOSH80
C%      CALL PUTKST(3,BLANKS(:57)//'RUN SET NUMBER'                       ATMOSH81
C%     1  //NUMSTG(NSET,1,'(I5)'))                                        ATMOSH82
      strg5=blanks(:57)//'RUN SET NUMBER'//numstg(nset,1,'(i5)')    ! 5 Jun 2004
      call putkst (3,strg5)                                         ! 5 Jun 2004
      CALL PUTKBK(3,1)                                                  ATMOSH83
C*    WRITE(STMP,'(10A8)') ID                                           ATMOSH84
      WRITE(STMP,'(A80)') ID                                        ! 5 Jun 2004
      CALL PUTKST(3,BLANKS(:52)//'ATMOSPHERIC MODEL ID -- '//STMP(:3))  ATMOSH85
      CALL PUTKBK(3,1)                                                  ATMOSH86
      CALL PUTKST(3,                                                    ATMOSH87
     1 BLANKS(:25)//'ATMOSPHERIC MODEL DESCRIPTION -- '//STMP(7:))      ATMOSH88
      CALL PUTKBK(3,1)                                                  ATMOSH89
C                                                                       ATMOSH90
      IF(NTYP.GT.0.AND.NTYP.LE.3) THEN                             !  9 Mar 2012
      WRITE(STMP,'(2A8)') (RAYNAME(I,NTYP),I=1,2)                       ATMOSH91
      ELSE                                                         !  9 Mar 2012
      WRITE(STMP,'(A8,I3,5X)') '    Root',INT(RAY)                 !  9 Mar 2012
      ENDIF                                                        !  9 Mar 2012
      CALL PUTKST(3,STMP)                                               ATMOSH92
      CALL PUTKBK(3,1)                                                  ATMOSH93
      CALL PUTKST(3,DIVIDR)                                             ATMOSH94
      CALL PUTKBK(3,1)                                                  ATMOSH95
      CALL PUTKST(3,                                                    ATMOSH96
     1  BLANKS(:8)//'MODEL                 SUBROUTINE    DATA SET'      ATMOSH97
     1  //'       DESCRIPTION')                                         ATMOSH98
      CALL PUTKST(3,                                                    ATMOSH99
     1  BLANKS(:8)//'TYPE                     NAME         ID')         ATMOS100
      CALL PUTKBK(3,1)                                                  ATMOS101
      CALL PUTKST(3,DIVIDR)                                             ATMOS102
      CALL PUTKBK(3,1)                                                  ATMOS103
      CALL PUTKST(3,' DISPERSION RELATION           '//DISPM            ATMOS104
     1  //BLANKS(:16)//MODRIN )                            ! 5 Jun 2004 ATMOS105
C*     1  //BLANKS(:16)//NUMSTG(MODRIN,8,'(8A8)'))         ! 5 Jun 2004 ATMOS105
      CALL PUTDES(3,'BACKGROUND WIND VELOCITY',MODU,IDSU)               ATMOS106
      CALL PUTDES(3,'WIND VELOCITY PERTURBATION',MODU(3),IDSDU)         ATMOS107
      CALL PUTDES(3,'BACKGROUND SOUND SPEED',MODC,IDSC)                 ATMOS108
      CALL PUTDES(3,'SOUND SPEED PERTURBATION',MODC(3),IDSDC)           ATMOS109
C                                                                   ! 5 Jun 2004
      CALL PUTDES(3,'BACKGROUND TEMPERATURE',MODT,IDST)                 ATMOS110
      CALL PUTDES(3,'TEMPERATURE PERTURBATION',MODT(3),IDSDT)           ATMOS111
      CALL PUTDES(3,'BACKGROUND GRAVITY',MODGV,IDSA)                ! 2 Feb 2006
      CALL PUTDES(3,'GRAVITY PERTURBATION',MODGV(3),IDSDA)          ! 2 Feb 2006
      CALL PUTDES(3,'BACKGROUND DENSITY',MODDS,IDSD)                ! 2 Feb 2006
      CALL PUTDES(3,'DENSITY PERTURBATION',MODDS(3),IDSDD)          ! 2 Feb 2006
      CALL PUTDES(3,'MOLECULAR WEIGHT',MODM,IDSM)                       ATMOS112
      CALL PUTDES(3,'BACKGROUND TERRAIN',MODG,IDSG)                     ATMOS113
      CALL PUTDES(3,'TERRAIN PERTURBATION',MODG(3),IDSDG)               ATMOS114
      CALL PUTKST(3,' BACKGROUND VISCOSITY/')                           ATMOS115
      CALL PUTDES(3,'  THERMAL CONDUCTIVITY',MODL,IDSV)    ! 5 Jun 2004 ATMOS116
      CALL PUTKST(3,' VISCOSITY/THERMAL')                               ATMOS117
      CALL PUTDES(3,'  CONDUCTIVITY PERTURBATION',MODL(3),IDSDV)    ! 5 Jun 2004
      CALL PUTDES(3,'BACKGROUND PRESSURE',MODP,IDSPR)                   ATMOS119
      CALL PUTDES(3,'PRESSURE PERTURBATION',MODP(3),IDSDP)              ATMOS120
      CALL PUTDES(3,'RECEIVER SURFACE',MODREC,IDSR)                     ATMOS121
      CALL PUTDES(3,'OCEAN SURFACE',MODSURF,IDSS)                   ! 5 Jun 2004
      CALL PUTDES(3,'OCEAN SURFACE PERTURBATION',MODSURF(3),IDSDS)  ! 5 Jun 2004
      CALL PUTKST(3,DIVIDR)                                             ATMOS122
C                                                                       ATMOS123
c      NOPUNCH=NOPUNCH.AND.RAYSET.LT.0.0                                ATMOS124
      NOPUNCH=NOPUNCH.or.RAYSET.Le.0.0                             ! 26 Jul 2006
      IF(NOPUNCH) RETURN                                                ATMOS125
c      NOPUNCH=RAYSET.LT.0.0                                            ATMOS126
      NOPUNCH=RAYSET.Le.0.0                                        ! 26 Jul 2006
C                                                                       ATMOS127
C*    WRITE(9,1200) ID,DAT,TOD                                          ATMOS128
      WRITE(9,1201) ID,DAT,TOD                                      ! 5 Jun 2004
1201  FORMAT(A80,2(A10,2X))                                         ! 5 Jun 2004
      WRITE(9,1600) MODU,MODC,MODT,MODM(1),MODM(2)        ! 21 Feb 2006 ATMOS129
     1 ,MODREC(1),MODREC(2),MODP,MODL                     ! 21 Feb 2006         
      WRITE(9,1600) MODGV,MODDS, MODG,MODSURF             ! 21 Feb 2006 ATMOS130
      IF(IDSU(1) .NE. IBLK) WRITE(9,1205) IDSU             ! 5 Jun 2004 ATMOS131
      IF(IDSDU(1) .NE. IBLK) WRITE(9,1205) IDSDU           ! 5 Jun 2004 ATMOS132
      IF(IDSC(1) .NE. IBLK) WRITE(9,1205) IDSC             ! 5 Jun 2004 ATMOS133
      IF(IDSDC(1) .NE. IBLK) WRITE(9,1205) IDSDC           ! 5 Jun 2004 ATMOS134
      IF(IDST(1) .NE. IBLK) WRITE(9,1205) IDST             ! 5 Jun 2004 ATMOS135
      IF(IDSDT(1) .NE. IBLK) WRITE(9,1205) IDSDT           ! 5 Jun 2004 ATMOS136
      IF(IDSA(1) .NE. IBLK) WRITE(9,1205) IDSA             ! 3 Feb 2006 
      IF(IDSDA(1) .NE. IBLK) WRITE(9,1205) IDSDA           ! 3 Feb 2006 
      IF(IDSD(1) .NE. IBLK) WRITE(9,1205) IDSD             ! 3 Feb 2006 
      IF(IDSDD(1) .NE. IBLK) WRITE(9,1205) IDSDD           ! 21 Feb 2006 
      IF(IDSM(1) .NE. IBLK) WRITE(9,1205) IDSM             ! 5 Jun 2004 ATMOS137
      IF(IDSR(1) .NE. IBLK) WRITE(9,1205) IDSR             ! 21 Feb 2006
      IF(IDSG(1) .NE. IBLK) WRITE(9,1205) IDSG             ! 5 Jun 2004 ATMOS138
      IF(IDSDG(1) .NE. IBLK) WRITE(9,1205) IDSDG           ! 21 Feb 2006
      IF(IDSV(1) .NE. IBLK) WRITE(9,1205) IDSV             ! 5 Jun 2004 ATMOS138
      IF(IDSDV(1) .NE. IBLK) WRITE(9,1205) IDSDV           ! 21 Feb 2006
      IF(IDSPR(1) .NE. IBLK) WRITE(9,1205) IDSPR                    ! 2 Jun 2004
      IF(IDSDP(1) .NE. IBLK) WRITE(9,1205) IDSDP                    ! 2 Jun 2004
      IF(IDSS(1) .NE. IBLK) WRITE(9,1205) IDSS                      ! 2 Jun 2004
      IF(IDSDS(1) .NE. IBLK) WRITE(9,1205) IDSDS                    ! 2 Jun 2004
C                                                                       ATMOS139
 1000 FORMAT (A1/A80,21X,2A10,' PAGE',I4)                  ! 5 Jun 2004 ATMOS140
1200  FORMAT(10A8,2(A10,2X))                               ! 5 Jun 2004 ATMOS141
1205  format (20A4)                                                 ! 5 Jun 2004
C                                                                       ATMOS142
      RETURN                                                            ATMOS143
C                                                                       ATMOS144
      ENTRY HEADER2                                                     ATMOS145
C                                                                       ATMOS146
C     COMPUTE EFFECTIVE LINES COUNT BASED ON FIXED PAGE SIZE            ATMOS147
      CALL NEWPAG(NPAG,INT(PAGLN),PC)                                   ATMOS148
      LINES=LINES+5                                                     ATMOS149
C                                                                       ATMOS150
      WRITE(3,1000) PC,ID,DAT,TOD,NPAG                                  ATMOS151
      WRITE(3,2400) SNGL(AZ1*DEGS),SNGL(TLAT*DEGS),SNGL(OW/PIT2),       5Jun2004
     1        SNGL(BETA*DEGS)                                           5Jun2004
     1        ,SNGL(TLON*DEGS),MAXERR                                   5Jun2004
 2400 FORMAT (                                                          ATMOS154
     1  /' AZIMUTH ANGLE OF TRANSMISSION   =',F12.6,' DEG'              ATMOS155
     2  ,'   TRANSMITTER  LATITUDE  =',F12.6,' DEG'                     ATMOS156
     3  ,'    FREQUENCY =',F20.8,' HZ'                ! 5 Jun 2004 ! 15 Mar 2011
     4  /' ELEVATION ANGLE OF TRANSMISSION =',F12.6,' DEG'              ATMOS158
     5  ,'   TRANSMITTER  LONGITUDE =',F12.6,' DEG'                     ATMOS159
     6  ,'    SINGLE STEP ERROR =',1PG13.6/)                            ATMOS160
C                                                                       ATMOS161
      RETURN                                                            ATMOS162
C                                                                       ATMOS163
C ----------------------------------------------------------------------!-------
      ENTRY PUTDVR(NUNIT)                                               ATMOS164
C ----------------------------------------------------------------------!-------
      CALL PUTKST(NUNIT,DIVIDR)                                         ATMOS165
      RETURN                                                            ATMOS166
C                                                                       ATMOS167
C
C ----------------------------------------------------------------------!-------
      ENTRY PUTHDR(NUNIT,PCC,NP)                                        ATMOS168
C ----------------------------------------------------------------------!-------
C%      CALL PUTKST(NUNIT,                                 ! 5 Jun 2004 ATMOS169
C%     1  PCC//DAT//TOD//BLANKS(:100)//'PAGE'//NUMSTG(NP,1,'(I5)')) ! " ATMOS170
      strg5=pcc//blanks(:2)//dat//tod//blanks(:100)//'PAGE'         ! 5 Jun 2004
     1 //numstg(np,1,'(i4)')                                        ! 5 Jun 2004
      call putkst(nunit,strg5)                                      ! 5 Jun 2004
      RETURN                                                            ATMOS171
C ----------------------------------------------------------------------!-------
      END SUBROUTINE ATMOSHD                                            ATMOS172
C ----------------------------------------------------------------------!-------
