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