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.
452 lines
16 KiB
Fortran
452 lines
16 KiB
Fortran
SUBROUTINE SUPERT(XPT,YPT,NVERT)
|
|
|
|
USE BLKMAP
|
|
! INCLUDE 'BLK1.COM'
|
|
REAL*8 XPT(*),YPT(*)
|
|
|
|
REAL*8 XMINM,YMINM,X45
|
|
DATA VDX9/-9.E9/
|
|
! Find minimum x and y
|
|
xminm=1.e20
|
|
yminm=1.e20
|
|
x45=-1.e20
|
|
DO J=1,NVERT
|
|
IF(XPT(J) .GT. VDX9) THEN
|
|
if(xminm .GT. XPT(j) ) then
|
|
xminm=XPT(j)
|
|
end if
|
|
IF(yminm .GT. YPT(j)) then
|
|
yminm=YPT(j)
|
|
endif
|
|
ENDIF
|
|
ENDDO
|
|
! Find max at 45 degrees
|
|
DO J=1,NVERT
|
|
IF(XPT(J) .GT. VDX9) THEN
|
|
X45T=((XPT(J)-XMINM)+(YPT(J)-YMINM))/1.414
|
|
IF(x45 .LT. X45T) THEN
|
|
X45=X45T
|
|
ENDIF
|
|
ENDIF
|
|
END DO
|
|
XPT(NVERT+1)=XMINM-5
|
|
YPT(NVERT+1)=YMINM-5.
|
|
XPT(NVERT+2)=XMINM+1.414*X45+10.
|
|
YPT(NVERT+2)=YMINM-5.
|
|
XPT(NVERT+3)=XMINM-5.
|
|
YPT(NVERT+3)=YMINM+1.414*X45+10.
|
|
NELT=1
|
|
NOPEL(1,1)=NVERT+1
|
|
NOPEL(1,2)=NVERT+2
|
|
NOPEL(1,3)=NVERT+3
|
|
NVERT=NVERT+3
|
|
CALL CCENTRE(XPT(NOPEL(1,1)),XPT(NOPEL(1,2)),XPT(NOPEL(1,3)) &
|
|
&,YPT(NOPEL(1,1)),YPT(NOPEL(1,2)),YPT(NOPEL(1,3)) &
|
|
&,XCEN(1),YCEN(1),RADS(1))
|
|
RETURN
|
|
END SUBROUTINE
|
|
|
|
SUBROUTINE INSIDCIRC(XPT,YPT,J,N,ISWT)
|
|
|
|
! Test for point inside circumcircle
|
|
|
|
USE BLKMAP
|
|
! INCLUDE 'BLK1.COM'
|
|
|
|
REAL*8 XPT(*),YPT(*)
|
|
REAL*8 DISQ
|
|
|
|
! Get the distance for this element
|
|
|
|
DISQ=(XCEN(J)-XPT(N))**2+(YCEN(J)-YPT(N))**2
|
|
|
|
! Test against the radius
|
|
|
|
IF(DISQ .GT. RADS(J)*RADS(J)) THEN
|
|
ISWT=0
|
|
ELSE
|
|
ISWT=1
|
|
ENDIF
|
|
RETURN
|
|
END SUBROUTINE
|
|
|
|
SUBROUTINE PROCESS(J,NEDGE,NGAP)
|
|
|
|
! Drop triangle and form edge buffers
|
|
|
|
USE BLKMAP
|
|
USE BLK1MOD
|
|
! INCLUDE 'BLK1.COM'
|
|
|
|
NEDGE=NEDGE+3
|
|
IEDGE(NEDGE-2,1)=NOPEL(J,1)
|
|
IEDGE(NEDGE-1,1)=NOPEL(J,2)
|
|
IEDGE(NEDGE,1) =NOPEL(J,3)
|
|
IEDGE(NEDGE-2,2)=NOPEL(J,2)
|
|
IEDGE(NEDGE-1,2)=NOPEL(J,3)
|
|
IEDGE(NEDGE,2) =NOPEL(J,1)
|
|
NOPEL(J,1)=0
|
|
NOPEL(J,2)=0
|
|
NOPEL(J,3)=0
|
|
NGAP=NGAP+1
|
|
IGAP(NGAP)=J
|
|
RETURN
|
|
END SUBROUTINE
|
|
|
|
SUBROUTINE FORMT(XPT,YPT,J,N,NGAP,K,WD)
|
|
|
|
! Form the triangle
|
|
|
|
USE BLKMAP
|
|
|
|
REAL*8 XPT(*),YPT(*)
|
|
REAL WD(*)
|
|
! INCLUDE 'BLK1.COM'
|
|
|
|
IF(NGAP .GT. 0) THEN
|
|
K=IGAP(NGAP)
|
|
NGAP=NGAP-1
|
|
ELSE
|
|
NELTS=NELTS+1
|
|
K=NELTS
|
|
ENDIF
|
|
NOPEL(K,1)=IEDGE(J,1)
|
|
NOPEL(K,2)=IEDGE(J,2)
|
|
NOPEL(K,3)=N
|
|
|
|
CALL TESTANG(XPT,YPT,K,WD)
|
|
|
|
! Now get circumcircle data
|
|
|
|
CALL CCENTRE(XPT(NOPEL(K,1)),XPT(NOPEL(K,2)),XPT(NOPEL(K,3)) &
|
|
&,YPT(NOPEL(K,1)),YPT(NOPEL(K,2)),YPT(NOPEL(K,3)) &
|
|
&,XCEN(K),YCEN(K),RADS(K))
|
|
RETURN
|
|
END SUBROUTINE
|
|
|
|
SUBROUTINE CCENTRE(X1,X2,X3,Y1,Y2,Y3,XC,YC,RC)
|
|
|
|
! get circumcentre and radius
|
|
|
|
REAL*8 X1,Y1,X2,Y2,X3,Y3,A,B,C,D,AF,R1,R2,RC,XC,YC
|
|
A=X2-X1
|
|
B=Y2-Y1
|
|
C=X3-X1
|
|
D=Y3-Y1
|
|
AF=2.*(B*C-A*D)
|
|
R1=(-D*(A**2+B**2) + B*(C**2+D**2))/AF
|
|
R2=( C*(A**2+B**2) - A*(C**2+D**2))/AF
|
|
RC=SQRT(R1**2+R2**2)
|
|
XC=X1+R1
|
|
YC=Y1+R2
|
|
RETURN
|
|
END SUBROUTINE
|
|
|
|
SUBROUTINE RIDPOINT(NVERT)
|
|
|
|
USE BLKMAP
|
|
|
|
NCOUNT=0
|
|
DO N=1,NELTS
|
|
DO K=1,3
|
|
IF(NOPEL(N,K) .GT. NVERT-3) THEN
|
|
DO L=1,3
|
|
NOPEL(N,L)=0
|
|
ENDDO
|
|
GO TO 500
|
|
ENDIF
|
|
ENDDO
|
|
NCOUNT=NCOUNT+1
|
|
DO K=1,3
|
|
NOPEL(NCOUNT,K)=NOPEL(N,K)
|
|
ENDDO
|
|
XCEN(NCOUNT)=XCEN(N)
|
|
YCEN(NCOUNT)=YCEN(N)
|
|
RADS(NCOUNT)=RADS(N)
|
|
500 CONTINUE
|
|
ENDDO
|
|
NELTS=NCOUNT
|
|
RETURN
|
|
END
|
|
|
|
SUBROUTINE SORTDB(A,NKEY,N)
|
|
!*********************************** .....SORT.....
|
|
!-
|
|
!......SORT IS A SIMPLE SHELL SORT ROUTINE IN DOUBLE PRECISION
|
|
!-
|
|
! SHELL SORT
|
|
SAVE
|
|
!
|
|
!IPK JAN94 INTEGER*2 NKEY
|
|
REAL*8 A(*)
|
|
INTEGER NKEY(*)
|
|
|
|
IF(N.LT.2) RETURN
|
|
DO 90 J=1,N
|
|
NKEY(J)=J
|
|
90 END DO
|
|
ID = N
|
|
100 ID = ID / 2
|
|
110 IB = 1
|
|
120 GO TO 200
|
|
130 IB = IB + 1
|
|
IF( IB .LE. ID ) GO TO 200
|
|
IF( ID .GT. 1 ) GO TO 100
|
|
RETURN
|
|
200 I = IB
|
|
210 K = I + ID
|
|
220 IF( A(NKEY(I)) .LE. A(NKEY(K)) ) GO TO 250
|
|
NKT = NKEY(K)
|
|
NKEY(K) = NKEY(I)
|
|
J = I
|
|
230 K = J - ID
|
|
IF( K .LT. 1 ) GO TO 240
|
|
IF( A(NKT) .GT. A(NKEY(K)) ) GO TO 240
|
|
NKEY(J) = NKEY(K)
|
|
J = K
|
|
GO TO 230
|
|
240 NKEY(J) = NKT
|
|
250 I = I + ID
|
|
IF( I + ID .LE. N ) GO TO 210
|
|
GO TO 130
|
|
END
|
|
|
|
SUBROUTINE SETEDG(NEDGE)
|
|
|
|
USE BLKMAP
|
|
|
|
! Setup to form new triangles
|
|
|
|
DO J=1,NEDGE
|
|
IF(J .LT. NEDGE) THEN
|
|
DO K=J+1,NEDGE
|
|
IF(IEDGE(K,1) .EQ. IEDGE(J,1)) THEN
|
|
IF(IEDGE(K,2) .EQ. IEDGE(J,2)) THEN
|
|
IEDGE(J,1)=0
|
|
IEDGE(J,2)=0
|
|
IEDGE(K,1)=0
|
|
IEDGE(K,2)=0
|
|
ENDIF
|
|
ELSEIF(IEDGE(K,1) .EQ. IEDGE(J,2)) THEN
|
|
IF(IEDGE(K,2) .EQ. IEDGE(J,1)) THEN
|
|
IEDGE(J,1)=0
|
|
IEDGE(J,2)=0
|
|
IEDGE(K,1)=0
|
|
IEDGE(K,2)=0
|
|
ENDIF
|
|
ENDIF
|
|
ENDDO
|
|
ENDIF
|
|
ENDDO
|
|
|
|
RETURN
|
|
END
|
|
|
|
SUBROUTINE TESTANG(XPT,YPT,K,WD)
|
|
|
|
USE BLKMAP
|
|
REAL*8 XPT(*),YPT(*)
|
|
REAL WD(*)
|
|
DATA PI/3.14159/
|
|
|
|
! IF(WD(NOPEL(K,1)) .EQ. WD(NOPEL(K,2)) .and. wd(nopel(k,1)) .gt. -9990. ) THEN
|
|
! RETURN
|
|
! ENDIF
|
|
!
|
|
IFD=0
|
|
DO N=1,NELTS
|
|
IF(N .NE. K) THEN
|
|
DO J=1,3
|
|
IF(NOPEL(K,1) .EQ. NOPEL(N,J)) THEN
|
|
IF(J .GT. 1) THEN
|
|
IF(NOPEL(K,2) .EQ. NOPEL(N,J-1)) THEN
|
|
IFD=N
|
|
ISIDE=J
|
|
GO TO 400
|
|
ENDIF
|
|
ELSE
|
|
IF(NOPEL(K,2) .EQ. NOPEL(N,3)) THEN
|
|
IFD=N
|
|
ISIDE=J
|
|
GO TO 400
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
ENDDO
|
|
ENDIF
|
|
ENDDO
|
|
RETURN
|
|
400 CONTINUE
|
|
|
|
J1=ISIDE+1
|
|
IF(J1 .GT. 3) J1=1
|
|
!
|
|
! IF(WD(NOPEL(K,3)) .EQ. WD(NOPEL(IFD,J1)) .and. wd(nopel(k,1)) .gt. -9990. ) THEN
|
|
! WRITE(148,'(12I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3)
|
|
! IF(NELTS .GT. 20) WRITE(148,'(12I8)') NOPEL(21,1),NOPEL(21,2),NOPEL(21,3)
|
|
! NOPEL(IFD,1)=NOPEL(K,3)
|
|
! NOPEL(IFD,2)=NOPEL(K,1)
|
|
! NOPEL(IFD,3)=NOPEL(IFD,J1)
|
|
! NOPEL(K,1)=NOPEL(IFD,3)
|
|
!
|
|
! WRITE(148,'(12I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3)
|
|
! IF(NELTS .GT. 20) WRITE(148,'(12I8)') NOPEL(21,1),NOPEL(21,2),NOPEL(21,3)
|
|
!
|
|
! CALL CCENTRE(XPT(NOPEL(IFD,1)),XPT(NOPEL(IFD,2)),XPT(NOPEL(IFD,3)) &
|
|
!& ,YPT(NOPEL(IFD,1)),YPT(NOPEL(IFD,2)),YPT(NOPEL(IFD,3)) &
|
|
!& ,XCEN(IFD),YCEN(IFD),RADS(K))
|
|
! CALL CCENTRE(XPT(NOPEL(K,1)),XPT(NOPEL(K,2)),XPT(NOPEL(K,3)) &
|
|
!& ,YPT(NOPEL(K,1)),YPT(NOPEL(K,2)),YPT(NOPEL(K,3)) &
|
|
!& ,XCEN(K),YCEN(K),RADS(K))
|
|
!
|
|
! RETURN
|
|
! ENDIF
|
|
A1=ATAN2(YPT(NOPEL(K,1))-YPT(NOPEL(K,3)),XPT(NOPEL(K,1))-XPT(NOPEL(K,3)))
|
|
A2=ATAN2(YPT(NOPEL(K,2))-YPT(NOPEL(K,3)),XPT(NOPEL(K,2))-XPT(NOPEL(K,3)))
|
|
IF(A1 .LT. 0) A1=A1+2.*PI
|
|
IF(A2 .LT. 0) A2=A2+2.*PI
|
|
DIFFA=A2-A1
|
|
! WRITE(148,*) 'DIFFA',K,DIFFA,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3)
|
|
IF(DIFFA .LT. 0) DIFFA=DIFFA+PI*2.
|
|
IF(DIFFA .LT. 2./3.*PI) RETURN
|
|
|
|
! WRITE(148,'(9I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3)
|
|
|
|
B1=ATAN2(YPT(NOPEL(IFD,J1))-YPT(NOPEL(K,2)),XPT(NOPEL(IFD,J1))-XPT(NOPEL(K,2)))
|
|
B2=ATAN2(YPT(NOPEL(K, 3))-YPT(NOPEL(K,2)),XPT(NOPEL(K, 3))-XPT(NOPEL(K,2)))
|
|
IF(B1 .LT. 0) B1=B1+2.*PI
|
|
IF(B2 .LT. 0) B2=B2+2.*PI
|
|
|
|
DIFFB=B2-B1
|
|
|
|
! WRITE(148,*) 'DIFFB',DIFFB,B2,B1
|
|
IF(DIFFB .LT. 0) DIFFB=DIFFB+2.*PI
|
|
IF(DIFFB .GT. DIFFA) RETURN
|
|
|
|
C1=ATAN2(YPT(NOPEL(K, 3))-YPT(NOPEL(K,1)),XPT(NOPEL(K, 3))-XPT(NOPEL(K,1)))
|
|
C2=ATAN2(YPT(NOPEL(IFD,J1))-YPT(NOPEL(K,1)),XPT(NOPEL(IFD,J1))-XPT(NOPEL(K,1)))
|
|
IF(C1 .LT. 0) C1=C1+2.*PI
|
|
IF(C2 .LT. 0) C2=C2+2.*PI
|
|
|
|
DIFFC=C2-C1
|
|
! WRITE(148,*) 'DIFFC',DIFFC,C2,C1
|
|
IF(DIFFC .LT. 0) DIFFC=DIFFC+2.*PI
|
|
IF(DIFFC .GT. DIFFA) RETURN
|
|
|
|
NOPEL(IFD,1)=NOPEL(K,3)
|
|
NOPEL(IFD,2)=NOPEL(K,1)
|
|
NOPEL(IFD,3)=NOPEL(IFD,J1)
|
|
NOPEL(K,1)=NOPEL(IFD,3)
|
|
|
|
! WRITE(148,'(9I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3)
|
|
|
|
CALL CCENTRE(XPT(NOPEL(IFD,1)),XPT(NOPEL(IFD,2)),XPT(NOPEL(IFD,3)) &
|
|
&,YPT(NOPEL(IFD,1)),YPT(NOPEL(IFD,2)),YPT(NOPEL(IFD,3)) &
|
|
&,XCEN(IFD),YCEN(IFD),RADS(IFD))
|
|
|
|
RETURN
|
|
END
|
|
|
|
|
|
SUBROUTINE TESTTR(XPT,YPT,K,WD)
|
|
|
|
USE BLKMAP
|
|
REAL WD(*)
|
|
REAL*8 XPT(*),YPT(*)
|
|
DATA PI/3.14159/
|
|
|
|
IF(WD(NOPEL(K,1)) .EQ. WD(NOPEL(K,2)) .and. wd(nopel(k,1)) .gt. -9990. ) THEN
|
|
RETURN
|
|
ENDIF
|
|
|
|
|
|
IFD=0
|
|
DO N=1,NELTS
|
|
IF(N .NE. K) THEN
|
|
DO J=1,3
|
|
IF(NOPEL(K,2) .EQ. NOPEL(N,J)) THEN
|
|
IF(J .GT. 1) THEN
|
|
IF(NOPEL(K,3) .EQ. NOPEL(N,J-1)) THEN
|
|
IFD=N
|
|
ISIDE=J
|
|
GO TO 400
|
|
ENDIF
|
|
ELSE
|
|
IF(NOPEL(K,3) .EQ. NOPEL(N,3)) THEN
|
|
IFD=N
|
|
ISIDE=J
|
|
GO TO 400
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
ENDDO
|
|
ENDIF
|
|
ENDDO
|
|
RETURN
|
|
400 CONTINUE
|
|
|
|
WRITE(148,'(9I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3)
|
|
write(148,'(9x,6f8.0)')wd(NOPEL(K,1)),wd(NOPEL(K,2)),wd(NOPEL(K,3)),wd(NOPEL(IFD,1)),wd(NOPEL(IFD,2)),wd(NOPEL(IFD,3))
|
|
J1=ISIDE+1
|
|
IF(J1 .GT. 3) J1=1
|
|
WRITE(148,*) J1
|
|
|
|
IF(WD(NOPEL(K,1)) .EQ. WD(NOPEL(IFD,J1)) .and. wd(nopel(k,1)) .gt. -9990. ) THEN
|
|
ITEMP=NOPEL(IFD,J1)
|
|
NOPEL(IFD,1)=NOPEL(K,3)
|
|
NOPEL(IFD,2)=NOPEL(K,1)
|
|
NOPEL(IFD,3)=ITEMP
|
|
NOPEL(K,1)=NOPEL(IFD,3)
|
|
|
|
WRITE(148,'(9I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3)
|
|
|
|
CALL CCENTRE(XPT(NOPEL(IFD,1)),XPT(NOPEL(IFD,2)),XPT(NOPEL(IFD,3)) &
|
|
& ,YPT(NOPEL(IFD,1)),YPT(NOPEL(IFD,2)),YPT(NOPEL(IFD,3)) &
|
|
& ,XCEN(IFD),YCEN(IFD),RADS(IFD))
|
|
|
|
RETURN
|
|
ENDIF
|
|
A1=ATAN2(YPT(NOPEL(K,2))-YPT(NOPEL(K,1)),XPT(NOPEL(K,2))-XPT(NOPEL(K,1)))
|
|
A2=ATAN2(YPT(NOPEL(K,3))-YPT(NOPEL(K,1)),XPT(NOPEL(K,3))-XPT(NOPEL(K,1)))
|
|
IF(A1 .LT. 0) A1=A1+2.*PI
|
|
IF(A2 .LT. 0) A2=A2+2.*PI
|
|
DIFFA=A2-A1
|
|
! WRITE(148,*) 'DIFFA',K,DIFFA,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3)
|
|
IF(DIFFA .LT. 0) DIFFA=DIFFA+PI*2.
|
|
IF(DIFFA .LT. 2./3.*PI) RETURN
|
|
|
|
B1=ATAN2(YPT(NOPEL(IFD,J1))-YPT(NOPEL(K,3)),XPT(NOPEL(IFD,J1))-XPT(NOPEL(K,3)))
|
|
B2=ATAN2(YPT(NOPEL(K, 1))-YPT(NOPEL(K,3)),XPT(NOPEL(K, 1))-XPT(NOPEL(K,3)))
|
|
IF(B1 .LT. 0) B1=B1+2.*PI
|
|
IF(B2 .LT. 0) B2=B2+2.*PI
|
|
|
|
DIFFB=B2-B1
|
|
|
|
! WRITE(148,*) 'DIFFB',DIFFB,B2,B1
|
|
IF(DIFFB .LT. 0) DIFFB=DIFFB+2.*PI
|
|
IF(DIFFB .GT. DIFFA) RETURN
|
|
|
|
C1=ATAN2(YPT(NOPEL(K, 1))-YPT(NOPEL(K,2)),XPT(NOPEL(K, 1))-XPT(NOPEL(K,2)))
|
|
C2=ATAN2(YPT(NOPEL(IFD,J1))-YPT(NOPEL(K,2)),XPT(NOPEL(IFD,J1))-XPT(NOPEL(K,2)))
|
|
IF(C1 .LT. 0) C1=C1+2.*PI
|
|
IF(C2 .LT. 0) C2=C2+2.*PI
|
|
|
|
DIFFC=C2-C1
|
|
! WRITE(148,*) 'DIFFC',DIFFC,C2,C1
|
|
IF(DIFFC .LT. 0) DIFFC=DIFFC+2.*PI
|
|
IF(DIFFC .GT. DIFFA) RETURN
|
|
ITEMP=NOPEL(IFD,J1)
|
|
NOPEL(IFD,1)=NOPEL(K,1)
|
|
NOPEL(IFD,2)=NOPEL(K,2)
|
|
NOPEL(IFD,3)=ITEMP
|
|
NOPEL(K,2)=NOPEL(IFD,3)
|
|
|
|
! WRITE(148,'(9I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3)
|
|
|
|
CALL CCENTRE(XPT(NOPEL(IFD,1)),XPT(NOPEL(IFD,2)),XPT(NOPEL(IFD,3)) &
|
|
&,YPT(NOPEL(IFD,1)),YPT(NOPEL(IFD,2)),YPT(NOPEL(IFD,3)) &
|
|
&,XCEN(IFD),YCEN(IFD),RADS(IFD))
|
|
|
|
RETURN
|
|
END
|