1 2 !----------------------------------------------------------------------- 3 SUBROUTINE DEPLETE(VDI,XRI,LROMB,QCOR) 4 !----------------------------------------------------------------------- 5 ! 6 ! --- DEPLETE Module of AERMOD 7 ! R.W. Brode, MACTEC/PES 8 ! 9 ! PURPOSE: Subroutine DEPLETE provides the value of the integral of 10 ! the vertical distribution function over the travel of the 11 ! plume from the source to the receptor. Integration is 12 ! performed by 2-point gaussian quadrature or Romberg 13 ! integration method, depending on logical argument, lromb. 14 ! 15 ! ARGUMENTS: 16 ! PASSED: vdi deposition velocity (m/s) [r] 17 ! vsi gravitational settling velocity (m/s) [r] 18 ! xri distance from source to receptor (m) [r] 19 ! hmixi mixing height (m) [r] 20 ! lromb logical for use of Romberg integration [l] 21 ! 22 ! RETURNED: qcor ratio of depleted emission rate to original [r] 23 ! 24 ! CALLING ROUTINES: PDEP, PDEPG 25 ! 26 ! EXTERNAL ROUTINES: F2INT, QATR2, QG2D2 27 !----------------------------------------------------------------------- 28 29 ! Set up call to QATR2(xl,xu,eps,ndim2,fct,y,ier,num,aux2) 30 ! Declare parameter to fix the size of the aux2 array 31 IMPLICIT NONE 32 33 SAVE 34 LOGICAL LROMB 35 REAL :: VDI , XRI , QCOR , EPS , VALUE 36 EXTERNAL F2INT 37 !JRA F2INT must be given a type if it is a FUNCTION 38 ! spotted by NAG 5.0 compiler 39 REAL F2INT 40 INTEGER NUM , IER 41 INTEGER , PARAMETER :: NDIM2 = 12 42 REAL AUX2(NDIM2) 43 44 ! Evaluate integral, Use Romberg if LROMB=.T., otherwise use 45 ! two-point Gaussian Quadrature: 46 IF ( LROMB ) THEN ! 0 47 ! Use ROMBERG Integration 48 EPS = .05 ! 0 49 CALL QATR2(1.,XRI,EPS,NDIM2,F2INT,VALUE,IER,NUM,AUX2) 50 ELSE 51 ! Use 2-point Gaussian Quadrature 52 CALL QG2D2(1.,XRI,F2INT,VALUE) ! 0 53 ENDIF 54 55 IF ( VDI*VALUE.GT.50.0 ) THEN ! 0 56 ! Potential underflow, limit product to 50.0 57 VALUE = 50.0/VDI ! 0 58 ELSEIF ( VDI*VALUE.LT.-50.0 ) THEN 59 ! Potential overflow, limit product to 50.0 60 VALUE = -50.0/VDI ! 0 61 ENDIF 62 63 QCOR = EXP(-VDI*VALUE) ! 0 64 65 CONTINUE 66 END
HyperKWIC - Version 1.00DD executed at 20:00 on 1 Mar 2018 | Personal or Academic or Evaluation User | Free for Non-Commercial, Non-Government Use