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.

445 lines
10 KiB
Fortran

9 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
! 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
! get adjacent corner save corner
m=2
list2(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
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
! 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)
jj=mod(k,ncorn(nel))+1
nd3=nop(nel,jj)
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