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.
141 lines
4.9 KiB
Fortran
141 lines
4.9 KiB
Fortran
5 years ago
|
! Last change: IPK 2 Feb 2003 6:25 pm
|
||
|
|
SUBROUTINE DELAUNAY1(XMAP1,YMAP1,NVERT)
|
||
|
|
|
||
|
|
USE BLKMAP
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
CHARACTER*80 LIND
|
||
|
|
CHARACTER*1 ANS
|
||
|
|
REAL*8 XMAP1(*),YMAP1(*)
|
||
|
|
DATA VDX9/-9.E9/,NEDGE/0/
|
||
|
|
|
||
|
|
! Get location of supertriangle
|
||
|
|
|
||
|
|
iprt=0
|
||
|
|
ngap=0
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
call supert(XMAP1,YMAP1,NVERT)
|
||
|
|
|
||
|
|
NELTS=1
|
||
|
|
|
||
|
|
NVERTM=NVERT-3
|
||
|
|
|
||
|
|
! Sort points into ascending x order
|
||
|
|
|
||
|
|
CALL SORTDB(XMAP1,NKEY,NVERTM)
|
||
|
|
|
||
|
|
! Loop on the vertices
|
||
|
|
|
||
|
|
YLV=7.5
|
||
|
|
DO NN=1,NVERT-3
|
||
|
|
|
||
|
|
|
||
|
|
if(mod(NN,2500) .eq. 0) then
|
||
|
|
ylv=ylv-0.3
|
||
|
|
if(ylv .lt. 0.1) then
|
||
|
|
ylv=7.9
|
||
|
|
call clscrn
|
||
|
|
endif
|
||
|
|
write(lind,6010) NN
|
||
|
|
6010 format(i8,' points processed')
|
||
|
|
call symbl &
|
||
|
|
& (1.1,ylv,0.20,LIND,0.0,80)
|
||
|
|
endif
|
||
|
|
|
||
|
|
! process next point
|
||
|
|
|
||
|
|
N=NKEY(NN)
|
||
|
|
|
||
|
|
! Skip out if inactive point
|
||
|
|
IF(N .EQ. 0) GO TO 500
|
||
|
|
IF(XMAP1(N) .LT. VDX9) GO TO 500
|
||
|
|
|
||
|
|
IF(NN .LT. NVERTM) THEN
|
||
|
|
DO KK=NN+1,NVERTM
|
||
|
|
K=NKEY(KK)
|
||
|
|
IF(K .NE. 0) THEN
|
||
|
|
IF(XMAP1(N) .EQ. XMAP1(K)) THEN
|
||
|
|
IF(YMAP1(N) .EQ. YMAP1(K)) THEN
|
||
|
|
WRITE(45,*) 'IDENT',N,K
|
||
|
|
NKEY(KK)=0
|
||
|
|
ENDIF
|
||
|
|
ELSE
|
||
|
|
GO TO 200
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
200 CONTINUE
|
||
|
|
ENDDO
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
! Set edge buffers to zero
|
||
|
|
|
||
|
|
IF(NEDGE .GT. 0) THEN
|
||
|
|
DO J=1,NEDGE
|
||
|
|
IEDGE(J,1)=0
|
||
|
|
IEDGE(J,2)=0
|
||
|
|
END DO
|
||
|
|
ELSE
|
||
|
|
DO J=1,100
|
||
|
|
IEDGE(J,1)=0
|
||
|
|
IEDGE(J,2)=0
|
||
|
|
END DO
|
||
|
|
ENDIF
|
||
|
|
NEDGE=0
|
||
|
|
|
||
|
|
! test for point in circumcircle
|
||
|
|
|
||
|
|
DO J=1,NELTS
|
||
|
|
CALL INSIDCIRC(XMAP1,YMAP1,J,N,ISWT)
|
||
|
|
|
||
|
|
! If inside process edges
|
||
|
|
|
||
|
|
IF(ISWT .EQ. 1) THEN
|
||
|
|
CALL PROCESS(J,NEDGE,NGAP)
|
||
|
|
ENDIF
|
||
|
|
END DO
|
||
|
|
|
||
|
|
! Setup to form new triangles
|
||
|
|
|
||
|
|
CALL SETEDG(NEDGE)
|
||
|
|
|
||
|
|
! Now form triangles as needed
|
||
|
|
|
||
|
|
DO J=1,NEDGE
|
||
|
|
IF(IEDGE(J,1) .NE. 0) THEN
|
||
|
|
!ipk dec17 add wd
|
||
|
|
CALL FORMT(XMAP1,YMAP1,J,N,NGAP,KK,wd)
|
||
|
|
ENDIF
|
||
|
|
END DO
|
||
|
|
|
||
|
|
NEDGE=0
|
||
|
|
if(iprt .eq. 0) go to 500
|
||
|
|
DO J=1,NELTS
|
||
|
|
IF(NOPEL(J,1) .GT. 0) THEN
|
||
|
|
WRITE(3,'(2i5,2i10,19x,''1'')') J,(NOPEL(J,K),K=1,3)
|
||
|
|
ENDIF
|
||
|
|
END DO
|
||
|
|
|
||
|
|
|
||
|
|
IF(NN .EQ. 1) THEN
|
||
|
|
write(41,'('' 9999'')')
|
||
|
|
do j=1,nvert
|
||
|
|
write(41,'(i10,2f20.4,F10.3)') j,XMAP1(j),YMAP1(j),VAL(J)
|
||
|
|
enddo
|
||
|
|
write(41,'('' 9999'')')
|
||
|
|
write(41,'('' 9999'')')
|
||
|
|
write(41,'('' 0 NENTRY'')')
|
||
|
|
write(41,'('' 0 NCLM'')')
|
||
|
|
WRITE(41,'(''ENDDATA'')')
|
||
|
|
ENDIF
|
||
|
|
500 continue
|
||
|
|
END DO
|
||
|
|
|
||
|
|
! Get rid of elements from super point
|
||
|
|
|
||
|
|
CALL RIDPOINT(NVERT)
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
END SUBROUTINE
|