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
10 KiB
Fortran
452 lines
10 KiB
Fortran
5 years ago
|
!IPK LAST UPDATE SEP 23 2015 ADD OPTION FOR JOINING ELEMENTS
|
||
|
|
subroutine joinel
|
||
|
|
|
||
|
|
USE BLK1MOD
|
||
|
|
USE BLK2MOD
|
||
|
|
use blkmap
|
||
|
|
INTEGER LIST1(1000),LIST2(1000),idel(1000)
|
||
|
|
real xmapt(1000),ymapt(1000)
|
||
|
|
|
||
|
|
|
||
|
|
CHARACTER*1 IFLAG,ANSW(10)
|
||
|
|
CHARACTER*60 STRELS
|
||
|
|
DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
||
|
|
|
||
|
|
|
||
|
|
DATA STRELS/' You have tried to join before executing "FILL"'/
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! Test to make sure fill has been executed.
|
||
|
|
!
|
||
|
|
DO N=1,NE
|
||
|
|
IF(IMAT(N) .GT. 0) THEN
|
||
|
|
DO M=2,NCORN(N),2
|
||
|
|
!ipkoct93
|
||
|
|
if(imat(n) .LT. 900) THEN
|
||
|
|
IF(NOP(N,M) .EQ. 0) THEN
|
||
|
|
CALL SYMBL(0.,7.30,0.20,STRELS,0.,60)
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
! Initiliaze list etc
|
||
|
|
|
||
|
|
NHTPSV=NHTP
|
||
|
|
NMESSSV=NMESS
|
||
|
|
NBRRSV=NBRR
|
||
|
|
|
||
|
|
! get starting elements
|
||
|
|
CALL KCON(0)
|
||
|
|
DO N=1,NE
|
||
|
|
DO M=1,8
|
||
|
|
NOPSV(N,M)=NOP(N,M)
|
||
|
|
ENDDO
|
||
|
|
IMATSV(N)=IMAT(N)
|
||
|
|
ENDDO
|
||
|
|
NESAV=NE
|
||
|
|
NEFSAV=NENTRY
|
||
|
|
NPUNDO=0
|
||
|
|
list1=0
|
||
|
|
list2=0
|
||
|
|
! SELECT FIRST ELEMENT
|
||
|
|
10 CONTINUE
|
||
|
|
CALL PANELTYP(NMTYP)
|
||
|
|
NHTP=0
|
||
|
|
NMESS=20
|
||
|
|
NBRR=8
|
||
|
|
CALL HEDR
|
||
|
|
|
||
|
|
CALL PROX(XC,YC,NE,XX,YY,NEL1,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
|
||
|
|
CALL fillem(NEL1)
|
||
|
|
!
|
||
|
|
IF(IFLAG .EQ. 'q') THEN
|
||
|
|
NHTP=NHTPSV
|
||
|
|
NMESS=NMESSSV
|
||
|
|
NBRR=NBRRSV
|
||
|
|
|
||
|
|
CALL HEDR
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
CALL PROX(XC,YC,NE,XX,YY,NEL2,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(NEL1)
|
||
|
|
CALL fillem(NEL2)
|
||
|
|
|
||
|
|
CALL PROX(XC,YC,NE,XX,YY,NEL3,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(NEL1)
|
||
|
|
CALL fillem(NEL2)
|
||
|
|
CALL fillem(NEL3)
|
||
|
|
CALL PROX(XC,YC,NE,XX,YY,NEL4,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(NEL1)
|
||
|
|
CALL fillem(NEL2)
|
||
|
|
CALL fillem(NEL3)
|
||
|
|
CALL fillem(NEL4)
|
||
|
|
|
||
|
|
! work on first pair
|
||
|
|
! get starting mid-side
|
||
|
|
ilc=0
|
||
|
|
call findbcel(nel1,nd1,nd2,nd3,ierr,ilc)
|
||
|
|
! save back node
|
||
|
|
list1(1)=nd1
|
||
|
|
write(90,*) '1',nd1
|
||
|
|
|
||
|
|
! get adjacent corner save corner
|
||
|
|
m=2
|
||
|
|
list1(m)=nd3
|
||
|
|
write(90,*) m,nd3
|
||
|
|
nelc=nel1
|
||
|
|
nelcsv=nel1
|
||
|
|
! start looop
|
||
|
|
do nss=1,1000
|
||
|
|
! find next element and get mid side
|
||
|
|
nadj=ndelm(nd3)
|
||
|
|
do kkk=1,nadj
|
||
|
|
nd3=list1(m)
|
||
|
|
nelc=nelcsv
|
||
|
|
if(necon(nd3,kkk) .ne. nelc) then
|
||
|
|
nelc=necon(nd3,kkk)
|
||
|
|
ilc=2
|
||
|
|
call findbcel(nelc,nd1,nd2,nd3,ierr,ilc)
|
||
|
|
if(ierr .eq. 0) go to 200
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
200 continue
|
||
|
|
nelcsv=nelc
|
||
|
|
! get and save next corner
|
||
|
|
m=m+1
|
||
|
|
if(m .gt. 1000) THEN
|
||
|
|
NHTP=NHTPSV
|
||
|
|
NMESS=NMESSSV
|
||
|
|
NBRR=NBRRSV
|
||
|
|
|
||
|
|
CALL HEDR
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
list1(m)=nd3
|
||
|
|
write(90,*) m,nd3
|
||
|
|
! test for last element
|
||
|
|
if(nelc .eq. nel2) go to 250
|
||
|
|
enddo
|
||
|
|
250 continue
|
||
|
|
m1=m
|
||
|
|
|
||
|
|
! repeat for second pair
|
||
|
|
! get starting mid-side
|
||
|
|
ilc=1
|
||
|
|
call findbcel(nel3,nd1,nd2,nd3,ierr,ilc)
|
||
|
|
! save back node
|
||
|
|
list2(1)=nd1
|
||
|
|
write(90,*) m,nd1
|
||
|
|
|
||
|
|
! get adjacent corner save corner
|
||
|
|
m=2
|
||
|
|
list2(m)=nd3
|
||
|
|
write(90,*) m,nd3
|
||
|
|
nelc=nel3
|
||
|
|
nelcsv=nel3
|
||
|
|
! start looop
|
||
|
|
do nss=1,1000
|
||
|
|
! find next element and get mid side
|
||
|
|
nadj=ndelm(nd3)
|
||
|
|
do kkk=1,nadj
|
||
|
|
nd3=list2(m)
|
||
|
|
nelc=nelcsv
|
||
|
|
if(necon(nd3,kkk) .ne. nelc) then
|
||
|
|
nelc=necon(nd3,kkk)
|
||
|
|
ilc=2
|
||
|
|
if(nelc .eq. nel4) ilc=4
|
||
|
|
call findbcel(nelc,nd1,nd2,nd3,ierr,ilc)
|
||
|
|
if(ierr .eq. 0) go to 300
|
||
|
|
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
300 continue
|
||
|
|
nelcsv=nelc
|
||
|
|
! get and save next corner
|
||
|
|
m=m+1
|
||
|
|
if(m .gt. 1000) THEN
|
||
|
|
NHTP=NHTPSV
|
||
|
|
NMESS=NMESSSV
|
||
|
|
NBRR=NBRRSV
|
||
|
|
|
||
|
|
CALL HEDR
|
||
|
|
ENDIF
|
||
|
|
list2(m)=nd3
|
||
|
|
write(90,*) m,nd3
|
||
|
|
! test for last element
|
||
|
|
if(nelc .eq. nel4) go to 350
|
||
|
|
enddo
|
||
|
|
350 continue
|
||
|
|
m2=m
|
||
|
|
! add points in triangle list
|
||
|
|
do j=1,m2
|
||
|
|
list1(m1+j)=list2(j)
|
||
|
|
enddo
|
||
|
|
nvert=m1+m2
|
||
|
|
do n=1,nvert
|
||
|
|
write(90,*) n,list1(n)
|
||
|
|
enddo
|
||
|
|
do j=1,nvert
|
||
|
|
xmap(j)=xusr(list1(j))
|
||
|
|
ymap(j)=yusr(list1(j))
|
||
|
|
xmapt(j)=xusr(list1(j))
|
||
|
|
ymapt(j)=yusr(list1(j))
|
||
|
|
imap(j)=1
|
||
|
|
val(j)=1.
|
||
|
|
enddo
|
||
|
|
! call for triangulation
|
||
|
|
|
||
|
|
CALL DELAUNAY(NVERT)
|
||
|
|
|
||
|
|
do n=1,nelts
|
||
|
|
if(nopel(n,1) .le. m1) then
|
||
|
|
if(nopel(n,2) .le. m1 .and. nopel(n,3) .le. m1) then
|
||
|
|
cycle
|
||
|
|
endif
|
||
|
|
else
|
||
|
|
if(nopel(n,2) .gt. m1 .and. nopel(n,3) .gt. m1) then
|
||
|
|
cycle
|
||
|
|
endif
|
||
|
|
500 continue
|
||
|
|
endif
|
||
|
|
! FORM A NEW ELEMENT ASSIGN TYPE AS INDICATED
|
||
|
|
CALL GETELM(J)
|
||
|
|
NOP(J,1)=list1(nopel(n,1))
|
||
|
|
NOP(J,3)=list1(nopel(n,2))
|
||
|
|
NOP(J,5)=list1(nopel(n,3))
|
||
|
|
NOP(J,2)=0
|
||
|
|
NOP(J,4)=0
|
||
|
|
NOP(J,6)=0
|
||
|
|
NOP(J,7)=0
|
||
|
|
NOP(J,8)=0
|
||
|
|
IMAT(J)=NMTYP
|
||
|
|
IESKP(J) = 0
|
||
|
|
NCORN(J)=6
|
||
|
|
enddo
|
||
|
|
CALL PLOTOT(1)
|
||
|
|
NHTP=NHTPSV
|
||
|
|
NMESS=NMESSSV
|
||
|
|
NBRR=NBRRSV
|
||
|
|
|
||
|
|
CALL HEDR
|
||
|
|
return
|
||
|
|
end
|
||
|
|
|
||
|
|
subroutine findbcel(nel,nd1,nd2,nd3,ierr,ilc)
|
||
|
|
use blk1mod
|
||
|
|
USE BLK2MOD
|
||
|
|
integer nel,nd1,nd2,nd3,mlc(5),ndkp
|
||
|
|
ndkp=nd3
|
||
|
|
ierr=0
|
||
|
|
kk=0
|
||
|
|
do k=2,ncorn(nel),2
|
||
|
|
nd2=nop(nel,k)
|
||
|
|
if(ndelm(nd2) .eq. 1) then
|
||
|
|
nd1=nop(nel,k-1)
|
||
|
|
if(nd1 .ne. ndkp .and. ilc .gt. 1) cycle
|
||
|
|
jj=mod(k,ncorn(nel))+1
|
||
|
|
nd3=nop(nel,jj)
|
||
|
|
if(ilc .eq. 4) return
|
||
|
|
if(ilc .gt. 0) then
|
||
|
|
kk=kk+1
|
||
|
|
mlc(kk)=k
|
||
|
|
cycle
|
||
|
|
else
|
||
|
|
! check for more than 1
|
||
|
|
kj=k+2
|
||
|
|
if(kj .gt. ncorn(nel)) kj=2
|
||
|
|
nd2a=nop(nel,kj)
|
||
|
|
if(ndelm(nd2a) .eq. 1) then
|
||
|
|
nd1=nop(nel,kj-1)
|
||
|
|
jj=mod(kj,ncorn(nel))+1
|
||
|
|
nd3=nop(nel,jj)
|
||
|
|
nd2=nd2a
|
||
|
|
endif
|
||
|
|
return
|
||
|
|
endif
|
||
|
|
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
if(ilc .gt. 0) then
|
||
|
|
if(kk .eq. 1) then
|
||
|
|
if(nd1 .eq. ndkp) then
|
||
|
|
return
|
||
|
|
else
|
||
|
|
ierr=1
|
||
|
|
return
|
||
|
|
endif
|
||
|
|
elseif(kk .eq. 2) then
|
||
|
|
if(abs(mlc(2)-mlc(1)) .eq. 4) then
|
||
|
|
do kk=1,2
|
||
|
|
nd1=nop(nel,mlc(kk)-1)
|
||
|
|
if(nd1 .eq. ndkp) then
|
||
|
|
nd2=nop(nel,mlc(kk))
|
||
|
|
nd3=mod(mlc(kk),ncorn(nel))+1
|
||
|
|
nd3=nop(nel,nd3)
|
||
|
|
return
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
endif
|
||
|
|
if(ilc .eq. 1) then
|
||
|
|
if(mlc(kk) .eq. ncorn(nel) .and. mlc(kk-1) .eq. 2) then
|
||
|
|
nd1=nop(nel,1)
|
||
|
|
nd2=nop(nel,2)
|
||
|
|
nd3=nop(nel,3)
|
||
|
|
else
|
||
|
|
return
|
||
|
|
endif
|
||
|
|
else
|
||
|
|
if(mlc(kk) .eq. ncorn(nel) .and. mlc(kk-1) .eq. 2) then
|
||
|
|
return
|
||
|
|
else
|
||
|
|
nd1=nop(nel,mlc(1)-1)
|
||
|
|
nd2=nop(nel,mlc(1))
|
||
|
|
nd3=nop(nel,mlc(1)+1)
|
||
|
|
endif
|
||
|
|
endif
|
||
|
|
elseif(kk .eq. 3) then
|
||
|
|
if(mlc(kk) .eq. ncorn(nel)) then
|
||
|
|
if(mlc(kk-1) .eq. ncorn(nel)-2) then
|
||
|
|
nd1=nop(nel,1)
|
||
|
|
nd2=nop(nel,2)
|
||
|
|
nd3=nop(nel,3)
|
||
|
|
elseif(mlc(kk-1) .eq. ncorn(nel)-4) then
|
||
|
|
nd1=nop(nel,3)
|
||
|
|
nd2=nop(nel,4)
|
||
|
|
nd3=nop(nel,5)
|
||
|
|
else
|
||
|
|
return
|
||
|
|
endif
|
||
|
|
else
|
||
|
|
return
|
||
|
|
endif
|
||
|
|
endif
|
||
|
|
! else
|
||
|
|
! return
|
||
|
|
endif
|
||
|
|
ierr=1
|
||
|
|
return
|
||
|
|
end
|
||
|
|
|
||
|
|
SUBROUTINE PANELTYP(N1)
|
||
|
|
|
||
|
|
! Choose options and intervals
|
||
|
|
|
||
|
|
use winteracter
|
||
|
|
|
||
|
|
implicit none
|
||
|
|
|
||
|
|
include 'D.inc'
|
||
|
|
INCLUDE 'BFILES.I90'
|
||
|
|
|
||
|
|
!
|
||
|
|
! Declare window-type and message variables
|
||
|
|
!
|
||
|
|
TYPE(WIN_STYLE) :: WINDOW
|
||
|
|
|
||
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
||
|
|
|
||
|
|
integer :: N1,itime,IERR
|
||
|
|
data itime/0/
|
||
|
|
|
||
|
|
if(itime .eq. 0) then
|
||
|
|
n1=1
|
||
|
|
itime=1
|
||
|
|
endif
|
||
|
|
|
||
|
|
call wdialogload(IDD_MATTYP)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogPutInteger(idf_integer1,N1)
|
||
|
|
|
||
|
|
CALL WDialogSelect(IDD_MATTYP)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||
|
|
CALL WDialogGetInteger(idf_integer1,N1)
|
||
|
|
ELSE
|
||
|
|
N1=1
|
||
|
|
RETURN
|
||
|
|
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|