home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FORTRAN / D2SOURCE.ZIP / HDS3.FOR < prev    next >
Encoding:
Text File  |  1985-12-20  |  11.7 KB  |  370 lines
  1. C  HAZARD DISTANCE / MASTER PROGRAM / C.G.WHITACRE
  2. C  ADAPTED TO MS-FORTRAN BY J.H.GRINER III and Richard L. zum Brunnen
  3.       CHARACTER*1 IST,MTC,AA1,AB1
  4.       CHARACTER*2 AGN,UM,AGNT,AA2,WT
  5.       CHARACTER*3 PNU,PNUT,PNUC,MUN,MUNT,REL,RELT,LOC,LOCT,SEA,SEAT,
  6.      1PRTT,SUR
  7.       CHARACTER*12 ADH
  8.       CHARACTER*20 APRT
  9.       COMMON NQI,QT(6),TWL(6),D(10),DL(10)
  10.       COMMON PR(1),DXT,HT,HML,SXS,SYS,SZS,TIVCH,UT,BR,SF,TMP,ALFA,SY100,
  11.      1BETA,SZ100,Z,RC,V,QS
  12.       COMMON TEVP,SA,FL,FMW,FMV,VP,BP
  13.       COMMON HS,DS,TSC,VS,RDE,FP,HR,CR
  14.       COMMON SLA,SLO,CC,CH,AE,PMM,Z0
  15.       COMMON LOCT(1),SEAT,MUNT,AGNT,AA1,REL,MTC,AA2,SUR,WT,AB1,ADH,ADR,
  16.      1AD2
  17.       COMMON IPR(1),ND,IPO,I2MC,IMA,IPC,IMM,IDD,IHR,NOV,INP,MRL,NMU,ID2,
  18.      1IDEP,IMTCH,IM,IR,IL,IRL,ISM,IVD,K33,K42
  19.       DIMENSION MUN(10),QF(10,3),SYSM(10),SZSM(10),AGN(18),D1(3,17)
  20.       DIMENSION FMWT(17),IST(11),LOC(12),SEA(4),HMLT(6,4,11),PMMT(12),
  21.      1PNU(77),J(67),K(67),RELT(8),PNUC(16),QTS(6)
  22. $INCLUDE:'A:HMLMDR1.FOR'
  23.       DATA RELT/'INS','EVP','SEM','VAR','STK','STJ','FLS','FIR'/
  24.       DATA AGN/'GB','VX','HD','AC','CG','CK','GA','GD','GF','H1','H3',
  25.      1'HT','LL','HY','UD','BZ','DM','NA'/
  26.       DATA PNUC/'ALL','STP','RST','INP','GTO','RSN','NQI','SMC','SMD',
  27.      1'SMP','RUN','TAB','???','DSP','PEE','VDP'/
  28.       DATA PNU/'TIM','DLX','HTS','HML','SXS','SYS','SZS','TMC','WND',
  29.      1'BRT','SKF','TMP','ALF','SYR','BTA','SZR','SMH','REF','SEV','QQQ',
  30.      2'TEV','ARE','DOW','FMW','FMV','VAP','BPT','HST','DST','TST','VST',
  31.      3'RDE','FRO','HRL','CRD','SLA','SLO','CCT','CHT','SUN','PMM','ZZO',
  32.      4'LOC','SEA','MUN','AGN','REL','STB','SUR','WOO','HLD','RLS','AD3',
  33.      5'IRT','NDI','OPO','2MC','IMA','OPC','IMM','IDD','HRS','NOV','INP',
  34.      6'MNR','NMU','NCI','IDE','IMT',' IM',' IR',' IL','IRL','ISM','IVD',
  35.      7'K33','K42'/
  36.       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/
  37.       DATA MUN/'105','155','8IN','500','750','M55','525','139','M23',
  38.      1'4.2'/
  39.       DATA IST/'A','B','C','D','E','F','N','I','U','S','W'/
  40.       DATA LOC/'AAD','DPG','EWA','JHI','LBG','NAP','PBA','PAD','RMA',
  41.      1'UAD','EUR','NDF'/
  42.       DATA SEA/'WIN','SPR','SUM','FAL'/
  43.       DO 1 I=1,74
  44.       QT(I)=0.
  45.  1    CONTINUE
  46.       DO 2 I=11
  47.       LOCT(I)='   '
  48.  2    CONTINUE
  49.       DO 3 I=22
  50.       IPR(I)=0
  51.  3    CONTINUE
  52.       TIVCH=1.E36
  53.       DXT=10.
  54.       Z=0.
  55.       NMU=1
  56.       RC=1.
  57.       V=0.
  58.       BR=25.
  59.       SF=.022
  60.       DATA I3,I4,I5/42,11,24/
  61.       WRITE (*,*) '            ---------------------------------'
  62.       WRITE (*,*) '            \ DOWNWIND HAZARD PROGRAM D2PC \'
  63.       WRITE (*,*) '            ---------------------------------'
  64.  4    DO 5 I=1,67
  65.       K(I)=0
  66.  5    CONTINUE
  67.       ND=0
  68.       CALL DEF (0,IRT)
  69. C     1. NOVICE LEVEL
  70.       WRITE (*,*) '    TYPE ? FOR DEFINITIONS'
  71.  6    CALL DEF (1,IRT)
  72.       IF (IRT.EQ.0) READ (*,'(BN,I5)',ERR=10) NOV
  73.       IF (NOV.GT.2) CALL DEF (39,IRT)
  74.       IF (NOV.GT.(-1)) GO TO 7
  75.       CALL DEF(80,IRT)
  76.       READ(*,93)LOCT(1),SEAT,MUNT,AGNT,REL,MTC,US
  77.       UT=US
  78. C     2. LOCATION
  79.  7    CALL DEF (2,IRT)
  80.       IF (IRT.EQ.0) READ (*,'(A3)') LOCT(1)
  81.       DO 8 IL=1,12
  82.       IF (LOCT(1).EQ.LOC(IL)) GO TO 11
  83.  8    CONTINUE
  84.       WRITE (*,9)
  85.  9    FORMAT (' LOCATION NOT DEFINED')
  86.       CALL DEF (42,IRT)
  87.       GO TO 7
  88.  10   CALL DEF (41,IRT)
  89.       GO TO 6
  90. C     3. SEASON
  91.  11   IF (IL.EQ.12) GO TO 14
  92.       CALL DEF (3,IRT)
  93.       IF (IRT.EQ.0) READ (*,'(A3)') SEAT
  94.       DO 12 IS=1,4
  95.       IF (SEAT.EQ.SEA(IS)) GO TO 13
  96.  12   CONTINUE
  97.       CALL DEF (43,IRT)
  98.       GO TO 11
  99.  13   IF (K(41).EQ.0.AND.IL.NE.12) PMM=PMMT(IL)
  100.       IF (IL.NE.12) GO TO 15
  101. C     4. HEIGHT OF MIXING LAYER
  102.  14   CALL READA (4,IRT,IA,HML)
  103.       IF (IRT.LT.0) GO TO 14
  104.  15   IDEP=0
  105.       IF (K(3).EQ.0) HT=0.
  106.       IF (K(57).EQ.0) I2MC=0
  107.       INQ=0
  108.       IMTCH=0
  109. C     5. MUNITION TYPE
  110.  16   CALL DEF (5,IRT)
  111.       IF (IRT.EQ.0) READ (*,'(A3)') MUNT
  112.       IF (MUNT.NE.'???') GO TO 17
  113.       CALL DEF (45,IRT)
  114.       GO TO 16
  115.  17   DO 18 IMU=1,10
  116.       IF (MUNT.EQ.MUN(IMU)) GO TO 19
  117.  18   CONTINUE
  118.       INQ=1
  119. C     6. AGENT TYPE
  120.  19   CALL DEF (6,IRT)
  121.       IF (IRT.EQ.0) READ (*,'(A2)') AGNT
  122.       IF (AGNT.NE.'??') GO TO 20
  123.       CALL DEF (46,IRT)
  124.       GO TO 19
  125.  20   DO 21 IA=1,18
  126.       IF (AGNT.EQ.AGN(IA)) GO TO 22
  127.  21   CONTINUE
  128.       IA=18
  129. C     8. RELEASE TYPE
  130.  22   CALL DEF (8,IRT)
  131.       IF (IRT.EQ.0) READ (*,'(A3)') REL
  132.       IF (REL.NE.'???') GO TO 23
  133.       CALL DEF (48,IRT)
  134.       GO TO 22
  135.  23   DO 24 IR=1,8
  136.       IF (RELT(IR).EQ.REL) GO TO 25
  137.  24   CONTINUE
  138.       WRITE (*,*) ' RELEASE NOT DEFINED'
  139.       CALL DEF (48,IRT)
  140.       GO TO 22
  141. C     9. STABILITY TYPE
  142.  25   CALL DEF (9,IRT)
  143.       IF (IRT.EQ.0) READ (*,'(A1)') MTC
  144.       IF (MTC.NE.'?') GO TO 26
  145.       CALL DEF (49,IRT)
  146.       GO TO 25
  147.  26   DO 27 IM=1,11
  148.       IF (MTC.EQ.IST(IM)) GO TO 28
  149.  27   CONTINUE
  150.       WRITE (*,*) ' STABILITY NOT DEFINED'
  151.       CALL DEF (49,IRT)
  152.       GO TO 25
  153.  28   IF (IMTCH.EQ.1) GO TO 29
  154. C     10. WINDSPEED
  155.       CALL READA (10,IRT,IA,US)
  156.       IF (IRT.LT.0) GO TO 28
  157.  29   UT=US
  158.       IF (IM.EQ.10) CALL STAB (US,IM,IL,IMM,IDD)
  159.       IF (IM.EQ.11) CALL WOODS (UT,ALFA,SY100,BETA,SZ100,WT)
  160.       IF (IM.NE.9) GO TO 30
  161. C     11. ALF,SYR,BTA,SZR
  162.       CALL DEF (11,IRT)
  163.       IF (IRT.EQ.0) READ (*,*) ALFA,SY100,BETA,SZ100
  164.  30   IF (IMTCH.EQ.1) GO TO 83
  165.       IF (IA.EQ.18) GO TO 34
  166.       IF (K(24).EQ.0) FMW=FMWT(IA)
  167.       IF (IA.LE.2.AND.K(57).EQ.0) I2MC=2-K(57)
  168.       IF (K(55).EQ.1.OR.K(67).GT.0) GO TO 32
  169.       DO 31 I=1,3
  170.       D(I)=D1(I,IA)
  171.  31   CONTINUE
  172.       ND=3
  173.       IRL=1
  174.       IF (K(65).EQ.0) MRL=0
  175.  32   IF (IA.EQ.2.AND.REL.EQ.'INS') GO TO 34
  176.       WRITE (*,33) (D(I),I=1,ND)
  177.  33   FORMAT (' DI=',10F8.1)
  178.  34   IF (IR.LT.4) NQI=1
  179.       IF ((IR+1)/2-2) 35,48,43
  180.  35   IF (INQ.EQ.0) GO TO 37
  181. C     7. SPILL OR AIRBORNE SOURCE
  182.  36   CALL READA (7,IRT,IA,QS)
  183.       IF (IRT.LT.0) GO TO 36
  184.       GO TO 40
  185.  37   IF (IA.GT.3) GO TO 38
  186.       IF (QF(IMU,IA).GT.0.) GO TO 39
  187.  38   WRITE (*,*) ' MUNITION-AGENT NOT DEFINED'
  188.       GO TO 36
  189.  39   IF (K(20).EQ.0) QS=QF(IMU,IA)
  190.  40   QT(1)=QS*NMU
  191.  41   IF (IR.EQ.2) WRITE (*,42)
  192.       IF (IR.NE.1) GO TO 43
  193.       IF (IA.EQ.2.OR.IA.GT.3.OR.INQ.EQ.1) GO TO 44
  194. C     12. TEMPERATURE
  195.  42   FORMAT (5X,'SURFACE')
  196.  43   CALL READA (12,IRT,IA,TMP)
  197.       IF (IRT.LT.0) GO TO 41
  198.  44   IF (IR.GT.2) GO TO 48
  199.       IF (IR.EQ.2) GO TO 51
  200.       TWL(1)=.08
  201.       IF (K(6).EQ.0.AND.INQ.EQ.0) SYS=SYSM(IMU)
  202.       IF (K(7).EQ.0.AND.INQ.EQ.0) SZS=SZSM(IMU)
  203.       IF (K(5).EQ.0.AND.INQ.EQ.0) SXS=SYS
  204.       IF (IA.EQ.2) GO TO 46
  205.       IF (IA.NE.1) GO TO 52
  206.       IF (INQ.EQ.1) GO TO 52
  207.       IF (QF(IMU,1).GT.4.5E7) GO TO 45
  208.       QT(1)=QT(1)*(.5+(.00782*TMP))
  209.       GO TO 52
  210.  45   QT(1)=QT(1)*(.52+(.0022*TMP))
  211.       GO TO 52
  212.  46   IDEP=1
  213.       D(1)=.44
  214.       D(2)=1.76
  215.       D(3)=4.
  216.       WRITE (*,47) D(1),D(2),D(3)
  217.  47   FORMAT (' EDI='3F5.2)
  218.       IF (IMU.NE.9) GO TO 52
  219.       IDEP=2
  220.       GO TO 52
  221. C     13. NQI,Q(),QT() OR Q,QT
  222.  48   CALL DEF (13,IRT)
  223.       IF (IRT.EQ.1) GO TO 49
  224.       IF (IR.NE.3) READ (*,*) NQI,(QTS(I),TWL(I),I=1,NQI)
  225.       IF (IR.EQ.3) READ (*,*) QTS(1),TWL(1)
  226.  49   DO 50 I=1,NQI
  227.       QT(I)=QTS(I)*NMU
  228.  50   CONTINUE
  229.       GO TO 52
  230.  51   CALL EVAP (AGNT,QT(1),PMM,UT,TMP,TWL(1),SUR,IL)
  231.       SXS=FL/3.
  232.       SYS=SA/(FL*3.)
  233.       SZS=.1
  234.  52   IF (IM.GT.6.AND.IL.NE.12.AND.K(4).NE.1) HML=HMLT(4,IS,IL)
  235.       IF (IM.LE.6.AND.IL.NE.12.AND.K(4).NE.1) HML=HMLT(IM,IS,IL)
  236.  53   JSM=0
  237.  54   ISM=3
  238.       IF (HML.EQ.0.) WRITE (*,55)
  239.  55   FORMAT (' DEFINE HML')
  240.       WRITE (*,56)
  241.  56   FORMAT (' ALL OTHER INPUT')
  242.  57   IER=1
  243.       READ (*,'(A3,1X,A20)') PNUT,APRT
  244.       READ (APRT,'(BN,F20.0)',ERR=59) PRT
  245.       IER=0
  246.       DO 58 I=1,16
  247.       IF (PNUT.EQ.PNUC(I)) GO TO 75
  248.  58   CONTINUE
  249. C
  250.  59   DO 66 I=1,67
  251.       IF (PNUT.NE.PNU(I)) GO TO 66
  252.       IF (I.LT.43.OR.I.GT.53) GO TO 62
  253.       READ (APRT,'(A3)') PRTT
  254.       IF (I.LT.51.OR.I.GT.52) GO TO 63
  255.       DO 60 II=1,67
  256.       IF (PRTT.EQ.PNU(II)) GO TO 61
  257.  60   CONTINUE
  258.  61   K(II)=52-I
  259.       IF (II.EQ.57.AND.I2MC.NE.0) I2MC=I-50
  260.       GO TO 57
  261.  62   IF (IER.EQ.0) GO TO 63
  262.       READ (APRT,'(A2,BN,F18.0)',ERR=54) UM,PRT
  263.       CALL UNT (UM,IA,PRT)
  264.  63   IF (I.LT.43) PR(I)=PRT
  265.       IF (I.GT.42.AND.I.LT.53) LOCT(I-42)=PRTT
  266.       IF (I.GT.53) IPR(I-53)=PRT
  267.       JSM=JSM+J(I)
  268.       IF (I.EQ.55.OR.I.EQ.67) GO TO 68
  269.       IF (I.EQ.58) K(67)=PRT
  270.       IF (I.EQ.58.AND.PRT.GT.0.AND.PRT.LT.4) WRITE (*,64)
  271.  64   FORMAT (' DEFINE NCI')
  272.       IF (I.EQ.9) US=UT
  273.       IF (I.EQ.47.AND.PRTT.EQ.'SEM'.OR.PRTT.EQ.'VAR') CALL DEF (-13,IRT)
  274.       IF (I.EQ.20.AND.IR.GT.2) WRITE (*,65)
  275.  65   FORMAT (' DEFINE NQI')
  276.       GO TO 57
  277.  66   CONTINUE
  278.       WRITE (*,67)
  279.  67   FORMAT (' SYM NOT FOUND')
  280.       GO TO 54
  281.  68   IF (IMA.EQ.0) WRITE (*,69)
  282.  69   FORMAT (' INPUT: DI()S')
  283.       IF (IMA.EQ.0) GO TO 71
  284.       WRITE (*,70)
  285.  70   FORMAT (' INPUT: CI()S')
  286.       ND=PRT
  287.  71   READ (*,*) (D(I),I=1,ND)
  288.       MRL=0
  289.       IRL=0
  290.       GO TO 54
  291.  72   NQI=PRT
  292.       WRITE (*,73)
  293.  73   FORMAT (' INPUT: Q()(MG), TQ()(MIN)')
  294.       READ (*,*) (QT(I),TWL(I),I=1,NQI)
  295.       DO 74 I=1,NQI
  296.       QTS(I)=QT(I)
  297.  74   CONTINUE
  298.       GO TO 54
  299.  75   NIQ=(-PRT)
  300.       IF (I.EQ.13) NIQ=0
  301.       IF (I.EQ.14) NIQ=PRT
  302.       IF (I.GT.11.AND.I.LT.15) CALL DEF(40,NIQ)
  303.       IF (I.EQ.16) IVD=PRT
  304.       IF (I.EQ.4.OR.I.EQ.5) CALL DEF (NIQ,IRT)
  305.       GO TO (77,89,4,59,6,7,72,76,76,76,78,54,54,54,90,57), I
  306.  76   ISM=I-8
  307.       IF (I.EQ.10) GO TO 57
  308.       CALL DDS
  309.       GO TO 54
  310.  77   IF (JSM.GT.0) GO TO 7
  311.  78   IF (ND.GT.0) GO TO 80
  312.       IF (IMA.EQ.0) WRITE (*,79)
  313.  79   FORMAT (' DEFINE NDI')
  314.       IF (IMA.GT.0) WRITE (*,64)
  315.       GO TO 57
  316.  80   IF (IMA.NE.2.OR.IA.NE.18) GO TO 81
  317. C     14. MOLECULAR WEIGHT
  318.       CALL DEF (14,IRT)
  319.       IF (IRT.EQ.0) READ (*,*) FMW
  320.  81   WRITE (*,82) NMU,MUNT,AGNT,REL,UT,TMP,LOCT(1),SEAT,MTC
  321.  82   FORMAT (//I3,' MUN:',A3,2X,'AGN:',A2,2X,'REL:',A3,2X,'WND=',F4.1,
  322.      1'(M/S)',2X,'TMP=',F4.1,'(C)',2X,A3,'-',A3,2X,'STB:',A1)
  323.       IF (IA.EQ.3.AND.IR.EQ.1) IDEP=-1
  324.  83   IF (IR.LE.4) GO TO 84
  325.       CALL PLRS (UT,TMP,PMM,IL,IM,IR,0.,HT,HML,IPC,IRTP)
  326.  84   IF (HT.GT.HML) WRITE (*,85)
  327.  85   FORMAT (' HEIGHT OF RELEASE IS GREATER THAN MIXING LAYER')
  328.       IF (QT(1).EQ.0.) WRITE (*,86)
  329.  86   FORMAT(' THE SOURCE STRENGHT IS SET AT ZERO')
  330.       IF (UT.EQ.0.) WRITE (*,88)
  331.       IF (HML.EQ.0..OR.HT.GT.HML.OR.QT(1).EQ.0..OR.UT.EQ.0.) GO TO 54
  332.       IF (IVD.EQ.1.AND.IL.EQ.12) GO TO 91
  333.       IF (IVD.EQ.1.AND.IM.GT.6) GO TO 94
  334.  92   K33 = K(33)
  335.       K42 = K(42)
  336.       IF (IMA.EQ.0) CALL DDS
  337.       IF (IMA.GT.0) CALL CDS
  338.       IF (IMTCH.EQ.1) GO TO 87
  339.       IF (IPR(1).EQ.0) GO TO 53
  340.       CALL DEF ((-IPR(1)),IRT)
  341.       GO TO 7
  342.  87   WRITE (*,*) ' INPUT: STB'
  343.       READ (*,'(A1)') MTC
  344.       WRITE(*,*)' INPUT: WND, HML, TMC'
  345.       READ (*,*) US,HML,TIVCH
  346.       GO TO 26
  347.  88   FORMAT (' DEFINE WND')
  348.  90   IF (PRT.EQ.1.) WRITE(*,'(1P2E10.3)')(QT(I),TWL(I),I=1,6)
  349.       IF (PRT.EQ.2.) WRITE(*,'(1P2E10.3)')(D(I),DL(I),I=1,10)
  350.       IF (PRT.EQ.3.) WRITE(*,'(2(A5,1PE10.3))')
  351.      $(PNU(I),PR(I),I=1,I3)
  352.       IF (PRT.EQ.4.) WRITE(*,'(A5,A4)')
  353.      $(PNU(I+42),LOCT(I),I=1,I4)
  354.       IF (PRT.EQ.5.) WRITE(*,'(2(A5,I6))')
  355.      $(PNU(I+53),IPR(I),I=1,I5)
  356. C THE FOLLOWING CALL IS A DUMMY CALL THE ONLY IMPORTAIN VARIABLE IS
  357. C LAST ONE (4).
  358.       IF (PRT.EQ.6) CALL VDPL(DD,DD,ID,ID,ID,ID,DD,DD,DD,DD,DD,DD,
  359.      1DD,DD,DD,DD,DD,DD,DD,4)
  360.       GO TO 54
  361. C     29. FROST PROFILE EXP AND ROUGHNESS LENGTH
  362.  91   CALL DEF(29,IRT)
  363.       IF (IRT.EQ.0) READ(*,*) FP,Z0
  364.       GO TO 92
  365.  93   FORMAT(A3,1X,A3,1X,A3,1X,A2,1X,A3,1X,A1,1X,BN,F10.0)
  366.  94   WRITE(*,*) ' VAPOR DEPLETION ONLY DEFINED FOR STABILITIES A-F'
  367.       GO TO 53
  368.  89   STOP
  369.       END
  370.