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