C file HARPA\ATMOSHD.ORG
C**************************************************************************** 
C This is the same as the 1986 version of ATMOSHD.FOR from file CAFILE1 
C that was in HARPA 
C**************************************************************************** 
      SUBROUTINE ATMOSHD                                                ATMOSHD2
C     PRINTS PAGE HEADINGS                                              ATMOSHD3
C     IF W(72) IS NEGATIVE, ONLY ONE HEADER OUTPUT IS INCLUDED IN RAYSE ATMOSHD4
      CHARACTER PCC*1,PC*1,BLANKS*100,DIVIDR*132,BANNER(8)*80           ATMOSHD5
      CHARACTER NUMSTG*80,STMP*80                                       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
      REAL MODA                                                         CAA    4
      REAL MU,MUPT,MUPR,MUPTH,MUPPH                                     CAA    5
      REAL KAP,KAPPT,KAPPR,KAPPTH,KAPPPH                                CAA    6
      COMMON/AA/MODA(4),MU,MUPT,MUPR,MUPTH,MUPPH                        CAA    7
      COMMON/AA/KAP,KAPPT,KAPPR,KAPPTH,KAPPPH                           CAA    8
C     COMMON DECK "PP" INSERTED HERE                                    CPP    2
      REAL MODP                                                         CPP    4
      COMMON/PP/MODP(4),P,PPT,PPR,PPTH,PPPH                             CPP    5
C                                                                       ATMOSH17
C     COMMON DECK "SS" INSERTED HERE                                    CSS    2
      REAL MODSURF                                                      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
      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/ID(10),MAXW,W(NWARSZ)                                   CWW1   4
      REAL MAXSTP,MAXERR,INTYP,LLAT,LLON                                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 (RCVRH,W(20)),                                                   CWW2   7
     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
      REAL MODG                                                         CGG    4
      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
      REAL MODREC                                                       CRR    4
      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(10)                          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(10)                      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(10)                      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(10)                      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(10)                          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(10)                          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(10)                          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(10)                          CB7    4
      REAL MGP                                                          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*10 INITID*80,DAT,TOD                                    CHDR   4
      COMMON/HDR/SEC                                                    CHDR   5
      COMMON/HDRC/INITID,DAT,TOD                                        CHDR   6
C     COMMON DECK "RINPLEX" INSERTED HERE                               CRINPLE2
      REAL KAY2,KAY2I                                                   CRINPLE4
      COMPLEX PNP,POLAR,LPOLAR                                          CRINPLE5
      LOGICAL SPACE                                                     CRINPLE6
      CHARACTER DISPM*6                                                 CRINPLE7
      COMMON/RINPL/DISPM                                                CRINPLE8
      COMMON /RIN/ MODRIN(8),RAYNAME(2,3),TYPE(3),SPACE                 CRINPLE9
      COMMON/RIN/OMEGMIN,OMEGMAX,KAY2,KAY2I                             CRINPL10
      COMMON/RIN/PNP(10),POLAR,LPOLAR,SGN                               CRINPL11
C     COMMON DECK "CC" INSERTED HERE                                    CCC    2
      REAL MODC                                                         CCC    4
      COMMON/CC/MODC(4),CS,PCST,PCSR,PCSTH,PCSPH                        CCC    5
C     COMMON DECK "MM" INSERTED HERE                                    CMM    2
      REAL M,MODM                                                       CMM    4
      COMMON/MM/MODM(4),M,PMT,PMR,PMTH,PMPH                             CMM    5
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
      REAL MODT                                                         CTT    4
      COMMON/TT/MODT(4), T,PTT,PTR,PTTH,PTPH                            CTT    5
C     COMMON DECK "UU" INSERTED HERE                                    CUU    2
      REAL MODU                                                         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                                                                       ATMOSH38
C     COMMON DECK "B10" INSERTED HERE                                   CB9    2
      INTEGER DGMX,DGNTBL,DGITBL,DGFRMTB,IDSDG(10)                      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(10)                          CB10   4
      COMMON/B8/RMX,RNTBL(10),RITBL(10),RFRMTBL(10),RGP(10)             CB10   5
      EQUIVALENCE (RGP,IDSR)                                            CB10   6
C     COMMON DECK "CB17" INSERTED HERE                                  CB17   2
      INTEGER VMX,VNTBL,VITBL,VFRMTBL,IDSV(10)                          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(10)                      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(10)                      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(10)                      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=8,NBLNS=8)                                      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
      DATA NOPUNCH/.FALSE./                                             ATMOSH58
      DATA IBLK/1H /                                                    ATMOSH59
C                                                                       ATMOSH60
      ENTRY HEADER1                                                     ATMOSH61
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
      NTYP=2                                                            ATMOSH67
      IF(RAY.NE.0.0) NTYP=2.0+SIGN(1.0,RAY)                             ATMOSH68
C                                                                       ATMOSH69
1600  FORMAT(2(2(A8,F7.1,1X),2X))                                       ATMOSH70
      CALL PUTKST(3,'1'                                                 ATMOSH71
     1  //DAT//TOD//BLANKS(:100)//'PAGE'//NUMSTG(NPAG,1,'(I5)'))        ATMOSH72
      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
      CALL PUTKST(3,BLANKS(:57)//'RUN SET NUMBER'                       ATMOSH81
     1  //NUMSTG(NSET,1,'(I5)'))                                        ATMOSH82
      CALL PUTKBK(3,1)                                                  ATMOSH83
      WRITE(STMP,'(10A8)') ID                                           ATMOSH84
      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
      WRITE(STMP,'(2A8)') (RAYNAME(I,NTYP),I=1,2)                       ATMOSH91
      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)//NUMSTG(MODRIN,8,'(8A8)'))                        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
      CALL PUTDES(3,'BACKGROUND TEMPERATURE',MODT,IDST)                 ATMOS110
      CALL PUTDES(3,'TEMPERATURE PERTURBATION',MODT(3),IDSDT)           ATMOS111
      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',MODA,IDSV)                 ATMOS116
      CALL PUTKST(3,' VISCOSITY/THERMAL')                               ATMOS117
      CALL PUTDES(3,'  CONDUCTIVITY PERTURBATION',MODA(3),IDSDV)        ATMOS118
      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 PUTKST(3,DIVIDR)                                             ATMOS122
C                                                                       ATMOS123
      NOPUNCH=NOPUNCH.AND.RAYSET.LT.0.0                                 ATMOS124
      IF(NOPUNCH) RETURN                                                ATMOS125
      NOPUNCH=RAYSET.LT.0.0                                             ATMOS126
C                                                                       ATMOS127
      WRITE(9,1200) ID,DAT,TOD                                          ATMOS128
      WRITE(9,1600) MODU,MODC,MODT,MODM,MODP,MODA                       ATMOS129
     1    ,MODG,MODREC                                                  ATMOS130
      IF(IDSU(1) .NE. IBLK) WRITE(9,1200) IDSU                          ATMOS131
      IF(IDSDU(1) .NE. IBLK) WRITE(9,1200) IDSDU                        ATMOS132
      IF(IDSC(1) .NE. IBLK) WRITE(9,1200) IDSC                          ATMOS133
      IF(IDSDC(1) .NE. IBLK) WRITE(9,1200) IDSDC                        ATMOS134
      IF(IDST(1) .NE. IBLK) WRITE(9,1200) IDST                          ATMOS135
      IF(IDSDT(1) .NE. IBLK) WRITE(9,1200) IDSDT                        ATMOS136
      IF(IDSM(1) .NE. IBLK) WRITE(9,1200) IDSM                          ATMOS137
      IF(IDSG(1) .NE. IBLK) WRITE(9,1200) IDSG                          ATMOS138
C                                                                       ATMOS139
 1000 FORMAT (A1,10A8,24X,2A,' PAGE',I4)                                ATMOS140
1200  FORMAT(10A8,2(A8,2X))                                             ATMOS141
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) AZ1*DEGS,TLAT*DEGS,OW/PIT2,BETA*DEGS                ATMOS152
     1        ,TLON*DEGS,MAXERR                                         ATMOS153
 2400 FORMAT (                                                          ATMOS154
     1  /' AZIMUTH ANGLE OF TRANSMISSION   =',F12.6,' DEG'              ATMOS155
     2  ,'      TRANSMITTER  LATITUDE  =',F12.6,' DEG'                  ATMOS156
     3  ,'    FREQUENCY =',F12.6,' HZ'                                  ATMOS157
     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
      ENTRY PUTDVR(NUNIT)                                               ATMOS164
      CALL PUTKST(NUNIT,DIVIDR)                                         ATMOS165
      RETURN                                                            ATMOS166
C                                                                       ATMOS167
      ENTRY PUTHDR(NUNIT,PCC,NP)                                        ATMOS168
      CALL PUTKST(NUNIT,                                                ATMOS169
     1  PCC//DAT//TOD//BLANKS(:100)//'PAGE'//NUMSTG(NP,1,'(I5)'))       ATMOS170
      RETURN                                                            ATMOS171
      END                                                               ATMOS172
