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