



      SUBROUTINE ATMOSHD                                                ATMOSHD2

c

      implicit real*8 (a-h,o-z)

c

C     PRINTS PAGE HEADINGS                                              ATMOSHD3

c

      real*8 mgp

c

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

      character*80 rnumstg

      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*8 moda

c     REAL MODA                                                         CAA    4

      REAL*8 MU,MUPT,MUPR,MUPTH,MUPPH                                   CAA    5

      REAL*8 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*8 modp

c     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*8 modsurf

c     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

      real*8 id

      COMMON/WW/ID(10),MAXW,W(NWARSZ)                                   CWW1   4

      REAL*8 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*8 modg

c     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*8 modrec 

c     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(20)                          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)                      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)                      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)                      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)                          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)                          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)                          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)                          CB7    4

c     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*8 KAY2,KAY2I                                                 CRINPLE4

      COMPLEX*16 PNP,POLAR,LPOLAR                                       CRINPLE5

      LOGICAL SPACE                                                     CRINPLE6

      CHARACTER DISPM*6                                                 CRINPLE7

      COMMON/RINPL/DISPM                                                CRINPLE8

      real*8 modrin

      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*8 modc

c     REAL MODC                                                         CCC    4

      COMMON/CC/MODC(4),CS,PCST,PCSR,PCSTH,PCSPH                        CCC    5

C     COMMON DECK "MM" INSERTED HERE                                    CMM    2

      real*8 modm

      REAL M                                                            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*8 modt

c     REAL MODT                                                         CTT    4

      COMMON/TT/MODT(4), T,PTT,PTR,PTTH,PTPH                            CTT    5

C     COMMON DECK "UU" INSERTED HERE                                    CUU    2

      real*8 modu

c     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(20)                      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)                          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(20)                          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)                      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)                      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)                      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

      xxx = 1.0

      IF(RAY.NE.0.0) NTYP=2.0+DSIGN(xxx,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)//RNUMSTG(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,2A10,' 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











      SUBROUTINE PUTDES(NUNIT,DES,MOD,ID)                               PUTDES 2

c

      implicit real*8 (a-h,o-z)

c

      CHARACTER DES*(*),TITLE*30,SMODL*20, NUMSTG*80                    PUTDES 3

      real*8 mod(2)

c     REAL MOD(2)                                                       PUTDES 4

c     real*8 id(10)

      TITLE=DES                                                         PUTDES 5

      WRITE(SMODL,'(A8,F10.2)') MOD                                     PUTDES 6

      CALL PUTKST(NUNIT, ' '//TITLE//SMODL// NUMSTG(ID,20,'(20A4)'))    PUTDES 7

      END                                                               PUTDES 8











      CHARACTER*80 FUNCTION NUMSTG(V,N,FRM)                             NUMSTG 2

      INTEGER V(N)                                                      NUMSTG 3

      CHARACTER FRM*(*)                                                 NUMSTG 4

      NUMSTG=' '                                                        NUMSTG 5

      WRITE(NUMSTG,FRM) V                                               NUMSTG 6

      RETURN                                                            NUMSTG 7

      END                                                               NUMSTG 8









      CHARACTER*80 FUNCTION RNUMSTG(V,N,FRM)                            NUMSTG 2

      real*8 v(n)

c     INTEGER V(N)                                                      NUMSTG 3

      CHARACTER FRM*(*)                                                 NUMSTG 4

      RNUMSTG=' '                                                       NUMSTG 5

      WRITE(RNUMSTG,FRM) V                                              NUMSTG 6

      RETURN                                                            NUMSTG 7

      END                                                               NUMSTG 8











      SUBROUTINE SFILL(STG,LN,C)                                        SFILL  2

      CHARACTER STG*(*),C*1                                             SFILL  3

C                                                                       SFILL  4

      DO 10 I=1,LN                                                      SFILL  5

10    STG(I:I)=C                                                        SFILL  6

      RETURN                                                            SFILL  7

      END                                                               SFILL  8











      INTEGER FUNCTION STRIM(C)                                         STRIM  2

      CHARACTER*(*) C                                                   STRIM  3

C                                                                       STRIM  4

      L=LEN(C)                                                          STRIM  5

      DO 100 I=L,1,-1                                                   STRIM  6

100   IF(C(I:I) .NE. ' ') GO TO 200                                     STRIM  7

      I=0                                                               STRIM  8

200   STRIM=I                                                           STRIM  9

      END                                                               STRIM 10











      FUNCTION RERR(V,ERT,ELAB,NKV,PREF)                                RERR   2

c

      implicit real*8 (a-h,o-z)

c

C     RETURNS RELATIVE ERROR OF VARIABLE RKVAR(NKV) IF PREF<>0 AND      RERR   3

C     THE ERROR IS GREATER THAN PREVIOUS ERROR 'V'.                     RERR   4

C     COMMON DECK "RKAM" INSERTED HERE                                  RKAMCOM2

      REAL*8 KR,KTH,KPH                                                 RKAMCOM4

      COMMON//R,TH,PH,KR,KTH,KPH,RKVARS(14),TPULSE,CSTEP,DRDT(20)       RKAMCOM5

C                                                                       RERR   6

      RERR=V                                                            RERR   7

      IF(NKV.LE.0) RETURN                                               RERR   8

      IF(PREF.EQ.0.) RETURN                                             RERR   9

      V1=RKVARS(NKV)/PREF-1.                                            RERR  10

      IF(DABS(V1).LT.DABS(V)) RETURN                                    RERR  11

C                                                                       RERR  12

      ERT=ELAB                                                          RERR  13

      RERR=V1                                                           RERR  14

      END                                                               RERR  15











      SUBROUTINE RERROR(ROUTIN,STR,VAL)                                 RERROR 2

c

      implicit real*8 (a-h,o-z)

c

C     REPORTS ERROR CONDITIONS AND STOPS PROGRAM.                       RERROR 3

C                                                                       RERROR 4

      PRINT 10,ROUTIN,STR,VAL                                           RERROR 5

10    FORMAT(39H ERROR CONDITION IN RAYTRACE ROUTINE <                  RERROR 6

     1  ,A8,10H> DUE TO " ,A10,9H", VALUE=  ,F8.2)                      RERROR 7

      STOP                                                              RERROR 8

      END                                                               RERROR 9











      SUBROUTINE STOPIT(A)                                              STOPIT 2

C     PRINTS CONDITION AND STOPS PROGRAM                                STOPIT 3

C     AFTER CALLING THE SYSTEM POST MORTEM DUMP.                        STOPIT 4

C                                                                       STOPIT 5

      CHARACTER A*(*)                                                   STOPIT 6

C                                                                       STOPIT 7

      PRINT 100, A                                                      STOPIT 8

      CALL MORTEM                                                       STOPIT 9

100   FORMAT('*** STOPIT WITH CONDITION <',A,'>')                       STOPIT10

      STOP                                                              STOPIT11

      END                                                               STOPIT12











      SUBROUTINE PUTKST(NUNIT,STRG)                                     PUTKST 2

c

      implicit real*8 (a-h,o-z)

c

C     WRITE LINE OF OUTPUT TO PRINTER UNIT ADDING TO LINE COUNT         PUTKST 3

C                                                                       PUTKST 4

      CHARACTER STRG*(*)                                                PUTKST 5

      CHARACTER BLANKS*100,STMP*80                                      PUTKST 6

      INTEGER STRIM                                                     PUTKST 7

      CHARACTER PC*1                                                    PUTKST 8

C                                                                       PUTKST 9

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                                                                       PUTKST11

      DATA BLANKS/' '/                                                  PUTKST12

C                                                                       PUTKST13

C     PUT OUT A STRING WITH LINE COUNT INCREMENT                        PUTKST14

      LINES=LINES+1                                                     PUTKST15

      LN=MIN0(LEN(STRG),132)                                            PUTKST16

      WRITE(NUNIT,'(A)') STRG(:LN)                                      PUTKST17

      RETURN                                                            PUTKST18

C                                                                       PUTKST19

      ENTRY PUTKCT(NUNIT,STRG)                                          PUTKST20

C     PUT OUT A CENTERED LINE AND COUNT                                 PUTKST21

      NTRM=MAX0(1,STRIM(STRG))                                          PUTKST22

      NBLKS=66-(NTRM+1)/2                                               PUTKST23

      LINES=LINES+1                                                     PUTKST24

      LN=MIN0(NTRM,132-NBLKS)                                           PUTKST25

      STMP=STRG                                                         PUTKST26

      WRITE(NUNIT,'(A)') BLANKS(:NBLKS)//STMP(:LN)                      PUTKST27

      RETURN                                                            PUTKST28

      ENTRY PUTKBK(NUNIT,NBKS)                                          PUTKST29

C     PUT A BLANK LINE TO PRINTER                                       PUTKST30

C                                                                       PUTKST31

      LINES=LINES+1                                                     PUTKST32

      DO 100 I=1,NBKS                                                   PUTKST33

100      WRITE(NUNIT,'(1X)')                                            PUTKST34

      RETURN                                                            PUTKST35

C                                                                       PUTKST36

      ENTRY NEWPAG(NP,LINSPP,PC)                                        PUTKST37

C     THE LOGIC HERE ASSUMES THAT A FORM FEED IS ALWAYS NEEDED          PUTKST38

      PC='1'                                                            PUTKST39

C     COMPUTE EFFECTIVE LINES COUNT AFTER NEXT FORM FEED                PUTKST40

      NPAG=(LINES+LINSPP-1)/LINSPP                                      PUTKST41

      LINES=NPAG*LINSPP                                                 PUTKST42

      NP=NPAG+1                                                         PUTKST43

      RETURN                                                            PUTKST44

      END                                                               PUTKST45











      SUBROUTINE OPNREP(IUN,FNAME)                                      OPNREP 2

C     CYBER VERSION OF OPEN FOR REPLACE                                 OPNREP 3

C     SINCE THIS OPERATION SEEMS TO BE COMPILER DEPENDENT               OPNREP 4

C     WE MAKE A SUBROUTINE OUT OF IT.                                   OPNREP 5

C     THIS OPEN OPERATION ALLOWS FOR AN EXISTING VERSION OF             OPNREP 6

C     A FILE. IF THE FILE EXISTS IT IS OVERWRITTEN.                     OPNREP 7

      CHARACTER*(*) FNAME                                               OPNREP 8

      OPEN(IUN,FILE=FNAME)                                              OPNREP 9

      REWIND IUN                                                        OPNREP10

      RETURN                                                            OPNREP11

      ENTRY OPNURP(IUN,FNAME)                                           OPNREP12

      OPEN(IUN,FILE=FNAME,FORM='UNFORMATTED')                           OPNREP13

      REWIND IUN                                                        OPNREP14

      END                                                               OPNREP15











      SUBROUTINE OVERRD(VAR,TST,DEFT,NFLG,NFVLEQ,NFVLNE)                OVERRD 2

c

      implicit real*8 (a-h,o-z)

c

C                                                                       OVERRD 3

C     OVERRIDE SUPPORT ROUTINE                                          OVERRD 4

C     TEST 'VAR' AGAINST 'TST', IF EQUAL SET TO DEFAULT 'DEFT'          OVERRD 5

C     AND ALSO SET INTEGER FLAG 'NFLG' TO VALUE 'NFVLEQ' ELSE 'NFVLNE'  OVERRD 6

C                                                                       OVERRD 7

      IF(VAR.EQ.TST) THEN                                               OVERRD 8

         VAR=DEFT                                                       OVERRD 9

         NFLG=NFVLEQ                                                    OVERRD10

      ELSE                                                              OVERRD11

         NFLG=NFVLNE                                                    OVERRD12

      ENDIF                                                             OVERRD13

      RETURN                                                            OVERRD14

      END                                                               OVERRD15











      FUNCTION ALCOSH(X)                                                ALCOSH 2

c

      implicit real*8 (a-h,o-z)

c

C     COMPUTE LOG(COSH(X)) AND USE LARGE ARGUMENT APPROXIMATION         ALCOSH 3

C     WHEN POSSIBLE.                                                    ALCOSH 4

      DATA ALOG2/.6931471806/                                           ALCOSH 5

C                                                                       ALCOSH 6

      IF(DABS(X).GT.50.0) GO TO 10                                      ALCOSH 7

      EX=DEXP(X)                                                        ALCOSH 8

      ALCOSH=DLOG((EX+1.0/EX)*.5)                                       ALCOSH 9

      RETURN                                                            ALCOSH10

10    ALCOSH=DABS(X)-ALOG2                                              ALCOSH11

      END                                                               ALCOSH12











      SUBROUTINE SFILTR(C,S,KSET)                                       SFILTR 2

      CHARACTER*(*) C,S,KSET                                            SFILTR 3

C                                                                       SFILTR 4

      LN=LEN(C)                                                         SFILTR 5

      J=0                                                               SFILTR 6

      DO 10 I=1,LN                                                      SFILTR 7

        IF(INDEX(KSET,C(I:I)).EQ.0) THEN                                SFILTR 8

           J=J+1                                                        SFILTR 9

           S(J:J)=C(I:I)                                                SFILTR10

        ENDIF                                                           SFILTR11

10    CONTINUE                                                          SFILTR12

      RETURN                                                            SFILTR13

      END                                                               SFILTR14







