initial upload
This commit is contained in:
590
src/resetpts.f
Executable file
590
src/resetpts.f
Executable file
@@ -0,0 +1,590 @@
|
||||
subroutine resetpts(imsgin,xmsgin,cmsgin,msgtype,nwds,ierror)
|
||||
C
|
||||
C
|
||||
C ######################################################################
|
||||
C
|
||||
C PURPOSE -
|
||||
C
|
||||
C THIS ROUTINE RESETS NODE QUANTITIES DEPENDING ON THE
|
||||
C OPTION SPECIFIED
|
||||
C
|
||||
C OPTIONS:
|
||||
C
|
||||
C parent resets itp and isn and itet
|
||||
C loop through points looking for parent type
|
||||
C change types of childen to dud
|
||||
C change type of parent to max of child types
|
||||
C fix up itet, replace references to child with parent
|
||||
C
|
||||
C itp resets itp
|
||||
C set external boundary node type based on boundary faces
|
||||
C for use when removing points or materials
|
||||
C
|
||||
C color resets itetclr
|
||||
C set itetclr array to zero
|
||||
C
|
||||
C fixitet resets itet
|
||||
C look for 2d meshes with reversed neighbor triangles
|
||||
C (normals pointing wrong way)
|
||||
C
|
||||
C cell_color resets imt
|
||||
C
|
||||
C imt_color_to_change
|
||||
C loops through all elements 1 to ntets
|
||||
C and resets chosen node imt to element color
|
||||
C default - loop will go from 1 to ntets
|
||||
C imt_color_to_change is negative, ntets to 1
|
||||
C
|
||||
C no args or istart, iend, istride
|
||||
C loops through all itetclr values 1 to maxclr
|
||||
C and resets node imt to chosen element colors
|
||||
C istart,istride,iend can be used to loop subset of colors
|
||||
C see examples below
|
||||
C
|
||||
C intrface resets itp and jtet
|
||||
C look at all faces - if more than one
|
||||
C interior material on face make the nodes
|
||||
C on the face interface nodes
|
||||
C
|
||||
c EXAMPLES
|
||||
C
|
||||
C for a grid with 4 itetclr colors:
|
||||
c resetpts/cell_color will loop through colors from 1 to 4
|
||||
c assigning node imt the element color
|
||||
c resetpts/cell_color/1,0,0 will loop through colors from 1 to 4
|
||||
c resetpts/cell_color/0,1,-1 will loop through colors from 4 to 1
|
||||
c resetpts/cell_color/1,2,1 will loop through colors from 1 to 2
|
||||
C
|
||||
C
|
||||
C INPUT ARGUMENTS -
|
||||
C
|
||||
C imsgin() - Integer array of command input tokens
|
||||
C xmsgin() - Real array of command input tokens
|
||||
C cmsgin() - Character array of command input tokens
|
||||
C msgtype() - Integer array of command input token types
|
||||
C nwds - Number of command input tokens
|
||||
C
|
||||
C OUTPUT ARGUMENTS -
|
||||
C
|
||||
C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
|
||||
C
|
||||
C
|
||||
C temporary options are color and fixitet
|
||||
C
|
||||
C CHANGE HISTORY -
|
||||
C
|
||||
C$Log: resetpts.f,v $
|
||||
CRevision 2.00 2007/11/09 20:04:01 spchu
|
||||
CImport to CVS
|
||||
C
|
||||
CPVCS
|
||||
CPVCS Rev 1.19 04 Apr 2007 10:32:20 gable
|
||||
CPVCS Added return in the case of MO with zero nodes.
|
||||
CPVCS
|
||||
CPVCS Rev 1.18 10 Apr 2001 13:54:30 dcg
|
||||
CPVCS remove bad line
|
||||
CPVCS
|
||||
CPVCS Rev 1.17 03 Apr 2000 18:35:48 gable
|
||||
CPVCS Changed some comments
|
||||
CPVCS
|
||||
CPVCS Rev 1.16 Wed Mar 24 11:21:56 1999 dcg
|
||||
CPVCS change error flag on mmrelprt call - because
|
||||
CPVCS for some options no temporary memory is used
|
||||
CPVCS
|
||||
CPVCS Rev 1.15 Wed Aug 19 12:16:58 1998 tam
|
||||
CPVCS added to cell_color option to reset imt from element colors
|
||||
CPVCS loop through all itetclr values 1 to maxclr, set imt from itetclr
|
||||
CPVCS istart,istride,iend can be used to loop subset of colors
|
||||
CPVCS also added comments and expanded information in header
|
||||
CPVCS
|
||||
CPVCS Rev 1.14 Fri May 29 14:36:38 1998 dcg
|
||||
CPVCS for resetpts/itp skip nodes whose itp >= ifitpst3 = 20
|
||||
CPVCS
|
||||
CPVCS Rev 1.13 Wed May 20 15:35:10 1998 dcg
|
||||
CPVCS add option 'interface' look at all faces - if more than one
|
||||
CPVCS interior material on face make the nodes on the face interface nodes
|
||||
CPVCS
|
||||
CPVCS Rev 1.12 Mon Mar 16 12:21:38 1998 gable
|
||||
CPVCS Added option resetpts / cell_color / node_color which
|
||||
CPVCS loops through all elements and resets node imt to element
|
||||
CPVCS color if the node is the user specified imt value.
|
||||
CPVCS
|
||||
CPVCS Rev 1.11 Thu Mar 12 15:21:50 1998 kuprat
|
||||
CPVCS Fixed bug where merged and dudded points where reset
|
||||
CPVCS to interior points.
|
||||
CPVCS
|
||||
CPVCS Rev 1.10 Tue Jul 15 10:46:58 1997 dcg
|
||||
CPVCS overwrite previous changes till fixed
|
||||
CPVCS
|
||||
CPVCS Rev 1.8 Thu May 08 17:01:46 1997 dcg
|
||||
CPVCS add resetpts/color command to set itetclr array to zero
|
||||
CPVCS add resetpts/ifixitet command to look for 2d meshes
|
||||
CPVCS with reversed neighbor triangles (normals pointing
|
||||
CPVCS wrong way)
|
||||
CPVCS
|
||||
CPVCS Rev 1.7 Mon Apr 14 16:59:48 1997 pvcs
|
||||
CPVCS No change.
|
||||
CPVCS
|
||||
CPVCS Rev 1.6 Thu Mar 06 13:01:36 1997 kmb
|
||||
CPVCS Removed debugging printout
|
||||
CPVCS
|
||||
CPVCS Rev 1.5 Thu Oct 03 13:02:20 1996 dcg
|
||||
CPVCS Reset the itp array for use when removing points or materials
|
||||
CPVCS changes added by Kathy Bowers(kmb)
|
||||
CPVCS Rev 1.4 Thu Jun 27 14:54:42 1996 het
|
||||
CPVCS Use unpackpc instead of the slow inline coding.
|
||||
CPVCS
|
||||
CPVCS Rev 1.3 11/16/95 14:23:46 dcg
|
||||
CPVCS look for null parent/child lists
|
||||
CPVCS
|
||||
CPVCS Rev 1.2 11/07/95 17:25:20 dcg
|
||||
CPVCS change flag to 2 in mmgetblk calls
|
||||
CPVCS
|
||||
CPVCS Rev 1.1 09/27/95 09:55:58 dcg
|
||||
CPVCS check for incomplete parent child loops
|
||||
CPVCS
|
||||
CPVCS Rev 1.0 09/20/95 09:52:18 dcg
|
||||
CPVCS Initial revision.
|
||||
C
|
||||
C ######################################################################
|
||||
implicit none
|
||||
integer nwds, imsgin(nwds), msgtype(nwds)
|
||||
REAL*8 xmsgin(nwds)
|
||||
character*(*) cmsgin(nwds)
|
||||
character*32 cbuff
|
||||
C
|
||||
integer ierror, ilen,itype,mbndry,length,icscode,ipnt,it,
|
||||
* node1,jt,nf,ip1,ip2,jt1,jf,jp1,jp2,iip1,iip2,jjp1,jjp2,
|
||||
* inode_color_change,istart,iend,istride,icount,in,imt0
|
||||
logical ibadface
|
||||
logical itsttp
|
||||
C
|
||||
C ######################################################################
|
||||
C
|
||||
character*40 cmo
|
||||
C
|
||||
integer npoints, ntets, nen, nef, nsdtopo, nsdgeom
|
||||
integer ic, ics, maxclr
|
||||
C
|
||||
pointer (ipitp1, itp1)
|
||||
pointer (ipisn1, isn1)
|
||||
pointer (ipimt1, imt1)
|
||||
integer isn1(1000000), itp1(1000000), imt1(1000000)
|
||||
C
|
||||
pointer (ipitettyp, itettyp)
|
||||
pointer (ipitetoff, itetoff)
|
||||
integer itettyp(10000000),
|
||||
* itetoff(10000000)
|
||||
C
|
||||
pointer (ipitet, itet1)
|
||||
pointer (ipjtet, jtet1)
|
||||
pointer (ipitetclr, itetclr)
|
||||
pointer (ipjtetoff, jtetoff)
|
||||
integer itetclr(1000000), jtetoff(1000000)
|
||||
integer itet1(10000000), jtet1(10000000)
|
||||
C
|
||||
pointer (ipiparent, iparent)
|
||||
integer iparent(1000000)
|
||||
|
||||
pointer (ipidone, idone)
|
||||
integer idone(10000000)
|
||||
C
|
||||
C
|
||||
C#######################################################################
|
||||
character*32 isubname, coption
|
||||
character*132 logmess
|
||||
integer itypar,nchild,itypmax,nxpt,itydud,i,j
|
||||
include 'chydro.h'
|
||||
include 'local_element.h'
|
||||
C
|
||||
C#######################################################################
|
||||
isubname='resetpts'
|
||||
ierror=0
|
||||
C Get mesh object.
|
||||
C
|
||||
call cmo_get_name(cmo,ierror)
|
||||
C
|
||||
if(ierror.ne.0) then
|
||||
write(logmess,'(a)') 'RESETPTS found bad mesh object'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
goto 9999
|
||||
endif
|
||||
C
|
||||
C ******************************************************************
|
||||
C Get mesh object data.
|
||||
C
|
||||
call cmo_get_info('nnodes', cmo, npoints, ilen, itype, ierror)
|
||||
if(ierror.ne.0) call x3d_error(isubname,'cmo_get_info')
|
||||
call cmo_get_info('nelements', cmo, ntets, ilen, itype, ierror)
|
||||
if(ierror.ne.0) call x3d_error(isubname,'cmo_get_info')
|
||||
call cmo_get_info('ndimensions_topo',cmo,
|
||||
* nsdtopo,ilen,itype,ierror)
|
||||
call cmo_get_info('ndimensions_geom',cmo,
|
||||
* nsdgeom,ilen,itype,ierror)
|
||||
call cmo_get_info('nodes_per_element',cmo,
|
||||
* nen,ilen,itype,ierror)
|
||||
call cmo_get_info('faces_per_element',cmo,
|
||||
* nef,ilen,itype,ierror)
|
||||
call cmo_get_info('itp1', cmo, ipitp1, ilen, itype, ierror)
|
||||
if(ierror.ne.0) call x3d_error(isubname,'cmo_get_info')
|
||||
call cmo_get_info('isn1', cmo, ipisn1, ilen, itype, ierror)
|
||||
if(ierror.ne.0) call x3d_error(isubname,'cmo_get_info')
|
||||
call cmo_get_info('imt1', cmo, ipimt1, ilen, itype, ierror)
|
||||
if(ierror.ne.0) call x3d_error(isubname,'cmo_get_info')
|
||||
call cmo_get_info('itettyp', cmo, ipitettyp,ilen,itype,ierror)
|
||||
if(ierror.ne.0) call x3d_error(isubname,'cmo_get_info')
|
||||
call cmo_get_info('itetoff', cmo, ipitetoff,ilen,itype,ierror)
|
||||
if(ierror.ne.0) call x3d_error(isubname,'cmo_get_info')
|
||||
if(ierror.ne.0) call x3d_error(isubname,'cmo_get_info')
|
||||
C
|
||||
call cmo_get_info('itet', cmo, ipitet, ilen, itype, ierror)
|
||||
if(ierror.ne.0) call x3d_error(isubname,'cmo_get_info')
|
||||
if(ierror.ne.0) call x3d_error(isubname,'cmo_get_info')
|
||||
|
||||
call cmo_get_info('mbndry',cmo,mbndry,ilen,itype,ierror)
|
||||
call cmo_get_info('itetclr',cmo,ipitetclr,ilen,itype,ierror)
|
||||
call cmo_get_info('jtetoff',cmo,ipjtetoff,ilen,itype,ierror)
|
||||
call cmo_get_info('jtet', cmo,ipjtet,ilen,itype,ierror)
|
||||
C
|
||||
if(nwds.lt.2) then
|
||||
coption='parent'
|
||||
else
|
||||
coption=cmsgin(2)
|
||||
endif
|
||||
|
||||
if(coption(1:6).eq.'parent') then
|
||||
c.....reset itp and isn
|
||||
call mmgetblk('iparent',isubname,ipiparent,npoints,1,ierror)
|
||||
call unpackpc(npoints,itp1,isn1,iparent)
|
||||
C *** Get an array that indicates the parents of each point.
|
||||
C
|
||||
C loop through points looking for parent type
|
||||
C change types of childen to dud
|
||||
C change type of parent to max of child types
|
||||
C
|
||||
call getptyp(inamppar,itypar,ierror)
|
||||
call getptyp(inampdud,itydud,ierror)
|
||||
nchild=0
|
||||
do i=1,npoints
|
||||
itypmax=0
|
||||
if(itp1(i).eq.itypar ) then
|
||||
nxpt=isn1(i)
|
||||
if(nxpt.eq.0.or.itp1(nxpt).eq.itydud.or.isn1(nxpt).eq.0)
|
||||
* then
|
||||
itp1(i)=itydud
|
||||
isn1(i)=0
|
||||
else
|
||||
do while (itp1(nxpt).ne.itypar.and.itp1(nxpt).ne.itydud)
|
||||
nchild=nchild+1
|
||||
itypmax=max(itypmax,itp1(nxpt))
|
||||
itp1(nxpt)=itydud
|
||||
nxpt=isn1(nxpt)
|
||||
enddo
|
||||
itp1(i)=itypmax
|
||||
isn1(i)=0
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
C
|
||||
C Fix up itet array replace references to child with parent.
|
||||
do i=1, ntets
|
||||
do j=1,nelmnen(itettyp(i))
|
||||
itet1(itetoff(i)+j)=iparent(itet1(itetoff(i)+j))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
elseif (coption(1:3).eq.'itp') then
|
||||
c.....reset the itp array
|
||||
C set the external boundary node type based on boundary faces.
|
||||
|
||||
cbuff='geniee ; finish'
|
||||
call dotaskx3d(cbuff,ierror)
|
||||
C
|
||||
length=npoints
|
||||
if(length .le. 0) goto 9999
|
||||
call mmgetblk('idone',isubname,ipidone,length,1,icscode)
|
||||
C
|
||||
do i=1,npoints
|
||||
idone(i)=0
|
||||
if (itp1(i).lt.ifitpst3) itp1(i)=0
|
||||
enddo
|
||||
C
|
||||
c ntets=number of tet
|
||||
c nelmnef= face number on tet
|
||||
c mbndry=ntets*nelmnef + 1 (or greater)
|
||||
c jtet1= boundary flag
|
||||
c itp1=boundary flag(0,10,2,12,etc)
|
||||
c ielmface0=node numbers on face
|
||||
|
||||
ipnt=0
|
||||
do it=1,ntets
|
||||
do i=1,nelmnef(itettyp(it))
|
||||
if (jtet1(jtetoff(it)+i).eq.mbndry) then
|
||||
c this is a boundary node
|
||||
do j=1,ielmface0(i,itettyp(it))
|
||||
node1 = itet1(itetoff(it)+
|
||||
* ielmface1(j,i,itettyp(it)))
|
||||
itp1(node1)=ifitprfl
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
C
|
||||
do it=1,ntets
|
||||
do i=1,nelmnef(itettyp(it))
|
||||
c check if on an interface
|
||||
if (jtet1(jtetoff(it)+i).gt.0.and.
|
||||
* jtet1(jtetoff(it)+i).ne.mbndry) then
|
||||
if (jtet1(jtetoff(it)+i).lt.mbndry) then
|
||||
jt=1+(jtet1(jtetoff(it)+i)-1)/nelmnef(itettyp(it))
|
||||
else
|
||||
jt=1+((jtet1(jtetoff(it)+i)-1)-mbndry)
|
||||
* /nelmnef(itettyp(it))
|
||||
endif
|
||||
if(itetclr(it).ne.itetclr(jt)) then
|
||||
do j=1,ielmface0(i,itettyp(it))
|
||||
node1=itet1(itetoff(it)+
|
||||
* ielmface1(j,i,itettyp(it)))
|
||||
if(idone(node1).eq.0) then
|
||||
idone(node1)=1
|
||||
if(itp1(node1).eq.ifitprfl) then
|
||||
itp1(node1)=ifitpinb
|
||||
else
|
||||
itp1(node1)=ifitpini
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
call mmrelblk('idone',isubname,ipidone,icscode)
|
||||
do 920 j=1,npoints
|
||||
920 continue
|
||||
|
||||
ierror=0
|
||||
|
||||
elseif(coption(1:5).eq.'color') then
|
||||
c.....reset itetclr
|
||||
do it=1,ntets
|
||||
itetclr(it)=0
|
||||
enddo
|
||||
|
||||
elseif(coption(1:7).eq.'fixitet') then
|
||||
c.....reset itet
|
||||
do it=1,ntets
|
||||
do nf=1,nef
|
||||
if(nf.eq.1) then
|
||||
ip1=2
|
||||
ip2=3
|
||||
elseif(nf.eq.2) then
|
||||
ip1=3
|
||||
ip2=1
|
||||
else
|
||||
ip1=1
|
||||
ip2=2
|
||||
endif
|
||||
jt1=jtet1((it-1)*nef+nf)
|
||||
if(jt1.eq.0.or.jt1.eq.mbndry) then
|
||||
print *,'bad neibor ',it,nf
|
||||
else
|
||||
if(jt1.gt.mbndry) jt1=jt1-mbndry
|
||||
|
||||
jt=1+(jt1-1)/nef
|
||||
jf=jt1-(jt-1)*nef
|
||||
if(jf.eq.1) then
|
||||
jp1=2
|
||||
jp2=3
|
||||
elseif(jf.eq.2) then
|
||||
jp1=3
|
||||
jp2=1
|
||||
else
|
||||
jp1=1
|
||||
jp2=2
|
||||
endif
|
||||
iip1=itet1((it-1)*nef+ip1)
|
||||
iip2=itet1((it-1)*nef+ip2)
|
||||
jjp1=itet1((jt-1)*nef+jp1)
|
||||
jjp2=itet1((jt-1)*nef+jp2)
|
||||
if(jjp1.ne.iip2) then
|
||||
print *,'reverse triangle ',it,nf,jt,jf
|
||||
|
||||
itet1((jt-1)*nef+jp1)=jjp2
|
||||
itet1((jt-1)*nef+jp2)=jjp1
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
elseif(coption(1:10).eq.'cell_color') then
|
||||
c.....reset imt
|
||||
c reset node imt based on element color
|
||||
c
|
||||
if (nwds .eq. 3)then
|
||||
c
|
||||
c CHANGE CHOSEN NODES TO ITETCLR VALUES
|
||||
c Reset imt to element color if the node is the user specified imt value.
|
||||
c Loop through elements 1 to ntets (default)
|
||||
c Note, this will introduce a bias since the loop is based
|
||||
c on going from 1 to ntets. The bias can be changed by using
|
||||
c a negative value for the input imt value. Then loop will
|
||||
c go from ntets to 1.
|
||||
c
|
||||
c resetpts / cell_color / inode_color_change
|
||||
c resetpts / cell_color / -inode_color_change
|
||||
c
|
||||
inode_color_change = abs(imsgin(3))
|
||||
if(imsgin(3) .ge. 0)then
|
||||
istart = 1
|
||||
iend = ntets
|
||||
istride = 1
|
||||
elseif(imsgin(3) .lt. 0)then
|
||||
istart = ntets
|
||||
iend = 1
|
||||
istride = -1
|
||||
endif
|
||||
icount = 0
|
||||
do it = istart, iend, istride
|
||||
do in = 1, nelmnen(itettyp(it))
|
||||
if(imt1(itet1(itetoff(it)+in)) .eq. inode_color_change)then
|
||||
imt1(itet1(itetoff(it)+in))=itetclr(it)
|
||||
icount = icount + 1
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
write(logmess,
|
||||
1 "(i8,' nodes of imt value',i8,' reset to their cell color')")
|
||||
2 icount, inode_color_change
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
|
||||
|
||||
else
|
||||
c
|
||||
c CHANGE NODE IMT TO CHOSEN ITETCLR VALUES
|
||||
C Reset node imt to element colors.
|
||||
c Loop through itetclr 1 to maxclr (default)
|
||||
c istart,istride,iend can be used to loop through subset of colors
|
||||
c ie. for a grid with 14 colors
|
||||
c default will loop through colors from 1 to 14
|
||||
c 1,12, 1 will loop through colors from 1 to 12
|
||||
c 0,1,-1 will loop through colors from 14 to 1
|
||||
c
|
||||
c resetpts / cell_color /
|
||||
c resetpts / cell_color / istart,iend,istride
|
||||
c 1 2 3 4 5
|
||||
C
|
||||
C READ PARSER VALUES
|
||||
icount=0
|
||||
|
||||
c this sets loop for element colors, not element set (iend=maxclr)
|
||||
istride = 1
|
||||
istart = 1
|
||||
iend = 0
|
||||
|
||||
c identify min and max of element colors
|
||||
do it = 1, ntets
|
||||
istart = min(istart, itetclr(it))
|
||||
iend = max(iend , itetclr(it))
|
||||
enddo
|
||||
maxclr = iend
|
||||
c
|
||||
if (nwds .eq. 4)then
|
||||
istart = imsgin(3)
|
||||
iend = imsgin(4)
|
||||
|
||||
elseif (nwds .eq. 5)then
|
||||
istart = imsgin(3)
|
||||
iend = imsgin(4)
|
||||
istride = imsgin(5)
|
||||
endif
|
||||
if (istart.eq.0) istart = maxclr
|
||||
if (iend.eq.0) iend = maxclr
|
||||
if (istride.eq.0) istride = 1
|
||||
if (istart.gt.iend .and. istride.gt.0) istride = -1*istride
|
||||
|
||||
c
|
||||
c INITIALIZE imat
|
||||
length=npoints
|
||||
call mmgetblk('idone',isubname,ipidone,length,1,icscode)
|
||||
do i = 1,length
|
||||
idone(i)=0
|
||||
enddo
|
||||
c
|
||||
do ic = istart, iend, istride
|
||||
do it = 1, ntets
|
||||
if(itetclr(it) .eq. ic)then
|
||||
do in = 1, nelmnen(itettyp(it))
|
||||
imt1(itet1(itetoff(it)+in))=itetclr(it)
|
||||
idone(itetclr(it)) = 1
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
do i = 1,length
|
||||
if (idone(i) .ne. 0) icount=icount+1
|
||||
enddo
|
||||
c
|
||||
call mmrelblk('idone',isubname,ipidone,icscode)
|
||||
write(logmess,'(a,i12,a,i12,a,i12)')
|
||||
1 'material # start= ', istart, ' end= ', iend,' stride= ',istride
|
||||
call writloga('default',0,logmess,0,ics)
|
||||
write(logmess,'(i12,a,i12)')
|
||||
*icount,' material numbers reset imt1 out of a maximum of ',maxclr
|
||||
call writloga('default',0,logmess,0,ics)
|
||||
|
||||
endif
|
||||
c
|
||||
c
|
||||
elseif(coption(1:10).eq.'intrface') then
|
||||
c.....reset itp and jtet
|
||||
length=npoints
|
||||
do it=1,ntets
|
||||
do i=1,nelmnef(itettyp(it))
|
||||
c check if material types of all nodes on the face
|
||||
C if there are more than one interior node material type
|
||||
C we have a multimaterial tet - make this face an
|
||||
c interface face and change point types
|
||||
imt0=0
|
||||
ibadface=.false.
|
||||
do j=1,ielmface0(i,itettyp(it))
|
||||
node1=itet1(itetoff(it)+
|
||||
* ielmface1(j,i,itettyp(it)))
|
||||
if(itsttp('interior',itp1(node1)).and.
|
||||
* .not.itsttp('intrface',itp1(node1))) then
|
||||
if(imt0.eq.0) then
|
||||
imt0=imt1(node1)
|
||||
else
|
||||
if(imt1(node1).ne.imt0.or.ibadface) then
|
||||
ibadface=.true.
|
||||
if(itsttp('boundary',itp1(node1))) then
|
||||
itp1(node1)=ifitpinb
|
||||
else
|
||||
itp1(node1)=ifitpini
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
if(ibadface) then
|
||||
if(jtet1(jtetoff(it)+i).lt.mbndry) then
|
||||
jtet1(jtetoff(it)+i)=jtet1(jtetoff(it)+i)+mbndry
|
||||
jt1=jtet1(jtetoff(it)+i)-mbndry
|
||||
jt=1+(jt1-1)/nef
|
||||
jf=jt1-(jt-1)*nef
|
||||
jtet1(jtetoff(jt)+jf)=jtet1(jtetoff(jt)+jf)+mbndry
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
else
|
||||
c.....invalid reset option
|
||||
|
||||
write(logmess,"(' Option ',a,' not implemented')") coption
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
go to 9999
|
||||
endif
|
||||
|
||||
9999 call mmrelprt(isubname,ics)
|
||||
return
|
||||
end
|
||||
Reference in New Issue
Block a user