1 2 3 SUBROUTINE PRTREC 4 !*********************************************************************** 5 ! PRTREC Module of the AMS/EPA Regulatory Model - AERMOD 6 ! 7 ! PURPOSE: Print Out The Receptor Network Values 8 ! 9 ! PROGRAMMER: Jeff Wang, Roger Brode 10 ! 11 ! DATE: March 2, 1992 12 ! 13 ! MODIFIED: To remove reference to Boundary 14 ! Receptors - 4/1/2004 15 ! 16 ! MODIFIED: To Adjust Format Statement 9082 for Boundary 17 ! Receptors - 9/29/92 18 ! 19 ! INPUTS: Arrays of Source Parameters 20 ! Arrays of Receptor Locations 21 ! Arrays of Model Results 22 ! 23 ! OUTPUTS: Printed Model Outputs 24 ! 25 ! CALLED FROM: INPSUM 26 !*********************************************************************** 27 28 ! Variable Declarations 29 USE MAIN1 30 IMPLICIT NONE 31 CHARACTER MODNAM*12 32 33 SAVE 34 INTEGER :: I , J , K , INDZ , NX , NY , INDC , ISRF 35 REAL :: YCOVAL , XRMS , YRMS , RANGE , RADIAL 36 CHARACTER BUF132*132 37 38 ! Variable Initializations 39 MODNAM = 'PRTREC' ! 3 40 41 DO I = 1 , INNET 42 CALL HEADER ! 3 43 WRITE (IOUNIT,9034) 44 9034 FORMAT (/40X,'*** GRIDDED RECEPTOR NETWORK SUMMARY ***') 45 WRITE (IOUNIT,9037) NTID(I) , NTTYP(I) 46 IF ( NTTYP(I).EQ.'GRIDCART' ) THEN 47 WRITE (IOUNIT,9038) ! 0 48 9038 FORMAT (/42X,'*** X-COORDINATES OF GRID ***'/52X, & 49 & '(METERS)'/) 50 ELSE 51 WRITE (IOUNIT,9036) XORIG(I) , YORIG(I) ! 3 52 9036 FORMAT (/42X,'*** ORIGIN FOR POLAR NETWORK ***'/,32X, & 53 & 'X-ORIG =',F10.2,' ; Y-ORIG = ',F10.2, & 54 & ' (METERS)') 55 WRITE (IOUNIT,9039) 56 9039 FORMAT (/42X,'*** DISTANCE RANGES OF NETWORK ***'/52X, & 57 & '(METERS)'/) 58 ENDIF 59 WRITE (IOUNIT,9040) (XCOORD(J,I),J=1,NUMXPT(I)) ! 3 60 IF ( NTTYP(I).EQ.'GRIDCART' ) THEN 61 WRITE (IOUNIT,9041) ! 0 62 9041 FORMAT (/42X,'*** Y-COORDINATES OF GRID *** ',/52X, & 63 & '(METERS)'/) 64 ELSE 65 WRITE (IOUNIT,9042) ! 3 66 9042 FORMAT (/42X,'*** DIRECTION RADIALS OF NETWORK *** ',/52X, & 67 & '(DEGREES)'/) 68 ENDIF 69 WRITE (IOUNIT,9040) (YCOORD(J,I),J=1,NUMYPT(I)) ! 3 70 IF ( ELEV ) THEN 71 ! Print Terrain Heights for Network 72 ! Set Number of Columns Per Page, NCPP 73 NCPP = 9 ! 0 74 ! Set Number of Rows Per Page, NRPP 75 NRPP = 40 76 ! Begin LOOP Through Networks 77 ! Calculate Number of Pages Per X-Group, NPPX, & Per Y-Group, NPPY 78 NPPX = 1 + INT((NUMXPT(I)-1)/NCPP) 79 NPPY = 1 + INT((NUMYPT(I)-1)/NRPP) 80 DO NX = 1 , NPPX 81 DO NY = 1 , NPPY ! 0 82 CALL HEADER ! 0 83 WRITE (IOUNIT,9037) NTID(I) , NTTYP(I) 84 WRITE (IOUNIT,9011) 85 86 9011 FORMAT (/48X,'* ELEVATION HEIGHTS IN METERS *'/) 87 IF ( NX.EQ.NPPX ) THEN 88 IF ( NTTYP(I).EQ.'GRIDCART' ) THEN ! 0 89 WRITE (IOUNIT,9016) ! 0 90 WRITE (IOUNIT,9017) & 91 & (XCOORD(J,I),J=1+NCPP*(NX-1),NUMXPT(I)) 92 ELSEIF ( NTTYP(I).EQ.'GRIDPOLR' ) THEN 93 WRITE (IOUNIT,9018) ! 0 94 WRITE (IOUNIT,9019) & 95 & (XCOORD(J,I),J=1+NCPP*(NX-1),NUMXPT(I)) 96 ENDIF 97 ELSE 98 IF ( NTTYP(I).EQ.'GRIDCART' ) THEN ! 0 99 WRITE (IOUNIT,9016) ! 0 100 WRITE (IOUNIT,9017) & 101 & (XCOORD(J,I),J=1+NCPP*(NX-1),NCPP*NX) 102 ELSEIF ( NTTYP(I).EQ.'GRIDPOLR' ) THEN 103 WRITE (IOUNIT,9018) ! 0 104 WRITE (IOUNIT,9019) & 105 & (XCOORD(J,I),J=1+NCPP*(NX-1),NCPP*NX) 106 ENDIF 107 ENDIF 108 WRITE (IOUNIT,9010) ! 0 109 IF ( NY.EQ.NPPY ) THEN 110 DO K = 1 + NRPP*(NY-1) , NUMYPT(I) ! 0 111 IF ( NTTYP(I).EQ.'GRIDCART' ) THEN ! 0 112 INDZ = NETEND(I) - K*NUMXPT(I) + 1 ! 0 113 YCOVAL = YCOORD(NUMYPT(I)-K+1,I) 114 ELSEIF ( NTTYP(I).EQ.'GRIDPOLR' ) THEN 115 INDZ = NETSTA(I) + (K-1)*NUMXPT(I) ! 0 116 YCOVAL = YCOORD(K,I) 117 ENDIF 118 IF ( NX.EQ.NPPX ) THEN ! 0 119 WRITE (IOUNIT,9013) YCOVAL , & 120 & (AZELEV(INDZ+J-1),J=1+NCPP*(NX-1), & 121 & NUMXPT(I)) 122 ELSE 123 WRITE (IOUNIT,9013) YCOVAL , & 124 & (AZELEV(INDZ+J-1),J=1+NCPP*(NX-1), & 125 & NCPP*NX) 126 ENDIF 127 ENDDO 128 ELSE 129 DO K = 1 + NRPP*(NY-1) , NRPP*NY ! 0 130 IF ( NTTYP(I).EQ.'GRIDCART' ) THEN ! 0 131 INDZ = NETEND(I) - K*NUMXPT(I) + 1 ! 0 132 YCOVAL = YCOORD(NUMYPT(I)-K+1,I) 133 ELSEIF ( NTTYP(I).EQ.'GRIDPOLR' ) THEN 134 INDZ = NETSTA(I) + (K-1)*NUMXPT(I) ! 0 135 YCOVAL = YCOORD(K,I) 136 ENDIF 137 IF ( NX.EQ.NPPX ) THEN ! 0 138 WRITE (IOUNIT,9013) YCOVAL , & 139 & (AZELEV(INDZ+J-1),J=1+NCPP*(NX-1), & 140 & NUMXPT(I)) 141 ELSE 142 WRITE (IOUNIT,9013) YCOVAL , & 143 & (AZELEV(INDZ+J-1),J=1+NCPP*(NX-1), & 144 & NCPP*NX) 145 ENDIF 146 ENDDO 147 ENDIF 148 ENDDO 149 ENDDO 150 ! Print Hill Height Scales for Network 151 ! Set Number of Columns Per Page, NCPP 152 NCPP = 9 ! 0 153 ! Set Number of Rows Per Page, NRPP 154 NRPP = 40 155 ! Begin LOOP Through Networks 156 ! Calculate Number of Pages Per X-Group, NPPX, & Per Y-Group, NPPY 157 NPPX = 1 + INT((NUMXPT(I)-1)/NCPP) 158 NPPY = 1 + INT((NUMYPT(I)-1)/NRPP) 159 DO NX = 1 , NPPX 160 DO NY = 1 , NPPY ! 0 161 CALL HEADER ! 0 162 WRITE (IOUNIT,9037) NTID(I) , NTTYP(I) 163 WRITE (IOUNIT,9012) 164 9012 FORMAT (/48X,'* HILL HEIGHT SCALES IN METERS *'/) 165 IF ( NX.EQ.NPPX ) THEN 166 IF ( NTTYP(I).EQ.'GRIDCART' ) THEN ! 0 167 WRITE (IOUNIT,9016) ! 0 168 WRITE (IOUNIT,9017) & 169 & (XCOORD(J,I),J=1+NCPP*(NX-1),NUMXPT(I)) 170 ELSEIF ( NTTYP(I).EQ.'GRIDPOLR' ) THEN 171 WRITE (IOUNIT,9018) ! 0 172 WRITE (IOUNIT,9019) & 173 & (XCOORD(J,I),J=1+NCPP*(NX-1),NUMXPT(I)) 174 ENDIF 175 ELSE 176 IF ( NTTYP(I).EQ.'GRIDCART' ) THEN ! 0 177 WRITE (IOUNIT,9016) ! 0 178 WRITE (IOUNIT,9017) & 179 & (XCOORD(J,I),J=1+NCPP*(NX-1),NCPP*NX) 180 ELSEIF ( NTTYP(I).EQ.'GRIDPOLR' ) THEN 181 WRITE (IOUNIT,9018) ! 0 182 WRITE (IOUNIT,9019) & 183 & (XCOORD(J,I),J=1+NCPP*(NX-1),NCPP*NX) 184 ENDIF 185 ENDIF 186 WRITE (IOUNIT,9010) ! 0 187 IF ( NY.EQ.NPPY ) THEN 188 DO K = 1 + NRPP*(NY-1) , NUMYPT(I) ! 0 189 IF ( NTTYP(I).EQ.'GRIDCART' ) THEN ! 0 190 INDZ = NETEND(I) - K*NUMXPT(I) + 1 ! 0 191 YCOVAL = YCOORD(NUMYPT(I)-K+1,I) 192 ELSEIF ( NTTYP(I).EQ.'GRIDPOLR' ) THEN 193 INDZ = NETSTA(I) + (K-1)*NUMXPT(I) ! 0 194 YCOVAL = YCOORD(K,I) 195 ENDIF 196 IF ( NX.EQ.NPPX ) THEN ! 0 197 WRITE (IOUNIT,9013) YCOVAL , & 198 & (AZHILL(INDZ+J-1),J=1+NCPP*(NX-1), & 199 & NUMXPT(I)) 200 ELSE 201 WRITE (IOUNIT,9013) YCOVAL , & 202 & (AZHILL(INDZ+J-1),J=1+NCPP*(NX-1), & 203 & NCPP*NX) 204 ENDIF 205 ENDDO 206 ELSE 207 DO K = 1 + NRPP*(NY-1) , NRPP*NY ! 0 208 IF ( NTTYP(I).EQ.'GRIDCART' ) THEN ! 0 209 INDZ = NETEND(I) - K*NUMXPT(I) + 1 ! 0 210 YCOVAL = YCOORD(NUMYPT(I)-K+1,I) 211 ELSEIF ( NTTYP(I).EQ.'GRIDPOLR' ) THEN 212 INDZ = NETSTA(I) + (K-1)*NUMXPT(I) ! 0 213 YCOVAL = YCOORD(K,I) 214 ENDIF 215 IF ( NX.EQ.NPPX ) THEN ! 0 216 WRITE (IOUNIT,9013) YCOVAL , & 217 & (AZHILL(INDZ+J-1),J=1+NCPP*(NX-1), & 218 & NUMXPT(I)) 219 ELSE 220 WRITE (IOUNIT,9013) YCOVAL , & 221 & (AZHILL(INDZ+J-1),J=1+NCPP*(NX-1), & 222 & NCPP*NX) 223 ENDIF 224 ENDDO 225 ENDIF 226 ENDDO 227 ENDDO 228 ENDIF 229 IF ( FLGPOL ) THEN ! 3 230 ! Print The Receptor Heights Above Ground for This Network 231 ! Set Number of Columns Per Page, NCPP 232 NCPP = 9 ! 0 233 ! Set Number of Rows Per Page, NRPP 234 NRPP = 40 235 ! Begin LOOP Through Networks 236 ! Calculate Number of Pages Per X-Group, NPPX, & Per Y-Group, NPPY 237 NPPX = 1 + INT((NUMXPT(I)-1)/NCPP) 238 NPPY = 1 + INT((NUMYPT(I)-1)/NRPP) 239 DO NX = 1 , NPPX 240 DO NY = 1 , NPPY ! 0 241 CALL HEADER ! 0 242 WRITE (IOUNIT,9037) NTID(I) , NTTYP(I) 243 WRITE (IOUNIT,9035) 244 9035 FORMAT (/44X,'* RECEPTOR FLAGPOLE HEIGHTS IN METERS *'& 245 & /) 246 IF ( NX.EQ.NPPX ) THEN 247 IF ( NTTYP(I).EQ.'GRIDCART' ) THEN ! 0 248 WRITE (IOUNIT,9016) ! 0 249 WRITE (IOUNIT,9017) & 250 & (XCOORD(J,I),J=1+NCPP*(NX-1),NUMXPT(I)) 251 ELSEIF ( NTTYP(I).EQ.'GRIDPOLR' ) THEN 252 WRITE (IOUNIT,9018) ! 0 253 WRITE (IOUNIT,9019) & 254 & (XCOORD(J,I),J=1+NCPP*(NX-1),NUMXPT(I)) 255 ENDIF 256 ELSE 257 IF ( NTTYP(I).EQ.'GRIDCART' ) THEN ! 0 258 WRITE (IOUNIT,9016) ! 0 259 WRITE (IOUNIT,9017) & 260 & (XCOORD(J,I),J=1+NCPP*(NX-1),NCPP*NX) 261 ELSEIF ( NTTYP(I).EQ.'GRIDPOLR' ) THEN 262 WRITE (IOUNIT,9018) ! 0 263 WRITE (IOUNIT,9019) & 264 & (XCOORD(J,I),J=1+NCPP*(NX-1),NCPP*NX) 265 ENDIF 266 ENDIF 267 WRITE (IOUNIT,9010) ! 0 268 IF ( NY.EQ.NPPY ) THEN 269 DO K = 1 + NRPP*(NY-1) , NUMYPT(I) ! 0 270 IF ( NTTYP(I).EQ.'GRIDCART' ) THEN ! 0 271 INDZ = NETEND(I) - K*NUMXPT(I) + 1 ! 0 272 YCOVAL = YCOORD(NUMYPT(I)-K+1,I) 273 ELSEIF ( NTTYP(I).EQ.'GRIDPOLR' ) THEN 274 INDZ = NETSTA(I) + (K-1)*NUMXPT(I) ! 0 275 YCOVAL = YCOORD(K,I) 276 ENDIF 277 IF ( NX.EQ.NPPX ) THEN ! 0 278 WRITE (IOUNIT,9013) YCOVAL , & 279 & (AZFLAG(INDZ+J-1),J=1+NCPP*(NX-1), & 280 & NUMXPT(I)) 281 ELSE 282 WRITE (IOUNIT,9013) YCOVAL , & 283 & (AZFLAG(INDZ+J-1),J=1+NCPP*(NX-1), & 284 & NCPP*NX) 285 ENDIF 286 ENDDO 287 ELSE 288 DO K = 1 + NRPP*(NY-1) , NRPP*NY ! 0 289 IF ( NTTYP(I).EQ.'GRIDCART' ) THEN ! 0 290 INDZ = NETEND(I) - K*NUMXPT(I) + 1 ! 0 291 YCOVAL = YCOORD(NUMYPT(I)-K+1,I) 292 ELSEIF ( NTTYP(I).EQ.'GRIDPOLR' ) THEN 293 INDZ = NETSTA(I) + (K-1)*NUMXPT(I) ! 0 294 YCOVAL = YCOORD(K,I) 295 ENDIF 296 IF ( NX.EQ.NPPX ) THEN ! 0 297 WRITE (IOUNIT,9013) YCOVAL , & 298 & (AZFLAG(INDZ+J-1),J=1+NCPP*(NX-1), & 299 & NUMXPT(I)) 300 ELSE 301 WRITE (IOUNIT,9013) YCOVAL , & 302 & (AZFLAG(INDZ+J-1),J=1+NCPP*(NX-1), & 303 & NCPP*NX) 304 ENDIF 305 ENDDO 306 ENDIF 307 ENDDO 308 ENDDO 309 ENDIF 310 ENDDO 311 312 IF ( IRSTAT(4).NE.0 .OR. IRSTAT(8).NE.0 ) THEN ! 3 313 !RWB Include EVALCART receptors with DISCCART receptors. 2/14/95 314 ! Print Out The Coordinates, Height , Hill Height & Flags For 315 ! Discrete Cart Receptors 316 317 INDC = 0 ! 0 318 DO I = 1 , NUMREC 319 IF ( RECTYP(I).EQ.'DC' ) THEN ! 0 320 INDC = INDC + 1 ! 0 321 IF ( MOD(INDC-1,90).EQ.0 ) THEN 322 CALL HEADER ! 0 323 WRITE (IOUNIT,9043) 324 9043 FORMAT (/45X,'*** DISCRETE CARTESIAN RECEPTORS ***', & 325 & /43X,'(X-COORD, Y-COORD, ZELEV, ZHILL, ZFLAG)'& 326 & ,/45X,' (METERS)'/) 327 ENDIF 328 IF ( MOD(INDC,2).NE.0 ) THEN ! 0 329 WRITE (BUF132(1:65),9045) AXR(I) , AYR(I) , AZELEV(I) & 330 & , AZHILL(I) , AZFLAG(I) 331 ELSE 332 WRITE (BUF132(66:130),9045) AXR(I) , AYR(I) , & 333 & AZELEV(I) , AZHILL(I) , AZFLAG(I) 334 WRITE (IOUNIT,9090) BUF132 335 WRITE (BUF132,9095) 336 ENDIF 337 ENDIF 338 ENDDO 339 IF ( MOD(INDC,2).NE.0 ) THEN ! 0 340 WRITE (IOUNIT,9090) BUF132 ! 0 341 WRITE (BUF132,9095) 342 ENDIF 343 ENDIF 344 345 IF ( IRSTAT(5).NE.0 ) THEN ! 3 346 ! Print Out The Coordinates, Height & Flags For Discrete Polar Receptors 347 INDC = 0 ! 0 348 DO I = 1 , NUMREC 349 IF ( RECTYP(I).EQ.'DP' ) THEN ! 0 350 INDC = INDC + 1 ! 0 351 XRMS = AXR(I) - AXS(IREF(I)) 352 YRMS = AYR(I) - AYS(IREF(I)) 353 RANGE = SQRT(XRMS*XRMS+YRMS*YRMS) 354 RADIAL = ATAN2(XRMS,YRMS)*RTODEG 355 IF ( RADIAL.LE.0.0 ) RADIAL = RADIAL + 360. 356 IF ( MOD(INDC-1,90).EQ.0 ) THEN 357 CALL HEADER ! 0 358 WRITE (IOUNIT,9044) 359 9044 FORMAT (/43X,' *** DISCRETE POLAR RECEPTORS ***', & 360 & /43X, & 361 & ' ORIGIN: (DIST, DIR, ZELEV, ZHILL, ZFLAG)', & 362 & /43X, & 363 & ' SRCID: (METERS,DEG,METERS,METERS,METERS)'/) 364 ENDIF 365 IF ( MOD(INDC,2).NE.0 ) THEN ! 0 366 WRITE (BUF132(1:65),9047) SRCID(IREF(I)) , RANGE , & 367 & RADIAL , AZELEV(I) , AZHILL(I) , AZFLAG(I) 368 ELSE 369 WRITE (BUF132(66:130),9047) SRCID(IREF(I)) , RANGE , & 370 & RADIAL , AZELEV(I) , AZHILL(I) , AZFLAG(I) 371 WRITE (IOUNIT,9090) BUF132 372 WRITE (BUF132,9095) 373 ENDIF 374 ENDIF 375 ENDDO 376 IF ( MOD(INDC,2).NE.0 ) THEN ! 0 377 WRITE (IOUNIT,9090) BUF132 ! 0 378 WRITE (BUF132,9095) 379 ENDIF 380 ENDIF 381 382 CONTINUE ! 3 383 9037 FORMAT (/34X,'*** NETWORK ID: ',A8,' ; NETWORK TYPE: ',A8,' ***') 384 9040 FORMAT (100(5X,10(F10.1,',')/)) 385 9010 FORMAT (66(' -')/) 386 9013 FORMAT (2X,F10.2,1X,'|',1X,9(1X,F12.2,:)) 387 9016 FORMAT (3X,' Y-COORD |',48X,'X-COORD (METERS)') 388 9017 FORMAT (3X,' (METERS) |',1X,9(1X,F12.2,:)) 389 9018 FORMAT (3X,'DIRECTION |',48X,'DISTANCE (METERS)') 390 9019 FORMAT (3X,'(DEGREES) |',1X,9(1X,F12.2,:)) 391 9045 FORMAT (4X,' (',4(F9.1,', '),F9.1,'); ') 392 9047 FORMAT (3X,A8,': (',F9.1,', ',3(F7.1,', '),F7.1,'); ') 393 9090 FORMAT (A132) 394 9095 FORMAT (132(' ')) 395 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