1 2 3 SUBROUTINE VCALC 4 !*********************************************************************** 5 ! VCALC Module of the AMS/EPA Regulatory Model - AERMOD 6 ! 7 ! PURPOSE: Calculates concentration or deposition values 8 ! for VOLUME sources 9 ! 10 ! PROGRAMMER: Roger Brode, Jeff Wang 11 ! 12 ! DATE: March 2, 1992 13 ! 14 ! MODIFIED: 15 ! Modified to include initialization of __VAL arrays 16 ! at end of receptor loop. 17 ! R. W. Brode, MACTEC (f/k/a PES), Inc., 10/26/04 18 ! 19 ! Modified to include the PVMRM and OLM options for 20 ! modeling conversion of NOx to NO2. 21 ! Added debug statement based on ENSR code. 22 ! R. W. Brode, MACTEC (f/k/a PES), Inc., 07/27/04 23 ! 24 ! To assign values to XDIST before calls to 25 ! SUBROUTINE VOLCALC. 26 ! R. W. Brode, MACTEC (f/k/a PES), Inc., 03/19/04 27 ! 28 ! INPUTS: Source Parameters for Specific Source 29 ! Arrays of Receptor Locations 30 ! Meteorological Variables for One Hour 31 ! 32 ! OUTPUTS: 1-hr CONC or DEPOS Values for Each Receptor for 33 ! Particular Source 34 ! 35 ! CALLED FROM: CALC 36 !*********************************************************************** 37 38 ! Variable Declarations 39 USE MAIN1 40 IMPLICIT NONE 41 CHARACTER MODNAM*12 42 INTEGER :: I 43 REAL :: AERPLM(NUMTYP) , AERPAN(NUMTYP) , FRAN 44 LOGICAL :: L_PLUME 45 46 SAVE 47 48 ! Variable Initializations 49 MODNAM = 'VCALC' ! 9132 50 WAKE = .FALSE. 51 52 ! Initialize HRVAL arrays 53 DO ITYP = 1 , NUMTYP 54 HRVAL(ITYP) = 0.0 ! 9132 55 HRVALD(ITYP) = 0.0 56 AERVAL(ITYP) = 0.0 57 AERVALD(ITYP) = 0.0 58 AERPLM(ITYP) = 0.0 59 AERPAN(ITYP) = 0.0 60 ENDDO 61 62 ! Set the Source Variables for This Source --- CALL SETSRC 63 CALL SETSRC ! 9132 64 65 ! Apply Variable Emission Rate and Unit Factors --- CALL EMFACT 66 CALL EMFACT(QS) 67 68 ! Initialize 'ARC' Arrays for EVALFILE Output --- CALL EVLINI 69 IF ( EVAL(ISRC) ) CALL EVLINI 70 71 IF ( QTK.NE.0.0 ) THEN 72 ! Set Mixing Height and Profiles for Urban Option if Needed 73 IF ( STABLE .AND. URBAN ) THEN ! 9132 74 IF ( URBSRC(ISRC).EQ.'Y' ) THEN ! 0 75 URBSTAB = .TRUE. ! 0 76 ZI = AMAX1(ZIURB,ZIMECH) 77 GRIDSV = GRDSVU 78 GRIDSW = GRDSWU 79 GRIDTG = GRDTGU 80 GRIDPT = GRDPTU 81 OBULEN = ABS(URBOBULEN) 82 USTAR = URBUSTR 83 ELSEIF ( URBSRC(ISRC).EQ.'N' ) THEN 84 URBSTAB = .FALSE. ! 0 85 ZI = ZIRUR 86 GRIDSV = GRDSVR 87 GRIDSW = GRDSWR 88 GRIDTG = GRDTGR 89 GRIDPT = GRDPTR 90 OBULEN = RUROBULEN 91 USTAR = RURUSTR 92 ENDIF 93 ELSE 94 URBSTAB = .FALSE. ! 9132 95 ENDIF 96 97 ! Initialize meteorological variables --- CALL METINI 98 CALL METINI ! 9132 99 ! Initialize miscellaneous variables 100 FB = 0.0 101 FM = 0.0 102 PPF = 0.0 103 HSP = HS 104 DHP = 0.0 105 DHP1 = 0.0 106 DHP2 = 0.0 107 DHP3 = 0.0 108 DHCRIT = 0.0 109 XFINAL = 0.0 110 XMIXED = ZI*UAVG/SWAVG 111 IF ( XMIXED.LT.XFINAL ) XMIXED = XFINAL 112 ZMIDMX = 0.5*ZI 113 114 ! Calculate Effective Radius 115 XRAD = 2.15*SYINIT 116 117 !DEP Initialize PDF parameters for use in calculating ZSUBP 118 IF ( UNSTAB .AND. (HS.LT.ZI) ) CALL PDF 119 ! Set Deposition Variables for this Source 120 ! Calculate Deposition Velocities for this Source --- CALL VDP 121 IF ( LDPART .OR. LDGAS ) CALL VDP 122 IF ( LWPART .OR. LWGAS ) THEN 123 !PES Set value of ZSUBP = MAX( ZI, TOP OF PLUME ), where 124 !PES TOP OF PLUME is defined as plume height (HE) plus 2.15*SZ, 125 !PES evaluated at a distance of 20 kilometers downwind. 126 !PES Apply minimum value of 500m and maximum value of 10,000m. 127 IF ( STABLE .OR. (UNSTAB .AND. HS.GE.ZI) ) THEN ! 0 128 CALL SIGZ(20000.) ! 0 129 ZSUBP = MAX(500.,ZI,HS+SZCOEF*SZAS) 130 ELSEIF ( UNSTAB ) THEN 131 CALL SIGZ(20000.) ! 0 132 ZSUBP = MAX(500.,ZI,HS+SZCOEF*(SZAD1+SZAD2)/2.) 133 ENDIF 134 ZSUBP = MIN(10000.,ZSUBP) ! 0 135 ! Calculate Scavenging Ratios for this Source --- CALL SCAVRAT 136 CALL SCAVRAT 137 ENDIF 138 139 ! Begin Receptor LOOP 140 RECEPTOR_LOOP:DO IREC = 1 , NUMREC ! 9132 141 ! Calculate Down and Crosswind Distances --- CALL XYDIST 142 IF ( EVONLY ) THEN !1315008 143 CALL XYDIST(IEVENT) ! 0 144 ELSE 145 CALL XYDIST(IREC) !1315008 146 ENDIF 147 148 ! --- First calculate coherent plume component using downwind distance 149 L_PLUME = .TRUE. !1315008 150 ! --- Assign XDIST for use in dry depletion (FUNCTION F2INT) 151 XDIST = X 152 CALL VOLCALC(X,L_PLUME,AERPLM) 153 154 ! --- Next calculate random "pancake" component using radial distance 155 L_PLUME = .FALSE. 156 ! --- Assign XDIST for use in dry depletion (FUNCTION F2INT) 157 XDIST = DISTR 158 CALL VOLCALC(DISTR,L_PLUME,AERPAN) 159 160 ! --- Calculate fraction of random kinetic energy to total kinetic energy. 161 ! Note that these effective parameters are based on the radial dist. 162 IF ( STABLE .OR. (UNSTAB .AND. (HS.GE.ZI)) ) THEN 163 CALL MEANDR(UEFF,SVEFF,FRAN) !1099872 164 ELSEIF ( UNSTAB ) THEN 165 CALL MEANDR(UEFFD,SVEFFD,FRAN) ! 215136 166 ENDIF 167 168 ! --- Combine coherent plume and random "pancake" components 169 DO ITYP = 1 , NUMTYP !1315008 170 HRVAL(ITYP) = FRAN*AERPAN(ITYP) + (1.-FRAN)*AERPLM(ITYP) !1315008 171 ! ENSR STATEMENT 172 IF ( DEBUG ) THEN 173 WRITE (DBGUNT,10) AERPAN(ITYP) , AERPLM(ITYP) , FRAN ,& 174 & HRVAL(ITYP) 175 10 FORMAT (/, & 176 & 'HRVAL(ITYP) = FRAN*AERPAN(ITYP) + (1.-FRAN) *AERPLM(ITYP)'& 177 & ,//,'PANCAKE/MEANDER COMPONENT, AERPAN(ITYP) = ',G16.8,/, & 178 & 'COHERENT PLUME COMPONENT, AERPLM(ITYP) = ',G16.8,/, & 179 & 'MEANDER FACTOR, FRAN = ',G16.8,/, & 180 & 'RESULTANT CONC, HRVAL(ITYP) = ',G16.8,//) 181 ENDIF 182 ENDDO 183 184 IF ( PVMRM .AND. .NOT.O3MISS ) THEN !1315008 185 ! --- Store data by source and receptor for PVMRM option 186 DO ITYP = 1 , NUMTYP ! 0 187 CHI(IREC,ISRC,ITYP) = HRVAL(ITYP) ! 0 188 ENDDO 189 IF ( STABLE .OR. (UNSTAB .AND. (HS.GE.ZI)) ) THEN ! 0 190 HECNTR(IREC,ISRC) = HE ! 0 191 UEFFS(IREC,ISRC) = UEFF 192 ELSE 193 HECNTR(IREC,ISRC) = CENTER ! 0 194 UEFFS(IREC,ISRC) = UEFFD 195 ENDIF 196 IF ( PPF.GT.0.0 ) THEN ! 0 197 HECNTR3(IREC,ISRC) = HE3 ! 0 198 PPFACT(ISRC) = PPF 199 UEFF3S(IREC,ISRC) = UEFF3 200 ENDIF 201 FOPTS(IREC,ISRC) = FOPT ! 0 202 ! Cycle to next receptor & skip call to SUMVAL (will be done later) 203 GOTO 50 204 ELSEIF ( OLM .AND. .NOT.O3MISS ) THEN 205 ! --- Store data by source and receptor for OLM option 206 DO ITYP = 1 , NUMTYP ! 0 207 CHI(IREC,ISRC,ITYP) = HRVAL(ITYP) ! 0 208 ENDDO 209 ! Cycle to next receptor & skip call to SUMVAL (will be done later) 210 GOTO 50 ! 0 211 ENDIF 212 213 IF ( EVONLY ) THEN !1315008 214 CALL EV_SUMVAL ! 0 215 ELSE 216 CALL SUMVAL !1315008 217 ENDIF 218 ! Check ARC centerline values for EVALFILE 219 ! output --- CALL EVALCK 220 IF ( EVAL(ISRC) ) CALL EVALCK !1315008 221 222 ! Initialize __VAL arrays 223 DO ITYP = 1 , NUMTYP 224 HRVAL(ITYP) = 0.0 !1315008 225 HRVALD(ITYP) = 0.0 226 AERVAL(ITYP) = 0.0 227 AERVALD(ITYP) = 0.0 228 AERPLM(ITYP) = 0.0 229 AERPAN(ITYP) = 0.0 230 ENDDO 231 232 50 ENDDO RECEPTOR_LOOP 233 ! End Receptor LOOP 234 235 ! Output 'ARC' Values for EVALFILE --- CALL EVALFL 236 IF ( EVAL(ISRC) ) CALL EVALFL ! 9132 237 238 ENDIF 239 240 CONTINUE ! 9132 241 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