1 2 3 SUBROUTINE DSBLDG 4 !*********************************************************************** 5 ! DSBLDG Module of the AMS/EPA Regulatory Model - AERMOD 6 ! 7 ! PURPOSE: Processes Direction-specific Building Directions 8 ! 9 ! PROGRAMMER: Jeff Wang, Roger Brode 10 ! 11 ! DATE: March 2, 1992 12 ! 13 ! INPUTS: Input Runstream Image Parameters 14 ! 15 ! OUTPUTS: Direction Specific Building Directions 16 ! 17 ! CALLED FROM: SOCARD 18 !*********************************************************************** 19 20 ! Variable Declarations 21 USE MAIN1 22 IMPLICIT NONE 23 CHARACTER MODNAM*12 24 25 SAVE 26 INTEGER :: I , IH , IL , ISDX 27 CHARACTER LID*8 , HID*8 , LID1*8 , LID2*8 , HID1*8 , HID2*8 28 CHARACTER(LEN=ILEN_FLD) :: SOID 29 LOGICAL FIND , INGRP , RMARK 30 31 ! Variable Initializations 32 FIND = .FALSE. ! 225 33 INGRP = .FALSE. 34 MODNAM = 'DSBLDG' 35 36 ! Check The Number Of The Fields 37 IF ( IFC.LE.2 ) THEN 38 ! Error Message: No Parameters 39 CALL ERRHDL(PATH,MODNAM,'E','200',KEYWRD) ! 0 40 GOTO 999 41 ELSEIF ( IFC.EQ.3 ) THEN 42 ! Error Message: Not Enough Parameters 43 CALL ERRHDL(PATH,MODNAM,'E','201',KEYWRD) ! 0 44 GOTO 999 45 ENDIF 46 47 ! Get The Source ID(s) 48 SOID = FIELD(3) ! 225 49 CALL FSPLIT(PATH,KEYWRD,SOID,ILEN_FLD,'-',RMARK,LID,HID) 50 51 ! Verify The Effective Srcid 52 IF ( LID.EQ.HID ) THEN 53 ! Search For The Index 54 CALL SINDEX(SRCID,NSRC,SOID,ISDX,FIND) ! 225 55 IF ( FIND ) THEN 56 IF ( SRCTYP(ISDX).EQ.'POINT' ) THEN ! 225 57 ! Fill Array 58 CALL DSFILL(ISDX) ! 225 59 ELSE 60 ! WRITE Warning Message: Building Inputs for Non-POINT Source 61 CALL ERRHDL(PATH,MODNAM,'W','233',SRCID(ISDX)) ! 0 62 ENDIF 63 ELSE 64 ! WRITE Error Message ! Source Location Has Not Been Identified 65 CALL ERRHDL(PATH,MODNAM,'E','300',KEYWRD) ! 0 66 ENDIF 67 ELSE 68 ! First Check Range for Upper Value < Lower Value 69 CALL SETIDG(LID,LID1,IL,LID2) ! 0 70 CALL SETIDG(HID,HID1,IH,HID2) 71 IF ( (HID1.LT.LID1) .OR. (IH.LT.IL) .OR. (HID2.LT.LID2) ) THEN 72 ! WRITE Error Message: Invalid Range, Upper < Lower 73 CALL ERRHDL(PATH,MODNAM,'E','203','SRCRANGE') ! 0 74 GOTO 999 75 ENDIF 76 DO I = 1 , NUMSRC ! 0 77 ! See Whether It's In The Group 78 CALL ASNGRP(SRCID(I),LID,HID,INGRP) ! 0 79 IF ( INGRP .AND. SRCTYP(I).EQ.'POINT' ) THEN 80 ISDX = I ! 0 81 ! Fill DS Array 82 CALL DSFILL(ISDX) 83 ENDIF 84 ENDDO 85 ENDIF 86 87 999 CONTINUE ! 225 88 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