You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
246 lines
10 KiB
Fortran
246 lines
10 KiB
Fortran
5 years ago
|
!----------------------------------------------------------------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
|