1 2 SUBROUTINE PRTANN 3 !*********************************************************************** 4 ! PRTANN Module of the AMS/EPA Regulatory Model - AERMOD 5 ! 6 ! PURPOSE: Print Out The Annual Average Data 7 ! 8 ! PROGRAMMER: Roger Brode, Jeff Wang 9 ! 10 ! DATE: March 2, 1992 11 ! 12 ! MODIFIED: To adjust format statement 9082 for BOUNDARY receptors 13 ! to better accommodate UTM coordinates - 9/29/92 14 ! 15 ! INPUTS: Arrays of Source Parameters 16 ! Arrays of Receptor Locations 17 ! Arrays of Model Results 18 ! 19 ! OUTPUTS: Printed Model Outputs 20 ! 21 ! CALLED FROM: OUTPUT 22 !*********************************************************************** 23 24 ! Variable Declarations 25 USE MAIN1 26 IMPLICIT NONE 27 CHARACTER MODNAM*12 28 29 SAVE 30 INTEGER :: I , J , K , II , NX , NY , INDZ , INDC , ISRF , INDEXW 31 REAL :: YCOVAL , XRMS , YRMS , DIST , DIR 32 CHARACTER PERCHR*6 , BUF132*132 33 34 ! Variable Initializations 35 MODNAM = 'PRTANN' ! 2 36 IF ( PERIOD ) THEN 37 PERCHR = 'PERIOD' ! 2 38 ELSEIF ( ANNUAL ) THEN 39 PERCHR = 'ANNUAL' ! 0 40 ENDIF 41 42 ! Begin Source Group LOOP 43 DO IGRP = 1 , NUMGRP ! 2 44 45 ! Fill Work Array With SRCIDs For This Group 46 INDGRP = 0 ! 2 47 DO ISRC = 1 , NUMSRC 48 IF ( IGROUP(ISRC,IGRP).EQ.1 ) THEN ! 18 49 INDGRP = INDGRP + 1 ! 18 50 WORKID(INDGRP) = SRCID(ISRC) 51 ENDIF 52 ENDDO 53 ! Check for More Than 31 Sources Per Group 54 INDEXW = MIN(31,NSRC) ! 2 55 IF ( INDGRP.GT.INDEXW ) THEN 56 WORKID(INDEXW) = ' . . . ' ! 0 57 INDGRP = INDEXW 58 ENDIF 59 60 ! Print Receptor Network Coordinates: 61 ! Set Number of Columns Per Page, NCPP 62 NCPP = 9 ! 2 63 ! Set Number of Rows Per Page, NRPP 64 NRPP = 40 65 ! Begin LOOP Through Networks 66 DO I = 1 , INNET 67 ! Calculate Number of Pages Per X-Group, NPPX, & Per Y-Group, NPPY 68 NPPX = 1 + INT((NUMXPT(I)-1)/NCPP) ! 2 69 NPPY = 1 + INT((NUMYPT(I)-1)/NRPP) 70 DO NX = 1 , NPPX 71 DO NY = 1 , NPPY ! 2 72 CALL HEADER ! 2 73 IF ( PERIOD ) THEN 74 WRITE (IOUNIT,9032) PERCHR , IANHRS , & 75 & (CHIDEP(II,ITYP),II=1,6) , GRPID(IGRP) , & 76 & (WORKID(K),K=1,INDGRP) 77 ELSEIF ( ANNUAL ) THEN 78 WRITE (IOUNIT,9033) PERCHR , NUMYRS , & 79 & (CHIDEP(II,ITYP),II=1,6) , GRPID(IGRP) , & 80 & (WORKID(K),K=1,INDGRP) 81 ENDIF 82 WRITE (IOUNIT,9037) NTID(I) , NTTYP(I) ! 2 83 9037 FORMAT (/35X,'*** NETWORK ID: ',A8, & 84 & ' ; NETWORK TYPE: ',A8,' ***') 85 ! Print The Values By Source Group 86 WRITE (IOUNIT,9011) CHIDEP(3,ITYP) , POLLUT , & 87 & PERLBL(ITYP) 88 IF ( NX.EQ.NPPX ) THEN 89 IF ( NTTYP(I).EQ.'GRIDCART' ) THEN ! 2 90 WRITE (IOUNIT,9016) ! 0 91 WRITE (IOUNIT,9017) & 92 & (XCOORD(J,I),J=1+NCPP*(NX-1),NUMXPT(I)) 93 ELSEIF ( NTTYP(I).EQ.'GRIDPOLR' ) THEN 94 WRITE (IOUNIT,9018) ! 2 95 WRITE (IOUNIT,9019) & 96 & (XCOORD(J,I),J=1+NCPP*(NX-1),NUMXPT(I)) 97 ENDIF 98 ELSE 99 IF ( NTTYP(I).EQ.'GRIDCART' ) THEN ! 0 100 WRITE (IOUNIT,9016) ! 0 101 WRITE (IOUNIT,9017) & 102 & (XCOORD(J,I),J=1+NCPP*(NX-1),NCPP*NX) 103 ELSEIF ( NTTYP(I).EQ.'GRIDPOLR' ) THEN 104 WRITE (IOUNIT,9018) ! 0 105 WRITE (IOUNIT,9019) & 106 & (XCOORD(J,I),J=1+NCPP*(NX-1),NCPP*NX) 107 ENDIF 108 ENDIF 109 WRITE (IOUNIT,9010) ! 2 110 9010 FORMAT (66(' -')/) 111 IF ( NY.EQ.NPPY ) THEN 112 DO K = 1 + NRPP*(NY-1) , NUMYPT(I) ! 2 113 IF ( NTTYP(I).EQ.'GRIDCART' ) THEN ! 72 114 INDZ = NETEND(I) - K*NUMXPT(I) + 1 ! 0 115 YCOVAL = YCOORD(NUMYPT(I)-K+1,I) 116 ELSEIF ( NTTYP(I).EQ.'GRIDPOLR' ) THEN 117 INDZ = NETSTA(I) + (K-1)*NUMXPT(I) ! 72 118 YCOVAL = YCOORD(K,I) 119 ENDIF 120 IF ( NX.EQ.NPPX ) THEN ! 72 121 WRITE (IOUNIT,9013) YCOVAL , & 122 & (ANNVAL(INDZ+J-1,IGRP,ITYP), & 123 & J=1+NCPP*(NX-1),NUMXPT(I)) 124 ELSE 125 WRITE (IOUNIT,9013) YCOVAL , & 126 & (ANNVAL(INDZ+J-1,IGRP,ITYP), & 127 & J=1+NCPP*(NX-1),NCPP*NX) 128 ENDIF 129 ENDDO 130 ELSE 131 DO K = 1 + NRPP*(NY-1) , NRPP*NY ! 0 132 IF ( NTTYP(I).EQ.'GRIDCART' ) THEN ! 0 133 INDZ = NETEND(I) - K*NUMXPT(I) + 1 ! 0 134 YCOVAL = YCOORD(NUMYPT(I)-K+1,I) 135 ELSEIF ( NTTYP(I).EQ.'GRIDPOLR' ) THEN 136 INDZ = NETSTA(I) + (K-1)*NUMXPT(I) ! 0 137 YCOVAL = YCOORD(K,I) 138 ENDIF 139 IF ( NX.EQ.NPPX ) THEN ! 0 140 WRITE (IOUNIT,9013) YCOVAL , & 141 & (ANNVAL(INDZ+J-1,IGRP,ITYP), & 142 & J=1+NCPP*(NX-1),NUMXPT(I)) 143 ELSE 144 WRITE (IOUNIT,9013) YCOVAL , & 145 & (ANNVAL(INDZ+J-1,IGRP,ITYP), & 146 & J=1+NCPP*(NX-1),NCPP*NX) 147 ENDIF 148 ENDDO 149 ENDIF 150 ENDDO 151 ENDDO 152 ENDDO 153 ! End LOOP Through Networks 154 155 IF ( IRSTAT(4).NE.0 ) THEN ! 2 156 ! Print Out The Coord. & Concentrations For Discrete Cart Receptors 157 INDC = 0 ! 0 158 DO IREC = 1 , NUMREC 159 IF ( RECTYP(IREC).EQ.'DC' ) THEN ! 0 160 INDC = INDC + 1 ! 0 161 IF ( MOD(INDC-1,80).EQ.0 ) THEN 162 CALL HEADER ! 0 163 IF ( PERIOD ) THEN 164 WRITE (IOUNIT,9032) PERCHR , IANHRS , & 165 & (CHIDEP(II,ITYP),II=1,6) , GRPID(IGRP) , & 166 & (WORKID(K),K=1,INDGRP) 167 ELSEIF ( ANNUAL ) THEN 168 WRITE (IOUNIT,9033) PERCHR , NUMYRS , & 169 & (CHIDEP(II,ITYP),II=1,6) , GRPID(IGRP) , & 170 & (WORKID(K),K=1,INDGRP) 171 ENDIF 172 WRITE (IOUNIT,9043) ! 0 173 9043 FORMAT (/45X, & 174 & '*** DISCRETE CARTESIAN RECEPTOR POINTS ***'& 175 & ) 176 WRITE (IOUNIT,9011) CHIDEP(3,ITYP) , POLLUT , & 177 & PERLBL(ITYP) 178 WRITE (IOUNIT,9048) CHIDEP(3,ITYP) , CHIDEP(3,ITYP) 179 9048 FORMAT (6X,' X-COORD (M) Y-COORD (M) ',A4,& 180 & 22X,' X-COORD (M) Y-COORD (M) ', & 181 & A4,/65(' -')) 182 ENDIF 183 IF ( MOD(INDC,2).NE.0 ) THEN ! 0 184 WRITE (BUF132(1:60),9045) AXR(IREC) , AYR(IREC) , & 185 & ANNVAL(IREC,IGRP,ITYP) 186 ELSE 187 WRITE (BUF132(61:120),9045) AXR(IREC) , AYR(IREC) ,& 188 & ANNVAL(IREC,IGRP,ITYP) 189 WRITE (IOUNIT,9090) BUF132 190 WRITE (BUF132,9095) 191 ENDIF 192 ENDIF 193 ENDDO 194 IF ( MOD(INDC,2).NE.0 ) THEN ! 0 195 WRITE (IOUNIT,9090) BUF132 ! 0 196 WRITE (BUF132,9095) 197 ENDIF 198 ENDIF 199 200 IF ( IRSTAT(5).NE.0 ) THEN ! 2 201 ! Print Out The Coord. & Concentrations For Discrete Polar Receptors 202 INDC = 0 ! 0 203 DO IREC = 1 , NUMREC 204 IF ( RECTYP(IREC).EQ.'DP' ) THEN ! 0 205 INDC = INDC + 1 ! 0 206 XRMS = AXR(IREC) - AXS(IREF(IREC)) 207 YRMS = AYR(IREC) - AYS(IREF(IREC)) 208 DIST = SQRT(XRMS*XRMS+YRMS*YRMS) 209 DIR = ATAN2(XRMS,YRMS)*RTODEG 210 IF ( DIR.LE.0.0 ) DIR = DIR + 360. 211 IF ( MOD(INDC-1,80).EQ.0 ) THEN 212 CALL HEADER ! 0 213 IF ( PERIOD ) THEN 214 WRITE (IOUNIT,9032) PERCHR , IANHRS , & 215 & (CHIDEP(II,ITYP),II=1,6) , GRPID(IGRP) , & 216 & (WORKID(K),K=1,INDGRP) 217 ELSEIF ( ANNUAL ) THEN 218 WRITE (IOUNIT,9033) PERCHR , NUMYRS , & 219 & (CHIDEP(II,ITYP),II=1,6) , GRPID(IGRP) , & 220 & (WORKID(K),K=1,INDGRP) 221 ENDIF 222 WRITE (IOUNIT,9044) ! 0 223 9044 FORMAT (/47X, & 224 & '*** DISCRETE POLAR RECEPTOR POINTS ***') 225 WRITE (IOUNIT,9011) CHIDEP(3,ITYP) , POLLUT , & 226 & PERLBL(ITYP) 227 WRITE (IOUNIT,9049) CHIDEP(3,ITYP) , CHIDEP(3,ITYP) 228 9049 FORMAT (5X,'ORIGIN',59X,'ORIGIN',/5X, & 229 & ' SRCID DIST (M) DIR (DEG) '& 230 & ,A4,18X, & 231 & ' SRCID DIST (M) DIR (DEG) '& 232 & ,A4,/65(' -')) 233 ENDIF 234 IF ( MOD(INDC,2).NE.0 ) THEN ! 0 235 WRITE (BUF132(1:65),9047) SRCID(IREF(IREC)) , & 236 & DIST , DIR , ANNVAL(IREC,IGRP,ITYP) 237 ELSE 238 WRITE (BUF132(66:130),9047) SRCID(IREF(IREC)) , & 239 & DIST , DIR , ANNVAL(IREC,IGRP,ITYP) 240 WRITE (IOUNIT,9090) BUF132 241 WRITE (BUF132,9095) 242 ENDIF 243 ENDIF 244 ENDDO 245 IF ( MOD(INDC,2).NE.0 ) THEN ! 0 246 WRITE (IOUNIT,9090) BUF132 ! 0 247 WRITE (BUF132,9095) 248 ENDIF 249 ENDIF 250 251 ! Write Out The Boundary Receptors For The Sources 252 IF ( IRSTAT(6).NE.0 ) THEN ! 2 253 INDC = 0 ! 0 254 IREC = 1 255 DO WHILE ( IREC.LE.NUMREC ) 256 IF ( RECTYP(IREC).EQ.'BD' ) THEN ! 0 257 INDC = INDC + 1 ! 0 258 ISRF = IREF(IREC) 259 IF ( MOD(INDC-1,3).EQ.0 ) THEN 260 CALL HEADER ! 0 261 IF ( PERIOD ) THEN 262 WRITE (IOUNIT,9032) PERCHR , IANHRS , & 263 & (CHIDEP(II,ITYP),II=1,6) , GRPID(IGRP) , & 264 & (WORKID(K),K=1,INDGRP) 265 ELSEIF ( ANNUAL ) THEN 266 WRITE (IOUNIT,9033) PERCHR , NUMYRS , & 267 & (CHIDEP(II,ITYP),II=1,6) , GRPID(IGRP) , & 268 & (WORKID(K),K=1,INDGRP) 269 ENDIF 270 WRITE (IOUNIT,9011) CHIDEP(3,ITYP) , POLLUT , & 271 & PERLBL(ITYP) 272 ENDIF 273 WRITE (IOUNIT,9082) SRCID(ISRF) , SRCTYP(ISRF) , & 274 & AXS(ISRF) , AYS(ISRF) , AZS(ISRF) & 275 & , CHIDEP(3,ITYP) , CHIDEP(3,ITYP) & 276 & , CHIDEP(3,ITYP) , & 277 & (J,AXR(IREC+J-1),AYR(IREC+J-1), & 278 & ANNVAL(IREC+J-1,IGRP,ITYP),J=1,36) 279 9082 FORMAT (' BOUNDARY RECEPTOR NETWORK OF SOURCE ID: ', & 280 & A8,/,5X,' OF SOURCE TYPE: ',A8, & 281 & '; WITH ORIGIN AT (',2(F10.2,', '),F10.2, & 282 & ')'/3(' (SEC.) X-COORD Y-COORD ',A4,& 283 & 6X),/, & 284 & 12(3(1X,I4,2X,F9.1,',',F10.1,',',F13.5,' ',2X)& 285 & ,/),/) 286 IREC = IREC + 36 287 ELSE 288 IREC = IREC + 1 ! 0 289 ENDIF 290 ENDDO 291 ENDIF 292 293 ! End Source Group Loop 294 ENDDO 295 296 CONTINUE ! 2 297 298 9011 FORMAT (/40X,'** ',A4,' OF ',A8,' IN ',A40,' **'/) 299 9013 FORMAT (2X,F10.2,1X,'|',1X,9(F13.5)) 300 9016 FORMAT (3X,' Y-COORD |',48X,'X-COORD (METERS)') 301 9017 FORMAT (3X,' (METERS) |',1X,9(1X,F12.2,:)) 302 9018 FORMAT (3X,'DIRECTION |',48X,'DISTANCE (METERS)') 303 9019 FORMAT (3X,'(DEGREES) |',1X,9(1X,F12.2,:)) 304 9032 FORMAT (30X,'*** THE ',A6,' (',I6,' HRS) ',6A4, & 305 & 'VALUES FOR SOURCE GROUP:',1X,A8,' ***',/34X, & 306 & 'INCLUDING SOURCE(S): ',7(A8,', ',:),/10X, & 307 & 12(A8,', ',:)/10X,12(A8,', ',:)) 308 9033 FORMAT (30X,'*** THE ',A6,' (',I4,' YRS) ',6A4, & 309 & 'VALUES FOR SOURCE GROUP:',1X,A8,' ***',/34X, & 310 & 'INCLUDING SOURCE(S): ',7(A8,', ',:),/10X, & 311 & 12(A8,', ',:)/10X,12(A8,', ',:)) 312 9045 FORMAT (6X,2(F12.2,2X),F13.5) 313 9047 FORMAT (4X,A8,': ',2(F12.2,2X),F13.5) 314 9090 FORMAT (A132) 315 9095 FORMAT (132(' ')) 316 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