1 2 !----------------------------------------------------------------------- 3 SUBROUTINE TGQA 4 !----------------------------------------------------------------------- 5 ! 6 ! --- ISCST2 Version: 1.0 Level: 931215 TGQA 7 ! D. Strimaitis, SRC 8 ! 9 ! PURPOSE: Subroutine checks source/receptor locations against 10 ! the corners of the terrain grid to assure that all lie 11 ! within the grid. 12 ! 13 ! MODIFIED: To use new FUNCTION ZINTERP (based on original FUNCION ZTERR) 14 ! to interpolate elevations for sources and receptors. 15 ! Roger W. Brode, PES, Inc. - 12/29/97 16 ! 17 ! MODIFIED: To compare interpolated elevations from grid file against 18 ! source elevations and receptor elevations. 19 ! Roger W. Brode, PES, Inc. - 11/29/94 20 ! 21 ! CALLING ROUTINES: SETUP 22 ! 23 ! EXTERNAL ROUTINES: none 24 !----------------------------------------------------------------------- 25 26 ! --- Variable Declarations 27 USE MAIN1 28 IMPLICIT NONE 29 CHARACTER MODNAM*12 30 31 SAVE 32 INTEGER :: I 33 REAL :: XSMIN , YSMIN , XSMAX , YSMAX , XRMIN , YRMIN , XRMAX , & 34 & YRMAX , XLLTEST , YLLTEST , XURTEST , YURTEST , ZINT , & 35 & ZINTERP , DIFF 36 37 ! --- Define a test logical 38 LOGICAL LFAIL 39 DATA LFAIL/.FALSE./ 40 41 ! --- Variable Initializations 42 MODNAM = 'TGQA' ! 0 43 44 ! --- Loop over sources to find max/min x and y coordinates 45 ! --- (Does NOT treat Area Sources !!) 46 XSMIN = AXS(1) 47 YSMIN = AYS(1) 48 XSMAX = AXS(1) 49 YSMAX = AYS(1) 50 DO I = 2 , NUMSRC 51 IF ( AXS(I).GT.XSMAX ) THEN ! 0 52 XSMAX = AXS(I) ! 0 53 ELSEIF ( AXS(I).LT.XSMIN ) THEN 54 XSMIN = AXS(I) ! 0 55 ENDIF 56 IF ( AYS(I).GT.YSMAX ) THEN ! 0 57 YSMAX = AYS(I) ! 0 58 ELSEIF ( AYS(I).LT.YSMIN ) THEN 59 YSMIN = AYS(I) ! 0 60 ENDIF 61 ENDDO 62 63 ! --- Loop over receptors to find max/min x and y coordinates 64 XRMIN = AXR(1) ! 0 65 YRMIN = AYR(1) 66 XRMAX = AXR(1) 67 YRMAX = AYR(1) 68 DO I = 2 , NUMREC 69 IF ( AXR(I).GT.XRMAX ) THEN ! 0 70 XRMAX = AXR(I) ! 0 71 ELSEIF ( AXR(I).LT.XRMIN ) THEN 72 XRMIN = AXR(I) ! 0 73 ENDIF 74 IF ( AYR(I).GT.YRMAX ) THEN ! 0 75 YRMAX = AYR(I) ! 0 76 ELSEIF ( AYR(I).LT.YRMIN ) THEN 77 YRMIN = AYR(I) ! 0 78 ENDIF 79 ENDDO 80 81 ! --- Test max/min against corners of terrain grid 82 XLLTEST = MIN(XSMIN,XRMIN) ! 0 83 YLLTEST = MIN(YSMIN,YRMIN) 84 XURTEST = MAX(XSMAX,XRMAX) 85 YURTEST = MAX(YSMAX,YRMAX) 86 IF ( XLLTEST.LT.GRDXLL ) LFAIL = .TRUE. 87 IF ( YLLTEST.LT.GRDYLL ) LFAIL = .TRUE. 88 IF ( XURTEST.GT.GRDXUR ) LFAIL = .TRUE. 89 IF ( YURTEST.GT.GRDYUR ) LFAIL = .TRUE. 90 91 IF ( LFAIL ) THEN 92 ! Write Error Message: Invalid Keyword for This Pathway 93 CALL ERRHDL(PATH,MODNAM,'E','305','GRID') ! 0 94 WRITE (IOUNIT,*) 'Lower Left of Source Range : ' , XSMIN , & 95 & YSMIN 96 WRITE (IOUNIT,*) 'Upper Right of Source Range : ' , XSMAX , & 97 & YSMAX 98 WRITE (IOUNIT,*) 'Lower Left of Receptor Range : ' , XRMIN , & 99 & YRMIN 100 WRITE (IOUNIT,*) 'Upper Right of Receptor Range: ' , XRMAX , & 101 & YRMAX 102 WRITE (IOUNIT,*) 'Lower Left of Terrain Grid : ' , GRDXLL , & 103 & GRDYLL 104 WRITE (IOUNIT,*) 'Upper Right of Terrain Grid : ' , GRDXUR , & 105 & GRDYUR 106 ENDIF 107 108 ! Loop through sources to compare source elevations to terrain grid 109 DO I = 1 , NUMSRC ! 0 110 111 ! Interpolate to obtain source elevation using FUNCTION ZINTERP 112 ZINT = ZINTERP(AXS(I),AYS(I)) ! 0 113 114 DIFF = ABS(AZS(I)-ZINT) 115 ! Compare interpolated height from terrain grid to source elevation 116 IF ( DIFF.GT.1.0 .AND. DIFF.GT.0.5*ZINT ) & 117 & CALL ERRHDL(PATH,MODNAM,'W','393',SRCID(I)) 118 119 ENDDO 120 121 ! Loop through receptors to compare receptor elevations to terrain grid 122 DO I = 1 , NUMREC ! 0 123 124 ! Interpolate to obtain receptor elevation using FUNCTION ZINTERP 125 ZINT = ZINTERP(AXR(I),AYR(I)) ! 0 126 127 DIFF = ABS(AZELEV(I)-ZINT) 128 ! Compare interpolated height from terrain grid to receptor elevation 129 IF ( DIFF.GT.1.0 .AND. DIFF.GT.0.5*ZINT ) THEN 130 WRITE (DUMMY,'("RE#",i5.5)') I ! 0 131 CALL ERRHDL(PATH,MODNAM,'W','394',DUMMY) 132 ENDIF 133 134 ENDDO 135 136 CONTINUE ! 0 137 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