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.
110 lines
2.4 KiB
Fortran
110 lines
2.4 KiB
Fortran
5 years ago
|
SUBROUTINE REATTACH
|
||
|
|
|
||
|
|
|
||
|
|
USE BLK1MOD
|
||
|
|
USE BLK2MOD
|
||
|
|
|
||
|
|
INTEGER NS1(3,4),NT1(3,4)
|
||
|
|
CHARACTER*1 IFLAG,ANSW(10)
|
||
|
|
DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
||
|
|
|
||
|
|
! SETUP CONNECTIVITY TABLE
|
||
|
|
CALL KCON(0)
|
||
|
|
! SELECT FIRST ELEMENT
|
||
|
|
10 CONTINUE
|
||
|
|
NHTPSV=NHTP
|
||
|
|
NMESSSV=NMESS
|
||
|
|
NBRRSV=NBRR
|
||
|
|
NHTP=0
|
||
|
|
NMESS=20
|
||
|
|
NBRR=8
|
||
|
|
CALL HEDR
|
||
|
|
|
||
|
|
CALL PROX(XC,YC,NE,XX,YY,IELEM,IFLAG,IESKP,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) THEN
|
||
|
|
NHTP=NHTPSV
|
||
|
|
NMESS=NMESSSV
|
||
|
|
NBRR=NBRRSV
|
||
|
|
CALL HEDR
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||
|
|
IFLAG=ANSW(IBOX)
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
IF(IFLAG .EQ. 'q') THEN
|
||
|
|
NHTP=NHTPSV
|
||
|
|
NMESS=NMESSSV
|
||
|
|
NBRR=NBRRSV
|
||
|
|
CALL HEDR
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
call fillem(ielem)
|
||
|
|
! GET UNATTACHED NOP
|
||
|
|
kk=0
|
||
|
|
DO K=2,NCORN(IELEM),2
|
||
|
|
NSX=NOP(IELEM,K)
|
||
|
|
IF(NDELM(NSX) .EQ. 1) THEN
|
||
|
|
! FOUND IT
|
||
|
|
KK=KK+1
|
||
|
|
NS1(1,KK)=NOP(IELEM,K-1)
|
||
|
|
NS1(2,KK)=NSX
|
||
|
|
KKK=MOD(K,NCORN(IELEM))+1
|
||
|
|
NS1(3,KK)=NOP(IELEM,KKK)
|
||
|
|
! GO TO 280
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
280 CONTINUE
|
||
|
|
|
||
|
|
|
||
|
|
! SELECT NEXT ELEMENT
|
||
|
|
|
||
|
|
CALL PROX(XC,YC,NE,XX,YY,IELEM1,IFLAG,IESKP,IBOX)
|
||
|
|
call fillem(ielem1)
|
||
|
|
|
||
|
|
! GET UNNATCHED SIDE
|
||
|
|
! FIND AN UNATTACHED SIDE (INDICATE OF TRIANGLE OR QUADRILATERAL)
|
||
|
|
LL=0
|
||
|
|
DO K=2,NCORN(IELEM1),2
|
||
|
|
NSX=NOP(IELEM1,K)
|
||
|
|
IF(NDELM(NSX) .EQ. 1) THEN
|
||
|
|
! FOUND IT
|
||
|
|
LL=LL+1
|
||
|
|
NT1(1,LL)=NOP(IELEM1,K-1)
|
||
|
|
NT1(2,LL)=NSX
|
||
|
|
KKK=MOD(K,NCORN(IELEM1))+1
|
||
|
|
NT1(3,LL)=NOP(IELEM1,KKK)
|
||
|
|
! GO TO 300
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
300 CONTINUE
|
||
|
|
|
||
|
|
! FORM A NEW ELEMENT ASSIGN TYPE AS INDICATED
|
||
|
|
! GET THE NEAREST TWO FACES
|
||
|
|
DISTKP=1.E20
|
||
|
|
DO NN=1,KK
|
||
|
|
DO MM=1,LL
|
||
|
|
DIST=(XUSR(NS1(2,NN))-XUSR(NT1(2,MM)))**2+(YUSR(NS1(2,NN))-YUSR(NT1(2,MM)))**2
|
||
|
|
IF(DIST .LT. DISTKP) THEN
|
||
|
|
NNN=NN
|
||
|
|
MMM=MM
|
||
|
|
DISTKP=DIST
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
ENDDO
|
||
|
|
CALL GETELM(J)
|
||
|
|
DO K=1,3
|
||
|
|
NOP(J,K)=NS1(K,NNN)
|
||
|
|
NOP(J,K+4)=NT1(K,MMM)
|
||
|
|
ENDDO
|
||
|
|
NOP(J,4)=0
|
||
|
|
NOP(J,8)=0
|
||
|
|
IMAT(J)=1
|
||
|
|
IESKP(J) = 0
|
||
|
|
NCORN(J)=8
|
||
|
|
|
||
|
|
! GO BACK TO LOOK FOR NEW PAIR
|
||
|
|
CALL PLOTOT(1)
|
||
|
|
GO TO 10
|
||
|
|
RETURN
|
||
|
|
END
|