1 2 SUBROUTINE DSFILL(ISDX) 3 !*********************************************************************** 4 ! DSFILL Module of the AMS/EPA Regulatory Model - AERMOD 5 ! ---------------------------------------------------------------------- 6 ! --- ISC-PRIME Version 1.0 Level 970812 Modified 7 ! --- V. Tino 8 ! --- Earth Tech, Inc. 9 ! Prepared for EPRI under contract WO3527-01 10 ! ---------------------------------------------------------------------- 11 ! 12 ! PURPOSE: Fill Direction-specific Building Dimension Arrays 13 ! 14 ! PROGRAMMER: Roger Brode, Jeff Wang 15 ! 16 ! DATE: March 2, 1992 17 ! 18 ! INPUTS: Input Runstream Image Parameters 19 ! 20 ! OUTPUTS: Direction Specific Building Directions 21 ! 22 ! CALLED FROM: DSBLDG 23 !*********************************************************************** 24 25 ! Variable Declarations 26 USE MAIN1 27 IMPLICIT NONE 28 CHARACTER MODNAM*12 29 30 SAVE 31 INTEGER :: J , K , ISDX 32 33 ! Variable Initializations 34 MODNAM = 'DSFILL' ! 225 35 36 IF ( KEYWRD.EQ.'BUILDHGT' ) THEN 37 ISET = IWRK2(ISDX,1) ! 9 38 DO K = 4 , IFC 39 ! Change Fields To Numbers 40 CALL STONUM(FIELD(K),ILEN_FLD,FNUM,IMIT) ! 9 41 ! Check The Numerical Field 42 IF ( IMIT.EQ.-1 ) THEN 43 CALL ERRHDL(PATH,MODNAM,'E','208',KEYWRD) ! 0 44 GOTO 50 45 ENDIF 46 DO J = 1 , IMIT ! 9 47 ISET = ISET + 1 ! 324 48 ! Assign The Field 49 IF ( ISET.LE.NSEC ) THEN 50 ADSBH(ISET,ISDX) = FNUM ! 324 51 ! WRITE Error Message: Negative Value for ADSBH 52 IF ( FNUM.LT.0.0 ) & 53 & CALL ERRHDL(PATH,MODNAM,'E','209',KEYWRD) 54 ELSE 55 ! WRITE Error Message ! Too Many Sectors Input 56 CALL ERRHDL(PATH,MODNAM,'E','234',KEYWRD) ! 0 57 ENDIF 58 ENDDO 59 50 ENDDO 60 IWRK2(ISDX,1) = ISET ! 9 61 ELSEIF ( KEYWRD.EQ.'BUILDWID' ) THEN 62 ISET = IWRK2(ISDX,2) ! 54 63 DO K = 4 , IFC 64 ! Change Fields To Numbers 65 CALL STONUM(FIELD(K),ILEN_FLD,FNUM,IMIT) ! 324 66 ! Check The Numerical Field 67 IF ( IMIT.EQ.-1 ) THEN 68 CALL ERRHDL(PATH,MODNAM,'E','208',KEYWRD) ! 0 69 GOTO 100 70 ENDIF 71 DO J = 1 , IMIT ! 324 72 ISET = ISET + 1 ! 324 73 ! Assign The Field 74 IF ( ISET.LE.NSEC ) THEN 75 ADSBW(ISET,ISDX) = FNUM ! 324 76 ! WRITE Error Message: Negative Value for ADSBW 77 IF ( FNUM.LT.0.0 ) & 78 & CALL ERRHDL(PATH,MODNAM,'E','209',KEYWRD) 79 ELSE 80 ! WRITE Error Message ! Too Many Sectors Input 81 CALL ERRHDL(PATH,MODNAM,'E','234',KEYWRD) ! 0 82 ENDIF 83 ENDDO 84 100 ENDDO 85 IWRK2(ISDX,2) = ISET ! 54 86 87 ! --- PRIME -------------------------------------------- 88 ! --- Fill building length information 89 ELSEIF ( KEYWRD.EQ.'BUILDLEN' ) THEN 90 ISET = IWRK2(ISDX,11) ! 54 91 DO K = 4 , IFC 92 ! Change Fields To Numbers 93 CALL STONUM(FIELD(K),ILEN_FLD,FNUM,IMIT) ! 324 94 ! Check The Numerical Field 95 IF ( IMIT.EQ.-1 ) THEN 96 CALL ERRHDL(PATH,MODNAM,'E','208',KEYWRD) ! 0 97 GOTO 150 98 ENDIF 99 DO J = 1 , IMIT ! 324 100 ISET = ISET + 1 ! 324 101 ! Assign The Field 102 IF ( ISET.LE.NSEC ) THEN 103 ADSBL(ISET,ISDX) = FNUM ! 324 104 ! WRITE Error Message: Negative value for ADSBL 105 IF ( FNUM.LT.0.0 ) & 106 & CALL ERRHDL(PATH,MODNAM,'E','209',KEYWRD) 107 ELSE 108 ! WRITE Error Message ! Too Many Sectors Input 109 CALL ERRHDL(PATH,MODNAM,'E','234',KEYWRD) ! 0 110 ENDIF 111 ENDDO 112 150 ENDDO 113 IWRK2(ISDX,11) = ISET ! 54 114 115 ! --- Fill building XBADJ information 116 ELSEIF ( KEYWRD.EQ.'XBADJ ' ) THEN 117 ISET = IWRK2(ISDX,12) ! 54 118 DO K = 4 , IFC 119 ! Change Fields To Numbers 120 CALL STONUM(FIELD(K),ILEN_FLD,FNUM,IMIT) ! 324 121 ! Check The Numerical Field 122 IF ( IMIT.EQ.-1 ) THEN 123 CALL ERRHDL(PATH,MODNAM,'E','208',KEYWRD) ! 0 124 GOTO 200 125 ENDIF 126 DO J = 1 , IMIT ! 324 127 ISET = ISET + 1 ! 324 128 ! Assign The Field 129 IF ( ISET.LE.NSEC ) THEN 130 ADSXADJ(ISET,ISDX) = FNUM ! 324 131 ELSE 132 ! WRITE Error Message ! Too Many Sectors Input 133 CALL ERRHDL(PATH,MODNAM,'E','234',KEYWRD) ! 0 134 ENDIF 135 ENDDO 136 200 ENDDO 137 IWRK2(ISDX,12) = ISET ! 54 138 139 ! --- Fill building YBADJ information 140 ELSEIF ( KEYWRD.EQ.'YBADJ ' ) THEN 141 ISET = IWRK2(ISDX,13) ! 54 142 DO K = 4 , IFC 143 ! Change Fields To Numbers 144 CALL STONUM(FIELD(K),ILEN_FLD,FNUM,IMIT) ! 324 145 ! Check The Numerical Field 146 IF ( IMIT.EQ.-1 ) THEN 147 CALL ERRHDL(PATH,MODNAM,'E','208',KEYWRD) ! 0 148 GOTO 250 149 ENDIF 150 DO J = 1 , IMIT ! 324 151 ISET = ISET + 1 ! 324 152 ! Assign The Field 153 IF ( ISET.LE.NSEC ) THEN 154 ADSYADJ(ISET,ISDX) = FNUM ! 324 155 ELSE 156 ! WRITE Error Message ! Too Many Sectors Input 157 CALL ERRHDL(PATH,MODNAM,'E','234',KEYWRD) ! 0 158 ENDIF 159 ENDDO 160 250 ENDDO 161 IWRK2(ISDX,13) = ISET ! 54 162 ! -------------------------------------------------------- 163 164 ENDIF 165 166 CONTINUE ! 225 167 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