1 2 3 SUBROUTINE VOLCALC(XARG,L_PLUME,AEROUT) 4 !*********************************************************************** 5 ! VOLCALC Module of the AMS/EPA Regulatory Model - AERMOD 6 ! 7 ! PURPOSE: Calculates the AERMOD concentration without downwash 8 ! 9 ! PROGRAMMER: Roger Brode, PES, Inc. 10 ! 11 ! DATE: November 10, 2000 12 ! 13 ! CHANGES: 14 ! Added debug statement based on ENSR code. 15 ! R. W. Brode, MACTEC (f/k/a PES), Inc., 07/27/04 16 ! 17 ! INPUTS: XARG - Real - Distance (m), downwind for coherent 18 ! plume component and radial for 19 ! random component 20 ! L_PLUME - Log - Specifies coherent plume calculation 21 ! if TRUE, otherwise random component 22 ! 23 ! OUTPUTS: AEROUT(NTYP) - Real - AERMOD component of concentration 24 ! without building downwash for either 25 ! coherent plume component or for 26 ! random component, depending on 27 ! L_PLUME. 28 ! 29 ! CALLED FROM: VCALC 30 ! 31 !*********************************************************************** 32 ! Variable Declarations 33 USE MAIN1 34 IMPLICIT NONE 35 CHARACTER MODNAM*12 36 REAL :: AEROUT(NUMTYP) , AERTMP(NUMTYP) , FYOUT , XARG , ADJ 37 INTEGER :: J 38 LOGICAL :: L_PLUME 39 40 SAVE 41 42 ! Variable Initializations 43 MODNAM = 'VOLCALC' !2630016 44 45 DO ITYP = 1 , NUMTYP 46 AEROUT(ITYP) = 0.0 !2630016 47 AERTMP(ITYP) = 0.0 48 ENDDO 49 50 IF ( DISTR.LT.(XRAD+0.99) ) THEN !2630016 51 ! Receptor Too Close to Source for Calculation 52 DO ITYP = 1 , NUMTYP ! 12176 53 AEROUT(ITYP) = 0.0 ! 12176 54 IF ( WETSCIM ) HRVALD(ITYP) = 0.0 55 ENDDO 56 ELSEIF ( (XARG-XRAD).LT.0.0 ) THEN 57 ! Receptor Upwind of Downwind Edge 58 DO ITYP = 1 , NUMTYP ! 645280 59 AEROUT(ITYP) = 0.0 ! 645280 60 IF ( WETSCIM ) HRVALD(ITYP) = 0.0 61 ENDDO 62 ELSEIF ( TOXICS .AND. DISTR.GT.80000. ) THEN 63 ! Receptor is beyond 80km from source. 64 DO ITYP = 1 , NUMTYP ! 0 65 AEROUT(ITYP) = 0.0 ! 0 66 IF ( WETSCIM ) HRVALD(ITYP) = 0.0 67 ENDDO 68 ELSE 69 70 ! Determine Deposition Correction Factors 71 IF ( LDGAS .OR. LWGAS ) THEN !1972560 72 CALL PDEPG(XARG) ! 0 73 ELSE 74 DQCORG = 1.0 !1972560 75 WQCORG = 1.0 76 ENDIF 77 IF ( LDPART .OR. LWPART ) THEN !1972560 78 CALL PDEP(XARG) ! 0 79 ELSEIF ( NPD.GT.0 ) THEN 80 DO J = 1 , NPD ! 0 81 DQCOR(J) = 1.0 ! 0 82 WQCOR(J) = 1.0 83 ENDDO 84 ENDIF 85 86 ! Set initial effective parameters 87 UEFF = US !1972560 88 SVEFF = SVS 89 SWEFF = SWS 90 TGEFF = TGS 91 IF ( UNSTAB .AND. (HS.LT.ZI) ) THEN 92 UEFFD = US ! 322632 93 SVEFFD = SVS 94 SWEFFD = SWS 95 UEFFN = US 96 SVEFFN = SVS 97 SWEFFN = SWS 98 ENDIF 99 100 !RJP Add temporary debugging statement here. 101 102 ! ENSR ENHANCEMENT OF WRITE STATEMENT TO IDENTIFY COMPONENT CONCENTRATION 103 IF ( DEBUG ) THEN !1972560 104 IF ( L_PLUME ) THEN ! 0 105 WRITE (DBGUNT,6015) UEFF , SVEFF , SWEFF ! 0 106 6015 FORMAT (//,'COHERENT PLUME COMPONENT',/,5X, & 107 & 'Initial effective parameters for ', & 108 & 'stable or direct convective ','plume:',//,5x, & 109 & 'Ueff = ',F7.2,' m/s; ','SVeff = ',F7.2, & 110 & ' m/s; SWeff = ',F7.2,' m/s.',/) 111 ELSE 112 WRITE (DBGUNT,6016) UEFF , SVEFF , SWEFF ! 0 113 6016 FORMAT (//,'MEANDER COMPONENT',/,5X, & 114 & 'Initial effective parameters for ', & 115 & 'stable or direct convective ','plume:',//,5x, & 116 & 'Ueff = ',F7.2,' m/s; ','SVeff = ',F7.2, & 117 & ' m/s; SWeff = ',F7.2,' m/s.',/) 118 ENDIF 119 ENDIF 120 121 ! Define plume centroid height (CENTER) for use in 122 ! inhomogeniety calculations 123 CALL CENTROID(XARG) !1972560 124 125 ! If the atmosphere is unstable and the stack 126 ! top is below the mixing height, calculate 127 ! the CBL PDF coefficients --- CALL PDF 128 IF ( UNSTAB .AND. (HS.LT.ZI) ) CALL PDF 129 130 ! Determine Effective Plume Height --- CALL HEFF 131 CALL HEFF(XARG) 132 133 ! Compute effective parameters using an 134 ! iterative average through plume rise layer 135 CALL IBLVAL(XARG) 136 137 ! Call PDF & HEFF again for final CBL plume heights 138 IF ( UNSTAB .AND. (HS.LT.ZI) ) THEN 139 CALL PDF ! 322632 140 CALL HEFF(XARG) 141 ENDIF 142 143 ! Determine Dispersion Parameters --- CALL VDIS 144 CALL VDIS(XARG) !1972560 145 146 ! Calculate the 'y-term' contribution to 147 ! dispersion, FSUBY 148 IF ( L_PLUME ) THEN 149 ! Calculate FSUBY for coherent plume --- CALL FYPLM 150 CALL FYPLM(SY,FYOUT) ! 663640 151 ELSE 152 ! Calculate FSUBY for random component --- CALL FYPAN 153 CALL FYPAN(FYOUT) !1308920 154 ENDIF 155 FSUBY = FYOUT !1972560 156 FSUBYD = FSUBY 157 FSUBYN = FSUBYD 158 159 ! Set lateral term = 0.0 for penetrated source 160 FSUBY3 = 0.0 161 162 ! Check for zero "y-terms"; if zero then skip calculations 163 ! and go to next receptor. 164 IF ( FSUBY.EQ.0.0 .AND. FSUBY3.EQ.0.0 ) THEN 165 DO ITYP = 1 , NUMTYP ! 213472 166 AEROUT(ITYP) = 0.0 ! 213472 167 IF ( WETSCIM ) HRVALD(ITYP) = 0.0 168 ENDDO 169 170 ELSE 171 172 IF ( NPD.EQ.0 ) THEN !1759088 173 ! Perform calculations for gases 174 ! Assign plume tilt, HV = 0.0 175 176 ADJ = DQCORG*WQCORG !1759088 177 178 IF ( STABLE .OR. (UNSTAB .AND. (HS.GE.ZI)) ) THEN 179 ! Calculate height of the "effective reflecting surface" 180 CALL REFL_HT(HE,XARG,0.0,VSIGZ,HSBL) !1468736 181 ELSEIF ( UNSTAB ) THEN 182 HSBL = 0.0 ! 290352 183 ENDIF 184 185 ! Determine the CRITical Dividing Streamline--- CALL CRITDS 186 CALL CRITDS(HE) !1759088 187 188 ! Calculate the fraction of plume below 189 ! HCRIT, PHEE --- CALL PFRACT 190 CALL PFRACT(HE) 191 192 ! Calculate FOPT = f(PHEE) --- CALL FTERM 193 CALL FTERM 194 195 ! Calculate Conc. for Virtual Point Source --- CALL AER_PCHI 196 CALL AER_PCHI(XARG,ADJ,VDEPG,0,AEROUT) 197 198 ELSE 199 ! Perform calculations for particles, loop through particle sizes 200 201 ! Begin loop over particle sizes 202 DO J = 1 , NPD ! 0 203 204 ! Calculate Plume Tilt Due to Settling, HV 205 HV = (XARG/US)*VGRAV(J) ! 0 206 207 ! Adjust Jth contribution by mass fraction and source 208 ! depletion 209 ADJ = PHI(J)*DQCOR(J)*WQCOR(J) 210 211 IF ( STABLE .OR. (UNSTAB .AND. (HS.GE.ZI)) ) THEN 212 ! Calculate height of the "effective reflecting surface" 213 HESETL = MAX(0.0,HE-HV) ! 0 214 CALL REFL_HT(HESETL,XARG,0.0,VSIGZ,HSBL) 215 ELSEIF ( UNSTAB ) THEN 216 HESETL = MAX(0.0,0.5*(HED1+HED2)-HV) ! 0 217 HSBL = 0.0 218 ENDIF 219 220 ! Determine the CRITical Dividing Streamline--- CALL CRITDS 221 CALL CRITDS(HESETL) ! 0 222 223 ! Calculate the fraction of plume below 224 ! HCRIT, PHEE --- CALL PFRACT 225 CALL PFRACT(HESETL) 226 227 ! Calculate FOPT = f(PHEE) --- CALL FTERM 228 CALL FTERM 229 230 ! Calculate Conc. for Virtual Point Source --- CALL AER_PCHI 231 CALL AER_PCHI(XARG,ADJ,VDEP(J),J,AERTMP) 232 AEROUT = AEROUT + AERTMP 233 234 ENDDO 235 ! End loop over particle sizes 236 237 ENDIF 238 ENDIF 239 ENDIF 240 241 CONTINUE !2630016 242 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