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