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