1 2 SUBROUTINE INPPDN 3 !*********************************************************************** 4 ! INPPDN Module of the AMS/EPA Regulatory Model - AERMOD 5 ! 6 ! PURPOSE: Processes Particle Density Input Values 7 ! 8 ! PROGRAMMER: D. Strimaitis, SRC 9 ! 10 ! ADAPTED FROM "INPGAM" 11 ! PROGRAMMER: Jeff Wang, Roger Brode 12 ! 13 ! DATE: February 15, 1993 14 ! 15 ! INPUTS: Input Runstream Image Parameters 16 ! 17 ! OUTPUTS: Particle Density Input Values 18 ! 19 ! CALLED FROM: PARTDEP 20 !*********************************************************************** 21 ! 22 ! Variable Declarations 23 USE MAIN1 24 IMPLICIT NONE 25 CHARACTER MODNAM*12 26 27 SAVE 28 INTEGER :: I , J , K , IH , IL , ISDX , IING 29 CHARACTER LID*8 , HID*8 , LID1*8 , LID2*8 , HID1*8 , HID2*8 30 CHARACTER(LEN=ILEN_FLD) :: SOID 31 LOGICAL FIND , INGRP , RMARK 32 33 ! Variable Initializations 34 FIND = .FALSE. ! 0 35 INGRP = .FALSE. 36 MODNAM = 'INPPDN' 37 38 ! Get The Source ID(s) 39 SOID = FIELD(3) 40 CALL FSPLIT(PATH,KEYWRD,SOID,ILEN_FLD,'-',RMARK,LID,HID) 41 42 IF ( LID.EQ.HID ) THEN 43 ! Search For The Index 44 CALL SINDEX(SRCID,NSRC,SOID,ISDX,FIND) ! 0 45 IF ( FIND ) THEN 46 ISET = IWRK2(ISDX,7) ! 0 47 DO K = 4 , IFC 48 ! Change It To Numbers 49 CALL STONUM(FIELD(K),ILEN_FLD,FNUM,IMIT) ! 0 50 ! Check The Numerical Field 51 IF ( IMIT.EQ.-1 ) THEN 52 CALL ERRHDL(PATH,MODNAM,'E','208',KEYWRD) ! 0 53 GOTO 20 54 ENDIF 55 ! WRITE Error Message: Particle Density Out-of-Range 56 IF ( FNUM.LE.0.0 ) & 57 & CALL ERRHDL(PATH,MODNAM,'E','334',SRCID(ISDX)) 58 DO J = 1 , IMIT 59 ISET = ISET + 1 ! 0 60 IF ( ISET.LE.NPDMAX ) THEN 61 ! Assign The Field 62 APDENS(ISET,ISDX) = FNUM ! 0 63 ELSE 64 ! WRITE Error Message: Too Many PartDiam Categories 65 WRITE (DUMMY,'(I8)') NPDMAX ! 0 66 CALL ERRHDL(PATH,MODNAM,'E','245',DUMMY) 67 ENDIF 68 ENDDO 69 20 ENDDO 70 IWRK2(ISDX,7) = ISET ! 0 71 ELSE 72 ! WRITE Error Message ! Source Location Has Not Been Identified 73 CALL ERRHDL(PATH,MODNAM,'E','300',KEYWRD) ! 0 74 ENDIF 75 ELSE 76 ! First Check Range for Upper Value < Lower Value 77 CALL SETIDG(LID,LID1,IL,LID2) ! 0 78 CALL SETIDG(HID,HID1,IH,HID2) 79 IF ( (HID1.LT.LID1) .OR. (IH.LT.IL) .OR. (HID2.LT.LID2) ) THEN 80 ! WRITE Error Message: Invalid Range, Upper < Lower 81 CALL ERRHDL(PATH,MODNAM,'E','203','SRCRANGE') ! 0 82 GOTO 999 83 ENDIF 84 SOURCE_LOOP:DO I = 1 , NUMSRC ! 0 85 ! See Whether It's In The Group 86 CALL ASNGRP(SRCID(I),LID,HID,INGRP) ! 0 87 IF ( INGRP ) THEN 88 IING = I ! 0 89 ISET = IWRK2(IING,7) 90 DO K = 4 , IFC 91 ! Get Numbers 92 CALL STONUM(FIELD(K),ILEN_FLD,FNUM,IMIT) ! 0 93 ! Check The Numerical Field 94 IF ( IMIT.NE.1 ) THEN 95 CALL ERRHDL(PATH,MODNAM,'E','208',KEYWRD) ! 0 96 GOTO 50 97 ENDIF 98 ! WRITE Error Message: Particle Density Out-of-Range 99 IF ( FNUM.LE.0.0 ) & 100 & CALL ERRHDL(PATH,MODNAM,'E','334',SRCID(ISDX)) 101 DO J = 1 , IMIT 102 ISET = ISET + 1 ! 0 103 IF ( ISET.LE.NPDMAX ) THEN 104 APDENS(ISET,I) = FNUM ! 0 105 ELSE 106 ! WRITE Error Message: Too Many PartDiam Categories 107 WRITE (DUMMY,'(I8)') NPDMAX ! 0 108 CALL ERRHDL(PATH,MODNAM,'E','245',DUMMY) 109 ENDIF 110 ENDDO 111 ENDDO 112 IWRK2(IING,7) = ISET ! 0 113 ENDIF 114 50 ENDDO SOURCE_LOOP 115 ENDIF 116 117 999 CONTINUE ! 0 118 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