1 2 SUBROUTINE SRCQA 3 !*********************************************************************** 4 ! SRCQA Module of the AMS/EPA Regulatory Model - AERMOD 5 ! 6 ! PURPOSE: Quality Assure Source Parameter Inputs 7 ! 8 ! PROGRAMMER: Roger Brode, Jeff Wang 9 ! MODIFIED BY D. Strimaitis, SRC (for WET & DRY DEPOSITION) 10 ! 11 ! DATE: November 8, 1993 12 ! 13 ! MODIFIED: Calculates equivalent XINIT and YINIT values for 14 ! AREAPOLY sources to allow for calculation of area 15 ! of source under TOXICS option. Also includes a 16 ! a more refined computation of centroid for 17 ! AREAPOLY sources. 18 ! R.W. Brode, MACTEC (f/k/a PES), Inc., 7/23/2004 19 ! 20 ! MODIFIED: To include an option to vary emissions by season, 21 ! hour-of-day, and day-of-week (SHRDOW). 22 ! R.W. Brode, PES, 4/10/2000 23 ! 24 ! MODIFIED BY D. Strimaitis, SRC (for DEPOSITION) 25 ! (DATE: February 15, 1993) 26 ! 27 ! INPUTS: Source Parameters 28 ! Source Parameters Array Limits, IWRK2(NSRC,13) 29 ! 30 ! OUTPUTS: Source Parameter Error Messages 31 ! 32 ! CALLED FROM: SOCARD 33 !*********************************************************************** 34 35 ! Variable Declarations 36 USE MAIN1 37 IMPLICIT NONE 38 CHARACTER MODNAM*12 39 40 SAVE 41 INTEGER :: I , J , K , N , ITOTSRC , ITOTGRP 42 REAL :: ATOT , SUM , SUMX , SUMY , AREA 43 44 ! Variable Initializations 45 MODNAM = 'SRCQA' ! 3 46 47 ! Begin Source LOOP 48 DO I = 1 , NUMSRC 49 50 ! Check Source Array Limits for Too Few Values; 51 ! (Too Many Checked In DSFILL and EFFILL) 52 IF ( IWRK2(I,1).GT.0 .OR. IWRK2(I,2).GT.0 .OR. IWRK2(I,3) & 53 & .GT.0 .OR. IWRK2(I,11).GT.0 .OR. IWRK2(I,12).GT.0 .OR. & 54 & IWRK2(I,13).GT.0 ) THEN 55 56 ! WRITE Error Message: Not Enough BUILDHGTs 57 IF ( IWRK2(I,1).LT.NSEC ) & 58 & CALL ERRHDL(PATH,MODNAM,'E','236',SRCID(I)) 59 ! WRITE Error Message: Not Enough BUILDWIDs 60 IF ( IWRK2(I,2).LT.NSEC ) & 61 & CALL ERRHDL(PATH,MODNAM,'E','237',SRCID(I)) 62 63 ! --- PRIME ------------------------------------------------- 64 ! WRITE Error Message: Not Enough BUILDLENs 65 IF ( IWRK2(I,11).LT.NSEC ) & 66 & CALL ERRHDL(PATH,MODNAM,'E','241',SRCID(I)) 67 ! WRITE Error Message: Not Enough XBADJs 68 IF ( IWRK2(I,12).LT.NSEC ) & 69 & CALL ERRHDL(PATH,MODNAM,'E','246',SRCID(I)) 70 ! WRITE Error Message: Not Enough YBADJs 71 IF ( IWRK2(I,13).LT.NSEC ) & 72 & CALL ERRHDL(PATH,MODNAM,'E','247',SRCID(I)) 73 ! ----------------------------------------------------------- 74 ENDIF 75 76 IF ( QFLAG(I).NE.' ' ) THEN ! 27 77 IF ( QFLAG(I).EQ.'SEASON' .AND. IWRK2(I,4).LT.4 ) THEN ! 0 78 ! WRITE Error Message: Not Enough QFACTs 79 CALL ERRHDL(PATH,MODNAM,'E','239',SRCID(I)) ! 0 80 ELSEIF ( QFLAG(I).EQ.'MONTH' .AND. IWRK2(I,4).LT.12 ) THEN 81 ! WRITE Error Message: Not Enough QFACTs 82 CALL ERRHDL(PATH,MODNAM,'E','239',SRCID(I)) ! 0 83 ELSEIF ( QFLAG(I).EQ.'HROFDY' .AND. IWRK2(I,4).LT.24 ) THEN 84 ! WRITE Error Message: Not Enough QFACTs 85 CALL ERRHDL(PATH,MODNAM,'E','239',SRCID(I)) ! 0 86 ELSEIF ( QFLAG(I).EQ.'WSPEED' .AND. IWRK2(I,4).LT.6 ) THEN 87 ! WRITE Error Message: Not Enough QFACTs 88 CALL ERRHDL(PATH,MODNAM,'E','239',SRCID(I)) ! 0 89 ELSEIF ( QFLAG(I).EQ.'SEASHR' .AND. IWRK2(I,4).LT.96 ) THEN 90 ! WRITE Error Message: Not Enough QFACTs 91 CALL ERRHDL(PATH,MODNAM,'E','239',SRCID(I)) ! 0 92 ELSEIF ( QFLAG(I).EQ.'SHRDOW' .AND. IWRK2(I,4).LT.288 ) THEN 93 ! WRITE Error Message: Not Enough QFACTs 94 CALL ERRHDL(PATH,MODNAM,'E','239',SRCID(I)) ! 0 95 ELSEIF ( QFLAG(I).EQ.'SHRDOW7' .AND. IWRK2(I,4).LT.672 ) & 96 & THEN 97 ! WRITE Error Message: Not Enough QFACTs 98 CALL ERRHDL(PATH,MODNAM,'E','239',SRCID(I)) ! 0 99 ENDIF 100 ENDIF 101 102 ! Check Settling and Removal Parameters 103 IF ( IWRK2(I,5).NE.0 .OR. IWRK2(I,6).NE.0 .OR. IWRK2(I,7) & 104 & .NE.0 ) THEN 105 ! Set Number of Particle Diameter Categories for This Source 106 INPD(I) = IWRK2(I,5) ! 0 107 ! Check for Consistent Number of Categories for All Parameters 108 ! WRITE Error Message: PartDiam Categories Don't Match 109 IF ( IWRK2(I,5).NE.IWRK2(I,6) .OR. IWRK2(I,5).NE.IWRK2(I,7) & 110 & ) CALL ERRHDL(PATH,MODNAM,'E','240',SRCID(I)) 111 ! Check for Mass Fraction Summing to 1.0 (+/- 2%) 112 ATOT = 0.0 113 N = INPD(I) 114 IF ( N.LE.NPDMAX ) THEN 115 DO J = 1 , N ! 0 116 ATOT = ATOT + APHI(J,I) ! 0 117 ENDDO 118 ! WRITE Error Message: Mass Fractions Don't Sum to 1.0 119 IF ( ATOT.LT.0.98 .OR. ATOT.GT.1.02 ) & 120 & CALL ERRHDL(PATH,MODNAM,'W','330',SRCID(I)) 121 ELSE 122 ! WRITE Error Message: Too Many Settling/Removal Categories 123 CALL ERRHDL(PATH,MODNAM,'E','244',SRCID(I)) ! 0 124 ENDIF 125 126 ! Check for OPENPIT source type with no particle categories 127 ELSEIF ( SRCTYP(I).EQ.'OPENPIT' ) THEN 128 ! WRITE Error Message: Open Pit source with no particle categories 129 CALL ERRHDL(PATH,MODNAM,'E','323',SRCID(I)) ! 0 130 ENDIF 131 132 ! Screen for Conflicts with the Deposition Options 133 IF ( INPD(I).EQ.0 ) THEN ! 27 134 ! Check for NPD=0 and no gas deposition with the DEPOS or DDEP 135 ! WRITE Error Message for Lack of Gas Deposition Parameters 136 IF ( (DEPOS .OR. DDEP) .AND. SOGAS(I).EQ.'N' .AND. & 137 & .NOT.LUSERVD ) & 138 & CALL ERRHDL(PATH,MODNAM,'E','242',SRCID(I)) 139 ENDIF 140 141 ! Check Vertices and Determine Centroid for AREAPOLY Sources 142 IF ( SRCTYP(I).EQ.'AREAPOLY' ) THEN ! 27 143 IF ( IWRK2(I,10).LT.NVERTS(I) ) THEN ! 0 144 ! WRITE Error Message: Not Enough Vertices Input For This Source 145 CALL ERRHDL(PATH,MODNAM,'E','265',SRCID(I)) ! 0 146 ELSE 147 ! Repeat First Vertex as Last Vertex to Close Polygon 148 AXVERT(NVERTS(I)+1,I) = AXVERT(1,I) ! 0 149 AYVERT(NVERTS(I)+1,I) = AYVERT(1,I) 150 151 ! Determine coordinates for centroid of polygon source 152 ! First calculate area of polygon 153 SUM = 0.0 154 DO J = 1 , NVERTS(I) 155 SUM = SUM + (AXVERT(J,I)*AYVERT(J+1,I)-AXVERT(J+1,I) & 156 & *AYVERT(J,I)) 157 ENDDO 158 159 AREA = 0.5*SUM ! 0 160 161 ! Assign SQRT(ABS(area)) to AXINIT and AYINIT; equivalent values 162 ! of AXINIT and AYINIT will be used to calculate area of polygon 163 AXINIT(I) = SQRT(ABS(AREA)) 164 AYINIT(I) = SQRT(ABS(AREA)) 165 166 ! Now determine coordinates of centroid 167 SUMX = 0.0 168 SUMY = 0.0 169 DO J = 1 , NVERTS(I) 170 SUMX = SUMX + (AXVERT(J,I)+AXVERT(J+1,I)) & 171 & *(AXVERT(J,I)*AYVERT(J+1,I)-AXVERT(J+1,I) & 172 & *AYVERT(J,I)) 173 SUMY = SUMY + (AYVERT(J,I)+AYVERT(J+1,I)) & 174 & *(AXVERT(J,I)*AYVERT(J+1,I)-AXVERT(J+1,I) & 175 & *AYVERT(J,I)) 176 ENDDO 177 178 AXCNTR(I) = SUMX/(6.*AREA) ! 0 179 AYCNTR(I) = SUMY/(6.*AREA) 180 181 ENDIF 182 ENDIF 183 184 ! Check for urban sources 185 IF ( URBSRC(I).EQ.'Y' ) NUMURB = NUMURB + 1 ! 27 186 187 ! Identify the index of the level immediately below the top of the 188 ! stack from the array of gridded heights; we are limiting the 189 ! number of levels to search to 29 (= 600 m). (Changed from 21 190 ! by R. Brode, PES, 2/17/95) 191 192 CALL LOCATE(GRIDHT,1,29,AHS(I),NDXSTK(I)) 193 194 ENDDO 195 ! End Source LOOP 196 197 ! Check for empty source groups 198 DO J = 1 , NUMGRP ! 3 199 ITOTSRC = 0 ! 3 200 DO I = 1 , NUMSRC 201 IF ( IGROUP(I,J).EQ.1 ) ITOTSRC = ITOTSRC + 1 ! 27 202 ENDDO 203 ! Write Warning Message: No Sources in SRCGROUP 204 IF ( ITOTSRC.EQ.0 ) CALL ERRHDL(PATH,MODNAM,'W','319',GRPID(J))! 3 205 ENDDO 206 207 ! Write Error Message: No urban sources defined with URBANOPT 208 IF ( URBAN .AND. NUMURB.EQ.0 ) & 209 & CALL ERRHDL(PATH,MODNAM,'E','130','URBANSRC') 210 211 ! Check for source in more than one OLMGROUP 212 DO I = 1 , NUMSRC 213 ITOTGRP = 0 ! 27 214 DO J = 1 , NUMOLM 215 IF ( IGRP_OLM(I,J).EQ.1 ) ITOTGRP = ITOTGRP + 1 ! 0 216 ENDDO 217 ! Write Error Message: Source in more than one OLMGROUP 218 IF ( ITOTGRP.GT.1 ) CALL ERRHDL(PATH,MODNAM,'E','282',SRCID(I))! 27 219 ENDDO 220 221 ! Check for negative emission rate with OLM or PVMRM option. 222 ! Negative emission for credit sources cannot be used for OLM and 223 ! PVMRM due to non-linear dependence of concentrations on emissions. 224 IF ( OLM .OR. PVMRM ) THEN ! 3 225 DO I = 1 , NUMSRC ! 0 226 ! Write Error Message: Negative emission rate for OLM or PVMRM 227 IF ( AQS(I).LT.0.0 ) & 228 & CALL ERRHDL(PATH,MODNAM,'E','338',SRCID(I)) 229 ENDDO 230 ENDIF 231 232 CONTINUE ! 3 233 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