1 2 SUBROUTINE REPOLR 3 !*********************************************************************** 4 ! REPOLR Module of the AMS/EPA Regulatory Model - AERMOD 5 ! 6 ! PURPOSE: Processes Polar Grid Receptor Network Inputs 7 ! 8 ! PROGRAMMER: Jeff Wang, Roger Brode 9 ! 10 ! DATE: March 2, 1992 11 ! 12 ! INPUTS: Input Runstream Image Parameters 13 ! 14 ! OUTPUTS: Polar Receptor Network Inputs 15 ! 16 ! CALLED FROM: RECARD 17 !*********************************************************************** 18 19 ! Variable Declarations 20 USE MAIN1 21 IMPLICIT NONE 22 CHARACTER MODNAM*12 23 24 SAVE 25 INTEGER :: I , IORSET , IXRSET , IDRSET , IGRSET 26 27 ! Variable Initializations 28 MODNAM = 'REPOLR' ! 15 29 30 IF ( IFC.LT.3 ) THEN 31 ! Write Error Message: Missing Data Field 32 CALL ERRHDL(PATH,MODNAM,'E','200',KEYWRD) ! 0 33 GOTO 999 34 ENDIF 35 36 ! READ in the Netid and Nettype 37 NETIDT = FIELD(3) ! 15 38 IF ( .NOT.NEWID .AND. (NETIDT.EQ.' ' .OR. NETIDT.EQ.'ORIG' .OR.& 39 & NETIDT.EQ.'DIST' .OR. NETIDT.EQ.'DDIR' .OR. & 40 & NETIDT.EQ.'ELEV' .OR. NETIDT.EQ.'HILL' .OR. & 41 & NETIDT.EQ.'FLAG' .OR. NETIDT.EQ.'GDIR' .OR. NETIDT.EQ.'END') & 42 & ) THEN 43 NETIDT = PNETID ! 9 44 KTYPE = FIELD(3) 45 ELSEIF ( .NOT.NEWID .AND. NETIDT.EQ.PNETID ) THEN 46 KTYPE = FIELD(4) ! 3 47 ELSEIF ( NEWID .AND. NETIDT.NE.' ' ) THEN 48 NEWID = .FALSE. ! 3 49 KTYPE = FIELD(4) 50 ! The Keyword Counter 51 INNET = INNET + 1 52 IF ( INNET.GT.NNET ) THEN 53 ! WRITE Error Message: Too Many Networks 54 WRITE (DUMMY,'(I8)') NNET ! 0 55 CALL ERRHDL(PATH,MODNAM,'E','224',DUMMY) 56 RECERR = .TRUE. 57 GOTO 999 58 ENDIF 59 IORSET = 0 ! 3 60 IXRSET = 0 61 IDRSET = 0 62 IGRSET = 0 63 IEVSET = 0 64 IFGSET = 0 65 ELSE 66 ! Error Message: Invalid Secondary Keyword 67 CALL ERRHDL(PATH,MODNAM,'E','170',PNETID) ! 0 68 RECERR = .TRUE. 69 GOTO 999 70 ENDIF 71 72 ! Start to Set Up the Network 73 IF ( KTYPE.EQ.'STA' ) THEN ! 15 74 ISTA = .TRUE. ! 3 75 IEND = .FALSE. 76 NEWID = .FALSE. 77 RECERR = .FALSE. 78 ICOUNT = 0 79 JCOUNT = 0 80 IZE = 0 81 IZH = 0 82 IZF = 0 83 IDC1 = IRXR 84 ! Check for Previous Grid Network With Same ID 85 DO I = 1 , INNET - 1 86 ! WRITE Warning Message: Duplicate Network ID 87 IF ( FIELD(3).EQ.NTID(I) ) & 88 & CALL ERRHDL(PATH,MODNAM,'W','252',NTID(I)) 89 ENDDO 90 ELSEIF ( KTYPE.EQ.'ORIG' ) THEN 91 ! Error Message: Conflict Secondary Keyword 92 IF ( IORSET.NE.0 ) CALL ERRHDL(PATH,MODNAM,'E','160',NETIDT) ! 3 93 ! Read In XINT, YINT --- CALL POLORG 94 CALL POLORG 95 IORSET = IORSET + 1 96 ELSEIF ( KTYPE.EQ.'DIST' ) THEN 97 ! Read in the Distance Set --- CALL POLDST 98 CALL POLDST ! 3 99 IXRSET = IXRSET + 1 100 ELSEIF ( KTYPE.EQ.'GDIR' ) THEN 101 ! Error Message: Conflict Secondary Keyword 102 IF ( IDRSET.NE.0 ) CALL ERRHDL(PATH,MODNAM,'E','180',NETIDT) ! 3 103 ! Set the Uniform Spacing Receptor Network --- CALL GENPOL 104 CALL GENPOL 105 IGRSET = IGRSET + 1 106 ELSEIF ( KTYPE.EQ.'DDIR' ) THEN 107 ! Error Message: Conflict Secondary Keyword 108 IF ( IGRSET.NE.0 ) CALL ERRHDL(PATH,MODNAM,'E','180',NETIDT) ! 0 109 ! Set the Non-uniform Spacing Receptor Network --- CALL RADRNG 110 CALL RADRNG 111 IDRSET = IDRSET + 1 112 ELSEIF ( KTYPE.EQ.'ELEV' ) THEN 113 ! Read in and set the Terrain Elevation --- CALL TERHGT 114 CALL TERHGT ! 0 115 IEVSET = IEVSET + 1 116 ELSEIF ( KTYPE.EQ.'HILL' ) THEN 117 ! Read in and set the Terrain Elevation --- CALL HILHGT 118 CALL HILHGT ! 0 119 IHLSET = IHLSET + 1 120 ELSEIF ( KTYPE.EQ.'FLAG' ) THEN 121 ! Read in and set the Flagpole Receptor --- CALL FLGHGT 122 CALL FLGHGT ! 0 123 IFGSET = IFGSET + 1 124 ELSEIF ( KTYPE.EQ.'END' ) THEN 125 IEND = .TRUE. ! 3 126 ! Get the Final Result 127 IF ( .NOT.ISTA ) THEN 128 ! Write Error: MISSING STA OF THE BLOCK DATA 129 CALL ERRHDL(PATH,MODNAM,'E','200','STA') ! 0 130 ELSEIF ( .NOT.RECERR ) THEN 131 CALL SETPOL ! 3 132 ENDIF 133 ISTA = .FALSE. ! 3 134 NEWID = .TRUE. 135 ! Check If The Secondary Parameter Has Been Specified 136 ! Warning Message: Missing (Xin,Yin) Point Setting 137 IF ( IORSET.EQ.0 ) THEN 138 CALL ERRHDL(PATH,MODNAM,'W','220',NETIDT) ! 0 139 XINT = 0.0 140 YINT = 0.0 141 ENDIF 142 ! Error Message: Missing Distance Point Setting 143 IF ( IXRSET.EQ.0 ) CALL ERRHDL(PATH,MODNAM,'E','221',NETIDT) ! 3 144 ! Error Message: Missing Degree Or Rad Setting 145 IF ( IGRSET.EQ.0 .AND. IDRSET.EQ.0 ) & 146 & CALL ERRHDL(PATH,MODNAM,'E','222',NETIDT) 147 148 ! Warning: Elevated Terrain Inputs Inconsistent With Options 149 IF ( ELEV .AND. (IEVSET.EQ.0 .OR. IHLSET.EQ.0) ) THEN 150 CALL ERRHDL(PATH,MODNAM,'W','214',NETIDT) ! 0 151 IRZE = IRXR 152 IRZH = IRZE 153 ELSEIF ( FLAT .AND. IEVSET.NE.0 ) THEN 154 CALL ERRHDL(PATH,MODNAM,'W','213',NETIDT) ! 0 155 IRZE = IRXR 156 IRZH = IRZE 157 ELSEIF ( FLAT .AND. IEVSET.EQ.0 ) THEN 158 IRZE = IRXR ! 3 159 IRZH = IRZE 160 ENDIF 161 162 ! Warning: Flagpole Receptor Inputs Inconsistent With Options 163 IF ( FLGPOL .AND. IFGSET.EQ.0 ) THEN ! 3 164 CALL ERRHDL(PATH,MODNAM,'W','216',NETIDT) ! 0 165 IRZF = IRXR 166 ELSEIF ( .NOT.FLGPOL .AND. IFGSET.NE.0 ) THEN 167 CALL ERRHDL(PATH,MODNAM,'W','215',NETIDT) ! 0 168 IRZF = IRXR 169 ELSEIF ( .NOT.FLGPOL .AND. IFGSET.EQ.0 ) THEN 170 IRZF = IRXR ! 3 171 ENDIF 172 173 ! Check If The Number of Elev & Flag Is Match 174 IF ( ELEV .AND. IEVSET.NE.0 ) THEN ! 3 175 ! Write Out The Error Message: No. Of ELEV not match 176 IF ( ICOUNT*JCOUNT.NE.IZE ) & 177 & CALL ERRHDL(PATH,MODNAM,'E','218','ELEV') 178 ! Write Out The Error Message: No. Of ZHILL not match 179 IF ( ICOUNT*JCOUNT.NE.IZH ) & 180 & CALL ERRHDL(PATH,MODNAM,'E','218','ZHILL') 181 ENDIF 182 IF ( FLGPOL .AND. IFGSET.NE.0 ) THEN ! 3 183 ! Write Out The Error Message: No. Of FLAG not match 184 IF ( ICOUNT*JCOUNT.NE.IZF ) & 185 & CALL ERRHDL(PATH,MODNAM,'E','218','FLAG') 186 ENDIF 187 188 ELSE 189 ! Error Message: Invalid Secondary Keyword 190 CALL ERRHDL(PATH,MODNAM,'E','170',NETIDT) ! 0 191 RECERR = .TRUE. 192 GOTO 999 193 194 ENDIF 195 196 PNETID = NETIDT ! 15 197 198 999 CONTINUE ! 15 199 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