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.
237 lines
6.5 KiB
Fortran
237 lines
6.5 KiB
Fortran
5 years ago
|
SUBROUTINE DELN2(NVERT,ISWT1)
|
||
|
|
|
||
|
|
USE BLKMAP
|
||
|
|
USE BLK1MOD
|
||
|
|
USE BLK2MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
! INCLUDE 'BLK2.COM'
|
||
|
|
|
||
|
|
CHARACTER*80 LIND
|
||
|
|
CHARACTER*1 ANS
|
||
|
|
DATA SPAC/0.0/
|
||
|
|
VOID = -1.E10
|
||
|
|
NEDGE=0
|
||
|
|
NINTV=1
|
||
|
|
NGAP=0
|
||
|
|
|
||
|
|
! Check options
|
||
|
|
|
||
|
|
IF(ISWT1 .EQ. 0) THEN
|
||
|
|
CALL TRIANOPT(NINTV,SPAC)
|
||
|
|
ELSE
|
||
|
|
NINTV=1
|
||
|
|
SPAC=0
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
! Sort points into ascending x order
|
||
|
|
|
||
|
|
CALL SORTDB(XUSR,NKEY,NVERT)
|
||
|
|
|
||
|
|
! Drop points based on spacing
|
||
|
|
|
||
|
|
IF(ISWT1 .NE. 0) THEN
|
||
|
|
IF(NINTV .GT. 1 .OR. SPAC .GT. 0.) THEN
|
||
|
|
CALL DROPPTS(NVERT,NINTV,SPAC)
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
! Get location of supertriangle
|
||
|
|
|
||
|
|
iprt=0
|
||
|
|
|
||
|
|
call supert(XUSR,YUSR,NVERT)
|
||
|
|
|
||
|
|
NELTS=1
|
||
|
|
|
||
|
|
NVERTM=NVERT-3
|
||
|
|
|
||
|
|
! Loop on the vertices
|
||
|
|
|
||
|
|
DO NN=1,NVERT-3
|
||
|
|
|
||
|
|
! process next point
|
||
|
|
|
||
|
|
N=NKEY(NN)
|
||
|
|
! Skip out if inactive point
|
||
|
|
IF(N .EQ. 0) GO TO 500
|
||
|
|
IF(LIST(N) .EQ. 0) GO TO 500
|
||
|
|
|
||
|
|
IF(NN .LT. NVERTM) THEN
|
||
|
|
DO KK=NN+1,NVERTM
|
||
|
|
K=NKEY(KK)
|
||
|
|
IF(K .NE. 0) THEN
|
||
|
|
IF(XUSR(N) .EQ. XUSR(K)) THEN
|
||
|
|
IF(YUSR(N) .EQ. YUSR(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
|
||
|
|
|
||
|
|
if(n .eq. 6) then
|
||
|
|
aa=0
|
||
|
|
endif
|
||
|
|
DO J=1,NELTS
|
||
|
|
CALL INSIDCIRC(XUSR,YUSR,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
|
||
|
|
NELFM(J)=0
|
||
|
|
IF(IEDGE(J,1) .NE. 0) THEN
|
||
|
|
CALL FORMT(XUSR,YUSR,J,N,NGAP,KK,WD)
|
||
|
|
NELFM(J)=KK
|
||
|
|
ENDIF
|
||
|
|
END DO
|
||
|
|
|
||
|
|
DO J=1,NEDGE
|
||
|
|
IF(NELFM(J) .GT. 0) THEN
|
||
|
|
CALL TESTTR(XUSR,YUSR,NELFM(J))
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
|
||
|
|
NEDGE=0
|
||
|
|
iprt=0
|
||
|
|
if(iprt .eq. 0) go to 500
|
||
|
|
DO J=1,NELTS
|
||
|
|
IF(NOPEL(J,1) .GT. 0) THEN
|
||
|
|
WRITE(150+nn,'(2i5,2i10,19x,''1'')') J,(NOPEL(J,K),K=1,3)
|
||
|
|
ENDIF
|
||
|
|
END DO
|
||
|
|
ninnin=9999
|
||
|
|
write(150+nn,'(i5)') ninnin
|
||
|
|
|
||
|
|
do j=1,nvert
|
||
|
|
write(150+nn,'(i10,f16.6,f20.6,f10.2)') j,xusr(j),yusr(j),val(j)
|
||
|
|
enddo
|
||
|
|
write(150+nn,'(i10)') ninnin
|
||
|
|
500 continue
|
||
|
|
END DO
|
||
|
|
|
||
|
|
! Get rid of elements from super point
|
||
|
|
|
||
|
|
CALL RIDPOINT(NVERT)
|
||
|
|
|
||
|
|
XUSR(NP+1)=VOID
|
||
|
|
XUSR(NP+2)=VOID
|
||
|
|
XUSR(NP+3)=VOID
|
||
|
|
YUSR(NP+1)=VOID
|
||
|
|
YUSR(NP+2)=VOID
|
||
|
|
YUSR(NP+3)=VOID
|
||
|
|
DO J=1,NELTS
|
||
|
|
DO K=1,3
|
||
|
|
NOPSTO(J,2*K-1,1)=NOPEL(J,K)
|
||
|
|
NOPSTO(J,2*K,1)=0
|
||
|
|
ENDDO
|
||
|
|
NOPSTO(J,7,1)=0
|
||
|
|
NOPSTO(J,8,1)=0
|
||
|
|
IMATSTO(J,1)=1
|
||
|
|
THTASTO(J,1)=0.
|
||
|
|
ENDDO
|
||
|
|
NP=NP-3
|
||
|
|
NPSTO(1)=NP
|
||
|
|
NESTO(1)=NELTS
|
||
|
|
|
||
|
|
! Get edge nodes for later filling
|
||
|
|
|
||
|
|
! IF(ISWT1 .EQ. 0) THEN
|
||
|
|
! CALL GETEDG
|
||
|
|
! ENDIF
|
||
|
|
if(iswt1 .eq. 2) then
|
||
|
|
do j=1,np
|
||
|
|
xusrsto(j,1)=xusr(j)
|
||
|
|
yusrsto(j,1)=yusr(j)
|
||
|
|
enddo
|
||
|
|
call mergemesh1(1)
|
||
|
|
! call mergemesh
|
||
|
|
endif
|
||
|
|
CALL ADDMESH(1)
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
END SUBROUTINE
|
||
|
|
|
||
|
|
|
||
|
|
SUBROUTINE GETEDG
|
||
|
|
|
||
|
|
USE BLKMAP
|
||
|
|
USE BLK1MOD
|
||
|
|
USE BLK2MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
! INCLUDE 'BLK2.COM'
|
||
|
|
|
||
|
|
! Look for edges that are duplicates
|
||
|
|
|
||
|
|
DO N=1,NESTO(1)
|
||
|
|
DO NN=1,3
|
||
|
|
N1=NOPEL(N,NN)
|
||
|
|
IF(NN .EQ. 3) THEN
|
||
|
|
N2=NOPEL(N,1)
|
||
|
|
ELSE
|
||
|
|
N2=NOPEL(N,NN+1)
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
DO M=1,NESTO(1)
|
||
|
|
DO MM=1,3
|
||
|
|
M1=NOPEL(M,MM)
|
||
|
|
IF(M1 .EQ. N2) THEN
|
||
|
|
|
||
|
|
! Keep looking for match
|
||
|
|
|
||
|
|
IF(MM .EQ. 3) THEN
|
||
|
|
M2=NOPEL(M,1)
|
||
|
|
ELSE
|
||
|
|
M2=NOPEL(M,MM+1)
|
||
|
|
ENDIF
|
||
|
|
IF(M2 .EQ. N1) THEN
|
||
|
|
|
||
|
|
! We have a match, this is no edge skip out to next side
|
||
|
|
|
||
|
|
GO TO 400
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
ENDDO
|
||
|
|
|
||
|
|
! No match these nodes are on an edge
|
||
|
|
|
||
|
|
NINC(N1)=1
|
||
|
|
NINC(N2)=1
|
||
|
|
|
||
|
|
400 CONTINUE
|
||
|
|
ENDDO
|
||
|
|
ENDDO
|
||
|
|
RETURN
|
||
|
|
END
|