!----------------------------------------------------------------elevint subroutine elevint(XX,YY,soln) !----------------------------------------------------------------------c ! purpose: c ! To interpolate elevation from map data. c !----------------------------------------------------------------------c ! Input data: c ! (XX, YY) -- a coordinate !----------------------------------------------------------------------c ! Output data: c ! soln -- elevation value c !----------------------------------------------------------------------c USE BLKMAP USE BLK1MOD ! INCLUDE 'BLK1.COM' INCLUDE 'TXFRM.COM' !IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL INTEGER LISTM,NLIST DIMENSION NLIST(200),ADIST(200) DIMENSION LISTM(1000),listt(60,4),nlf(4),icomp(4),xnear(4) ! common /mapc/imap(maxpl) ! ! Establish size for range ! JS=1 K=0 KPT=0 DO 120 J=1,MAXPTS ! ! Determine how long each line is ! MLEN=J-JS ! print *,XMAP(J),VDX,MAXPTS,MLEN,J,JS IF(CMAP(J,1) .LT. VDX) THEN ! ! Now check it. ! K=K+1 IF(MLEN .GT. 1) THEN ! LTP=LINTYP(K) DO 110 M=1,MLEN IF(VAL(JS+M-1) .GT. -9000.) THEN KPT=KPT+1 ENDIF 110 CONTINUE ENDIF NMAP=J IF(MLEN .EQ. 0) GO TO 130 JS=J+1 go to 120 ENDIF cxcur=xmap(j) cycur=ymap(j) 120 END DO 130 CONTINUE ! ! Estimate areal density to get 100 points ! ADEN=AMAP*40./(FLOAT(KPT)*TXSCAL**2) ! ! Find square coverage ! XNEARS=SQRT(ADEN) xnearo=xnears ! ! initialize range ! ict=0 xnears=xnearo do nang=1,4 XNEAR(nang)=XNEARO icomp(nang)=0 enddo ! ! set imap to zero to start or -1 if no value ! 220 continue do n=1,nmap if(cmap(n,1) .lt. vdx) then imap(n)=-1 elseif(val(n) .lt. -9000.) then imap(n)=-1 else imap(n)=0 endif enddo ! ! initialize list and completeness test ! do nang=1,4 icomp(nang)=0 do n=1,50 listt(n,nang)=0 enddo enddo ! ! start processing ! 280 continue ! ! check for completeness intialize counter ! do nang=1,4 if(icomp(nang) .eq. 0) then nlf(nang)=0 else ict=ict+1 endif enddo ! ! if ict = 4 we are done ! if(ict .lt. 4) then ! ! loop through map points ! DO 300 N=1,NMAP ! ! skip if no useful value ! if(imap(n) .eq. -1) go to 300 ! ! use nang if we have been through before ! if(imap(n) .gt. 0) then nang=imap(n) ! ! skip to end if done ! if(icomp(nang) .eq. 1) then go to 300 endif ! ! otherwise check range skipping out if out of range ! d1=cmap(n,1)-XX d2=cmap(n,2)-YY IF(ABS(D1) .GT. XNEAR(NANG)) THEN IMAP(N)=-1 GO TO 300 ELSEIF(ABS(D2) .GT. XNEAR(NANG)) THEN IMAP(N)=-1 GO TO 300 ENDIF ! ! process new point checking range and setting direction ! else d1=cmap(n,1)-XX d2=cmap(n,2)-YY IF(ABS(D1) .LT. XNEAR(1)) THEN IF(ABS(D2) .LT. XNEAR(1)) THEN if(d1 .lt. 0) then if(d2 .lt. 0) then imap(n)=3 nang=3 else imap(n)=2 nang=2 endif elseif(d2 .lt. 0) then imap(n)=4 nang=4 else imap(n)=1 nang=1 endif ! ! set to skip out if out of range ! ELSE imap(n)=-1 go to 300 ENDIF ELSE imap(n)=-1 go to 300 ENDIF endif ! ! save value if total less then 50 ! NLF(NANG)=NLF(NANG)+1 IF(NLF(NANG) .LT. 51) THEN LISTT(NLF(NANG),NANG)=N ENDIF 300 CONTINUE ! ! now reset range if we need to ! ictz=0 do nang=1,4 if(nlf(nang) .gt. 50) then rat=sqrt(45./nlf(nang)) if(rat .lt. 0.2) rat=0.2 xnear(nang)=xnear(nang)*rat elseif(nlf(nang) .eq. 0) then if(xnear(nang) .eq. xnears) then ictz=ictz+1 else icomp(nang)=1 endif else icomp(nang)=1 endif enddo if(ictz .gt. 1) then do nang=1,4 xnear(nang)=xnear(nang)*2. xnears=xnears*2. enddo if(xnear(1) .lt. 4.) then go to 220 endif endif ! ! go back and try again ! go to 280 endif ! ! finished now compact list ! nlg=0 do nang=1,4 nlim=nlf(nang) if(nlim .eq. 0) then nlim=50 endif do nlgg=1,nlim if(listt(nlgg,nang) .gt. 0) then nlg=nlg+1 listm(nlg)=listt(nlgg,nang) endif enddo enddo ! !-----perform interpolation ! SOLN=-9999.0 CALL GRIDIN(XX,YY,SOLN,LISTM,NLG) return END