C  HAZARD DISTANCE / MASTER PROGRAM / C.G.WHITACRE
C  ADAPTED TO MS-FORTRAN BY J.H.GRINER III and Richard L. zum Brunnen
      CHARACTER*1 IST,MTC,AA1,AB1
      CHARACTER*2 AGN,UM,AGNT,AA2,WT
      CHARACTER*3 PNU,PNUT,PNUC,MUN,MUNT,REL,RELT,LOC,LOCT,SEA,SEAT,
     1PRTT,SUR
      CHARACTER*12 ADH
      CHARACTER*20 APRT
      COMMON NQI,QT(6),TWL(6),D(10),DL(10)
      COMMON PR(1),DXT,HT,HML,SXS,SYS,SZS,TIVCH,UT,BR,SF,TMP,ALFA,SY100,
     1BETA,SZ100,Z,RC,V,QS
      COMMON TEVP,SA,FL,FMW,FMV,VP,BP
      COMMON HS,DS,TSC,VS,RDE,FP,HR,CR
      COMMON SLA,SLO,CC,CH,AE,PMM,Z0
      COMMON LOCT(1),SEAT,MUNT,AGNT,AA1,REL,MTC,AA2,SUR,WT,AB1,ADH,ADR,
     1AD2
      COMMON IPR(1),ND,IPO,I2MC,IMA,IPC,IMM,IDD,IHR,NOV,INP,MRL,NMU,ID2,
     1IDEP,IMTCH,IM,IR,IL,IRL,ISM,IVD,K33,K42
      DIMENSION MUN(10),QF(10,3),SYSM(10),SZSM(10),AGN(18),D1(3,17)
      DIMENSION FMWT(17),IST(11),LOC(12),SEA(4),HMLT(6,4,11),PMMT(12),
     1PNU(77),J(67),K(67),RELT(8),PNUC(16),QTS(6)
$INCLUDE:'A:HMLMDR1.FOR'
      DATA RELT/'INS','EVP','SEM','VAR','STK','STJ','FLS','FIR'/
      DATA AGN/'GB','VX','HD','AC','CG','CK','GA','GD','GF','H1','H3',
     1'HT','LL','HY','UD','BZ','DM','NA'/
      DATA PNUC/'ALL','STP','RST','INP','GTO','RSN','NQI','SMC','SMD',
     1'SMP','RUN','TAB','???','DSP','PEE','VDP'/
      DATA PNU/'TIM','DLX','HTS','HML','SXS','SYS','SZS','TMC','WND',
     1'BRT','SKF','TMP','ALF','SYR','BTA','SZR','SMH','REF','SEV','QQQ',
     2'TEV','ARE','DOW','FMW','FMV','VAP','BPT','HST','DST','TST','VST',
     3'RDE','FRO','HRL','CRD','SLA','SLO','CCT','CHT','SUN','PMM','ZZO',
     4'LOC','SEA','MUN','AGN','REL','STB','SUR','WOO','HLD','RLS','AD3',
     5'IRT','NDI','OPO','2MC','IMA','OPC','IMM','IDD','HRS','NOV','INP',
     6'MNR','NMU','NCI','IDE','IMT',' IM',' IR',' IL','IRL','ISM','IVD',
     7'K33','K42'/
      DATA J/1,7*0,1,2*0,1,7*0,8*1,8*0,6*1,0,8*1,9*0,3*1,0,1,0,1,0/
      DATA MUN/'105','155','8IN','500','750','M55','525','139','M23',
     1'4.2'/
      DATA IST/'A','B','C','D','E','F','N','I','U','S','W'/
      DATA LOC/'AAD','DPG','EWA','JHI','LBG','NAP','PBA','PAD','RMA',
     1'UAD','EUR','NDF'/
      DATA SEA/'WIN','SPR','SUM','FAL'/
      DO 1 I=1,74
      QT(I)=0.
 1    CONTINUE
      DO 2 I=11
      LOCT(I)='   '
 2    CONTINUE
      DO 3 I=22
      IPR(I)=0
 3    CONTINUE
      TIVCH=1.E36
      DXT=10.
      Z=0.
      NMU=1
      RC=1.
      V=0.
      BR=25.
      SF=.022
      DATA I3,I4,I5/42,11,24/
      WRITE (*,*) '            ---------------------------------'
      WRITE (*,*) '            \ DOWNWIND HAZARD PROGRAM D2PC \'
      WRITE (*,*) '            ---------------------------------'
 4    DO 5 I=1,67
      K(I)=0
 5    CONTINUE
      ND=0
      CALL DEF (0,IRT)
C     1. NOVICE LEVEL
      WRITE (*,*) '    TYPE ? FOR DEFINITIONS'
 6    CALL DEF (1,IRT)
      IF (IRT.EQ.0) READ (*,'(BN,I5)',ERR=10) NOV
      IF (NOV.GT.2) CALL DEF (39,IRT)
      IF (NOV.GT.(-1)) GO TO 7
      CALL DEF(80,IRT)
      READ(*,93)LOCT(1),SEAT,MUNT,AGNT,REL,MTC,US
      UT=US
C     2. LOCATION
 7    CALL DEF (2,IRT)
      IF (IRT.EQ.0) READ (*,'(A3)') LOCT(1)
      DO 8 IL=1,12
      IF (LOCT(1).EQ.LOC(IL)) GO TO 11
 8    CONTINUE
      WRITE (*,9)
 9    FORMAT (' LOCATION NOT DEFINED')
      CALL DEF (42,IRT)
      GO TO 7
 10   CALL DEF (41,IRT)
      GO TO 6
C     3. SEASON
 11   IF (IL.EQ.12) GO TO 14
      CALL DEF (3,IRT)
      IF (IRT.EQ.0) READ (*,'(A3)') SEAT
      DO 12 IS=1,4
      IF (SEAT.EQ.SEA(IS)) GO TO 13
 12   CONTINUE
      CALL DEF (43,IRT)
      GO TO 11
 13   IF (K(41).EQ.0.AND.IL.NE.12) PMM=PMMT(IL)
      IF (IL.NE.12) GO TO 15
C     4. HEIGHT OF MIXING LAYER
 14   CALL READA (4,IRT,IA,HML)
      IF (IRT.LT.0) GO TO 14
 15   IDEP=0
      IF (K(3).EQ.0) HT=0.
      IF (K(57).EQ.0) I2MC=0
      INQ=0
      IMTCH=0
C     5. MUNITION TYPE
 16   CALL DEF (5,IRT)
      IF (IRT.EQ.0) READ (*,'(A3)') MUNT
      IF (MUNT.NE.'???') GO TO 17
      CALL DEF (45,IRT)
      GO TO 16
 17   DO 18 IMU=1,10
      IF (MUNT.EQ.MUN(IMU)) GO TO 19
 18   CONTINUE
      INQ=1
C     6. AGENT TYPE
 19   CALL DEF (6,IRT)
      IF (IRT.EQ.0) READ (*,'(A2)') AGNT
      IF (AGNT.NE.'??') GO TO 20
      CALL DEF (46,IRT)
      GO TO 19
 20   DO 21 IA=1,18
      IF (AGNT.EQ.AGN(IA)) GO TO 22
 21   CONTINUE
      IA=18
C     8. RELEASE TYPE
 22   CALL DEF (8,IRT)
      IF (IRT.EQ.0) READ (*,'(A3)') REL
      IF (REL.NE.'???') GO TO 23
      CALL DEF (48,IRT)
      GO TO 22
 23   DO 24 IR=1,8
      IF (RELT(IR).EQ.REL) GO TO 25
 24   CONTINUE
      WRITE (*,*) ' RELEASE NOT DEFINED'
      CALL DEF (48,IRT)
      GO TO 22
C     9. STABILITY TYPE
 25   CALL DEF (9,IRT)
      IF (IRT.EQ.0) READ (*,'(A1)') MTC
      IF (MTC.NE.'?') GO TO 26
      CALL DEF (49,IRT)
      GO TO 25
 26   DO 27 IM=1,11
      IF (MTC.EQ.IST(IM)) GO TO 28
 27   CONTINUE
      WRITE (*,*) ' STABILITY NOT DEFINED'
      CALL DEF (49,IRT)
      GO TO 25
 28   IF (IMTCH.EQ.1) GO TO 29
C     10. WINDSPEED
      CALL READA (10,IRT,IA,US)
      IF (IRT.LT.0) GO TO 28
 29   UT=US
      IF (IM.EQ.10) CALL STAB (US,IM,IL,IMM,IDD)
      IF (IM.EQ.11) CALL WOODS (UT,ALFA,SY100,BETA,SZ100,WT)
      IF (IM.NE.9) GO TO 30
C     11. ALF,SYR,BTA,SZR
      CALL DEF (11,IRT)
      IF (IRT.EQ.0) READ (*,*) ALFA,SY100,BETA,SZ100
 30   IF (IMTCH.EQ.1) GO TO 83
      IF (IA.EQ.18) GO TO 34
      IF (K(24).EQ.0) FMW=FMWT(IA)
      IF (IA.LE.2.AND.K(57).EQ.0) I2MC=2-K(57)
      IF (K(55).EQ.1.OR.K(67).GT.0) GO TO 32
      DO 31 I=1,3
      D(I)=D1(I,IA)
 31   CONTINUE
      ND=3
      IRL=1
      IF (K(65).EQ.0) MRL=0
 32   IF (IA.EQ.2.AND.REL.EQ.'INS') GO TO 34
      WRITE (*,33) (D(I),I=1,ND)
 33   FORMAT (' DI=',10F8.1)
 34   IF (IR.LT.4) NQI=1
      IF ((IR+1)/2-2) 35,48,43
 35   IF (INQ.EQ.0) GO TO 37
C     7. SPILL OR AIRBORNE SOURCE
 36   CALL READA (7,IRT,IA,QS)
      IF (IRT.LT.0) GO TO 36
      GO TO 40
 37   IF (IA.GT.3) GO TO 38
      IF (QF(IMU,IA).GT.0.) GO TO 39
 38   WRITE (*,*) ' MUNITION-AGENT NOT DEFINED'
      GO TO 36
 39   IF (K(20).EQ.0) QS=QF(IMU,IA)
 40   QT(1)=QS*NMU
 41   IF (IR.EQ.2) WRITE (*,42)
      IF (IR.NE.1) GO TO 43
      IF (IA.EQ.2.OR.IA.GT.3.OR.INQ.EQ.1) GO TO 44
C     12. TEMPERATURE
 42   FORMAT (5X,'SURFACE')
 43   CALL READA (12,IRT,IA,TMP)
      IF (IRT.LT.0) GO TO 41
 44   IF (IR.GT.2) GO TO 48
      IF (IR.EQ.2) GO TO 51
      TWL(1)=.08
      IF (K(6).EQ.0.AND.INQ.EQ.0) SYS=SYSM(IMU)
      IF (K(7).EQ.0.AND.INQ.EQ.0) SZS=SZSM(IMU)
      IF (K(5).EQ.0.AND.INQ.EQ.0) SXS=SYS
      IF (IA.EQ.2) GO TO 46
      IF (IA.NE.1) GO TO 52
      IF (INQ.EQ.1) GO TO 52
      IF (QF(IMU,1).GT.4.5E7) GO TO 45
      QT(1)=QT(1)*(.5+(.00782*TMP))
      GO TO 52
 45   QT(1)=QT(1)*(.52+(.0022*TMP))
      GO TO 52
 46   IDEP=1
      D(1)=.44
      D(2)=1.76
      D(3)=4.
      WRITE (*,47) D(1),D(2),D(3)
 47   FORMAT (' EDI='3F5.2)
      IF (IMU.NE.9) GO TO 52
      IDEP=2
      GO TO 52
C     13. NQI,Q(),QT() OR Q,QT
 48   CALL DEF (13,IRT)
      IF (IRT.EQ.1) GO TO 49
      IF (IR.NE.3) READ (*,*) NQI,(QTS(I),TWL(I),I=1,NQI)
      IF (IR.EQ.3) READ (*,*) QTS(1),TWL(1)
 49   DO 50 I=1,NQI
      QT(I)=QTS(I)*NMU
 50   CONTINUE
      GO TO 52
 51   CALL EVAP (AGNT,QT(1),PMM,UT,TMP,TWL(1),SUR,IL)
      SXS=FL/3.
      SYS=SA/(FL*3.)
      SZS=.1
 52   IF (IM.GT.6.AND.IL.NE.12.AND.K(4).NE.1) HML=HMLT(4,IS,IL)
      IF (IM.LE.6.AND.IL.NE.12.AND.K(4).NE.1) HML=HMLT(IM,IS,IL)
 53   JSM=0
 54   ISM=3
      IF (HML.EQ.0.) WRITE (*,55)
 55   FORMAT (' DEFINE HML')
      WRITE (*,56)
 56   FORMAT (' ALL OTHER INPUT')
 57   IER=1
      READ (*,'(A3,1X,A20)') PNUT,APRT
      READ (APRT,'(BN,F20.0)',ERR=59) PRT
      IER=0
      DO 58 I=1,16
      IF (PNUT.EQ.PNUC(I)) GO TO 75
 58   CONTINUE
C
 59   DO 66 I=1,67
      IF (PNUT.NE.PNU(I)) GO TO 66
      IF (I.LT.43.OR.I.GT.53) GO TO 62
      READ (APRT,'(A3)') PRTT
      IF (I.LT.51.OR.I.GT.52) GO TO 63
      DO 60 II=1,67
      IF (PRTT.EQ.PNU(II)) GO TO 61
 60   CONTINUE
 61   K(II)=52-I
      IF (II.EQ.57.AND.I2MC.NE.0) I2MC=I-50
      GO TO 57
 62   IF (IER.EQ.0) GO TO 63
      READ (APRT,'(A2,BN,F18.0)',ERR=54) UM,PRT
      CALL UNT (UM,IA,PRT)
 63   IF (I.LT.43) PR(I)=PRT
      IF (I.GT.42.AND.I.LT.53) LOCT(I-42)=PRTT
      IF (I.GT.53) IPR(I-53)=PRT
      JSM=JSM+J(I)
      IF (I.EQ.55.OR.I.EQ.67) GO TO 68
      IF (I.EQ.58) K(67)=PRT
      IF (I.EQ.58.AND.PRT.GT.0.AND.PRT.LT.4) WRITE (*,64)
 64   FORMAT (' DEFINE NCI')
      IF (I.EQ.9) US=UT
      IF (I.EQ.47.AND.PRTT.EQ.'SEM'.OR.PRTT.EQ.'VAR') CALL DEF (-13,IRT)
      IF (I.EQ.20.AND.IR.GT.2) WRITE (*,65)
 65   FORMAT (' DEFINE NQI')
      GO TO 57
 66   CONTINUE
      WRITE (*,67)
 67   FORMAT (' SYM NOT FOUND')
      GO TO 54
 68   IF (IMA.EQ.0) WRITE (*,69)
 69   FORMAT (' INPUT: DI()S')
      IF (IMA.EQ.0) GO TO 71
      WRITE (*,70)
 70   FORMAT (' INPUT: CI()S')
      ND=PRT
 71   READ (*,*) (D(I),I=1,ND)
      MRL=0
      IRL=0
      GO TO 54
 72   NQI=PRT
      WRITE (*,73)
 73   FORMAT (' INPUT: Q()(MG), TQ()(MIN)')
      READ (*,*) (QT(I),TWL(I),I=1,NQI)
      DO 74 I=1,NQI
      QTS(I)=QT(I)
 74   CONTINUE
      GO TO 54
 75   NIQ=(-PRT)
      IF (I.EQ.13) NIQ=0
      IF (I.EQ.14) NIQ=PRT
      IF (I.GT.11.AND.I.LT.15) CALL DEF(40,NIQ)
      IF (I.EQ.16) IVD=PRT
      IF (I.EQ.4.OR.I.EQ.5) CALL DEF (NIQ,IRT)
      GO TO (77,89,4,59,6,7,72,76,76,76,78,54,54,54,90,57), I
 76   ISM=I-8
      IF (I.EQ.10) GO TO 57
      CALL DDS
      GO TO 54
 77   IF (JSM.GT.0) GO TO 7
 78   IF (ND.GT.0) GO TO 80
      IF (IMA.EQ.0) WRITE (*,79)
 79   FORMAT (' DEFINE NDI')
      IF (IMA.GT.0) WRITE (*,64)
      GO TO 57
 80   IF (IMA.NE.2.OR.IA.NE.18) GO TO 81
C     14. MOLECULAR WEIGHT
      CALL DEF (14,IRT)
      IF (IRT.EQ.0) READ (*,*) FMW
 81   WRITE (*,82) NMU,MUNT,AGNT,REL,UT,TMP,LOCT(1),SEAT,MTC
 82   FORMAT (//I3,' MUN:',A3,2X,'AGN:',A2,2X,'REL:',A3,2X,'WND=',F4.1,
     1'(M/S)',2X,'TMP=',F4.1,'(C)',2X,A3,'-',A3,2X,'STB:',A1)
      IF (IA.EQ.3.AND.IR.EQ.1) IDEP=-1
 83   IF (IR.LE.4) GO TO 84
      CALL PLRS (UT,TMP,PMM,IL,IM,IR,0.,HT,HML,IPC,IRTP)
 84   IF (HT.GT.HML) WRITE (*,85)
 85   FORMAT (' HEIGHT OF RELEASE IS GREATER THAN MIXING LAYER')
      IF (QT(1).EQ.0.) WRITE (*,86)
 86   FORMAT(' THE SOURCE STRENGHT IS SET AT ZERO')
      IF (UT.EQ.0.) WRITE (*,88)
      IF (HML.EQ.0..OR.HT.GT.HML.OR.QT(1).EQ.0..OR.UT.EQ.0.) GO TO 54
      IF (IVD.EQ.1.AND.IL.EQ.12) GO TO 91
      IF (IVD.EQ.1.AND.IM.GT.6) GO TO 94
 92   K33 = K(33)
      K42 = K(42)
      IF (IMA.EQ.0) CALL DDS
      IF (IMA.GT.0) CALL CDS
      IF (IMTCH.EQ.1) GO TO 87
      IF (IPR(1).EQ.0) GO TO 53
      CALL DEF ((-IPR(1)),IRT)
      GO TO 7
 87   WRITE (*,*) ' INPUT: STB'
      READ (*,'(A1)') MTC
      WRITE(*,*)' INPUT: WND, HML, TMC'
      READ (*,*) US,HML,TIVCH
      GO TO 26
 88   FORMAT (' DEFINE WND')
 90   IF (PRT.EQ.1.) WRITE(*,'(1P2E10.3)')(QT(I),TWL(I),I=1,6)
      IF (PRT.EQ.2.) WRITE(*,'(1P2E10.3)')(D(I),DL(I),I=1,10)
      IF (PRT.EQ.3.) WRITE(*,'(2(A5,1PE10.3))')
     $(PNU(I),PR(I),I=1,I3)
      IF (PRT.EQ.4.) WRITE(*,'(A5,A4)')
     $(PNU(I+42),LOCT(I),I=1,I4)
      IF (PRT.EQ.5.) WRITE(*,'(2(A5,I6))')
     $(PNU(I+53),IPR(I),I=1,I5)
C THE FOLLOWING CALL IS A DUMMY CALL THE ONLY IMPORTAIN VARIABLE IS
C LAST ONE (4).
      IF (PRT.EQ.6) CALL VDPL(DD,DD,ID,ID,ID,ID,DD,DD,DD,DD,DD,DD,
     1DD,DD,DD,DD,DD,DD,DD,4)
      GO TO 54
C     29. FROST PROFILE EXP AND ROUGHNESS LENGTH
 91   CALL DEF(29,IRT)
      IF (IRT.EQ.0) READ(*,*) FP,Z0
      GO TO 92
 93   FORMAT(A3,1X,A3,1X,A3,1X,A2,1X,A3,1X,A1,1X,BN,F10.0)
 94   WRITE(*,*) ' VAPOR DEPLETION ONLY DEFINED FOR STABILITIES A-F'
      GO TO 53
 89   STOP
      END
