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