1 2 SUBROUTINE EVLOC 3 !*********************************************************************** 4 ! EVLOC Module of ISCEV2 Model 5 ! 6 ! PURPOSE: Processes Receptor Location Inputs for Events 7 ! 8 ! PROGRAMMER: Jeff Wang, Roger Brode 9 ! 10 ! DATE: March 2, 1992 11 ! 12 ! INPUTS: Input Runstream Image Parameters 13 ! 14 ! OUTPUTS: Event Name, AXR, AYR, AZELEV, AZFLAG of the Event 15 ! 16 ! CALLED FROM: EVCARD 17 !*********************************************************************** 18 19 ! Variable Declarations 20 USE MAIN1 21 IMPLICIT NONE 22 CHARACTER MODNAM*12 23 24 SAVE 25 INTEGER :: ISDX 26 REAL :: SETAXR , SETAYR 27 CHARACTER USEVN*8 , IDNAM1*4 , IDNAM2*4 28 LOGICAL FIND 29 30 ! Variable Initializations 31 MODNAM = 'EVLOC' ! 0 32 33 ! Check Whether There Are Enough Parameter Fields 34 IF ( IFC.EQ.2 ) THEN 35 ! Error Message: Missing Parameter 36 CALL ERRHDL(PATH,MODNAM,'E','200',KEYWRD) ! 0 37 GOTO 999 38 ELSEIF ( IFC.LT.8 ) THEN 39 ! Error Message: Not Enough Parameters 40 CALL ERRHDL(PATH,MODNAM,'E','201',KEYWRD) ! 0 41 GOTO 999 42 ELSEIF ( IFC.GT.10 ) THEN 43 ! Error Message: Too Many Parameters 44 CALL ERRHDL(PATH,MODNAM,'E','202',KEYWRD) ! 0 45 GOTO 999 46 ENDIF 47 48 ! READ Event Name, XCOOR,YCOOR,ELEV,FLAG And Assign to Different Array 49 USEVN = FIELD(3) ! 0 50 ! Check for Previous EVNAME 51 CALL SINDEX(EVNAME,NEVE,USEVN,ISDX,FIND) 52 IF ( .NOT.FIND ) THEN 53 ! Error Message: EVNAME Does Not Match 54 CALL ERRHDL(PATH,MODNAM,'E','203','EVNAME') ! 0 55 GOTO 999 56 ENDIF 57 58 IDNAM1 = FIELD(4) ! 0 59 60 CALL STONUM(FIELD(5),ILEN_FLD,FNUM,IMIT) 61 ! Check The Numerical Field 62 IF ( IMIT.EQ.-1 ) THEN 63 CALL ERRHDL(PATH,MODNAM,'E','208',KEYWRD) ! 0 64 ELSE 65 SETAXR = FNUM ! 0 66 ENDIF 67 68 IDNAM2 = FIELD(6) ! 0 69 70 CALL STONUM(FIELD(7),ILEN_FLD,FNUM,IMIT) 71 ! Check The Numerical Field 72 IF ( IMIT.EQ.-1 ) THEN 73 CALL ERRHDL(PATH,MODNAM,'E','208',KEYWRD) ! 0 74 ELSE 75 SETAYR = FNUM ! 0 76 ENDIF 77 78 IF ( IFC.GE.8 ) THEN ! 0 79 CALL STONUM(FIELD(8),ILEN_FLD,FNUM,IMIT) ! 0 80 ! Check The Numerical Field 81 IF ( IMIT.EQ.-1 ) THEN 82 CALL ERRHDL(PATH,MODNAM,'E','208',KEYWRD) ! 0 83 ELSE 84 AZELEV(ISDX) = FNUM ! 0 85 ENDIF 86 CALL STONUM(FIELD(9),ILEN_FLD,FNUM,IMIT) ! 0 87 ! Check The Numerical Field 88 IF ( IMIT.EQ.-1 ) THEN 89 CALL ERRHDL(PATH,MODNAM,'E','208',KEYWRD) ! 0 90 ELSE 91 AZHILL(ISDX) = FNUM ! 0 92 ENDIF 93 ELSE 94 AZELEV(ISDX) = 0. ! 0 95 AZHILL(ISDX) = 0. 96 ENDIF 97 98 IF ( IFC.EQ.10 ) THEN ! 0 99 CALL STONUM(FIELD(10),ILEN_FLD,FNUM,IMIT) ! 0 100 ! Check The Numerical Field 101 IF ( IMIT.EQ.-1 ) THEN 102 CALL ERRHDL(PATH,MODNAM,'E','208',KEYWRD) ! 0 103 ELSE 104 AZFLAG(ISDX) = FNUM ! 0 105 ENDIF 106 ELSE 107 AZFLAG(ISDX) = 0. ! 0 108 ENDIF 109 110 IF ( IDNAM1.EQ.'XR=' .AND. IDNAM2.EQ.'YR=' ) THEN ! 0 111 AXR(ISDX) = SETAXR ! 0 112 AYR(ISDX) = SETAYR 113 ELSEIF ( IDNAM1.EQ.'RNG=' .AND. IDNAM2.EQ.'DIR=' ) THEN 114 AXR(ISDX) = SETAXR*SIN(SETAYR*DTORAD) ! 0 115 AYR(ISDX) = SETAXR*COS(SETAYR*DTORAD) 116 ELSE 117 ! Write Error Message: Illegal Parameter 118 CALL ERRHDL(PATH,MODNAM,'E','203','REC-TYPE') ! 0 119 ENDIF 120 121 999 CONTINUE ! 0 122 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