1 SUBROUTINE SOCARD 2 !*********************************************************************** 3 ! SOCARD Module of the AMS/EPA Regulatory Model - AERMOD 4 ! ---------------------------------------------------------------------- 5 ! --- ISC-PRIME Version 1.0 Level 970812 Modified 6 ! --- V. Tino 7 ! --- Earth Tech, Inc. 8 ! Prepared for EPRI under contract WO3527-01 9 ! ---------------------------------------------------------------------- 10 ! 11 ! PURPOSE: To process SOurce Pathway card images 12 ! 13 ! PROGRAMMER: Roger Brode, Jeff Wang 14 ! MODIFIED BY D. Strimaitis, SRC (for WET DEPOSITION) 15 ! 16 ! DATE: November 8, 1993 17 ! 18 ! MODIFIED BY D. Strimaitis, SRC (for DRY DEPOSITION) 19 ! (DATE: February 15, 1993) 20 ! 21 ! INPUTS: Pathway (SO) and Keyword 22 ! 23 ! OUTPUTS: Source Arrays 24 ! Sourcer Setup Status Switches 25 ! 26 ! CALLED FROM: SETUP 27 !*********************************************************************** 28 29 ! Variable Declarations 30 USE MAIN1 31 IMPLICIT NONE 32 CHARACTER MODNAM*12 33 34 SAVE 35 INTEGER :: I , J , ILSAVE 36 37 ! Variable Initializations 38 MODNAM = 'SOCARD' ! 291 39 40 IF ( KEYWRD.EQ.'STARTING' ) THEN 41 ! Initialize Counters and Set Status Switch 42 ISRC = 0 ! 3 43 IGRP = 0 44 NUMSRC = 0 45 NUMGRP = 0 46 NUMURB = 0 47 ISSTAT(1) = ISSTAT(1) + 1 48 IF ( ISSTAT(1).NE.1 ) THEN 49 CALL ERRHDL(PATH,MODNAM,'E','135',KEYWRD) ! 0 50 GOTO 999 51 ENDIF 52 ! Flush The Working Area 53 DO I = 1 , NSRC ! 3 54 DO J = 1 , 13 ! 27 55 IWRK2(I,J) = 0 ! 351 56 ENDDO 57 ENDDO 58 ELSEIF ( KEYWRD.EQ.'LOCATION' ) THEN 59 ! Set Status Switch 60 ISSTAT(2) = ISSTAT(2) + 1 ! 27 61 ! Check for SRCGROUP Card Out Of Order 62 IF ( ISSTAT(24).NE.0 ) & 63 & CALL ERRHDL(PATH,MODNAM,'E','140','SRCGROUP') 64 ! Process Source Location --- CALL SOLOCA 65 CALL SOLOCA 66 ELSEIF ( KEYWRD.EQ.'SRCPARAM' ) THEN 67 ! Set Status Switch 68 ISSTAT(3) = ISSTAT(3) + 1 ! 27 69 ! Check for SRCGROUP Card Out Of Order 70 IF ( ISSTAT(24).NE.0 ) & 71 & CALL ERRHDL(PATH,MODNAM,'E','140','SRCGROUP') 72 ! Process Source Parameters --- CALL SOPARM 73 CALL SOPARM 74 75 ! --- PRIME --------------------------------- 76 ! prm& KEYWRD .EQ. 'LOWBOUND') THEN 77 ELSEIF ( KEYWRD.EQ.'BUILDHGT' .OR. KEYWRD.EQ.'BUILDWID' .OR. & 78 & KEYWRD.EQ.'BUILDLEN' .OR. KEYWRD.EQ.'XBADJ ' .OR. & 79 & KEYWRD.EQ.'YBADJ ' ) THEN 80 ! ------------------------------------------- 81 82 ! Check for SRCGROUP Card Out Of Order 83 IF ( ISSTAT(24).NE.0 ) & 84 & CALL ERRHDL(PATH,MODNAM,'E','140','SRCGROUP') 85 ! Set Status Switch 86 IF ( KEYWRD.EQ.'BUILDHGT' ) THEN 87 ISSTAT(4) = ISSTAT(4) + 1 ! 9 88 ELSEIF ( KEYWRD.EQ.'BUILDWID' ) THEN 89 ISSTAT(5) = ISSTAT(5) + 1 ! 54 90 91 ! --- PRIME ----------------------------------- 92 ELSEIF ( KEYWRD.EQ.'BUILDLEN' ) THEN 93 ISSTAT(21) = ISSTAT(21) + 1 ! 54 94 ELSEIF ( KEYWRD.EQ.'XBADJ ' ) THEN 95 ISSTAT(22) = ISSTAT(22) + 1 ! 54 96 ELSEIF ( KEYWRD.EQ.'YBADJ ' ) THEN 97 ISSTAT(23) = ISSTAT(23) + 1 ! 54 98 ! --------------------------------------------- 99 100 ENDIF 101 ! Process Direction-specific Building Dimensions --- CALL DSBLDG 102 CALL DSBLDG ! 225 103 ELSEIF ( KEYWRD.EQ.'EMISFACT' ) THEN 104 ! Set Status Switch 105 ISSTAT(7) = ISSTAT(7) + 1 ! 0 106 ! Check for SRCGROUP Card Out Of Order 107 IF ( ISSTAT(24).NE.0 ) & 108 & CALL ERRHDL(PATH,MODNAM,'E','140','SRCGROUP') 109 ! Process Variable Emission Rate Factors --- CALL EMVARY 110 CALL EMVARY 111 ELSEIF ( KEYWRD.EQ.'EMISUNIT' ) THEN 112 ! Set Status Switch 113 ISSTAT(8) = ISSTAT(8) + 1 ! 0 114 ! Check for SRCGROUP Card Out Of Order 115 IF ( ISSTAT(24).NE.0 ) & 116 & CALL ERRHDL(PATH,MODNAM,'E','140','SRCGROUP') 117 IF ( ISSTAT(8).NE.1 ) THEN 118 CALL ERRHDL(PATH,MODNAM,'E','135',KEYWRD) ! 0 119 ELSEIF ( NUMTYP.EQ.1 ) THEN 120 ! Process Emission Rate Unit Conversion Factors --- CALL EMUNIT 121 CALL EMUNIT ! 0 122 ELSE 123 ! WRITE Error Message: EMISUNIT Keyword with more than 1 output type 124 CALL ERRHDL(PATH,MODNAM,'E','158',' ') ! 0 125 ENDIF 126 ELSEIF ( KEYWRD.EQ.'PARTDIAM' .OR. KEYWRD.EQ.'MASSFRAX' .OR. & 127 & KEYWRD.EQ.'PARTDENS' ) THEN 128 ! Set Status Switch 129 IF ( KEYWRD.EQ.'PARTDIAM' ) THEN ! 0 130 ISSTAT(9) = ISSTAT(9) + 1 ! 0 131 ELSEIF ( KEYWRD.EQ.'MASSFRAX' ) THEN 132 ISSTAT(10) = ISSTAT(10) + 1 ! 0 133 ELSEIF ( KEYWRD.EQ.'PARTDENS' ) THEN 134 ISSTAT(11) = ISSTAT(11) + 1 ! 0 135 ENDIF 136 ! Check for SRCGROUP Card Out Of Order 137 IF ( ISSTAT(24).NE.0 ) & 138 & CALL ERRHDL(PATH,MODNAM,'E','140','SRCGROUP') 139 ! Process Particle Deposition Parameters --- CALL PARTDEP 140 CALL PARTDEP 141 142 ELSEIF ( KEYWRD.EQ.'ELEVUNIT' ) THEN 143 ! Set Status Switch 144 ISSTAT(15) = ISSTAT(15) + 1 ! 3 145 ! Check for SRCGROUP Card Out Of Order 146 IF ( ISSTAT(24).NE.0 ) & 147 & CALL ERRHDL(PATH,MODNAM,'E','140','SRCGROUP') 148 IF ( ISSTAT(15).NE.1 ) THEN 149 ! WRITE Error Message: Repeat Non-repeatable Keyword 150 CALL ERRHDL(PATH,MODNAM,'E','135',KEYWRD) ! 0 151 ELSEIF ( NUMSRC.GT.0 ) THEN 152 ! Write Error Message: ELEVUNIT must be first card after STARTING 153 CALL ERRHDL(PATH,MODNAM,'E','152',' SO') ! 0 154 ELSE 155 ! Process Elevation Units for Source Elevations --- CALL SOELUN 156 CALL SOELUN ! 3 157 ENDIF 158 ELSEIF ( KEYWRD.EQ.'HOUREMIS' ) THEN 159 !* Set Status Switch 160 ISSTAT(16) = ISSTAT(16) + 1 ! 0 161 ! Check for SRCGROUP Card Out Of Order 162 IF ( ISSTAT(24).NE.0 ) & 163 & CALL ERRHDL(PATH,MODNAM,'E','140','SRCGROUP') 164 ! Set HOURLY Flag 165 HOURLY = .TRUE. 166 !* Process Hourly Emissions --- CALL HREMIS 167 CALL HREMIS 168 !*# 169 170 ELSEIF ( KEYWRD.EQ.'CONCUNIT' ) THEN 171 ! Set Status Switch 172 ISSTAT(17) = ISSTAT(17) + 1 ! 0 173 ! Check for SRCGROUP Card Out Of Order 174 IF ( ISSTAT(24).NE.0 ) & 175 & CALL ERRHDL(PATH,MODNAM,'E','140','SRCGROUP') 176 IF ( ISSTAT(17).NE.1 ) THEN 177 CALL ERRHDL(PATH,MODNAM,'E','135',KEYWRD) ! 0 178 ELSEIF ( ISSTAT(8).NE.0 ) THEN 179 CALL ERRHDL(PATH,MODNAM,'E','159',KEYWRD) ! 0 180 ELSE 181 ! Process Emission Rate Unit Conversion Factors --- CALL COUNIT 182 CALL COUNIT ! 0 183 ENDIF 184 ELSEIF ( KEYWRD.EQ.'DEPOUNIT' ) THEN 185 ! Set Status Switch 186 ISSTAT(18) = ISSTAT(18) + 1 ! 0 187 ! Check for SRCGROUP Card Out Of Order 188 IF ( ISSTAT(24).NE.0 ) & 189 & CALL ERRHDL(PATH,MODNAM,'E','140','SRCGROUP') 190 IF ( ISSTAT(18).NE.1 ) THEN 191 CALL ERRHDL(PATH,MODNAM,'E','135',KEYWRD) ! 0 192 ELSEIF ( ISSTAT(8).NE.0 ) THEN 193 CALL ERRHDL(PATH,MODNAM,'E','159',KEYWRD) ! 0 194 ELSE 195 ! Process Emission Rate Unit Conversion Factors --- CALL DPUNIT 196 CALL DPUNIT ! 0 197 ENDIF 198 199 ELSEIF ( KEYWRD.EQ.'AREAVERT' ) THEN 200 ! Set Status Switch 201 ISSTAT(19) = ISSTAT(19) + 1 ! 0 202 ! Check for SRCGROUP Card Out Of Order 203 IF ( ISSTAT(24).NE.0 ) & 204 & CALL ERRHDL(PATH,MODNAM,'E','140','SRCGROUP') 205 ! Process Vertices for AREAPOLY Sources --- CALL ARVERT 206 CALL ARVERT 207 208 ELSEIF ( KEYWRD.EQ.'INCLUDED' ) THEN 209 ! Set Status Switch 210 ISSTAT(20) = ISSTAT(20) + 1 ! 0 211 ! Save ILINE as ISAVE 212 ILSAVE = ILINE 213 ! Process the Included Receptor File --- CALL INCLUD 214 CALL INCLUD 215 ! Retrieve ILINE From ISAVE 216 ILINE = ILSAVE 217 218 ELSEIF ( KEYWRD.EQ.'SRCGROUP' ) THEN 219 ! Set Status Switch 220 ISSTAT(24) = ISSTAT(24) + 1 ! 3 221 ! Process Source Groups --- CALL SOGRP 222 CALL SOGRP 223 224 ELSEIF ( KEYWRD.EQ.'GASDEPOS' ) THEN 225 ! Set Status Switch 226 ISSTAT(21) = ISSTAT(21) + 1 ! 0 227 ! Check for SRCGROUP Card Out Of Order 228 IF ( ISSTAT(24).NE.0 ) & 229 & CALL ERRHDL(PATH,MODNAM,'E','140','SRCGROUP') 230 IF ( .NOT.TOXICS ) THEN 231 ! Write Error Message: Gas Deposition Option w/o TOXICS Option 232 CALL ERRHDL(PATH,MODNAM,'E','198',KEYWRD) ! 0 233 ELSEIF ( .NOT.LUSERVD ) THEN 234 ! Process Gas Deposition Parameters --- CALL GASDEP 235 CALL GASDEP ! 0 236 ELSE 237 ! Write Error Message: User-specified deposition velocity 238 CALL ERRHDL(PATH,MODNAM,'E','196',KEYWRD) ! 0 239 ENDIF 240 241 ELSEIF ( KEYWRD.EQ.'METHOD_2' ) THEN 242 ! Set Status Switch 243 ISSTAT(22) = ISSTAT(22) + 1 ! 0 244 ! Check for SRCGROUP Card Out Of Order 245 IF ( ISSTAT(24).NE.0 ) & 246 & CALL ERRHDL(PATH,MODNAM,'E','140','SRCGROUP') 247 IF ( .NOT.TOXICS ) THEN 248 ! Write Error Message: Method 2 Deposition Option w/o TOXICS Option 249 CALL ERRHDL(PATH,MODNAM,'E','198',KEYWRD) ! 0 250 ELSE 251 ! Process Method 2 Deposition Parameters --- CALL METH_2 252 CALL METH_2 ! 0 253 ENDIF 254 255 ELSEIF ( KEYWRD.EQ.'URBANSRC' ) THEN 256 ! Set Status Switch 257 ISSTAT(22) = ISSTAT(22) + 1 ! 0 258 ! Check for SRCGROUP Card Out Of Order 259 IF ( ISSTAT(24).NE.0 ) & 260 & CALL ERRHDL(PATH,MODNAM,'E','140','SRCGROUP') 261 IF ( URBAN ) THEN 262 ! Process the Urban Source Card --- CALL URBANS 263 CALL URBANS ! 0 264 ELSE 265 ! Write Error Message: Urban source defined without URBANOPT card 266 CALL ERRHDL(PATH,MODNAM,'E','130','URBANOPT') ! 0 267 ENDIF 268 269 ELSEIF ( KEYWRD.EQ.'NO2RATIO' ) THEN 270 ! Set Status Switch 271 ISSTAT(26) = ISSTAT(26) + 1 ! 0 272 ! Check for SRCGROUP Card Out Of Order 273 IF ( ISSTAT(24).NE.0 ) & 274 & CALL ERRHDL(PATH,MODNAM,'E','140','SRCGROUP') 275 IF ( PVMRM .OR. OLM ) THEN 276 ! Process the NO2 Ratio Card --- CALL NO2RAT 277 CALL NO2RAT ! 0 278 ELSE 279 ! Write Error Message: NO2RATIO specified without PVMRM or OLM 280 CALL ERRHDL(PATH,MODNAM,'E','142',KEYWRD) ! 0 281 ENDIF 282 283 ELSEIF ( KEYWRD.EQ.'OLMGROUP' ) THEN 284 ! Set Status Switch 285 ISSTAT(27) = ISSTAT(27) + 1 ! 0 286 ! Check for SRCGROUP Card Out Of Order 287 IF ( ISSTAT(24).NE.0 ) & 288 & CALL ERRHDL(PATH,MODNAM,'E','140','SRCGROUP') 289 IF ( OLM ) THEN 290 ! Process the OLM Group Card --- CALL OLMGRP 291 CALL OLMGRP ! 0 292 ELSE 293 ! Write Error Message: OLMGROUP specified without OLM 294 CALL ERRHDL(PATH,MODNAM,'E','144',KEYWRD) ! 0 295 ENDIF 296 297 ELSEIF ( KEYWRD.EQ.'FINISHED' ) THEN 298 ! Set Status Switch 299 ISSTAT(25) = ISSTAT(25) + 1 ! 3 300 IF ( ISSTAT(25).NE.1 ) & 301 & CALL ERRHDL(PATH,MODNAM,'E','135',KEYWRD) 302 303 ! Check for Missing Mandatory Keywords 304 IF ( ISSTAT(1).EQ.0 ) & 305 & CALL ERRHDL(PATH,MODNAM,'E','130','STARTING') 306 IF ( ISSTAT(2).EQ.0 ) & 307 & CALL ERRHDL(PATH,MODNAM,'E','130','LOCATION') 308 IF ( ISSTAT(3).EQ.0 ) & 309 & CALL ERRHDL(PATH,MODNAM,'E','130','SRCPARAM') 310 IF ( ISSTAT(24).EQ.0 ) & 311 & CALL ERRHDL(PATH,MODNAM,'E','130','SRCGROUP') 312 ! Must Be Missing a SRCPARAM Card for One or More Sources 313 IF ( ISSTAT(3).LT.ISSTAT(2) ) & 314 & CALL ERRHDL(PATH,MODNAM,'E','130','SRCPARAM') 315 316 ! Check to Insure That SRCGROUP Was The Last Functional Keyword 317 IF ( PKEYWD.NE.'SRCGROUP' ) & 318 & CALL ERRHDL(PATH,MODNAM,'E','140','SRCGROUP') 319 320 IF ( NUMSRC.EQ.0 ) THEN 321 ! WRITE Error Message: No Sources Input 322 CALL ERRHDL(PATH,MODNAM,'E','248','NUMSRC=0') ! 0 323 ELSE 324 ! Quality Assure Source Parameter Inputs --- CALL SRCQA 325 CALL SRCQA ! 3 326 ! Check for consistency of deposition logical variables 327 ! with DFAULT/TOXICS options 328 ! Write Error Message: Deposition Option w/o TOXICS Option 329 IF ( .NOT.TOXICS .AND. (LDGAS .OR. LWGAS) ) & 330 & CALL ERRHDL(PATH,MODNAM,'E','198',' GASDEP ') 331 ! Write Error Message: Deposition Option w/o TOXICS Option 332 IF ( .NOT.TOXICS .AND. (LWPART .OR. LWGAS) ) & 333 & CALL ERRHDL(PATH,MODNAM,'E','198',' WETDEP ') 334 ! Check for CO GDSEASON Card if Gas Deposition is Calculated 335 ! Write Error Message: Missing Mandatory Keyword 336 IF ( LDGAS .AND. ICSTAT(18).EQ.0 ) & 337 & CALL ERRHDL('CO',MODNAM,'E','130','GDSEASON') 338 ! Check for CO GDLANUSE Card if Gas Deposition is Calculated 339 ! Write Error Message: Missing Mandatory Keyword 340 IF ( LDGAS .AND. ICSTAT(21).EQ.0 ) & 341 & CALL ERRHDL('CO',MODNAM,'E','130','GDLANUSE') 342 ! Calculate settling velocity and related time-invariant 343 ! deposition data --- CALL VDP1 344 IF ( LDPART .OR. LDGAS ) CALL VDP1 345 ENDIF 346 347 ELSE 348 ! Write Error Message: Invalid Keyword for This Pathway 349 CALL ERRHDL(PATH,MODNAM,'E','110',KEYWRD) ! 0 350 ENDIF 351 352 999 CONTINUE ! 291 353 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