home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FORTRAN / D2SOURCE.ZIP / FTC3.FOR < prev    next >
Encoding:
Text File  |  1986-01-16  |  6.4 KB  |  213 lines
  1. C  PEAK CONCENTRATION/ INS/ CON/ FUM/ SAO PER CGW-JHG
  2.       SUBROUTINE CDS
  3.       CHARACTER*1 IST
  4.       COMMON NQI,QT(6),TWL(6),CI(10),CL(10)
  5.       COMMON PR(1),DXT,H,HML,SXS,SYS,SZS,TIVCH,UT,BR,SF,TMP,ALF,SYR,BTA,
  6.      1SZR,Z,RC,V,QS,TEVP,SA,FL,FMW,CDM(8),FP,CDM1(8),Z0,CDM2(11)
  7.       COMMON IPR(1),ND,IPO,I2MC,IMA,IPC,IMM,IDD,
  8.      1IHR,NOV,INP,MRL,ID1,ID2,IDEP,IMTCH,IM,IR,IL,IRL,ISM,IVD,K33,K42
  9.       DIMENSION ALFA(6),BETA(6),SY100(6,2),SZ100(6)
  10.       DIMENSION SY100C(2,3),SZ20C(2,3),BETAC(2,3)
  11.       DIMENSION IST(11),Y(10),AR(10)
  12.       DATA ALFA/1.0,1.0,1.0,.9,.8,.7/
  13.       DATA BETA/1.4,1.,.9,.85,.8,.75/
  14.       DATA SY100/9.,6.33,4.8,4.,3.,2.,27.,19.,12.5,8.,6.,4./
  15.       DATA SZ100/14.,11.,7.5,4.5,3.5,2.5/
  16.       DATA SY100C/41.19,31.18,66.56,30.98,26.17,29.33/
  17.       DATA SZ20C/3.,1.652,.797,1.934,.705,1.242/
  18.       DATA BETAC/1.344,.755,1.218,.949,1.182,1./
  19.       DATA IST/'A','B','C','D','E','F','N','I','U','S','W'/
  20.       DATA HK/0./
  21.       IF (IDEP.EQ.0) GO TO 42
  22.       WRITE(*,1)
  23.  1    FORMAT ('CONCENTRATION NOT DEFINED FOR INSTANTEOUS'
  24.      $' RELEASE OF VX OR HD')
  25.       RETURN
  26.  42   IF (IMTCH) 2,2,43
  27.  2    DO 3 I=1,ND
  28.       AR(I)=0.
  29.       CL(I)=LOG(CI(I))
  30.  3    CONTINUE
  31.       X=0.
  32.       DX=DXT
  33.       SDEPL=1.
  34.       Q=QT(1)
  35.       IS=1
  36.       IF (TWL(1).GT..083) IS=2
  37.  43   IMTCH=0
  38.       IF (IM.GT.8) GO TO 5
  39.       IF (IM.GT.6) GO TO 4
  40.       ALF=ALFA(IM)
  41.       SYR=SY100(IM,IS)
  42.       BTA=BETA(IM)
  43.       SZR=SZ100(IM)
  44.       GO TO 5
  45.  4    I=UT/2.235+1
  46.       IF (I.GT.3) I=3
  47.       MC=IM-6
  48.       BTA=BETAC(MC,I)
  49.       ALF=.5
  50.       SYR=SY100C(MC,I)
  51.       SZR=SZ20C(MC,I)*5**BTA
  52.  5    XC=1.E36
  53.       IF (TWL(1).EQ.1.E36) GO TO 6
  54.       Q=QT(1)/TWL(1)
  55.       XC=0.
  56.       IF (IS.EQ.1) GO TO 6
  57.       XC=EXP(ALOG(TWL(1)*UT*157.27)/.9294)
  58.  6    QOU=Q/UT
  59.       HKOU=HK/UT/60.
  60.       XCH=1.E36
  61.       IF (TIVCH.NE.1.E36) XCH=UT*TIVCH*60.+X
  62.       IF (IMTCH.EQ.1) GO TO 44
  63.       MXLF=0
  64.       TWHML=HML+HML
  65.       IC=ND
  66.       IND=0
  67.       IRTP=5-IR
  68.       CPMX=0.
  69.       CPLSAV=-87.5
  70.       XSAVE=0.
  71.  44   A=0.
  72.       B=0.
  73.       C=0.
  74.       IF (SXS.NE.0.) A=(SXS/.1522)**1.076-X
  75.       IF (SYS.NE.0.) B=100*(SYS/SYR)**(1./ALF)-X
  76.       IF (SZS.NE.0.) C=100.*(SZS/SZR)**(1./BTA)-X
  77.       WRITE(*,7)
  78.  7    FORMAT(/5X,'Q(MG)',4X,'TS(MIN)',3X,'HTS(M)',4X,'HML(M)',
  79.      +6X,'WND')
  80.       WRITE (*,8) QT(1),TWL(1),H,HML,UT,IST(IM)
  81.  8    FORMAT (3X,1PE9.3,4(1X,E9.3),4X,A2)
  82.       WRITE (*,9)
  83.  9    FORMAT(/4X,'ALF',2X,'SYR',4X,'BTA',3X,'SZR',8X,'SYS(M)',
  84.      +2X,'SZS(M)',2X,'XY(M)',3X,'XZ(M)',3X,'XC(M)')
  85.       WRITE (*,10) ALF,SYR,BTA,SZR,SYS,SZS,B,C,XC
  86.  10   FORMAT (1X,4F6.2,6X,1P5E8.1/)
  87.       IF (IVD.EQ.1) CALL VDPL(Q,SY,SZ,CI(1),X,DX,DXA,XS,XCH,CP,CP,
  88.      1SDEPL,1)
  89.       IF (IMA.EQ.3) WRITE(*,11)
  90.  11   FORMAT (' FUMIGATION')
  91.       IF (IPO.NE.3) GO TO 13
  92.       WRITE(*,12) (CI(I),I=1,ND)
  93.  12   FORMAT('       CONCENTRATIONS',10F5.0)
  94.       WRITE(*,*)
  95.       WRITE(*,*) '       X       CP    CONTOUR HALF-WIDTHS'
  96.  13   IF (IPO.LT.3) WRITE(*,41)
  97.       IF (IMA.EQ.2) WRITE(*,*)'                 PPM'
  98.  14   IF (X.GT.XCH) X=XCH
  99.       DXA=DX
  100.       IF (X.GE.(DX*10.)) DX=DX*10.
  101.       DXA=DXA+DX
  102.       IF (X.EQ.0) X=1
  103.       SY=SYR*((X+B)*.01)**ALF
  104.       SZ=SZR*((X+C)*.01)**BTA
  105.       IF (IVD.EQ.1.AND.X.EQ.1.) CALL VDPL(Q,SY,SZ,CI(1),X,DX,DXA,XS,
  106.      1XCH,CP,CP,SDEPL,2)
  107.       IF (IRTP.GT.0) GO TO 15
  108.       CALL PLRS (UT,TMP,PMM,IL,IM,IR,X,H,HML,IPC,IRTP)
  109.  15   IF (IMA.NE.3) GO TO 16
  110.       SYF=SY+(H*.125)
  111.       CP=QOU/(150.39770*SYF*(H+SZ+SZ))
  112.       GO TO 24
  113.  16   IF (MXLF) 18,18,17
  114.  17   CP=QOU/(150.39770*SY*HML)
  115.       GO TO 22
  116.  18   CP=QOU/(188.49556*SZ*SY)
  117.       TSZSQ=SZ*SZ*2.
  118.       HPZ=H+Z
  119.       HMZ=H-Z
  120.       VT=V*X/UT
  121.       FAC=0.
  122.       HML2=1.E36
  123.       ARG=(HMZ-VT)**2/TSZSQ
  124.       IF (ARG.LT.87.) FAC=FAC+EXP(-ARG)
  125.       ARG=(HPZ-VT)**2/TSZSQ
  126.       IF (ARG.LT.87.) FAC=FAC+RC/EXP(ARG)
  127.       ZFAC=0.
  128.       IF (HML.GT.1.E10.OR.MXLF.EQ.1) GO TO 21
  129.       DO 19 JJ=1,20
  130.       SMHML=TWHML*JJ
  131.       ARG=(SMHML-HPZ+VT)**2/TSZSQ
  132.       IF (ARG.GT.87.) GO TO 20
  133.       ZFAC=ZFAC+RC**(JJ-1)/EXP(ARG)
  134.       ARG=(SMHML-HMZ+VT)**2/TSZSQ
  135.       IF (ARG.LT.87.) ZFAC=ZFAC+RC**JJ/EXP(ARG)
  136.       ARG=(SMHML+HMZ-VT)**2/TSZSQ
  137.       IF (ARG.LT.87.) ZFAC=ZFAC+RC**JJ/EXP(ARG)
  138.       ARG=(SMHML+HPZ-VT)**2/TSZSQ
  139.  19   IF (ARG.LT.87.) ZFAC=ZFAC+RC**(JJ+1)/EXP(ARG)
  140.  20   IF((FAC+ZFAC).NE.0.)HML2=(2.5066283*SZ)/(FAC+ZFAC)
  141.       IF (HML.GT.HML2.AND.(HML-HML2).LT.1) MXLF=1
  142.  21   RF=(FAC+ZFAC)/2.
  143.       CP=CP*RF
  144.  22   IF (X.LT.XC) GO TO 23
  145.       SX=.1522*((X+A)**.9294)
  146.       CP=CP*TWL(1)*UT*23.936537/SX
  147.  23   IF (HK.GT.0.) CP=CP/EXP(X*HKOU)
  148.  24   IF (CP.LT.1.E-35) GO TO 36
  149.       IF (IVD.EQ.1) CALL VDPL(Q,SY,SZ,CI(1),X,DX,DXA,XS,
  150.      1XCH,CP,CP,SDEPL,3)
  151.       IF (IMA.EQ.2) CP=CP*24.45/FMW
  152.       CPL=LOG(CP)
  153.       IF (XSAVE.EQ.0..OR.CPL.GE.CPLSAV) GO TO 28
  154.       IND=1
  155.  25   IF (CPMX.LT.CI(IC)) GO TO 26
  156.       IF (CP.GT.CI(IC).OR.CPLSAV.LT.CL(IC)) GO TO 29
  157.       XLNA=ALOG(X)
  158.       XLNB=ALOG(XSAVE)
  159.       XLNC=XLNB+(XLNA-XLNB)*(CL(IC)-CPLSAV)/(CPL-CPLSAV)
  160.       XINT=EXP(XLNC)
  161.       IF (IVD.EQ.1) WRITE(*,'(F5.2)') SDEPL
  162.       WRITE (*,27) XINT,CI(IC)
  163.  26   IC=IC-1
  164.       IF (IC-MRL) 29,29,25
  165.  27   FORMAT (/1X,F10.0,'* ',1PE10.3)
  166.  28   IND=0
  167.       IC=ND
  168.       IF (CP.LT.CPMX) GO TO 29
  169.       CPMX=CP
  170.       XCMX=X
  171.  29   IF (IPO.NE.3) GO TO 32
  172.       SYRT2=1.41421*SY
  173.       Y(1)=0.
  174.       DO 30 IY=1,ND
  175.       ARG=CPL-CL(IY)
  176.       IF (ARG.LT.0.) GO TO 31
  177.       Y(IY)=SYRT2*SQRT(ARG)
  178.       IF (X.NE.XCH) AR(IY)=AR(IY)+Y(IY)*DXA
  179.       IF (X.EQ.XCH) AR(IY)=AR(IY)-Y(IY)*(XSAVE+DX-XCH)
  180.  30   CONTINUE
  181.       IY=ND+1
  182.  31   IY=IY-1
  183.       WRITE (*,39) X,CP,(Y(I),I=1,IY)
  184.       GO TO 35
  185.  32   IF (IPO.EQ.0.OR.IPO.EQ.4) GO TO 35
  186.       IF (RF.EQ.1.0.OR.MXLF.EQ.1) GO TO 34
  187.       WRITE (*,33) X,CP,RF
  188.  33   FORMAT (1X,F10.0,2X,1P2E10.3)
  189.       GO TO 35
  190.  34   WRITE (*,33) X,CP
  191.  35   IF (IND.EQ.1.AND.CPL.LT.CL(1+MRL).AND.IRTP.GT.0) GO TO 37
  192.       XSAVE=X
  193.       CPLSAV=CPL
  194.       IF (X.NE.XCH) GO TO 36
  195.       IMTCH=1
  196.       SXS=SX
  197.       SYS=SY
  198.       SZS=SZ
  199.       RETURN
  200.  36   IF (X.EQ.1..AND.DX.GT.1.) X=0.
  201.       X=X+DX
  202.       GO TO 14
  203.  37   IF (CPMX.LT.CI(1+MRL)) WRITE(*,39) XCMX,CPMX
  204.       IF (IPO.EQ.3) WRITE (*,40) (CI(I),AR(I),I=ND,1,-1)
  205.       IF (IVD.EQ.1.AND.IPO.EQ.4) CALL VDPL(Q,SY,SZ,CI(1),X,DX,DXA,XS,
  206.      1XCH,CP,CP,SDEPL,4)
  207.       RETURN
  208.  38   FORMAT (21X,10F5.0)
  209.  39   FORMAT (1X,F10.0,1PE10.3,0P10F5.0)
  210.  40   FORMAT (//5X,'C',8X,'AREA',/(1P2E10.3))
  211.  41   FORMAT(/9X,'X',8X,'CP',8X,'RF')
  212.       END
  213.