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.
265 lines
8.0 KiB
Fortran
265 lines
8.0 KiB
Fortran
5 years ago
|
SUBROUTINE TRIANG
|
||
|
|
|
||
|
|
USE WINTERACTER
|
||
|
|
USE BLKMAP
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
|
||
|
|
DATA VOID10/-1.E10/,SPAC/0.0/
|
||
|
|
|
||
|
|
NELTS=0
|
||
|
|
NVERT=MAXPTS
|
||
|
|
NINTV=1
|
||
|
|
CALL TRIANOPT(NINTV,SPAC)
|
||
|
|
|
||
|
|
|
||
|
|
! FIRST WRITE EXISTING MAP TO SCRATCH
|
||
|
|
OPEN(99,FORM='BINARY',STATUS='SCRATCH')
|
||
|
|
|
||
|
|
CALL WRTMAP(99)
|
||
|
|
REWIND 99
|
||
|
|
|
||
|
|
DO N=1,NVERT
|
||
|
|
IF(MOD(N-1,NINTV) .EQ. 0) THEN
|
||
|
|
IMAP(N)=1
|
||
|
|
ELSE
|
||
|
|
IMAP(N)=0
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
|
||
|
|
IF(SPAC .GT. 0.) THEN
|
||
|
|
DO N=1,NVERT
|
||
|
|
IF(IMAP(N) .EQ. 1) THEN
|
||
|
|
IF(N .LT. NVERT) THEN
|
||
|
|
DO M=N+1,NVERT
|
||
|
|
DISQ=(XMAP(M)-XMAP(N))**2+(YMAP(M)-YMAP(N))**2
|
||
|
|
IF(DISQ .LT. SPAC**2) THEN
|
||
|
|
IMAP(M)=0
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
ENDIF
|
||
|
|
NN=0
|
||
|
|
DO N=1,NVERT
|
||
|
|
IF(IMAP(N) .GT. 0) THEN
|
||
|
|
NN=NN+1
|
||
|
|
XMAP(NN)=XMAP(N)
|
||
|
|
YMAP(NN)=YMAP(N)
|
||
|
|
IMAP(NN)=IMAP(N)
|
||
|
|
val(nn)=val(n)
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
NVERT=NN
|
||
|
|
! WRITE(185,*) 'NEW NVERT',NVERT
|
||
|
|
|
||
|
|
|
||
|
|
call WcursorShape(CurHourGlass)
|
||
|
|
CALL DELAUNAY(NVERT)
|
||
|
|
call WcursorShape(CurArrow)
|
||
|
|
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
! Last change: IPK 2 Feb 2003 6:25 pm
|
||
|
|
SUBROUTINE DELAUNAY(NVERT)
|
||
|
|
|
||
|
|
USE BLKMAP
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
CHARACTER*80 LIND
|
||
|
|
CHARACTER*1 ANS
|
||
|
|
DATA VDX9/-9.E9/,NEDGE/0/
|
||
|
|
|
||
|
|
! Get location of supertriangle
|
||
|
|
|
||
|
|
iprt=0
|
||
|
|
ngap=0
|
||
|
|
YLV=7.5
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
call supert(XMAP,YMAP,NVERT)
|
||
|
|
|
||
|
|
NELTS=1
|
||
|
|
|
||
|
|
NVERTM=NVERT-3
|
||
|
|
IF(NVERT .GT. MAXP) THEN
|
||
|
|
DEALLOCATE (NKEY)
|
||
|
|
ALLOCATE (NKEY(NVERT))
|
||
|
|
NKEY=0
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
! Sort points into ascending x order
|
||
|
|
|
||
|
|
CALL SORTDB(XMAP,NKEY,NVERTM)
|
||
|
|
|
||
|
|
! Loop on the vertices
|
||
|
|
|
||
|
|
DO NN=1,NVERT-3
|
||
|
|
|
||
|
|
! IF(MOD(NN,5) .EQ. 0) WRITE(185,*) 'LOOP',NN
|
||
|
|
if(mod(NN,2500) .eq. 0) then
|
||
|
|
WRITE(90,*) NN,' points processed'
|
||
|
|
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(IMAP(N) .EQ. 0) GO TO 500
|
||
|
|
IF(XMAP(N) .LT. VDX9) GO TO 500
|
||
|
|
IF(VAL(N) .LT. -9000.) GO TO 500
|
||
|
|
! IF(NN .GT. 1700. .AND. MOD(NN,5) .EQ. 0) WRITE(185,*) 'N',N,IMAP(N),XMAP(N),VAL(N)
|
||
|
|
|
||
|
|
! WRITE(45,*) NN,N,NVERT,XMAP(N),YMAP(N)
|
||
|
|
IF(NN .LT. NVERTM) THEN
|
||
|
|
DO KK=NN+1,NVERTM
|
||
|
|
K=NKEY(KK)
|
||
|
|
! IF(NN .GT. 1700) WRITE(185,*) 'NKEY',K,KK
|
||
|
|
|
||
|
|
IF(K .NE. 0) THEN
|
||
|
|
IF(XMAP(N) .EQ. XMAP(K)) THEN
|
||
|
|
IF(YMAP(N) .EQ. YMAP(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(NN .GT. 1700 .AND. MOD(NN,5) .EQ. 0) WRITE(185,*) 'AFTER 200 NEDGE',NEDGE
|
||
|
|
|
||
|
|
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(XMAP,YMAP,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
|
||
|
|
CALL FORMT(XMAP,YMAP,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,XMAP(j),YMAP(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
|
||
|
|
|
||
|
|
SUBROUTINE TRIANOPT(NINTV,SPAC)
|
||
|
|
|
||
|
|
USE WINTERACTER
|
||
|
|
include 'd.inc'
|
||
|
|
|
||
|
|
!
|
||
|
|
! Declare window-type and message variables
|
||
|
|
!
|
||
|
|
TYPE(WIN_STYLE) :: WINDOW
|
||
|
|
|
||
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
||
|
|
|
||
|
|
INTEGER :: NINTV
|
||
|
|
INTEGER :: IERR
|
||
|
|
REAL :: SPAC
|
||
|
|
CHARACTER*1 :: IFLAG
|
||
|
|
|
||
|
|
call wdialogload(IDD_TRIAN)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogSelect(IDD_TRIAN)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogPutInteger(IDF_INTEGER1,NINTV)
|
||
|
|
CALL WDialogPutReal(IDF_REAL1,SPAC)
|
||
|
|
|
||
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
do
|
||
|
|
!
|
||
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||
|
|
|
||
|
|
|
||
|
|
CALL WDialogGetINTEGER(IDF_INTEGER1,NINTV)
|
||
|
|
IF(NINTV .EQ. 0) NINTV=1
|
||
|
|
CALL WDialogGetREAL(IDF_REAL1,SPAC)
|
||
|
|
ELSE
|
||
|
|
SPAC=0.0
|
||
|
|
NINTV=1
|
||
|
|
ENDIF
|
||
|
|
RETURN
|
||
|
|
enddo
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|