1 2 SUBROUTINE SOGRP 3 !*********************************************************************** 4 ! SOGRP Module of the AMS/EPA Regulatory Model - AERMOD 5 ! 6 ! PURPOSE: Processes Source Group Inputs for Pass One 7 ! 8 ! PROGRAMMER: Jeff Wang, Roger Brode 9 ! 10 ! DATE: March 2, 1992 11 ! 12 ! INPUTS: Input Runstream Image Parameters 13 ! 14 ! OUTPUTS: Source Group Input For Pass One 15 ! 16 ! CALLED FROM: SOCARD 17 !*********************************************************************** 18 ! 19 20 ! Variable Declarations 21 USE MAIN1 22 IMPLICIT NONE 23 CHARACTER MODNAM*12 24 25 SAVE 26 INTEGER :: I , K , IH , IL 27 CHARACTER*8 LOWID , HIGID , LID1 , LID2 , HID1 , HID2 , TEMPID 28 LOGICAL CONT , INGRP , RMARK 29 30 ! Variable Initializations 31 CONT = .FALSE. ! 3 32 MODNAM = 'SOGRP' 33 34 ! Check The Number Of The Fields 35 IF ( IFC.LE.2 ) THEN 36 ! Error Message: No Parameters 37 CALL ERRHDL(PATH,MODNAM,'E','200',KEYWRD) ! 0 38 GOTO 999 39 ELSEIF ( IFC.LE.3 .AND. FIELD(3).NE.'ALL' ) THEN 40 ! Error Message: Not Enough Parameters 41 CALL ERRHDL(PATH,MODNAM,'E','201',KEYWRD) ! 0 42 GOTO 999 43 ENDIF 44 45 ! READ in the Group ID and Check for Continuation Card 46 TEMPID = FIELD(3) ! 3 47 DO I = 1 , NUMGRP 48 IF ( TEMPID.EQ.GRPID(I) ) CONT = .TRUE. ! 0 49 ENDDO 50 51 ! Increment Counters and Assign Group ID If Not a Continuation Card 52 IF ( .NOT.CONT ) THEN ! 3 53 IGRP = IGRP + 1 ! 3 54 IF ( IGRP.GT.NGRP ) THEN 55 ! WRITE Error Message ! Too Many Source Groups Specified 56 WRITE (DUMMY,'(I8)') NGRP ! 0 57 CALL ERRHDL(PATH,MODNAM,'E','235',DUMMY) 58 ! Exit to END 59 GOTO 999 60 ENDIF 61 NUMGRP = NUMGRP + 1 ! 3 62 GRPID(IGRP) = TEMPID 63 ENDIF 64 65 ! Set Up The Source Group Array 66 IF ( GRPID(IGRP).EQ.'ALL' .AND. .NOT.CONT ) THEN ! 3 67 DO I = 1 , NUMSRC ! 3 68 IGROUP(I,IGRP) = 1 ! 27 69 ENDDO 70 ELSE 71 ! Loop Through Fields 72 DO I = 4 , IFC ! 0 73 CALL FSPLIT(PATH,KEYWRD,FIELD(I),ILEN_FLD,'-',RMARK,LOWID, & 74 & HIGID) 75 ! First Check Range for Upper Value < Lower Value 76 CALL SETIDG(LOWID,LID1,IL,LID2) 77 CALL SETIDG(HIGID,HID1,IH,HID2) 78 IF ( (HID1.LT.LID1) .OR. (IH.LT.IL) .OR. (HID2.LT.LID2) ) & 79 & THEN 80 ! WRITE Error Message: Invalid Range, Upper < Lower 81 CALL ERRHDL(PATH,MODNAM,'E','203','SRCRANGE') ! 0 82 GOTO 50 83 ENDIF 84 DO K = 1 , NUMSRC ! 0 85 CALL ASNGRP(SRCID(K),LOWID,HIGID,INGRP) ! 0 86 IF ( INGRP ) IGROUP(K,IGRP) = 1 87 ENDDO 88 50 ENDDO 89 ENDIF 90 91 999 CONTINUE ! 3 92 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