1 2 SUBROUTINE EMVARY 3 !*********************************************************************** 4 ! EMVARY Module of the AMS/EPA Regulatory Model - AERMOD 5 ! 6 ! PURPOSE: Processes Variable Emission Rate Factors 7 ! 8 ! PROGRAMMER: Jeff Wang, Roger Brode 9 ! 10 ! DATE: March 2, 1992 11 ! 12 ! MODIFIED: To replace 'STAR' option with 'WSPEED'. 13 ! R.W. Brode, PES, 02/25/02 14 ! 15 ! MODIFIED: To include an option to vary emissions by season, 16 ! hour-of-day, and day-of-week (SHRDOW). 17 ! R.W. Brode, PES, 4/10/2000 18 ! 19 ! INPUTS: Input Runstream Image Parameters 20 ! 21 ! OUTPUTS: Variable Emmission Rate Factors 22 ! 23 ! CALLED FROM: SOCARD 24 !*********************************************************************** 25 26 ! Variable Declarations 27 USE MAIN1 28 IMPLICIT NONE 29 CHARACTER MODNAM*12 30 31 SAVE 32 INTEGER :: I , IH , IL , ISDX , IQMAX 33 CHARACTER LID*8 , HID*8 , LID1*8 , LID2*8 , HID1*8 , HID2*8 34 CHARACTER(LEN=ILEN_FLD) :: SOID 35 LOGICAL FIND , INGRP , RMARK 36 37 ! Variable Initializations 38 FIND = .FALSE. ! 0 39 INGRP = .FALSE. 40 MODNAM = 'EMVARY' 41 42 ! Check The Number Of The Fields 43 IF ( IFC.LE.2 ) THEN 44 ! Error Message: No Parameters 45 CALL ERRHDL(PATH,MODNAM,'E','200',KEYWRD) ! 0 46 GOTO 999 47 ELSEIF ( IFC.EQ.3 ) THEN 48 ! Error Message: No Numerical Parameters 49 CALL ERRHDL(PATH,MODNAM,'E','201',KEYWRD) ! 0 50 GOTO 999 51 ELSEIF ( IFC.LT.5 ) THEN 52 ! Error Message: Not Enough Parameters 53 CALL ERRHDL(PATH,MODNAM,'E','201',KEYWRD) ! 0 54 GOTO 999 55 ENDIF 56 57 ! Get The Source ID(s) 58 SOID = FIELD(3) ! 0 59 CALL FSPLIT(PATH,KEYWRD,SOID,ILEN_FLD,'-',RMARK,LID,HID) 60 61 ! Verify The Effective Srcid 62 IF ( LID.EQ.HID ) THEN 63 ! Search For The Index 64 CALL SINDEX(SRCID,NSRC,SOID,ISDX,FIND) ! 0 65 IF ( FIND ) THEN 66 QFLAG(ISDX) = FIELD(4) ! 0 67 IF ( QFLAG(ISDX).EQ.'SEASON' ) THEN 68 IQMAX = 4 ! 0 69 ELSEIF ( QFLAG(ISDX).EQ.'MONTH' ) THEN 70 IQMAX = 12 ! 0 71 ELSEIF ( QFLAG(ISDX).EQ.'HROFDY' ) THEN 72 IQMAX = 24 ! 0 73 ELSEIF ( QFLAG(ISDX).EQ.'WSPEED' ) THEN 74 IQMAX = 6 ! 0 75 ELSEIF ( QFLAG(ISDX).EQ.'SEASHR' ) THEN 76 IQMAX = 96 ! 0 77 ELSEIF ( QFLAG(ISDX).EQ.'SHRDOW' ) THEN 78 IQMAX = 288 ! 0 79 ELSEIF ( QFLAG(ISDX).EQ.'SHRDOW7' ) THEN 80 IQMAX = 672 ! 0 81 ELSE 82 ! WRITE Error Message ! Invalid QFLAG Field Entered 83 CALL ERRHDL(PATH,MODNAM,'E','203','QFLAG') ! 0 84 ENDIF 85 IF ( IQMAX.LE.NQF ) THEN ! 0 86 CALL EFFILL(ISDX,IQMAX) ! 0 87 ELSE 88 ! WRITE Error Message ! NQF Parameter Not Large Enough 89 WRITE (DUMMY,'(I8)') NQF ! 0 90 CALL ERRHDL(PATH,MODNAM,'E','260',DUMMY) 91 ENDIF 92 ELSE 93 ! WRITE Error Message ! Source Location Has Not Been Identified 94 CALL ERRHDL(PATH,MODNAM,'E','300',KEYWRD) ! 0 95 ENDIF 96 ELSE 97 ! First Check Range for Upper Value < Lower Value 98 CALL SETIDG(LID,LID1,IL,LID2) ! 0 99 CALL SETIDG(HID,HID1,IH,HID2) 100 IF ( (HID1.LT.LID1) .OR. (IH.LT.IL) .OR. (HID2.LT.LID2) ) THEN 101 ! WRITE Error Message: Invalid Range, Upper < Lower 102 CALL ERRHDL(PATH,MODNAM,'E','203','SRCRANGE') ! 0 103 GOTO 999 104 ENDIF 105 DO I = 1 , NUMSRC ! 0 106 ! See Whether It's In The Group 107 CALL ASNGRP(SRCID(I),LID,HID,INGRP) ! 0 108 IF ( INGRP ) THEN 109 ISDX = I ! 0 110 QFLAG(ISDX) = FIELD(4) 111 IF ( QFLAG(ISDX).EQ.'SEASON' ) THEN 112 IQMAX = 4 ! 0 113 ELSEIF ( QFLAG(ISDX).EQ.'MONTH' ) THEN 114 IQMAX = 12 ! 0 115 ELSEIF ( QFLAG(ISDX).EQ.'HROFDY' ) THEN 116 IQMAX = 24 ! 0 117 ELSEIF ( QFLAG(ISDX).EQ.'WSPEED' ) THEN 118 IQMAX = 6 ! 0 119 ELSEIF ( QFLAG(ISDX).EQ.'SEASHR' ) THEN 120 IQMAX = 96 ! 0 121 ELSEIF ( QFLAG(ISDX).EQ.'SHRDOW' ) THEN 122 IQMAX = 288 ! 0 123 ELSEIF ( QFLAG(ISDX).EQ.'SHRDOW7' ) THEN 124 IQMAX = 672 ! 0 125 ELSE 126 ! WRITE Error Message ! Invalid QFLAG Field Entered 127 CALL ERRHDL(PATH,MODNAM,'E','203','QFLAG') ! 0 128 ENDIF 129 IF ( IQMAX.LE.NQF ) THEN ! 0 130 CALL EFFILL(ISDX,IQMAX) ! 0 131 ELSE 132 ! WRITE Error Message ! NQF Parameter Not Large Enough 133 WRITE (DUMMY,'(I8)') NQF ! 0 134 CALL ERRHDL(PATH,MODNAM,'E','260',DUMMY) 135 ENDIF 136 ENDIF 137 ENDDO 138 ENDIF 139 140 999 CONTINUE ! 0 141 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