SUBROUTINE HATCH
C                                VERSION 4.00  --  26 JAN 1986/1900
C******************************************************************
C   SETUP WHICH THE USER IS EXPECTED TO DO BEFORE CALLING HATCH IS:
C     1. SET 'NMED' TO THE NUMBER OF MEDIA TO BE USED.
C     2. SET THE ARRAY 'MEDIA', WHICH CONTAINS THE NAMES OF THE
C        MEDIA THAT ARE DESIRED.  THE CHARACTER FORMAT IS A1, SO
C        THAT MEDIA(IB,IM) CONTAINS THE IB'TH BYTE OF THE NAME OF
C        THE IM'TH MEDIUM IN A1 FORMAT.
C     3. SET 'DUNIT', THE DISTANCE UNIT TO BE USED.
C        DUNIT.GT.0 MEANS VALUE OF DUNIT IS LENGTH OF DISTANCE UNIT
C        CENTIMETERS.  DUNIT.LT.0 MEANS USE THE RADIATION LENGTH OF
C        THE ABS(DUNIT)'TH MEDIUM FOR THE DISTANCE UNIT.
C     4. FILL THE ARRAY 'MED' WITH THE MEDIUM INDICES FOR THE
C        REGIONS.
C     5. FILL ARRAYS 'ECUT' AND 'PCUT' WITH THE ELECTRON AND PHOTON
C        CUT-OFF ENERGIES FOR EACH REGION RESPECTIVELY.  SETUP WILL
C        RAISE THESE IF NECESSARY TO MAKE THEM AT LEAST AS LARGE AS
C        THE REGION'S MEDIUM'S AE AND AP RESPECTIVELY.
C     6. FILL 'MED' ARRAY.  MED(IR) IS THE MEDIUM INDEX FOR REGION
C        IR.  A ZERO MEDIUM INDEX MEANS THE REGION IS IN A VACUUM.
C     7. FILL THE ARRAY 'IRAYLR' WITH 1 FOR EACH REGION IN WHICH
C        RAYLEIGH (COHERENT) SCATTERING IS TO BE INCLUDED.
C******************************************************************
      CHARACTER MBUF*72,MDLABL*8
      DIMENSION ZEROS(3)
CNOTE: ABOVE IS ZEROS OF SINE, 0,PI,TWOPI
      COMMON/BOUNDS/ECUT(6),PCUT(6),VACDST
      COMMON/BREMPR/DL1(6),DL2(6),DL3(6),DL4(6),DL5(6),DL6(6),DELCM, ALP
     *HI(2),BPAR(2),DELPOS(2),PWR2I(50)
      COMMON/ELECIN/EKELIM,ICOMP,EKE0,EKE1,CMFP0,CMFP1,RANGE0,RANGE1, XR
     *0,TEFF0,BLCC,XCC,PICMP0(1),PICMP1(1),EICMP0(1),EICMP1(1),MPEEM(1),
     * ESIG0(500),ESIG1(500),PSIG0(500),PSIG1(500),EDEDX0(500),EDEDX1(50
     *0),PDEDX0(500),PDEDX1(500),EBR10(500),EBR11(500),PBR10(500),PBR11(
     *500),PBR20(500),PBR21(500),TMXS0(500),TMXS1(500),CMFPE0(1),CMFPE1(
     *1),CMFPP0(1),CMFPP1(1),ERANG0(1),ERANG1(1),PRANG0(1),PRANG1(1),CXC
     *2E0(1),CXC2E1(1),CXC2P0(1),CXC2P1(1),CLXAE0(1),CLXAE1(1),CLXAP0(1)
     *,CLXAP1(1), THR0(1,1),THR1(1,1),THR2(1,1),THRI0(1,1),THRI1(1,1),TH
     *RI2(1,1),FSTEP(16),FSQR(16),MSMAP(200), VERT1(1000),VERT2(100,16),
     *MSTEPS,JRMAX,MXV1, MXV2,NBLC,NRNTH,NRNTHI,BLC0,BLC1,RTHR0,RTHR1,RT
     *HRI0,RTHRI1
      COMMON /MEDIA/ NMED, RLC,RLDU,RLDUI,RHO,MSGE,MGE,MSEKE,MEKE,MLEKE,
     *MCMFP,MRANGE,IRAYLM,HBARO(6),HBAROI(6)
      CHARACTER MEDIA*24
      COMMON/MEDIAC/MEDIA
      COMMON/MISC/KMPI,KMPO,DUNIT,NOSCAT,MED(6),RHOR(6),IRAYLR(6)
      COMMON/PHOTIN/EBINDA,GE0,GE1, MPGEM(1),GMFP0(500),GMFP1(500),GBR10
     *(500),GBR11(500),GBR20(500),GBR21(500),GBR30(500),GBR31(500),GBR40
     *(500),GBR41(500),NGR,RCO0,RCO1, RSCT0(100),RSCT1(100), COHE0(500),
     *COHE1(500)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,
     *                 STEPFC,NRRUN,NSHOW,PATAPE,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,
     *                 CETAPE,
     *                 SHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,
     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE
     *                ,GHEISH,GHESIG
      COMMON /RUNPAC/  DSN,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB
      REAL             STEPFC
      INTEGER          NRRUN,NSHOW,PATAPE,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 SHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE
      INTEGER          CETAPE
      CHARACTER*79     DSN
      CHARACTER*20     HOST,USER
 
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE
     *                ,GHEISH,GHESIG
*KEEP,STACKE.
      COMMON/STACKE/   E,TIME,X,Y,Z,U,V,W,DNEAR,IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIME(60)
      REAL             X(60),Y(60),Z(60),U(60),V(60),W(60),DNEAR(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON/THRESH/RMT2,RMSQ,ESCD2,AP,API,AE,UP,UE,TE,THMOLL
      COMMON/UPHIIN/SINC0,SINC1,SIN0(20002),SIN1(20002)
      COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
      DOUBLE PRECISION PZERO,PRM,PRMT2,RMI,VC
      COMMON/USEFUL/PZERO,PRM,PRMT2,RMI,VC,RM,MEDIUM,MEDOLD,IBLOBE,ICALL
      DATA MDLABL/' MEDIUM='/,LMDL/8/,LMDN/24/,DUNITO/1./
      DATA I1ST/1/,NSINSS/37/,MXSINC/20002/,ISTEST/0/,NRNA/1000/
510   FORMAT(1X,14I5)
520   FORMAT(1X,1P,5E14.5)
530   FORMAT(A72)
      IF (I1ST.NE.0) THEN
       I1ST=0
       PRM=RM
       RMI=1./PRM
       PRMT2=2.D0*PRM
       PZERO=0.0D0
       NISUB=MXSINC-2
       FNSSS=NSINSS
       WID=PI5D2/REAL(NISUB)
       WSS=WID/(FNSSS-1.0)
       ZEROS(1)=0.
       ZEROS(2)=PI
       ZEROS(3)=TWOPI
        DO 541 ISUB=1,MXSINC
        SX=0.
        SY=0.
        SXX=0.
        SXY=0.
        XS0=WID*REAL(ISUB-2)
        XS1=XS0+WID
        IZ=0
         DO 551 IZZ=1,3
         IF ((XS0.LE.ZEROS(IZZ)).AND.(ZEROS(IZZ).LE.XS1)) THEN
          IZ=IZZ
          GO TO552
         END IF
551     CONTINUE
552     CONTINUE
        IF (IZ.EQ.0) THEN
         XSI=XS0
        ELSE
         XSI=ZEROS(IZ)
        END IF
         DO 561 ISS=1,NSINSS
         XS=WID*REAL(ISUB-2)+WSS*REAL(ISS-1)-XSI
         YS=SIN(XS+XSI)
         SX=SX+XS
         SY=SY+YS
         SXX=SXX+XS*XS
         SXY=SXY+XS*YS
561     CONTINUE
562     CONTINUE
        IF (IZ.NE.0) THEN
         SIN1(ISUB)=SXY/SXX
         SIN0(ISUB)=-SIN1(ISUB)*XSI
        ELSE
         DEL=FNSSS*SXX-SX*SX
         SIN1(ISUB)=(FNSSS*SXY-SY*SX)/DEL
         SIN0(ISUB)=(SY*SXX-SX*SXY)/DEL - SIN1(ISUB)*XSI
        END IF
541    CONTINUE
542    CONTINUE
       SINC0=2.0
       SINC1=1.0/WID
       IF (ISTEST.NE.0) THEN
        ADEV=0.
        RDEV=0.
        S2C2MN=10.
        S2C2MX=0.
         DO 571 ISUB=1,NISUB
          DO 581 ISS=1,NSINSS
          THETA=WID*REAL(ISUB-1)+WSS*REAL(ISS-1)
          CTHET=PI5D2-THETA
          LTHETA=SINC1*THETA+SINC0
          LCTHET=SINC1*CTHET+SINC0
          SINTHE=SIN1(LTHETA)*THETA+SIN0(LTHETA)
          COSTHE=SIN1(LCTHET)*CTHET+SIN0(LCTHET)
          SINT=SIN(THETA)
          COST=COS(THETA)
          ASD=ABS(SINTHE-SINT)
          ACD=ABS(COSTHE-COST)
          ADEV=MAX(ADEV,ASD,ACD)
          IF((SINT.NE.0.0))RDEV=MAX(RDEV,ASD/ABS(SINT))
          IF((COST.NE.0.0))RDEV=MAX(RDEV,ACD/ABS(COST))
          S2C2=SINTHE**2+COSTHE**2
          S2C2MN=MIN(S2C2MN,S2C2)
          S2C2MX=MAX(S2C2MX,S2C2)
          IF (ISUB.LT.11) THEN
           WRITE(KMPO,590)THETA,SINTHE,SINT,COSTHE,COST
590        FORMAT(1P,5E20.7)
          END IF
581      CONTINUE
582      CONTINUE
571     CONTINUE
572     CONTINUE
        WRITE(KMPO,600)MXSINC,NSINSS
600     FORMAT(' SINE TESTS,MXSINC,NSINSS=',2I5)
        WRITE(KMPO,610)ADEV,RDEV,S2C2MN,S2C2MX
610     FORMAT(' ADEV,RDEV,S2C2(MN,MX) =',1P,4E16.8)
        ADEV=0.
        RDEV=0.
        S2C2MN=10.
        S2C2MX=0.
         DO 621 IRN=1,NRNA
         CALL RMMAR(THETA,1,2)
         THETA=THETA*PI5D2
         CTHET=PI5D2-THETA
         LTHETA=SINC1*THETA+SINC0
         LCTHET=SINC1*CTHET+SINC0
         SINTHE=SIN1(LTHETA)*THETA+SIN0(LTHETA)
         COSTHE=SIN1(LCTHET)*CTHET+SIN0(LCTHET)
         SINT=SIN(THETA)
         COST=COS(THETA)
         ASD=ABS(SINTHE-SINT)
         ACD=ABS(COSTHE-COST)
         ADEV=MAX(ADEV,ASD,ACD)
         IF((SINT.NE.0.0))RDEV=MAX(RDEV,ASD/ABS(SINT))
         IF((COST.NE.0.0))RDEV=MAX(RDEV,ACD/ABS(COST))
         S2C2=SINTHE**2+COSTHE**2
         S2C2MN=MIN(S2C2MN,S2C2)
         S2C2MX=MAX(S2C2MX,S2C2)
621     CONTINUE
622     CONTINUE
        WRITE(KMPO,630)NRNA
630     FORMAT(' TEST AT ',I7,' RANDOM ANGLES IN (0,5*PI/2)')
        WRITE(KMPO,640)ADEV,RDEV,S2C2MN,S2C2MX
640     FORMAT(' ADEV,RDEV,S2C2(MN,MX) =',1P,4E16.8)
       END IF
       P=1.
        DO 651 I=1,50
        PWR2I(I)=P
        P=P*.5
651    CONTINUE
652    CONTINUE
      END IF
       DO 661 IM=1,NMED
670    CONTINUE
        DO 671 I=1,6
        IF (IRAYLR(I).EQ.1.AND.MED(I).EQ.IM) THEN
         IRAYLM=1
         GO TO 672
        END IF
671    CONTINUE
672    CONTINUE
661   CONTINUE
662   CONTINUE
      REWIND KMPI
      NM=0
       DO 681 IM=1,NMED
       LOK=0
       IF (IRAYLM.EQ.1) THEN
        WRITE(KMPO,690)IM
690     FORMAT(' RAYLEIGH OPTION REQUESTED FOR MEDIUM NUMBER',I3,/)
       END IF
681   CONTINUE
682   CONTINUE
700   CONTINUE
701    CONTINUE
710    CONTINUE
711     CONTINUE
        READ(KMPI,530,END=720)MBUF
         DO 731 IB=1,LMDL
         IF((MBUF(IB:IB).NE.MDLABL(IB:IB)))GO TO 711
731     CONTINUE
732     CONTINUE
740     CONTINUE
         DO 741 IM=1,NMED
          DO 751 IB=1,LMDN
          IL=LMDL+IB
          IF((MBUF(IL:IL).NE.MEDIA(IB:IB)))GO TO 741
          IF((IB.EQ.LMDN))GO TO 712
751      CONTINUE
752      CONTINUE
741     CONTINUE
742     CONTINUE
       GO TO 711
712    CONTINUE
       IF((LOK.NE.0))GO TO 710
       LOK=1
       NM=NM+1
       WRITE(KMPO,760)IM,MBUF
760    FORMAT(' DATA FOR MEDIUM #',I3,', WHICH IS:',A72)
       READ(KMPI,770)(MBUF(I:I),I=1,5),RHO,NE
770    FORMAT(5A1,5X,F11.0,4X,I2)
       WRITE(KMPO,780)(MBUF(I:I),I=1,5),RHO,NE
780    FORMAT(5A1,',RHO=',1P,G11.4, ',NE=',I2,',COMPOSITION IS :')
        DO 791 IE=1,NE
        READ(KMPI,530)MBUF
        WRITE(KMPO,530)MBUF
791    CONTINUE
792    CONTINUE
       READ(KMPI,520)RLC,AE,AP,UE,UP
       TE=AE-RM
       THMOLL=TE*2. + RM
       READ(KMPI,510)MSGE,MGE,MSEKE,MEKE,MLEKE,MCMFP,MRANGE,IRAYL
       NSGE=MSGE
       NGE=MGE
       NSEKE=MSEKE
       NEKE=MEKE
       NLEKE=MLEKE
       NCMFP=MCMFP
       NRANGE=MRANGE
       READ(KMPI,520)(DL1(I),DL2(I),DL3(I),DL4(I),DL5(I),DL6(I),I=1,6)
       READ(KMPI,520)DELCM,(ALPHI(I),BPAR(I),DELPOS(I),I=1,2)
       READ(KMPI,520)XR0,TEFF0,BLCC,XCC
       READ(KMPI,520)EKE0,EKE1
       READ(KMPI,520)(ESIG0(I),ESIG1(I),PSIG0(I),PSIG1(I),EDEDX0(I),EDED
     * X1(I),PDEDX0(I),PDEDX1(I),EBR10(I),EBR11(I),PBR10(I),PBR11(I),PBR
     * 20(I),PBR21(I),TMXS0(I),TMXS1(I),I=1,NEKE)
       READ(KMPI,520)EBINDA,GE0,GE1
       READ(KMPI,520)(GMFP0(I),GMFP1(I),GBR10(I),GBR11(I),GBR20(I),GBR21
     * (I),GBR30(I),GBR31(I),GBR40(I),GBR41(I),I=1,NGE)
       IF (IRAYLM.EQ.1.AND.IRAYL.NE.1) THEN
        WRITE(KMPO,800)IM
800     FORMAT(' STOPPED IN HATCH: REQUESTED RAYLEIGH OPTION FOR MEDIUM'
     *  ,I3/ ' BUT RAYLEIGH DATA NOT INCLUDED IN DATA CREATED BY PEGS.')
        STOP
       END IF
       IF (IRAYL.EQ.1) THEN
        READ(KMPI,510)NGR
        NGRIM=NGR
        READ(KMPI,520)RCO0,RCO1
        READ(KMPI,520)(RSCT0(I),RSCT1(I),I=1,NGRIM)
        READ(KMPI,520)(COHE0(I),COHE1(I),I=1,NGE)
        IF (IRAYLM.NE.1) THEN
         WRITE(KMPO,810)IM
810      FORMAT(' RAYLEIGH DATA AVAILABLE FOR MEDIUM',I3,' BUT OPTION ',
     *    'NOT REQUESTED.',/)
        END IF
       END IF
       IF((NM.GE.NMED))GO TO702
      GO TO 701
702   CONTINUE
      DUNITR=DUNIT
      IF (DUNIT.LT.0.0) THEN
       MD=MAX(1,MIN(1,IFIX(-DUNIT)))
       DUNIT=RLC
      END IF
      IF (DUNIT.NE.1.0) THEN
       WRITE(KMPO,820)DUNITR,DUNIT
820    FORMAT(' DUNIT REQUESTED&USED ARE:',1P,2E14.5,'(CM.)')
      END IF
       DO 831 IM=1,NMED
       DFACT=RLC/DUNIT
       DFACTI=1.0/DFACT
       I=1
        GO TO 843
841     I=I+1
843     IF(I-(MEKE).GT.0)GO TO 842
        ESIG0(I)=ESIG0(I)*DFACTI
        ESIG1(I)=ESIG1(I)*DFACTI
        PSIG0(I)=PSIG0(I)*DFACTI
        PSIG1(I)=PSIG1(I)*DFACTI
        EDEDX0(I)=EDEDX0(I)*DFACTI
        EDEDX1(I)=EDEDX1(I)*DFACTI
        PDEDX0(I)=PDEDX0(I)*DFACTI
        PDEDX1(I)=PDEDX1(I)*DFACTI
        TMXS0(I)=TMXS0(I)*DFACT
        TMXS1(I)=TMXS1(I)*DFACT
       GO TO 841
842    CONTINUE
       I=1
        GO TO 853
851     I=I+1
853     IF(I-(MLEKE).GT.0)GO TO 852
        ERANG0(I)=ERANG0(I)*DFACT
        ERANG1(I)=ERANG1(I)*DFACT
        PRANG0(I)=PRANG0(I)*DFACT
        PRANG1(I)=PRANG1(I)*DFACT
       GO TO 851
852    CONTINUE
       TEFF0=TEFF0*DFACT
       BLCC=BLCC*DFACTI
       XCC=XCC*SQRT(DFACTI)
       RLDU=RLC/DUNIT
       RLDUI=1./RLDU
       I=1
        GO TO 863
861     I=I+1
863     IF(I-(MGE).GT.0)GO TO 862
        GMFP0(I)=GMFP0(I)*DFACT
        GMFP1(I)=GMFP1(I)*DFACT
       GO TO 861
862    CONTINUE
831   CONTINUE
832   CONTINUE
      VACDST=VACDST*DUNITO/DUNIT
      DUNITO=DUNIT
       DO 871 JR=1,6
       MD=MED(JR)
       IF ((MD.GE.1).AND.(MD.LE.NMED)) THEN
        ECUT(JR)=MAX(ECUT(JR),AE,AP+1.1*RM)
        PCUT(JR)=MAX(PCUT(JR),AP)
        IF((RHOR(JR).EQ.0.0))RHOR(JR)=RHO
       END IF
871   CONTINUE
872   CONTINUE
      IF (NMED.EQ.1) THEN
       WRITE(KMPO,880)
880    FORMAT(' EGS SUCCESSFULLY ''HATCHED'' FOR ONE MEDIUM.')
      ELSE
       WRITE(KMPO,890)NMED
890    FORMAT(' EGS SUCCESSFULLY ''HATCHED'' FOR ',I5,' MEDIA.')
      END IF
      RETURN
720   WRITE(KMPO,900)KMPI
900   FORMAT(' END OF FILE ON UNIT ',I2,//, ' PROGRAM STOPPED IN HATCH '
     *, 'BECAUSE THE'/ ' FOLLOWING NAMES WERE NOT RECOGNIZED:',/)
       DO 911 IM=1,NMED
       IF (LOK.NE.1) THEN
        WRITE(KMPO,920)(MEDIA(I:I),I=1,LMDN)
920     FORMAT(40X,'''',24A1,'''')
       END IF
911   CONTINUE
912   CONTINUE
      STOP
      END