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.
425 lines
17 KiB
Fortran
425 lines
17 KiB
Fortran
5 years ago
|
SUBROUTINE SETRNG(XNEARS,NMAP)
|
||
|
|
|
||
|
|
USE BLKMAP
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
|
||
|
|
INCLUDE 'TXFRM.COM'
|
||
|
|
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
|
||
|
|
!
|
||
|
|
! Establish size for range
|
||
|
|
!
|
||
|
|
JS=1
|
||
|
|
K=0
|
||
|
|
KPT=0
|
||
|
|
VDX=-1.E9
|
||
|
|
write(90,*) 'maxpts', maxpts
|
||
|
|
DO 120 J=1,MAXPTS+1
|
||
|
|
!
|
||
|
|
! Determine how long each line is
|
||
|
|
!
|
||
|
|
MLEN=J-JS
|
||
|
|
! write(90,*) 'mlen',j,js,mlen,xmap(j),nmap,vdx
|
||
|
|
! write(90,*) j,js,mlen,cmap(j,1),xmap(j),vdx,maxpts
|
||
|
|
IF(XMAP(J) .LT. VDX) THEN
|
||
|
|
!IPK NOV05 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
|
||
|
|
! write(191,*) j,m,js+m-1,nmap
|
||
|
|
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
|
||
|
|
write(90,*) 'number of points forming map',nmap
|
||
|
|
write(90,*) 'last map coordinates',cxcur,cycur
|
||
|
|
!
|
||
|
|
! Estimate areal density to get 100 points
|
||
|
|
!
|
||
|
|
ADEN=AMAP*40./(FLOAT(KPT)*TXSCAL**2)
|
||
|
|
!
|
||
|
|
! Find square coverage
|
||
|
|
!
|
||
|
|
XNEARS=SQRT(ADEN)
|
||
|
|
xnearo=xnears
|
||
|
|
xnearf=xnears
|
||
|
|
!ipk sep97 xnearo forms the current value xnearp is limiting plus side
|
||
|
|
XNEARP=XNEARS
|
||
|
|
! xnears=2.0
|
||
|
|
WRITE(90,*) 'Radius for nearby points',XNEARS
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE SETELV(XNEARS,NMAP,M,ISWT)
|
||
|
|
|
||
|
|
USE WINTERACTER
|
||
|
|
USE BLKMAP
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
|
||
|
|
! common /mapc/imap(maxpl),NCRS(MAXPL)
|
||
|
|
! dimension ccmap(maxpl)
|
||
|
|
|
||
|
|
DIMENSION LISTM(1000),listt(1600,4),nlf(4),icomp(4),xnear(4)
|
||
|
|
dimension xnearkp(4)
|
||
|
|
|
||
|
|
|
||
|
|
DATA ITIME/0/
|
||
|
|
|
||
|
|
IF(.NOT. ALLOCATED(CCMAP)) THEN
|
||
|
|
ALLOCATE (CCMAP(MAXPL))
|
||
|
|
ENDIF
|
||
|
|
call WcursorShape(CurHourGlass)
|
||
|
|
|
||
|
|
|
||
|
|
!ipk feb94 change logic to allow 4 passes and check angles
|
||
|
|
!
|
||
|
|
! initialize range
|
||
|
|
!
|
||
|
|
ict=0
|
||
|
|
!ipk sep97 xnears=xnearo
|
||
|
|
xnearo=xnears
|
||
|
|
xnearp=xnears
|
||
|
|
xnearf=xnears
|
||
|
|
write(90,*) 'working node',m
|
||
|
|
do nang=1,4
|
||
|
|
XNEAR(nang)=XNEARS
|
||
|
|
xnearkp(nang)=0.
|
||
|
|
icomp(nang)=0
|
||
|
|
enddo
|
||
|
|
!
|
||
|
|
! set imap to zero to start or -1 if no value
|
||
|
|
!
|
||
|
|
!IPK MAY97 INITIALIZE COUNTER
|
||
|
|
ntime=0
|
||
|
|
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
|
||
|
|
!
|
||
|
|
!ipk sep97 Sortlist of map points in increasing x except for single poin
|
||
|
|
!
|
||
|
|
IF(ielvsw .EQ. 0 .AND. ISWT .NE. 1) THEN
|
||
|
|
!ipk mar99
|
||
|
|
do n=1,nmap
|
||
|
|
ccmap(n)=cmap(n,1)
|
||
|
|
enddo
|
||
|
|
CALL SORTMAP(CCMAP,NCRS,NMAP,IMAP)
|
||
|
|
ielvsw=1
|
||
|
|
! DO N=1,NMAP
|
||
|
|
! WRITE(90,*) N,CMAP(NCRS(N),1),IMAP(NCRS(N))
|
||
|
|
! ENDDO
|
||
|
|
ENDIF
|
||
|
|
!ipk sep97 end addition
|
||
|
|
!
|
||
|
|
! initialize list and completeness test
|
||
|
|
!
|
||
|
|
do nang=1,4
|
||
|
|
icomp(nang)=0
|
||
|
|
do n=1,1600
|
||
|
|
listt(n,nang)=0
|
||
|
|
enddo
|
||
|
|
enddo
|
||
|
|
!
|
||
|
|
! start processing
|
||
|
|
!
|
||
|
|
280 continue
|
||
|
|
!
|
||
|
|
! check for completeness intialize counter
|
||
|
|
!
|
||
|
|
ict=0
|
||
|
|
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
|
||
|
|
!
|
||
|
|
!ipk sep97 change loop
|
||
|
|
do nang=1,4
|
||
|
|
nlf(nang)=0
|
||
|
|
icomp(nang)=0
|
||
|
|
enddo
|
||
|
|
IFND=0
|
||
|
|
NN=0
|
||
|
|
285 NN=NN+1
|
||
|
|
IF(NN .GT. NMAP) GO TO 305
|
||
|
|
! DO 300 NNN=1,NMAP
|
||
|
|
N=NN
|
||
|
|
if(val(n) .lt. -9990.) go to 285
|
||
|
|
IF(ISWT .EQ. 1) GO TO 297
|
||
|
|
IF(IFND .EQ. 1) GO TO 295
|
||
|
|
IF(XNEARO .LT. XNEARF) THEN
|
||
|
|
IFND=1
|
||
|
|
GO TO 294
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
!IPK SEP97 START SEARCH
|
||
|
|
NLOCA=NMAP/2
|
||
|
|
NSTEPS=NMAP/2
|
||
|
|
290 CONTINUE
|
||
|
|
|
||
|
|
! WRITE(90,*) 'elvset-164',NLOCA
|
||
|
|
! write(90,*) NSTEPS,NCRS(NLOCA)
|
||
|
|
! WRITE(90,*) CMAP(NCRS(NLOCA),1),CORD(M,1),XNEAR(1)
|
||
|
|
NCUR=NCRS(NLOCA)
|
||
|
|
! IF(CMAP(NCUR,1) .GT. 1.E34) THEN
|
||
|
|
! WE ARE AOUT OF RANGE
|
||
|
|
! GO TO
|
||
|
|
! ENDIF
|
||
|
|
IF(CMAP(NCUR,1)+XNEARO .LT. CORD(M,1).and. val(ncur) .gt. -9000.) THEN
|
||
|
|
! still below increase nloca
|
||
|
|
NSTEPS=NSTEPS/2
|
||
|
|
IF(NSTEPS .EQ. 0) THEN
|
||
|
|
! we are there
|
||
|
|
NLOCA=NLOCA-1
|
||
|
|
IFND=1
|
||
|
|
GO TO 293
|
||
|
|
ENDIF
|
||
|
|
NLOCA=NLOCA+NSTEPS
|
||
|
|
GO TO 290
|
||
|
|
ELSE
|
||
|
|
! too great decrease nloca
|
||
|
|
NSTEPS=(NSTEPS+1)/2
|
||
|
|
NLOCA=NLOCA-NSTEPS
|
||
|
|
IF(NLOCA .LE. 0) THEN
|
||
|
|
NLOCA=0
|
||
|
|
IFND=1
|
||
|
|
GO TO 293
|
||
|
|
ENDIF
|
||
|
|
GO TO 290
|
||
|
|
ENDIF
|
||
|
|
293 NLOCS=NLOCA
|
||
|
|
! WRITE(90,*) 'elvset-201',NLOCA,NSTEPS,NCRS(NLOCA)
|
||
|
|
! WRITE(90,*) CMAP(NCRS(NLOCA),1),CORD(M,1),XNEAR(1)
|
||
|
|
GO TO 295
|
||
|
|
294 NLOCA=NLOCS
|
||
|
|
295 CONTINUE
|
||
|
|
NLOCA=NLOCA+1
|
||
|
|
if(nloca .gt. nmap) go to 305
|
||
|
|
NCUR=NCRS(NLOCA)
|
||
|
|
!
|
||
|
|
! test to see if we are past area
|
||
|
|
!
|
||
|
|
if(ncur .eq. 0) go to 305
|
||
|
|
IF(CMAP(NCUR,1)-XNEARP .GT. CORD(M,1)) GO TO 305
|
||
|
|
if(val(ncur) .lt. -9000.) go to 295
|
||
|
|
N=NCUR
|
||
|
|
297 CONTINUE
|
||
|
|
d1=cmap(n,1)-cord(m,1)
|
||
|
|
d2=cmap(n,2)-cord(m,2)
|
||
|
|
!ipk may97 IF(ABS(D1) .LT. XNEAR(1)) THEN
|
||
|
|
!ipk may97 IF(ABS(D2) .LT. XNEAR(1)) THEN
|
||
|
|
IF(ABS(D1) .LT. max(XNEARO,xnearp)) THEN
|
||
|
|
IF(ABS(D2) .LT. max(XNEARO,xnearp)) THEN
|
||
|
|
if(d1 .lt. 0) then
|
||
|
|
if(d2 .lt. 0) then
|
||
|
|
nang=3
|
||
|
|
if(abs(d1) .lt. xnear(NANG) .and. &
|
||
|
|
& abs(d2) .lt. xnear(NANG)) then
|
||
|
|
imap(n)=3
|
||
|
|
else
|
||
|
|
imap(n)=-1
|
||
|
|
go to 300
|
||
|
|
endif
|
||
|
|
else
|
||
|
|
nang=2
|
||
|
|
if(abs(d1) .lt. xnear(NANG) .and. &
|
||
|
|
& abs(d2) .lt. xnear(NANG)) then
|
||
|
|
imap(n)=2
|
||
|
|
else
|
||
|
|
imap(n)=-1
|
||
|
|
go to 300
|
||
|
|
endif
|
||
|
|
endif
|
||
|
|
elseif(d2 .lt. 0) then
|
||
|
|
nang=4
|
||
|
|
if(abs(d1) .lt. xnear(NANG) .and. &
|
||
|
|
& abs(d2) .lt. xnear(NANG)) then
|
||
|
|
imap(n)=4
|
||
|
|
else
|
||
|
|
imap(n)=-1
|
||
|
|
go to 300
|
||
|
|
endif
|
||
|
|
else
|
||
|
|
nang=1
|
||
|
|
if(abs(d1) .lt. xnear(NANG) .and. &
|
||
|
|
& abs(d2) .lt. xnear(NANG)) then
|
||
|
|
imap(n)=1
|
||
|
|
else
|
||
|
|
imap(n)=-1
|
||
|
|
go to 300
|
||
|
|
endif
|
||
|
|
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
|
||
|
|
!
|
||
|
|
!IPK SEP97 END MAJOR REWRITE
|
||
|
|
!
|
||
|
|
! save value if total less then 50
|
||
|
|
!
|
||
|
|
NLF(NANG)=NLF(NANG)+1
|
||
|
|
IF(NLF(NANG) .LT. 101) THEN
|
||
|
|
LISTT(NLF(NANG),NANG)=N
|
||
|
|
ENDIF
|
||
|
|
300 CONTINUE
|
||
|
|
GO TO 285
|
||
|
|
305 CONTINUE
|
||
|
|
!
|
||
|
|
! now reset range if we need to
|
||
|
|
!
|
||
|
|
ictz=0
|
||
|
|
! write(90,*) ' '
|
||
|
|
! write(90,*) ntime
|
||
|
|
! write(90,*) 'nlf',nlf
|
||
|
|
! write(90,*) 'xnear',xnear
|
||
|
|
do nang=1,4
|
||
|
|
if(nlf(nang) .gt. 150) then
|
||
|
|
! rat=sqrt((45.+ntime*3.)/nlf(nang))
|
||
|
|
! if(rat .lt. 0.2) rat=0.2
|
||
|
|
rat=sqrt(0.1+0.06*ntime)
|
||
|
|
xnearkp(nang)=xnear(nang)
|
||
|
|
xnear(nang)=xnear(nang)*rat
|
||
|
|
!ipk may97 elseif(nlf(nang) .eq. 0) then
|
||
|
|
elseif(nlf(nang) .lt. 2) then
|
||
|
|
!ipk may97 if(xnear(nang) .eq. xnears) then
|
||
|
|
ictz=ictz+1
|
||
|
|
!ipk may97 else
|
||
|
|
!ipk may97 icomp(nang)=1
|
||
|
|
!ipk may97 endif
|
||
|
|
else
|
||
|
|
icomp(nang)=1
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
xnearf=xnearo
|
||
|
|
! write(90,*) 'ntime,ictz,xnear',ntime,ictz
|
||
|
|
! write(90,*) 'icomp',icomp
|
||
|
|
! write(90,*) 'xneara',xnear
|
||
|
|
if(ictz .gt. 0) then
|
||
|
|
do nang=1,4
|
||
|
|
if(nlf(nang) .lt. 2) then
|
||
|
|
if(xnearkp(nang) .gt. 0.) then
|
||
|
|
xnear(nang)=xnearkp(nang)
|
||
|
|
else
|
||
|
|
xnear(nang)=xnear(nang)*1.5
|
||
|
|
endif
|
||
|
|
if(nang .eq. 2 .or. nang .eq. 3) then
|
||
|
|
if(xnear(nang) .gt. xnearo) xnearo=xnear(nang)
|
||
|
|
endif
|
||
|
|
if(nang .eq. 1 .or. nang .eq. 4) then
|
||
|
|
if(xnear(nang) .gt. xnearp) xnearp=xnear(nang)
|
||
|
|
endif
|
||
|
|
endif
|
||
|
|
!ipk may97 xnears=xnears*2.
|
||
|
|
! write(90,*) 'nang,xnear',nang,xnear(nang)
|
||
|
|
! write(90,*) 'xnearo,xnearp',xnearo,xnearp
|
||
|
|
|
||
|
|
enddo
|
||
|
|
!ipk sep97 xnears=xnears*2.
|
||
|
|
ntime=ntime+1
|
||
|
|
if(ntime .lt. 12) go to 220
|
||
|
|
! go to 220
|
||
|
|
! endif
|
||
|
|
endif
|
||
|
|
!
|
||
|
|
! go back and try again
|
||
|
|
!
|
||
|
|
!ipk may97 go to 280
|
||
|
|
ntime=ntime+1
|
||
|
|
if(ntime .lt. 16) go to 280
|
||
|
|
endif
|
||
|
|
!
|
||
|
|
! finished now compact list
|
||
|
|
!
|
||
|
|
do nang=1,4
|
||
|
|
! write(90,*)'nang',nang,nlf(nang),xnear(nang)
|
||
|
|
enddo
|
||
|
|
nlg=0
|
||
|
|
do nang=1,4
|
||
|
|
nlim=nlf(nang)
|
||
|
|
!ipksep97 if(nlim .eq. 0) then
|
||
|
|
!ipksep97 nlim=50
|
||
|
|
!ipk sep97 endif
|
||
|
|
!ipk sep97 chnage limit and act only if nlim > 0
|
||
|
|
! write(90,*) 'nlim',nlim
|
||
|
|
if(nlim .gt. 1600) nlim=1600
|
||
|
|
if(nlim .gt. 0) then
|
||
|
|
do nlgg=1,nlim
|
||
|
|
if(listt(nlgg,nang) .gt. 0) then
|
||
|
|
if(nlg .eq. 1000) nlg=999
|
||
|
|
nlg=nlg+1
|
||
|
|
listm(nlg)=listt(nlgg,nang)
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
! write(90,*) nlg
|
||
|
|
! write(90,*) m,(listm(n),n=1,nlg),xnear
|
||
|
|
!ipk feb94 end changes
|
||
|
|
! do n=1,nmap
|
||
|
|
! write(90,*) n,cmap(n,1),cmap(n,2),val(n)
|
||
|
|
! enddo
|
||
|
|
! write(90,*) 'LIST MAP POINTS NEAR ',M,CORD(M,1),CORD(M,2)
|
||
|
|
! DO N=1,NLG
|
||
|
|
! WRITE(90,*) listm(n),CMAP(LISTM(N),1),CMAP(LISTM(N),2),val(listm(n))
|
||
|
|
! ENDDO
|
||
|
|
! read(*,*) n234
|
||
|
|
|
||
|
|
!IPK JUL98 CALL GRIDIN(M,SOLN,LISTM,NLG)
|
||
|
|
XXX=CORD(M,1)
|
||
|
|
YYY=CORD(M,2)
|
||
|
|
CALL GRIDIN(XXX,YYY,SOLN,LISTM,NLG)
|
||
|
|
IF(IRMAIN .EQ. 1) then
|
||
|
|
call WcursorShape(CurArrow)
|
||
|
|
RETURN
|
||
|
|
endif
|
||
|
|
WD(M)=SOLN
|
||
|
|
FPN = WD(M)*10.
|
||
|
|
X = CORD(M,1)
|
||
|
|
Y = CORD(M,2) - .11
|
||
|
|
IF(X .GT. 0. .AND. X .LT. HSIZE .AND. &
|
||
|
|
& Y .GT. 0. .AND. Y .LT. 7.5) THEN
|
||
|
|
CALL RRED
|
||
|
|
CALL NUMBR(X,Y,0.1,FPN,0.0,-1)
|
||
|
|
ENDIF
|
||
|
|
! call WcursorShape(0)
|
||
|
|
call WcursorShape(CurArrow)
|
||
|
|
RETURN
|
||
|
|
END
|