zhangyiss/LaGriT
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
a09a73537fe441c6f6807af05692b8e090c084d4
LaGriT/src/resetpts.f

591 lines
20 KiB
FortranFixed
Raw Normal View History

initial upload
2025-12-17 11:00:57 +08:00
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 Copy Permalink