1 2 SUBROUTINE INPPDM 3 !*********************************************************************** 4 ! INPPDM Module of the AMS/EPA Regulatory Model - AERMOD 5 ! 6 ! PURPOSE: Processes Particle Diameter Categories 7 ! 8 ! PROGRAMMER: D. Strimaitis, SRC 9 ! 10 ! ADAPTED FROM "INPVSN" 11 ! PROGRAMMER: Jeff Wang, Roger Brode 12 ! 13 ! DATE: February 15, 1993 14 ! 15 ! INPUTS: Input Runstream Image Parameters 16 ! 17 ! OUTPUTS: Particle Diameter Categories 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 = 'INPPDM' 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,5) ! 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 DO J = 1 , IMIT ! 0 56 ISET = ISET + 1 ! 0 57 IF ( ISET.LE.NPDMAX ) THEN 58 ! Assign The Field 59 APDIAM(ISET,ISDX) = FNUM ! 0 60 ELSE 61 ! WRITE Error Message: Too Many PartDiam Categories 62 WRITE (DUMMY,'(I8)') NPDMAX ! 0 63 CALL ERRHDL(PATH,MODNAM,'E','245',DUMMY) 64 ENDIF 65 ENDDO 66 20 ENDDO 67 IWRK2(ISDX,5) = ISET ! 0 68 ELSE 69 ! WRITE Error Message ! Source Location Has Not Been Identified 70 CALL ERRHDL(PATH,MODNAM,'E','300',KEYWRD) ! 0 71 ENDIF 72 ELSE 73 ! First Check Range for Upper Value < Lower Value 74 CALL SETIDG(LID,LID1,IL,LID2) ! 0 75 CALL SETIDG(HID,HID1,IH,HID2) 76 IF ( (HID1.LT.LID1) .OR. (IH.LT.IL) .OR. (HID2.LT.LID2) ) THEN 77 ! WRITE Error Message: Invalid Range, Upper < Lower 78 CALL ERRHDL(PATH,MODNAM,'E','203','SRCRANGE') ! 0 79 GOTO 999 80 ENDIF 81 SOURCE_LOOP:DO I = 1 , NUMSRC ! 0 82 ! See Whether It's In The Group 83 CALL ASNGRP(SRCID(I),LID,HID,INGRP) ! 0 84 IF ( INGRP ) THEN 85 IING = I ! 0 86 ISET = IWRK2(IING,5) 87 DO K = 4 , IFC 88 ! Get Numbers 89 CALL STONUM(FIELD(K),ILEN_FLD,FNUM,IMIT) ! 0 90 ! Check The Numerical Field 91 IF ( IMIT.EQ.-1 ) THEN 92 CALL ERRHDL(PATH,MODNAM,'E','208',KEYWRD) ! 0 93 GOTO 50 94 ENDIF 95 DO J = 1 , IMIT ! 0 96 ISET = ISET + 1 ! 0 97 IF ( ISET.LE.NPDMAX ) THEN 98 APDIAM(ISET,I) = FNUM ! 0 99 ELSE 100 ! WRITE Error Message: Too Many PartDiam Categories 101 WRITE (DUMMY,'(I8)') NPDMAX ! 0 102 CALL ERRHDL(PATH,MODNAM,'E','245',DUMMY) 103 ENDIF 104 ENDDO 105 ENDDO 106 IWRK2(IING,5) = ISET ! 0 107 ENDIF 108 50 ENDDO SOURCE_LOOP 109 ENDIF 110 111 999 CONTINUE ! 0 112 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