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

2825 lines
103 KiB
FortranFixed
Raw Normal View History

initial upload
2025-12-17 11:00:57 +08:00
subroutine refine(imsgin,xmsgin,cmsgin,msgtype,nwds,ierror)
C
C
C #####################################################################
C
C PURPOSE -
C
C This routine call the correct grid refinement routine
C depending on the type and dimensionality of the CMO.
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 CHANGE HISTORY -
C
C $Log: refine.f,v $
C Revision 2.00 2007/11/09 20:04:00 spchu
C Import to CVS
C
CPVCS
CPVCS Rev 1.13 05 Jan 2007 12:34:58 tam
CPVCS removed lines with integer idebug, already declared in
CPVCS chydro.h which the mac does not like
CPVCS
CPVCS Rev 1.12 30 Oct 2006 14:05:34 gable
CPVCS Added debugging IO withing addpts parts of code.
CPVCS
CPVCS Rev 1.11 24 Dec 2003 10:23:18 tam
CPVCS add 'amr' iprd option to the refine command
CPVCS change screen messege to indicate element type instead of 'tet'
CPVCS
CPVCS Rev 1.10 17 Dec 2001 09:54:34 dcg
CPVCS fix errors in faceedge and tetedge options
CPVCS
CPVCS Rev 1.9 17 Dec 2001 06:59:48 gable
CPVCS Added option to refine on element sets.
CPVCS
CPVCS Rev 1.8 29 May 2001 17:52:34 kuprat
CPVCS We now pass PSETNAME=-def- in the case of 2-D with no surface.
CPVCS In this case the entire 2-D grid will be in the 'pset' for refinement.
CPVCS
CPVCS Rev 1.7 16 Nov 2000 15:24:26 tam
CPVCS make equivalent node attributes imt,imt1, itp,itp1,icr,icr1,isn,isn1
CPVCS
CPVCS Rev 1.6 03 Oct 2000 09:45:00 dcg
CPVCS remove unused references to ialias
CPVCS
CPVCS Rev 1.5 21 Jun 2000 11:44:40 dcg
CPVCS don't pass cmo name - get active cmo name in gradient
CPVCS
CPVCS Rev 1.4 20 Jun 2000 10:33:14 dcg
CPVCS get volumes of all types of elements -
CPVCS modify amount of temp space used
CPVCS
CPVCS Rev 1.3 Wed Apr 05 11:14:48 2000 dcg
CPVCS add 'spawn' option
CPVCS
CPVCS Rev 1.2 28 Jan 2000 16:51:12 dcg
CPVCS
CPVCS Rev 1.1 26 Jan 2000 16:26:52 dcg
CPVCS
CPVCS Rev 1.0 25 Jan 2000 15:44:04 dcg
CPVCS Initial revision.
CPVCS
CPVCS Rev 1.76 Wed Nov 10 15:22:02 1999 dcg
CPVCS declare nnfreq as local variable - get value from storage block
CPVCS
CPVCS Rev 1.75 Fri Jul 23 09:39:20 1999 dcg
CPVCS remove calls to open_face
CPVCS this code was never implemented
CPVCS was meant to do de-refinement
CPVCS
CPVCS Rev 1.74 Fri Jun 11 15:34:58 1999 dcg
CPVCS make refine/../edge for 2d grids work like refine/../face
CPVCS in 2d edges are facets hence original thinking but
CPVCS edges are always edges so the 'edge' syntax should work
CPVCS
CPVCS Rev 1.73 Wed Feb 10 11:24:06 1999 dcg
CPVCS add refine/interface option
CPVCS
CPVCS Rev 1.73 Wed Feb 10 11:20:56 1999 dcg
CPVCS
CPVCS Rev 1.72 Mon Jan 04 16:26:48 1999 dcg
CPVCS put error message and quit if mesh has no elements
CPVCS
CPVCS Rev 1.71 Wed Dec 23 15:41:48 1998 dcg
CPVCS add command option refine/edge_list
CPVCS
CPVCS Rev 1.69 Mon Nov 16 10:40:26 1998 kuprat
CPVCS Added explicit calls to 'recon', after calls to 'cel' and 'cel_chain'.
CPVCS
CPVCS Rev 1.68 Fri Jul 24 15:45:28 1998 dcg
CPVCS fix test on options
CPVCS
CPVCS Rev 1.67 Fri Jul 24 15:17:44 1998 dcg
CPVCS add refine/rivara_boundary option
CPVCS
CPVCS Rev 1.66 Thu Jul 02 16:02:50 1998 dcg
CPVCS add call to truncated rivara refine
CPVCS
CPVCS Rev 1.64 Tue Jun 23 15:17:38 1998 dcg
CPVCS changes for refine/rivara command
CPVCS
CPVCS Rev 1.63 Fri Oct 17 11:18:26 1997 dcg
CPVCS replace print statement
CPVCS
CPVCS Rev 1.62 Fri Oct 10 12:46:38 1997 tam
CPVCS added check for nnfreq value before calling recon
CPVCS
CPVCS Rev 1.61 Fri Oct 03 11:02:42 1997 dcg
CPVCS reorder declarations as per DEC compiler
CPVCS
CPVCS Rev 1.59 Mon Apr 14 16:58:56 1997 pvcs
CPVCS No change.
CPVCS
CPVCS Rev 1.58 Sun Feb 23 10:37:36 1997 het
CPVCS Add the refinement for quads.
CPVCS
CPVCS Rev 1.57 Fri Jan 24 14:25:22 1997 het
CPVCS Correct an error in the refine/edge/ command.
CPVCS
CPVCS Rev 1.56 Mon Nov 11 20:55:08 1996 het
CPVCS Make the call for unimplemented refine CMO anyway.
CPVCS
CPVCS Rev 1.55 Wed Jul 24 17:33:46 1996 dcg
CPVCS use mesh object 'nef' attribute to pack element and
CPVCS face number into jtet array
CPVCS
CPVCS Rev 1.54 Thu Jun 27 14:55:22 1996 het
CPVCS For addpts use the names of points without duplicating the points.
CPVCS
CPVCS Rev 1.53 Fri May 24 13:58:24 1996 het
CPVCS Correct an error in the addpts option for edge points.
CPVCS
CPVCS Rev 1.52 Tue Apr 30 07:26:22 1996 het
CPVCS Change the refine_add_pts option for imt1=0 points.
CPVCS
CPVCS Rev 1.51 Tue Apr 09 16:42:10 1996 dcg
CPVCS declare coption_len to be integer
CPVCS
CPVCS Rev 1.50 Tue Apr 02 02:29:02 1996 het
CPVCS Change this routine to give new nodes names.
CPVCS
CPVCS Rev 1.49 Thu Mar 14 13:38:48 1996 het
CPVCS Change the call to the refine commands to add names.
CPVCS
CPVCS Rev 1.48 Tue Mar 05 12:32:56 1996 het
CPVCS Add reconnection for tets and tris when using the addpts option.
CPVCS
CPVCS Rev 1.47 Fri Feb 16 21:51:32 1996 het
CPVCS Fix an error with the exclusive/inclusive option
CPVCS
CPVCS Rev 1.46 Fri Feb 02 14:23:48 1996 dcg
CPVCS remove references to explicit vector attributes (u,w,v,e,r,pic)
CPVCS
CPVCS Rev 1.45 Thu Feb 01 01:45:10 1996 het
CPVCS Fix an error in qualifying a xfield.
CPVCS
CPVCS Rev 1.44 Wed Jan 31 12:57:58 1996 het
CPVCS Correct an error with the field variable.
CPVCS
CPVCS Rev 1.43 Mon Jan 29 22:21:28 1996 het
CPVCS
CPVCS Fix some errors with the refine/addpts option
CPVCS
CPVCS Rev 1.42 Wed Jan 24 06:07:34 1996 het
CPVCS Fix an error in the calculation of element refinement coordinates.
CPVCS
CPVCS Rev 1.41 Tue Jan 23 09:18:20 1996 het
CPVCS Fix an error in copying isn1 numbers.
CPVCS
CPVCS Rev 1.40 Fri Dec 22 14:18:26 1995 het
CPVCS Correct errors for inside_ routines.
CPVCS
CPVCS Rev 1.39 11/22/95 09:07:36 dcg
CPVCS fix confusion between ielmface and ielmedge
CPVCS
CPVCS Rev 1.38 11/17/95 15:22:32 dcg
CPVCS replace literal character strings in calls
CPVCS
CPVCS Rev 1.37 11/16/95 17:12:22 het
CPVCS Start to add all the functions for refine.
CPVCS
CPVCS Rev 1.36 11/07/95 17:24:02 dcg
CPVCS change flag to 2 in mmgetblk calls
CPVCS
CPVCS Rev 1.35 11/07/95 11:28:04 het
CPVCS Modify the 2D triangle refinement algorithms.
CPVCS
CPVCS Rev 1.34 10/22/95 13:46:20 het
CPVCS Insert some cmo_get_info calles
CPVCS
CPVCS Rev 1.33 10/22/95 13:17:42 het
CPVCS Correct a memory management error
CPVCS
CPVCS Rev 1.32 10/20/95 10:48:44 het
CPVCS Fix iparent memory management error and add new refine options.
CPVCS
CPVCS Rev 1.31 10/19/95 17:01:30 het
CPVCS Add the refine/edge refine/face refine/tet commands
CPVCS
CPVCS Rev 1.30 10/18/95 12:15:34 het
CPVCS Dud out the original points that are being added
CPVCS
CPVCS Rev 1.29 10/05/95 15:46:44 het
CPVCS Add the intrface refinement option
CPVCS
CPVCS Rev 1.28 10/04/95 07:44:36 het
CPVCS Add the addpts option to the refine commands
CPVCS
CPVCS Rev 1.27 09/29/95 09:13:42 het
CPVCS Put in added attributes inheritance
CPVCS
CPVCS Rev 1.26 09/11/95 14:41:48 het
CPVCS Change to the storage block based CMO stuff.
CPVCS
CPVCS Rev 1.25 08/30/95 21:09:04 het
CPVCS Put cmo table data into the cmoatt storage block
CPVCS
CPVCS Rev 1.24 08/29/95 12:03:06 dcg
CPVCS set length for names to 40 characters
CPVCS
CPVCS Rev 1.23 08/16/95 00:23:36 het
CPVCS Correct errors in recon and refine calles
CPVCS
CPVCS Rev 1.22 08/15/95 18:24:30 het
CPVCS Cleanup code and correct errors
C
C ######################################################################
C
implicit none
C
include "local_element.h"
C
C ######################################################################
C
integer nwds, imsgin(nwds), msgtype(nwds)
real*8 xmsgin(nwds)
character*(*) cmsgin(nwds)
C
integer ierror,nen,ilen,itype,icscode,nef,nsd,npoints,
* npoints_save,ipointi,ipointj,imesh_type
integer icharlnf
integer iprd
C
character*32 cmo,isubname,mesh_type
character*132 logmess,cbuf
C
C#######################################################################
C
C
isubname='refine'
iprd=0
call cmo_get_name(cmo,ierror)
if(ierror.ne.0) then
write(logmess,9000)
9000 format('No CMOs defined')
call writloga('default',1,logmess,1,ierror)
goto 9999
endif
C
call cmo_get_info('nodes_per_element',cmo,nen,ilen,itype,icscode)
call cmo_get_info('faces_per_element',cmo,nef,ilen,itype,icscode)
call cmo_get_info('ndimensions_topo',cmo,nsd,ilen,itype,icscode)
call cmo_get_mesh_type(cmo,mesh_type,imesh_type,icscode)
C
call cmo_get_info('nnodes',cmo,npoints,ilen,itype,ierror)
npoints_save=npoints
C
call cmo_get_info('ipointi',cmo,ipointi,ilen,itype,icscode)
if (icscode .ne. 0) call x3d_error(isubname,'get_info_i')
call cmo_get_info('ipointj',cmo,ipointj,ilen,itype,icscode)
if (icscode .ne. 0) call x3d_error(isubname,'get_info_i')
c
if((cmsgin(2) .eq. 'element_set').or.
* (cmsgin(2) .eq. 'eltset'))then
C
C----------------------------------------------------------------
C
C The following lagrit command will refine all elements
C int the specified element set.
C Syntax:
C refine/element_set /eltset get eltset_name
C refine/eltset /eltset get eltset_name
C
C Internally the two lagrit commands will be issued.
c The first command creates a point set (pset) of
c all nodes in the specified element set.
c
c pset/refine_eltset_pset_tmp_abc_xyz/eltset/eltset_name
c
C The second command refines all elements all of whose nodes
c are in the point set. We send to refine the
c criterion of 'constant' and
c test the value of imt. All nodes in the point set
c will satisfy this criterion because all material numbers
c are always >=0.
C
C refine/constant/imt1/linear/element/pset,get,p_fault/-1.,0.,0./exclusive
C
C Create a temporary pset from the eltset
C
cbuf='pset/refine_eltset_pset_tmp_abc_xyz/eltset/'//
* cmsgin(5)(1:icharlnf(cmsgin(5)))//
* '/ ; finish'
call dotaskx3d(cbuf,ierror)
C
C End of creating pset from eltset
C
C Refine on the pset
C
cbuf='refine/constant/imt1/linear/element/pset,get,'//
* 'refine_eltset_pset_tmp_abc_xyz/'//
* '-1.,0.,0./exclusive'//
* '/ ; finish'
call dotaskx3d(cbuf,ierror)
C
C Release temporary pset
C
cbuf = 'pset/refine_eltset_pset_tmp_abc_xyz/delete'//
* '/ ; finish'
call dotaskx3d(cbuf,ierror)
C
C----------------------------------------------------------------
C
elseif(nen.eq.nelmnen(ifelmtri).and.nef.eq.nelmnef(ifelmtri)) then
call refine3d(imsgin,xmsgin,cmsgin,msgtype,nwds,ierror)
elseif(nen.eq.nelmnen(ifelmqud).and.nef.eq.nelmnef(ifelmqud).and.
* nsd.eq.2) then
call refine3d(imsgin,xmsgin,cmsgin,msgtype,nwds,ierror)
elseif(nen.eq.nelmnen(ifelmtet).and.nef.eq.nelmnef(ifelmtet).and.
* nsd.eq.3) then
call refine3d(imsgin,xmsgin,cmsgin,msgtype,nwds,ierror)
elseif(nen.eq.nelmnen(ifelmhex).and.nef.eq.nelmnef(ifelmhex).and.
* nsd.eq.3) then
call refine3d(imsgin,xmsgin,cmsgin,msgtype,nwds,ierror)
else
write(logmess,9010) cmo(1:icharlnf(cmo))
9010 format('Refine on this CMO type is not implemented: ',a)
call writloga('default',1,logmess,0,ierror)
write(logmess,9015) mesh_type(1:8)
9015 format('mesh_type: ',a10)
call writloga('default',0,logmess,0,ierror)
write(logmess,9011) nen
9011 format('nodes_per_element: ',i10)
call writloga('default',0,logmess,0,ierror)
write(logmess,9012) nef
9012 format('faces_per_element: ',i10)
call writloga('default',0,logmess,0,ierror)
write(logmess,9014) nsd
9014 format('ndimensions_topo: ',i10)
call writloga('default',0,logmess,1,ierror)
C***** goto 9999
call refine3d(imsgin,xmsgin,cmsgin,msgtype,nwds,ierror)
endif
C
call cmo_get_info('nnodes',cmo,
* npoints,ilen,itype,ierror)
ipointi=npoints_save+1
ipointj=npoints
C
call cmo_set_info('ipointi',cmo,ipointi,1,1,icscode)
if (icscode .ne. 0) call x3d_error(isubname,'get_info_i')
call cmo_set_info('ipointj',cmo,ipointj,1,1,icscode)
if (icscode .ne. 0) call x3d_error(isubname,'get_info_i')
C
goto 9999
9999 continue
return
end
c
subroutine refine3d(imsgin,xmsgin,cmsgin,msgtype,nwds,ierror)
C
C
C #####################################################################
C
C PURPOSE -
C
C Mark tets that need to be refined according to the
C criterion given on the input line.
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
implicit none
C
C ######################################################################
C
C
include "local_element.h"
include "chydro.h"
C
C ######################################################################
C
integer nwds, imsgin(12), msgtype(12)
real*8 xmsgin(12)
character*(*) cmsgin(12)
C
integer ierror
integer npoints,ilen,itype,icscode,ntets,nen,nef,nsd,ierr,
* length,len,interp,mpno,ipt1,ipt2,ipt3,inclusive,
* it,if,i1,nee,nadd,ie,i2,j,isum,
* jt,jf,j1,j2,nadd1,ierrw,k,
* mbndry,ityp,ipointi,ipointj,ierrwrt,
* jadd,imesh_type,
* lenc,isum12,ier,npoints_save,
* naddelm,ierr2,ics,lenout,i
real*8 ref_distance,xsum,distance,xedge,yedge,zedge,
* xface,yface,zface
C
C#######################################################################
C
pointer (ipout,iout)
integer iout(*)
pointer (ipisetwd, isetwd)
pointer (ipimt1, imt1)
pointer (ipitp1, itp1)
pointer (ipicr1, icr1)
pointer (ipisn1, isn1)
integer isetwd(*),imt1(*),itp1(*),icr1(*),isn1(*)
pointer (ipitet, itet1)
pointer (ipjtet, jtet1)
integer itet1(*), jtet1(*)
C
pointer (ipitetclr, itetclr)
pointer (ipitettyp, itettyp)
pointer (ipitetoff, itetoff)
pointer (ipjtetoff, jtetoff)
integer itetclr(*), itettyp(*),
* itetoff(*), jtetoff(*)
C
pointer (ipnedge_bin, nedge_bin)
pointer (ipnedge_off, nedge_off)
integer nedge_bin(*), nedge_off(*)
C
pointer (ipitadd, itadd)
pointer (ipitadd2, itadd2)
pointer (ipifadd, ifadd)
pointer (ipieadd, ieadd)
pointer (ipitdone, itdone)
pointer (iplist, list)
integer itadd(*), ifadd(*), ieadd(*),
* list(*), itdone(*),itadd2(*)
pointer (ipiadd, iadd)
integer iadd(*)
pointer (ipiarray, iarray)
integer iarray(*)
pointer (ipmpary, mpary)
integer mpary(*)
pointer (ipiparent, iparent)
integer iparent(*)
pointer (ipintp,intp)
integer intp(*)
pointer (ipxadd, xadd)
pointer (ipyadd, yadd)
pointer (ipzadd, zadd)
real*8 xadd(*), yadd(*), zadd(*)
C
pointer (ipxic, xic)
pointer (ipyic, yic)
pointer (ipzic, zic)
real*8 xic(*),yic(*),zic(*)
C
pointer (ipxedge1, xedge1)
pointer (ipyedge1, yedge1)
pointer (ipzedge1, zedge1)
real*8 xedge1(*), yedge1(*), zedge1(*)
C
real*8 xrefine(3)
C
pointer (ipxfield, xfield)
real*8 xfield(*)
C
real*8 toldamage
integer coption_len,ioption,ierror_return,index,iprd
character*132 logmess,cbuf
character*32 ich1,ich2,ich3,ctype,crank,clen,cinter,cpers,cio
C
character*32 iblknam, cmo ,cmode, surfname,psetname
C
character*32 coption, itopo, cinterp, mesh_type
character*32 isubname,cnewx,cnewy,cnewz
integer icharlnf
C
C ######################################################################
C BEGIN begin
C
isubname='refine'
c
ierror = 0
c
c
c ************************************************************
coption=cmsgin(2)
coption_len=icharlnf(coption)
if(coption(1:coption_len).eq.'junction') ioption=1
if(coption(1:coption_len).eq.'constant') ioption=2
if(coption(1:coption_len).eq.'maxsize') ioption=3
if(coption(1:coption_len).eq.'minsize') ioption=-4
if(coption(1:coption_len).eq.'aspect') ioption=5
if(coption(1:coption_len).eq.'delta') ioption=6
if(coption(1:coption_len).eq.'grading') ioption=-7
if(coption(1:coption_len).eq.'lambda') ioption=8
if(coption(1:coption_len).eq.'lambdade') ioption=-9
if(coption(1:coption_len).eq.'testing') ioption=-10
if(coption(1:coption_len).eq.'errormax') ioption=-11
if(coption(1:coption_len).eq.'addpts') ioption=12
if(coption(1:coption_len).eq.'rmelements') ioption=-13
if(coption(1:coption_len).eq.'point') ioption=-14
if(coption(1:coption_len).eq.'edge') ioption=-15
if(coption(1:coption_len).eq.'face') ioption=-16
if(coption(1:coption_len).eq.'element' .or.
* coption(1:coption_len).eq.'tet') ioption=-17
if(coption(1:coption_len).eq.'rivara'.or.
* coption(1:coption_len).eq.'rivara_boundary'.or.
* coption(1:coption_len).eq.'rivara_truncated') ioption=18
if(coption(1:coption_len).eq.'cel') ioption=19
if(coption(1:coption_len).eq.'roughness') ioption=20
if(coption(1:coption_len).eq.'edge_list') ioption=21
if(coption(1:coption_len).eq.'interface') ioption=22
if(coption(1:coption_len).eq.'intrface') ioption=22
if(coption(1:coption_len).eq.'spawn') ioption=23
if(ioption.eq.0) then
write(logmess,'(a,a)') 'illegal refine option: ',
* coption(1:coption_len)
call writloga('default',0,logmess,0,ierrw)
goto 9999
endif
if(ioption.lt.0) then
write(logmess,'(a,a)') 'unimplemented option: ',
* coption(1:coption_len)
call writloga('default',0,logmess,0,ierrw)
goto 9999
endif
c AMR PRD - principal refine direction based on topology (het version)
c get prd value to pass into the amr refine command
c this is the original syntax for the refine command
c look for keyword 'amr' then iprd value after that
c iprd 0 = xyz using refine_hex_add()
c iprd 4 or 123 = xyz using refine_hex_prd()
c iprd 1 = x 2 = y 3 = z
c iprd 12 = xy 13 = xz 23 = yz
c improved syntax should include options for alternate
c topology or geometry and use of a refine level attribute
iprd=0
do i= 2, nwds-1
if (msgtype(i).eq.3) then
if(cmsgin(i)(1:3).eq.'amr') then
C
if(msgtype(i+1).eq.1) then
iprd=imsgin(i+1)
if (iprd.eq.123) iprd = 4
elseif(msgtype(i+1).eq.2) then
iprd=nint(xmsgin(i))
elseif(msgtype(i+1).eq.3) then
iprd=0
endif
iprd=max(0,min(23,iprd))
endif
endif
enddo
C
call cmo_get_name(cmo,ierror)
if(ierror.ne.0) then
write(logmess,'(a)') 'REFINE found bad mesh object'
call writloga('default',0,logmess,0,ierrw)
goto 9999
endif
C
call cmo_get_info('nnodes',cmo,npoints,ilen,itype,icscode)
call cmo_get_info('nelements',cmo,ntets,ilen,itype,icscode)
if(ntets.le.0) then
write(logmess,'(a)') 'mesh has no elements cannot refine '
call writloga('default',0,logmess,0,ierrw)
goto 9999
endif
call cmo_get_info('mbndry',cmo,mbndry,ilen,itype,icscode)
call cmo_get_info('nodes_per_element',cmo,nen,ilen,itype,icscode)
call cmo_get_info('faces_per_element',cmo,nef,ilen,itype,icscode)
call cmo_get_info('edges_per_element',cmo,nee,ilen,itype,icscode)
call cmo_get_info('ndimensions_topo',cmo,nsd,ilen,itype,icscode)
call cmo_get_info('isetwd',cmo,
* ipisetwd,ilen,ityp,icscode)
call cmo_get_info('imt1',cmo,ipimt1,ilen,ityp,ierr)
call cmo_get_info('itp1',cmo,ipitp1,ilen,ityp,ierr)
call cmo_get_info('icr1',cmo,ipicr1,ilen,ityp,ierr)
call cmo_get_info('isn1',cmo,ipisn1,ilen,ityp,ierr)
call cmo_get_info('xic',cmo,ipxic,ilen,ityp,ierr)
call cmo_get_info('yic',cmo,ipyic,ilen,ityp,ierr)
call cmo_get_info('zic',cmo,ipzic,ilen,ityp,ierr)
call cmo_get_info('itetclr',cmo,
* ipitetclr,ilen,ityp,ierr)
call cmo_get_info('itettyp',cmo,
* ipitettyp,ilen,ityp,ierr)
call cmo_get_info('itetoff',cmo,
* ipitetoff,ilen,ityp,ierr)
call cmo_get_info('jtetoff',cmo,
* ipjtetoff,ilen,ityp,ierr)
call cmo_get_info('itet',cmo,ipitet,ilen,ityp,ierr)
call cmo_get_info('jtet',cmo,ipjtet,ilen,ityp,ierr)
call cmo_get_intinfo('idebug',cmo,idebug,ilen,ityp,ierr)
C
C
C ************************************************************
C
C Get the parents for each node.
C
length=npoints
call mmgetblk("iparent",isubname,ipiparent,length,1,icscode)
call unpackpc(npoints,itp1,isn1,iparent)
C
len=icharlnf(cmsgin(4))
cinterp(1:len)=cmsgin(4)
interp=1
if(cinterp(1:6).eq.'linear') interp=1
if(cinterp(1:3).eq.'log') interp=2
if(cinterp(1:5).eq.'asinh') interp=3
itopo=cmsgin(5)
len=icharlnf(itopo)
length=npoints
call mmgetblk('mpary' ,isubname,ipmpary,length,1,icscode)
ich1=' '
ich2=' '
ich3=' '
mpno=0
if(msgtype(6).eq.1) then
ipt1=imsgin(6)
ipt2=imsgin(7)
ipt3=imsgin(8)
C
call cmo_get_info('ipointi',cmo,
* ipointi,ilen,ityp,icscode)
if (icscode .ne. 0) call x3d_error(isubname,'get_info_i')
call cmo_get_info('ipointj',cmo,
* ipointj,ilen,ityp,icscode)
if (icscode .ne. 0) call x3d_error(isubname,'get_info_i')
C
if(ipt1.eq.0) ipt1=ipointi
if(ipt2.eq.0) ipt2=ipointj
if(ipt3.eq.0) ipt3=1
ich3='-def-'
call pntlimn(ipt1,ipt2,ipt3,ipmpary,mpno,
* npoints,isetwd,itp1)
else
ich1=cmsgin(6)
ich2=cmsgin(7)
ich3=cmsgin(8)
call pntlimc(ich1,ich2,ich3,ipmpary,mpno,
* npoints,isetwd,itp1)
endif
C
if (msgtype(9).eq.3.and.coption.eq.'spawn') then
cnewx=cmsgin(9)
cnewy=cmsgin(10)
cnewz=cmsgin(11)
else
xrefine(1)=xmsgin(9)
if (msgtype(10).eq.3.and.coption.eq.'roughness')
* surfname=cmsgin(10)
xrefine(2)=xmsgin(10)
xrefine(3)=xmsgin(11)
endif
C
inclusive=0
if(nwds.ge.12 .and.
* cmsgin(12)(1:9).eq.'inclusive') inclusive=1
C
C
C Branch on option
C
if(coption(1:coption_len).eq.'spawn') then
call refine_spawn_lg(mpno,mpary,cnewx,cnewy,cnewz,ierror)
elseif(coption(1:coption_len).eq.'cel'
* .and.itopo(1:len).eq.'edge') then
call get_epsilon('epsilonl',toldamage)
call cel(cmo,xrefine(1),toldamage,mpary,mpno,inclusive,
* ich3,ierror)
write(cbuf,'(a,e16.8,a)')'recon/0/',toldamage
& ,'/ ; finish'
call dotaskx3d(cbuf,ierr)
go to 9998
elseif(coption(1:coption_len).eq.'rivara_truncated'
* .and.itopo(1:len).eq.'edge') then
call get_epsilon('epsilonl',toldamage)
cmode='truncated'
call cel_chain(cmo,xrefine(1),toldamage,mpary,mpno,inclusive,
* ich3,cmode,ierror)
write(cbuf,'(a,e16.8,a)')'recon/0/',toldamage
& ,'/ ; finish'
call dotaskx3d(cbuf,ierr)
go to 9998
elseif(coption(1:coption_len).eq.'rivara_boundary'
* .and.itopo(1:len).eq.'edge') then
call get_epsilon('epsilonl',toldamage)
cmode='boundary'
call cel_chain(cmo,xrefine(1),toldamage,mpary,mpno,inclusive,
* ich3,cmode,ierror)
write(cbuf,'(a,e16.8,a)')'recon/0/',toldamage
& ,'/ ; finish'
call dotaskx3d(cbuf,ierr)
go to 9998
elseif(coption(1:coption_len).eq.'rivara'
* .and.itopo(1:len).eq.'edge') then
call get_epsilon('epsilonl',toldamage)
cmode='full'
call cel_chain(cmo,xrefine(1),toldamage,mpary,mpno,inclusive,
* ich3,cmode,ierror)
write(cbuf,'(a,e16.8,a)')'recon/0/',toldamage
& ,'/ ; finish'
call dotaskx3d(cbuf,ierr)
go to 9998
elseif(coption(1:coption_len).eq.'roughness'
* .and.itopo(1:len).eq.'edge') then
call get_epsilon('epsilonl',toldamage)
if (nsd.ne.2.or.surfname(1:icharlnf(surfname)).ne.'-def-') then
cbuf = 'pset/-rruf-/surface/'//
* surfname(1:icharlnf(surfname))//'/'//
* cmsgin(6)(1:icharlnf(cmsgin(6)))//'/'//
* cmsgin(7)(1:icharlnf(cmsgin(7)))//'/'//
* cmsgin(8)(1:icharlnf(cmsgin(8)))//
* '/ ; finish'
call dotaskx3d(cbuf,ierr)
psetname='-rruf-'
else
psetname='-def-'
endif
call mmgetblk('intp',isubname,ipintp,npoints,1,icscode)
do i=1,mpno
intp(mpary(i))=1
enddo
cmode='truncated'
call cer_chain(cmo,xrefine(1),toldamage,mpary,mpno,inclusive,
* psetname,cmode,ierror)
go to 9998
elseif(coption(1:coption_len).eq.'edge_list'
* .and.itopo(1:len).eq.'edge') then
call refine_edge_list_lg(nwds,imsgin,xmsgin,cmsgin,ierror)
go to 9998
elseif((coption(1:coption_len).eq.'interface'.or.
* coption(1:coption_len).eq.'intrface').and.
* itopo(1:len).eq.'edge') then
call refine_interface_elements_lg(imsgin,xmsgin,cmsgin
* ,msgtype,nwds,ierror)
go to 9998
endif
C
C
if(coption(1:coption_len).eq.'addpts') then
length=mpno
call mmgetblk("iadd",isubname,ipiadd,length,1,icscode)
call mmgetblk("xadd",isubname,ipxadd,length,2,icscode)
call mmgetblk("yadd",isubname,ipyadd,length,2,icscode)
call mmgetblk("zadd",isubname,ipzadd,length,2,icscode)
nadd=mpno
do i=1,mpno
i1=mpary(i)
if(imt1(i1).lt.0) then
iadd(i)=0
itp1(i1)=ifitpdud
elseif(imt1(i1).eq.0) then
iadd(i)=-i1
elseif(imt1(i1).gt.0) then
iadd(i)=i1
endif
xadd(i)=xic(i1)
yadd(i)=yic(i1)
zadd(i)=zic(i1)
enddo
if(idebug .ge. 3)then
write(logmess,'(a,i9)')
* 'refine addpts: #candidates = ',mpno
call writloga('default',0,logmess,0,ierrw)
endif
call refine_add_pts(cmo,itopo,
* mpno,ipiadd,ipxadd,ipyadd,ipzadd)
goto 9998
endif
C
if(itopo(1:len).eq.'tet'.or.
* itopo(1:len).eq.'element') then
write(logmess,'(a)') "refine elements: "
call writloga('default',0,logmess,0,ierrw)
if(coption(1:coption_len).ne.'addpts' .and.
* coption(1:coption_len).ne.'rmelements') then
C
C ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
C CHECK TO SEE IF THE SPECIFIED FIELD EXISTS
C
call cmo_get_name(cmo,ierror)
len=icharlnf(cmsgin(3))
iblknam=' '
iblknam(1:len)=cmsgin(3)
if(len.eq.3) then
if(iblknam(1:3).eq.'itp') iblknam='itp1'
if(iblknam(1:3).eq.'imt') iblknam='imt1'
if(iblknam(1:3).eq.'icr') iblknam='icr1'
if(iblknam(1:3).eq.'isn') iblknam='isn1'
len=icharlnf(iblknam)
endif
call mmfindbk(iblknam,cmo,ipout,lenout,icscode)
if(icscode.eq.0) then
ctype=' '
call cmo_get_attparam(iblknam,cmo,index,ctype,
* crank,clen,cinter,cpers,cio,ierror_return)
lenc=icharlnf(ctype)
if(ctype(1:lenc).eq.'VINT') then
call mmfindbk(iblknam,cmo,ipiarray,lenout,icscode)
length=npoints
call mmgetblk('xfield',isubname,ipxfield,length,2,ics)
do i=1,npoints
xfield(i)=iarray(i)
enddo
elseif(ctype(1:lenc).eq.'VDOUBLE') then
call mmfindbk(iblknam,cmo,ipxfield,lenout,icscode)
endif
else
write(logmess,'(a,a)') 'Field does not exist: ',
* iblknam(1:len)
call writloga('default',0,logmess,0,ierrwrt)
goto 9998
endif
C
C ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
C
length=nee*ntets
call mmgetblk("itadd",isubname,ipitadd,length,1,icscode)
call mmgetblk("ifadd",isubname,ipifadd,length,1,icscode)
call mmgetblk("ieadd",isubname,ipieadd,length,1,icscode)
call mmgetblk("iadd",isubname,ipiadd,length,1,icscode)
call mmgetblk("xadd",isubname,ipxadd,length,2,icscode)
call mmgetblk("yadd",isubname,ipyadd,length,2,icscode)
call mmgetblk("zadd",isubname,ipzadd,length,2,icscode)
nadd=0
call gradient(itopo,coption,
* inclusive,
* npoints,ntets,
* ipxfield,interp,
* xrefine,
* mpno,ipmpary,
* nadd,ipitadd,ipifadd,ipieadd)
elseif(coption(1:coption_len).eq.'rmelements') then
length=ntets
call mmgetblk("itadd",isubname,ipitadd,length,1,icscode)
length=mpno
call mmgetblk("iadd",isubname,ipiadd,length,1,icscode)
call mmgetblk("xadd",isubname,ipxadd,length,2,icscode)
call mmgetblk("yadd",isubname,ipyadd,length,2,icscode)
call mmgetblk("zadd",isubname,ipzadd,length,2,icscode)
nadd=mpno
do i=1,mpno
i1=mpary(i)
iadd(i)=0
xadd(i)=xic(i1)
yadd(i)=yic(i1)
zadd(i)=zic(i1)
enddo
call table_element(cmo,
& ipxadd,ipyadd,ipzadd,nadd,
& ipitadd,
& ierr2)
naddelm=0
do i=1,nadd
if(itadd(i).gt.0) then
naddelm=naddelm+1
itadd(naddelm)=itadd(i)
iadd(naddelm)=0
xadd(naddelm)=xadd(i)
yadd(naddelm)=yadd(i)
zadd(naddelm)=zadd(i)
endif
enddo
nadd=naddelm
endif
if(coption(1:coption_len).eq.'minsize' .or.
* coption(1:coption_len).eq.'lambdade' .or.
* coption(1:coption_len).eq.'rmelements') then
write(logmess,201) coption(1:coption_len)
201 format('Option not implemented ',a)
call writloga('default',0,logmess,0,ierrw)
go to 9999
else
do i=1,nadd
it=itadd(i)
xsum=0.0
iadd(i)=0
xadd(i)=0.0
yadd(i)=0.0
zadd(i)=0.0
do j=1,nelmnen(itettyp(it))
i1=itet1(itetoff(it)+j)
xsum=xsum+1.0
xadd(i)=xadd(i)+xic(i1)
yadd(i)=yadd(i)+yic(i1)
zadd(i)=zadd(i)+zic(i1)
enddo
xadd(i)=xadd(i)/xsum
yadd(i)=yadd(i)/xsum
zadd(i)=zadd(i)/xsum
enddo
c Write type of elements to refine
mesh_type = 'notset'
call cmo_get_mesh_type(cmo,mesh_type,imesh_type,ier)
if (ier.ne.0 .or. imesh_type.le.0) then
write(logmess,'(a,a,a,a)')'WARNING: Undefined mesh type: ',
> mesh_type(1:8),' for ',cmo
call writloga('default',0,logmess,1,ierrw)
else
write(logmess,'(a,a,i10)')
> 'refine ',mesh_type(1:8)//': ',nadd
call writloga('default',0,logmess,0,ierrw)
endif
if(nadd.gt.0) then
npoints_save=npoints
call refine_element_add(cmo,
* iprd, nadd,
* ipitadd,
* ipiadd,ipxadd,ipyadd,ipzadd)
call cmo_get_name(cmo,ierror)
call cmo_get_info('nnodes',cmo,npoints,ilen,ityp,ier)
call cmo_get_info('nelements',cmo,ntets,ilen,ityp,ier)
call cmo_get_info('itetclr',cmo,ipitetclr,ilen,
* ityp,ier)
call cmo_get_info('jtet',cmo,ipjtet,ilen,ityp,ier)
if(npoints_save.ne.npoints) then
ipointi=npoints_save+1
ipointj=npoints
call cmo_set_info('ipointi',cmo,
& ipointi,1,1,icscode)
if (icscode .ne. 0)
& call x3d_error(isubname,'get_info_i')
call cmo_set_info('ipointj',cmo,
& ipointj,1,1,icscode)
if (icscode .ne. 0)
& call x3d_error(isubname,'get_info_i')
endif
endif
endif
call mmrelblk("itadd",isubname,ipitadd,icscode)
call mmrelblk("iadd",isubname,ipiadd,icscode)
call mmrelblk("xadd",isubname,ipxadd,icscode)
call mmrelblk("yadd",isubname,ipyadd,icscode)
call mmrelblk("zadd",isubname,ipzadd,icscode)
elseif(itopo(1:len).eq.'face') then
write(logmess,'(a)') "refine faces: "
call writloga('default',0,logmess,0,ierrw)
C
C ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
C CHECK TO SEE IF THE SPECIFIED FIELD EXISTS
C
call cmo_get_name(cmo,ierror)
len=icharlnf(cmsgin(3))
iblknam=' '
iblknam(1:len)=cmsgin(3)
if(len.eq.3) then
if(iblknam(1:3).eq.'itp') iblknam='itp1'
if(iblknam(1:3).eq.'imt') iblknam='imt1'
if(iblknam(1:3).eq.'icr') iblknam='icr1'
if(iblknam(1:3).eq.'isn') iblknam='isn1'
len=icharlnf(iblknam)
endif
call mmfindbk(iblknam,cmo,ipout,lenout,icscode)
if(icscode.eq.0) then
call cmo_get_attparam(iblknam,cmo,index,ctype,
* crank,clen,cinter,cpers,cio,ierror_return)
lenc=icharlnf(ctype)
if(ctype(1:lenc).eq.'VINT') then
call mmfindbk(iblknam,cmo,ipiarray,lenout,icscode)
length=npoints
call mmgetblk('xfield',isubname,ipxfield,length,2,ics)
do i=1,npoints
xfield(i)=iarray(i)
enddo
elseif(ctype(1:lenc).eq.'VDOUBLE') then
call mmfindbk(iblknam,cmo,ipxfield,lenout,icscode)
endif
else
write(logmess,'(a,a)') 'Field does not exist: ',
* iblknam(1:len)
call writloga('default',0,logmess,0,ierrwrt)
goto 9998
endif
C
C ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
C
length=nef*ntets
call mmgetblk("itdone",isubname,ipitdone,length,1,
* icscode)
call mmgetblk("list",isubname,iplist,length,1,icscode)
call mmgetblk("itadd",isubname,ipitadd,length,1,icscode)
call mmgetblk("ifadd",isubname,ipifadd,length,1,icscode)
call mmgetblk("ieadd",isubname,ipieadd,length,1,icscode)
call mmgetblk("iadd",isubname,ipiadd,length,1,icscode)
call mmgetblk("xadd",isubname,ipxadd,length,2,icscode)
call mmgetblk("yadd",isubname,ipyadd,length,2,icscode)
call mmgetblk("zadd",isubname,ipzadd,length,2,icscode)
nadd=0
call gradient(itopo,coption,
* inclusive,
* npoints,ntets,
* ipxfield,interp,
* xrefine,
* mpno,ipmpary,
* nadd,ipitadd,ipifadd,ipieadd)
if(coption(1:coption_len).eq.'minsize' .or.
* coption(1:coption_len).eq.'lambdade') then
else
do it=1,ntets
do i=1,nelmnef(itettyp(it))
itdone(jtetoff(it)+i)=0
enddo
enddo
nadd1=0
do i=1,nadd
it=itadd(i)
if=ifadd(i)
if(nadd1.gt.0) then
if(jtet1(jtetoff(it)+if).gt.0 .and.
* jtet1(jtetoff(it)+if).lt.mbndry) then
jt=1+(jtet1(jtetoff(it)+if)-1)/nef
jf=jtet1(jtetoff(it)+if)-
* nef*(jt-1)
if(itdone(jtetoff(jt)+jf).ne.0) goto 200
elseif(jtet1(jtetoff(it)+if).gt.mbndry) then
jt=1+(jtet1(jtetoff(it)+if)-mbndry-1) /
* nef
jf=jtet1(jtetoff(it)+if)-
* mbndry-
* nef*(jt-1)
if(itdone(jtetoff(jt)+jf).ne.0) goto 200
endif
endif
xsum=0.0
xface=0.0
yface=0.0
zface=0.0
do j=1,ielmface0(if,itettyp(it))
i1=itet1(itetoff(it)+
* ielmface1(j,if,itettyp(it)))
xsum=xsum+1.0
xface=xface+xic(i1)
yface=yface+yic(i1)
zface=zface+zic(i1)
enddo
xface=xface/xsum
yface=yface/xsum
zface=zface/xsum
nadd1=nadd1+1
itadd(nadd1)=it
ifadd(nadd1)=if
iadd(nadd1)=0
xadd(nadd1)=xface
yadd(nadd1)=yface
zadd(nadd1)=zface
itdone(jtetoff(it)+if)=nadd1
200 continue
enddo
nadd=nadd1
write(logmess,'(a,i10)') "refine faces: ",nadd
call writloga('default',0,logmess,0,ierrw)
if(nadd.gt.0) then
npoints_save=npoints
call refine_face_add(cmo,nadd,ipitadd,ipifadd,
* ipiadd,ipxadd,ipyadd,ipzadd)
call cmo_get_name(cmo,ierror)
call cmo_get_info('nnodes',cmo,npoints,ilen,ityp,ier)
call cmo_get_info('nelements',cmo,ntets,ilen,ityp,ier)
call cmo_get_info('itetclr',cmo,ipitetclr,ilen,
* ityp,ier)
call cmo_get_info('jtet',cmo,ipjtet,ilen,ityp,ier)
if(npoints_save.ne.npoints) then
ipointi=npoints_save+1
ipointj=npoints
call cmo_set_info('ipointi',cmo,
& ipointi,1,1,icscode)
if (icscode .ne. 0)
& call x3d_error(isubname,'get_info_i')
call cmo_set_info('ipointj',cmo,
& ipointj,1,1,icscode)
if (icscode .ne. 0)
& call x3d_error(isubname,'get_info_i')
endif
endif
endif
call mmrelblk("itdone",isubname,ipitdone,icscode)
call mmrelblk("itadd",isubname,ipitadd,icscode)
call mmrelblk("ifadd",isubname,ipifadd,icscode)
call mmrelblk("list",isubname,iplist,icscode)
call mmrelblk("iadd",isubname,ipiadd,icscode)
call mmrelblk("xadd",isubname,ipxadd,icscode)
call mmrelblk("yadd",isubname,ipyadd,icscode)
call mmrelblk("zadd",isubname,ipzadd,icscode)
elseif(itopo(1:len).eq.'edge') then
write(logmess,'(a)') "refine edges: "
call writloga('default',0,logmess,0,ierrw)
C
C ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
C CHECK TO SEE IF THE SPECIFIED FIELD EXISTS
C
call cmo_get_name(cmo,ierror)
len=icharlnf(cmsgin(3))
iblknam=' '
iblknam(1:len)=cmsgin(3)
if(len.eq.3) then
if(iblknam(1:3).eq.'itp') iblknam='itp1'
if(iblknam(1:3).eq.'imt') iblknam='imt1'
if(iblknam(1:3).eq.'icr') iblknam='icr1'
if(iblknam(1:3).eq.'isn') iblknam='isn1'
len=icharlnf(iblknam)
endif
call mmfindbk(iblknam,cmo,ipout,lenout,icscode)
if(icscode.eq.0) then
call cmo_get_attparam(iblknam,cmo,index,ctype,
* crank,clen,cinter,cpers,cio,ierror_return)
lenc=icharlnf(ctype)
if(ctype(1:lenc).eq.'VINT') then
call mmfindbk(iblknam,cmo,ipiarray,lenout,icscode)
length=npoints
call mmgetblk('xfield',isubname,ipxfield,length,2,ics)
do i=1,npoints
xfield(i)=iarray(i)
enddo
elseif(ctype(1:lenc).eq.'VDOUBLE') then
call mmfindbk(iblknam,cmo,ipxfield,lenout,icscode)
endif
else
write(logmess,'(a,a)') 'Field does not exist: ',
* iblknam(1:len)
call writloga('default',0,logmess,0,ierrwrt)
goto 9998
endif
C
C ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
C
length=nee*ntets
call mmgetblk("itadd",isubname,ipitadd,length,1,icscode)
call mmgetblk("ifadd",isubname,ipifadd,length,1,icscode)
call mmgetblk("ieadd",isubname,ipieadd,length,1,icscode)
call mmgetblk("list",isubname,iplist,length,1,icscode)
call mmgetblk("iadd",isubname,ipiadd,length,1,icscode)
call mmgetblk("xadd",isubname,ipxadd,length,2,icscode)
call mmgetblk("yadd",isubname,ipyadd,length,2,icscode)
call mmgetblk("zadd",isubname,ipzadd,length,2,icscode)
nadd=0
call gradient(itopo,coption,
* inclusive,
* npoints,ntets,
* ipxfield,interp,
* xrefine,
* mpno,ipmpary,
* nadd,ipitadd,ipifadd,ipieadd)
if(coption(1:coption_len).eq.'minsize' .or.
* coption(1:coption_len).eq.'lambdade') then
else
length=2*npoints
call mmgetblk('nedge_bin',isubname,
* ipnedge_bin,length,1,icscode)
call mmgetblk('nedge_off',isubname,
* ipnedge_off,length,1,icscode)
do i=1,2*npoints
nedge_bin(i)=0
nedge_off(i)=0
enddo
do i=1,nadd
it=itadd(i)
ie=ieadd(i)
i1=itet1(itetoff(it)+ielmedge1(1,ie,itettyp(it)))
i2=itet1(itetoff(it)+ielmedge1(2,ie,itettyp(it)))
isum12=iparent(i1)+iparent(i2)
nedge_bin(isum12)=nedge_bin(isum12)+1
enddo
isum=0
do i=1,2*npoints
if(nedge_bin(i).gt.0) then
nedge_off(i)=isum
isum=isum+nedge_bin(i)
endif
nedge_bin(i)=0
enddo
length=isum+1
call mmgetblk('xedge1',isubname,
* ipxedge1,length,2,icscode)
call mmgetblk('yedge1',isubname,
* ipyedge1,length,2,icscode)
call mmgetblk('zedge1',isubname,
* ipzedge1,length,2,icscode)
do i=1,length
xedge1(i)=0.0
yedge1(i)=0.0
zedge1(i)=0.0
enddo
call get_epsilon('epsilonl',ref_distance)
nadd1=0
do i=1,nadd
it=itadd(i)
ie=ieadd(i)
j1=itet1(itetoff(it)+ielmedge1(1,ie,itettyp(it)))
j2=itet1(itetoff(it)+ielmedge1(2,ie,itettyp(it)))
xedge=(xic(j1)+xic(j2))/2.0d+00
yedge=(yic(j1)+yic(j2))/2.0d+00
zedge=(zic(j1)+zic(j2))/2.0d+00
isum12=iparent(j1)+iparent(j2)
if(nedge_bin(isum12).gt.0) then
do jadd=nedge_off(isum12)+1,
* nedge_off(isum12)+nedge_bin(isum12)
distance=(xedge-xedge1(jadd))**2 +
* (yedge-yedge1(jadd))**2 +
* (zedge-zedge1(jadd))**2
if(distance.lt.ref_distance) goto 300
enddo
endif
nedge_bin(isum12)=nedge_bin(isum12)+1
xedge1(nedge_off(isum12)+nedge_bin(isum12))=xedge
yedge1(nedge_off(isum12)+nedge_bin(isum12))=yedge
zedge1(nedge_off(isum12)+nedge_bin(isum12))=zedge
nadd1=nadd1+1
itadd(nadd1)=it
ieadd(nadd1)=ie
iadd(nadd1)=0
xadd(nadd1)=xedge
yadd(nadd1)=yedge
zadd(nadd1)=zedge
300 continue
enddo
nadd=nadd1
call mmrelblk('nedge_bin',isubname,ipnedge_bin,icscode)
call mmrelblk('nedge_off',isubname,ipnedge_off,icscode)
call mmrelblk('xedge1',isubname,ipxedge1,icscode)
call mmrelblk('yedge1',isubname,ipyedge1,icscode)
call mmrelblk('zedge1',isubname,ipzedge1,icscode)
write(logmess,'(a,i10)') "Refine edges: ",nadd
call writloga('default',0,logmess,0,ierrw)
if(nadd.gt.0) then
npoints_save=npoints
call refine_edge_add(cmo,nadd,ipitadd,ipieadd,
* ipiadd,ipxadd,ipyadd,ipzadd)
call cmo_get_name(cmo,ierror)
call cmo_get_info('nnodes',cmo,npoints,ilen,ityp,ier)
call cmo_get_info('nelements',cmo,ntets,ilen,ityp,ier)
call cmo_get_info('itetclr',cmo,ipitetclr,ilen,
* ityp,ier)
call cmo_get_info('jtet',cmo,ipjtet,ilen,ityp,ier)
if(npoints_save.ne.npoints) then
ipointi=npoints_save+1
ipointj=npoints
call cmo_set_info('ipointi',cmo,
& ipointi,1,1,icscode)
if (icscode .ne. 0)
& call x3d_error(isubname,'get_info_i')
call cmo_set_info('ipointj',cmo,
& ipointj,1,1,icscode)
if (icscode .ne. 0)
& call x3d_error(isubname,'get_info_i')
endif
endif
endif
call mmrelblk("itadd",isubname,ipitadd,icscode)
call mmrelblk("ieadd",isubname,ipieadd,icscode)
call mmrelblk("list",isubname,iplist,icscode)
call mmrelblk("iadd",isubname,ipiadd,icscode)
call mmrelblk("xadd",isubname,ipxadd,icscode)
call mmrelblk("yadd",isubname,ipyadd,icscode)
call mmrelblk("zadd",isubname,ipzadd,icscode)
elseif(itopo(1:len).eq.'faceedge') then
write(logmess,'(a)') "refine face edges: "
call writloga('default',0,logmess,0,ierrw)
C
C ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
C CHECK TO SEE IF THE SPECIFIED FIELD EXISTS
C
call cmo_get_name(cmo,ierror)
len=icharlnf(cmsgin(3))
iblknam=' '
iblknam(1:len)=cmsgin(3)
if(len.eq.3) then
if(iblknam(1:3).eq.'itp') iblknam='itp1'
if(iblknam(1:3).eq.'imt') iblknam='imt1'
if(iblknam(1:3).eq.'icr') iblknam='icr1'
if(iblknam(1:3).eq.'isn') iblknam='isn1'
len=icharlnf(iblknam)
endif
call mmfindbk(iblknam,cmo,ipout,lenout,icscode)
if(icscode.eq.0) then
call cmo_get_attparam(iblknam,cmo,index,ctype,
* crank,clen,cinter,cpers,cio,ierror_return)
lenc=icharlnf(ctype)
if(ctype(1:lenc).eq.'VINT') then
call mmfindbk(iblknam,cmo,ipiarray,lenout,icscode)
length=npoints
call mmgetblk('xfield',isubname,ipxfield,length,2,ics)
do i=1,npoints
xfield(i)=iarray(i)
enddo
elseif(ctype(1:lenc).eq.'VDOUBLE') then
call mmfindbk(iblknam,cmo,ipxfield,lenout,icscode)
endif
else
write(logmess,'(a,a)') 'Field does not exist: ',
* iblknam(1:len)
call writloga('default',0,logmess,0,ierrwrt)
goto 9998
endif
C
C ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
C
length=12*ntets
call mmgetblk("itadd",isubname,ipitadd,length,1,icscode)
call mmgetblk("ifadd",isubname,ipifadd,length,1,icscode)
call mmgetblk("ieadd",isubname,ipieadd,length,1,icscode)
call mmgetblk("itadd2",isubname,ipitadd2,length,1,icscode)
call mmgetblk("iadd",isubname,ipiadd,length,1,icscode)
call mmgetblk("xadd",isubname,ipxadd,length,2,icscode)
call mmgetblk("yadd",isubname,ipyadd,length,2,icscode)
call mmgetblk("zadd",isubname,ipzadd,length,2,icscode)
nadd=0
call gradient(itopo,coption,
* inclusive,
* npoints,ntets,
* ipxfield,interp,
* xrefine,
* mpno,ipmpary,
* nadd,ipitadd2,ipifadd,ipieadd)
if(coption(1:coption_len).eq.'minsize' .or.
* coption(1:coption_len).eq.'lambdade') then
else
call get_epsilon('epsilonl',ref_distance)
nadd1=0
do i=1,nadd
it=itadd2(i)
if=ifadd(i)
do k=1,ielmface0(if,itettyp(it))
ie=ielmface2(k,if,itettyp(it))
if(ie.le.0) go to 301
j1=itet1(itetoff(it)+ielmedge1(1,ie,itettyp(it)))
j2=itet1(itetoff(it)+ielmedge1(2,ie,itettyp(it)))
xedge=(xic(j1)+xic(j2))/2.0d+00
yedge=(yic(j1)+yic(j2))/2.0d+00
zedge=(zic(j1)+zic(j2))/2.0d+00
if(nadd1.gt.0) then
do jadd=1,nadd1
distance=(xedge-xadd(jadd))**2 +
* (yedge-yadd(jadd))**2 +
* (zedge-zadd(jadd))**2
if(distance.lt.ref_distance) goto 301
enddo
endif
nadd1=nadd1+1
itadd(nadd1)=it
ieadd(nadd1)=ie
iadd(nadd1)=0
xadd(nadd1)=xedge
yadd(nadd1)=yedge
zadd(nadd1)=zedge
301 continue
enddo
enddo
nadd=nadd1
write(logmess,'(a,i10)') "Refine edges: ",nadd
call writloga('default',0,logmess,0,ierrw)
if(nadd.gt.0) then
npoints_save=npoints
call refine_edge_add(cmo,nadd,ipitadd,ipieadd,
* ipiadd,ipxadd,ipyadd,ipzadd)
call cmo_get_name(cmo,ierror)
call cmo_get_info('nnodes',cmo,npoints,ilen,itype,ier)
call cmo_get_info('nelements',cmo,ntets,ilen,itype,ier)
call cmo_get_info('itetclr',cmo,ipitetclr,ilen,
* ityp,ier)
call cmo_get_info('jtet',cmo,ipjtet,ilen,itype,ier)
if(npoints_save.ne.npoints) then
ipointi=npoints_save+1
ipointj=npoints
call cmo_set_info('ipointi',cmo,
& ipointi,1,1,icscode)
if (icscode .ne. 0)
& call x3d_error(isubname,'get_info_i')
call cmo_set_info('ipointj',cmo,
& ipointj,1,1,icscode)
if (icscode .ne. 0)
& call x3d_error(isubname,'get_info_i')
endif
endif
endif
call mmrelblk("itadd",isubname,ipitadd,icscode)
call mmrelblk("ieadd",isubname,ipieadd,icscode)
call mmrelblk("iadd",isubname,ipiadd,icscode)
call mmrelblk("xadd",isubname,ipxadd,icscode)
call mmrelblk("yadd",isubname,ipyadd,icscode)
call mmrelblk("zadd",isubname,ipzadd,icscode)
elseif(itopo(1:len).eq.'tetedge') then
write(logmess,'(a)') "refine tet edges: "
call writloga('default',0,logmess,0,ierrw)
C
C ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
C CHECK TO SEE IF THE SPECIFIED FIELD EXISTS
C
call cmo_get_name(cmo,ierror)
len=icharlnf(cmsgin(3))
iblknam=' '
iblknam(1:len)=cmsgin(3)
if(len.eq.3) then
if(iblknam(1:3).eq.'itp') iblknam='itp1'
if(iblknam(1:3).eq.'imt') iblknam='imt1'
if(iblknam(1:3).eq.'icr') iblknam='icr1'
if(iblknam(1:3).eq.'isn') iblknam='isn1'
len=icharlnf(iblknam)
endif
call mmfindbk(iblknam,cmo,ipout,lenout,icscode)
if(icscode.eq.0) then
call cmo_get_attparam(iblknam,cmo,index,ctype,
* crank,clen,cinter,cpers,cio,ierror_return)
lenc=icharlnf(ctype)
if(ctype(1:lenc).eq.'VINT') then
call mmfindbk(iblknam,cmo,ipiarray,lenout,icscode)
length=npoints
call mmgetblk('xfield',isubname,ipxfield,length,2,ics)
do i=1,npoints
xfield(i)=iarray(i)
enddo
elseif(ctype(1:lenc).eq.'VDOUBLE') then
call mmfindbk(iblknam,cmo,ipxfield,lenout,icscode)
endif
else
write(logmess,'(a,a)') 'Field does not exist: ',
* iblknam(1:len)
call writloga('default',0,logmess,0,ierrwrt)
goto 9998
endif
C
C ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
C
length=nee*ntets
call mmgetblk("itadd",isubname,ipitadd,length,1,icscode)
call mmgetblk("ifadd",isubname,ipifadd,length,1,icscode)
call mmgetblk("ieadd",isubname,ipieadd,length,1,icscode)
call mmgetblk("iadd",isubname,ipiadd,length,1,icscode)
call mmgetblk("xadd",isubname,ipxadd,length,2,icscode)
call mmgetblk("yadd",isubname,ipyadd,length,2,icscode)
call mmgetblk("zadd",isubname,ipzadd,length,2,icscode)
nadd=0
c
c note we use space for faces (ifadd) to store element
c numbers - itadd will be filled later
c
call gradient(itopo,coption,
* inclusive,
* npoints,ntets,
* ipxfield,interp,
* xrefine,
* mpno,ipmpary,
* nadd,ipifadd,ipitadd,ipieadd)
if(coption(1:coption_len).eq.'minsize' .or.
* coption(1:coption_len).eq.'rmelements') then
else
call get_epsilon('epsilonl',ref_distance)
nadd1=0
do i=1,nadd
it=ifadd(i)
do j=1,nelmnee(itettyp(it))
ie=j
j1=itet1(itetoff(it)+ielmedge1(1,ie,itettyp(it)))
j2=itet1(itetoff(it)+ielmedge1(2,ie,itettyp(it)))
xedge=(xic(j1)+xic(j2))/2.0d+00
yedge=(yic(j1)+yic(j2))/2.0d+00
zedge=(zic(j1)+zic(j2))/2.0d+00
if(nadd1.gt.0) then
do jadd=1,nadd1
distance=(xedge-xadd(jadd))**2 +
* (yedge-yadd(jadd))**2 +
* (zedge-zadd(jadd))**2
if(distance.lt.ref_distance) goto 302
enddo
endif
nadd1=nadd1+1
itadd(nadd1)=it
ieadd(nadd1)=ie
iadd(nadd1)=0
xadd(nadd1)=xedge
yadd(nadd1)=yedge
zadd(nadd1)=zedge
302 continue
enddo
enddo
nadd=nadd1
write(logmess,'(a,i10)') "Refine edges: ",nadd
call writloga('default',0,logmess,0,ierrw)
if(nadd.gt.0) then
npoints_save=npoints
call refine_edge_add(cmo,nadd,ipitadd,ipieadd,
* ipiadd,ipxadd,ipyadd,ipzadd)
call cmo_get_name(cmo,ierror)
call cmo_get_info('nnodes',cmo,npoints,ilen,ityp,ier)
call cmo_get_info('nelements',cmo,ntets,ilen,ityp,ier)
call cmo_get_info('itetclr',cmo,ipitetclr,ilen,
* ityp,ier)
call cmo_get_info('jtet',cmo,ipjtet,ilen,ityp,ier)
if(npoints_save.ne.npoints) then
ipointi=npoints_save+1
ipointj=npoints
call cmo_set_info('ipointi',cmo,
& ipointi,1,1,icscode)
if (icscode .ne. 0)
& call x3d_error(isubname,'get_info_i')
call cmo_set_info('ipointj',cmo,
& ipointj,1,1,icscode)
if (icscode .ne. 0)
& call x3d_error(isubname,'get_info_i')
endif
endif
endif
call mmrelblk("itadd",isubname,ipitadd,icscode)
call mmrelblk("ieadd",isubname,ipieadd,icscode)
call mmrelblk("iadd",isubname,ipiadd,icscode)
call mmrelblk("xadd",isubname,ipxadd,icscode)
call mmrelblk("yadd",isubname,ipyadd,icscode)
call mmrelblk("zadd",isubname,ipzadd,icscode)
endif
C
9998 continue
C
call cmo_get_name(cmo,ierror)
call cmo_get_info('nnodes',cmo,npoints,ilen,ityp,ier)
call cmo_get_info('nelements',cmo,ntets,ilen,ityp,ier)
call cmo_set_info('nelements',cmo,ntets,1,1,ier)
call cmo_set_info('nnodes',cmo,npoints,1,1,ier)
call cmo_newlen(cmo,ier)
call mmrelprt(isubname,icscode)
C
goto 9999
9999 continue
C
return
end
c
c***********************************************************************
subroutine refine_add_pts(cmo,ctopo,
* naddpts,ipiaddpts,
* ipxaddpts,ipyaddpts,ipzaddpts)
C
C ######################################################################
C
implicit none
C
character*132 logmess
C
include "chydro.h"
include "local_element.h"
C
C ######################################################################
C
character*(*) cmo, ctopo
integer naddpts
C
pointer (ipiaddpts, iaddpts)
integer iaddpts(naddpts)
pointer (ipxaddpts, xaddpts)
pointer (ipyaddpts, yaddpts)
pointer (ipzaddpts, zaddpts)
real*8 xaddpts(naddpts), yaddpts(naddpts), zaddpts(naddpts)
C
pointer (ipitp1, itp1)
integer itp1(*)
C
pointer (ipxic, xic)
pointer (ipyic, yic)
pointer (ipzic, zic)
real*8 xic(*), yic(*), zic(*)
C
pointer (ipitetclr, itetclr)
pointer (ipitettyp, itettyp)
pointer (ipitetoff, itetoff)
pointer (ipjtetoff, jtetoff)
integer itetclr(*), itettyp(*),
* itetoff(*), jtetoff(*)
pointer (ipitet, itet1)
pointer (ipjtet, jtet1)
integer itet1(4*1000000), jtet1(4*1000000)
C
pointer (ipitadd, itadd)
integer itadd(*)
pointer (ipifadd, ifadd)
integer ifadd(*)
pointer (ipieadd, ieadd)
integer ieadd(*)
C
pointer (ipiadd, iadd)
integer iadd(*)
pointer (ipxadd, xadd)
pointer (ipyadd, yadd)
pointer (ipzadd, zadd)
real*8 xadd(*), yadd(*), zadd(*)
C
pointer (ipiadd1, iadd1)
integer iadd1(*)
pointer (ipxadd1, xadd1)
pointer (ipyadd1, yadd1)
pointer (ipzadd1, zadd1)
real*8 xadd1(*), yadd1(*), zadd1(*)
C
pointer (ipiadd2, iadd2)
integer iadd2(*)
pointer (ipxadd2, xadd2)
pointer (ipyadd2, yadd2)
pointer (ipzadd2, zadd2)
real*8 xadd2(*), yadd2(*), zadd2(*)
C
pointer (ipitcheck, itcheck)
integer itcheck(*)
C
integer ipointi,ipointj,icscode,ilen,itype,ics,length,
* npoints_start,j3p,j2p,je,i3p,i2p,ie,iedge,k,
* l2,l1,k2,k1,in_face,j3,j2,j1,iface,nen,nef,nee,ierror,
* npoints,ityp,npoints_save,nsdgeom,j,icmotype
integer i,naddtotal,nadd2,naddelm,irecon,nsdtopo,nnfreq,
* ier,ierr2,naddelm1,it,in_element,idist,idup,
* i1,i2,i3,i4,i5,i6,i7,i8,ntets,itcount,ierrw,
* jt,jf,mbndry
real*8 xa,ya,za,dist,x1,y1,z1,x2,y2,z2,x3,y3,z3,
* x4,y4,z4,x5,y5,z5,x6,y6,z6,x7,y7,z7,x8,y8,z8,
* dsa1,dsa2,ds12
character*32 isubname
C
data irecon / 1 /
C
isubname='refine_add_pts'
C
call cmo_get_info('ipointi',cmo,ipointi,ilen,itype,icscode)
if (icscode .ne. 0) call x3d_error(isubname,'get_info_i')
call cmo_get_info('ipointj',cmo,ipointj,ilen,itype,icscode)
if (icscode .ne. 0) call x3d_error(isubname,'get_info_i')
npoints_start=ipointj
C
C old code used nnfreq as follows:
C nnfreq=-1 - do recon, nnfreq=-2 -do special recon
C nnfreq=0 - do not do recon, else do recon nnfreq times
call cmo_get_info('nnfreq',cmo,
* nnfreq,ilen,itype,icscode)
if (nnfreq.eq.0) irecon=0
C
call cmo_get_info('ndimensions_geom',cmo,nsdgeom,ilen,itype,ics)
call cmo_get_info('ndimensions_topo',cmo,nsdtopo,ilen,itype,ics)
call cmo_get_info('nodes_per_element',cmo,nen,ilen,itype,icscode)
call cmo_get_info('faces_per_element',cmo,nef,ilen,itype,icscode)
call cmo_get_info('edges_per_element',cmo,nee,ilen,itype,icscode)
call cmo_get_intinfo('idebug',cmo,idebug,ilen,ityp,icscode)
C
length=naddpts
call mmgetblk("iadd1",isubname,ipiadd1,length,1,icscode)
call mmgetblk("xadd1",isubname,ipxadd1,length,2,icscode)
call mmgetblk("yadd1",isubname,ipyadd1,length,2,icscode)
call mmgetblk("zadd1",isubname,ipzadd1,length,2,icscode)
call mmgetblk("iadd2",isubname,ipiadd2,length,1,icscode)
call mmgetblk("xadd2",isubname,ipxadd2,length,2,icscode)
call mmgetblk("yadd2",isubname,ipyadd2,length,2,icscode)
call mmgetblk("zadd2",isubname,ipzadd2,length,2,icscode)
call mmgetblk("iadd",isubname,ipiadd,length,1,icscode)
call mmgetblk("xadd",isubname,ipxadd,length,2,icscode)
call mmgetblk("yadd",isubname,ipyadd,length,2,icscode)
call mmgetblk("zadd",isubname,ipzadd,length,2,icscode)
call mmgetblk("itadd",isubname,ipitadd,length,1,icscode)
call mmgetblk("ifadd",isubname,ipifadd,length,1,icscode)
call mmgetblk("ieadd",isubname,ipieadd,length,1,icscode)
C
do i=1,naddpts
itadd(i)=0
iadd(i)=iaddpts(i)
xadd(i)=xaddpts(i)
yadd(i)=yaddpts(i)
zadd(i)=zaddpts(i)
enddo
C
naddtotal=0
C
nadd2=0
naddelm=naddpts
C
100 continue
C
dowhile((ctopo(1:3).eq.'tet' .or.
* ctopo(1:7).eq.'element'.or.
* ctopo(1:5).eq.'-all-') .and.
* naddelm.gt.0)
C
if(irecon.eq.1) then
if(nsdtopo.eq.2 .and.
* nen.eq.nelmnen(ifelmtri) .and.
* nef.eq.nelmnef(ifelmtri)) then
call dotaskx3d('recon/0 ; finish',ierror)
elseif(nsdtopo.eq.3 .and.
* nen.eq.nelmnen(ifelmtet) .and.
* nef.eq.nelmnef(ifelmtet)) then
call dotaskx3d('recon ; finish',ierror)
endif
else
write(logmess,'(a)') 'REFINE NOT USING RECON.'
call writloga('default',0,logmess,0,ierrw)
endif
C
call cmo_get_info('itp1',cmo,ipitp1,ilen,itype,ier)
call cmo_get_info('xic',cmo,ipxic,ilen,itype,ier)
call cmo_get_info('yic',cmo,ipyic,ilen,itype,ier)
call cmo_get_info('zic',cmo,ipzic,ilen,itype,ier)
call cmo_get_info('itetclr',cmo,
* ipitetclr,ilen,itype,ier)
call cmo_get_info('itettyp',cmo,
* ipitettyp,ilen,itype,ier)
call cmo_get_info('itetoff',cmo,
* ipitetoff,ilen,itype,ier)
call cmo_get_info('jtetoff',cmo,
* ipjtetoff,ilen,itype,ier)
call cmo_get_info('itet',cmo,ipitet,ilen,itype,ierror)
call cmo_get_info('jtet',cmo,ipjtet,ilen,itype,ierror)
C
call table_element(cmo,
& ipxadd,ipyadd,ipzadd,naddelm,
& ipitadd,
& ierr2)
if(idebug .ge. 4)then
do i = 1, naddelm
write(logmess,'(a,i8,i8)')
* 'Vol. Candidate Elements', i, itadd(i)
call writloga('default',0,logmess,0,ier)
enddo
endif
naddelm1=0
do i=1,naddelm
if(itadd(i).gt.0) then
it=itadd(i)
xa=xadd(i)
ya=yadd(i)
za=zadd(i)
in_element=-1
idist=0
do j=1,nelmnen(itettyp(it))
i1=itet1(itetoff(it)+j)
dist=(xic(i1)-xa)**2+(yic(i1)-ya)**2+(zic(i1)-za)**2
if(dist.lt.1.0e-10) then
idup=i1
idist=idist+1
endif
enddo
if(idist.gt.0) then
elseif(itettyp(it).eq.ifelmtri) then
i1=itet1(itetoff(it)+1)
i2=itet1(itetoff(it)+2)
i3=itet1(itetoff(it)+3)
x1=xic(i1)
y1=yic(i1)
z1=zic(i1)
x2=xic(i2)
y2=yic(i2)
z2=zic(i2)
x3=xic(i3)
y3=yic(i3)
z3=zic(i3)
call inside_tri2d(x1,y1,z1,x2,y2,z2,x3,y3,z3,
* xa,ya,za,
* in_element)
elseif(itettyp(it).eq.ifelmqud) then
i1=itet1(itetoff(it)+1)
i2=itet1(itetoff(it)+2)
i3=itet1(itetoff(it)+3)
i4=itet1(itetoff(it)+4)
x1=xic(i1)
y1=yic(i1)
z1=zic(i1)
x2=xic(i2)
y2=yic(i2)
z2=zic(i2)
x3=xic(i3)
y3=yic(i3)
z3=zic(i3)
x4=xic(i4)
y4=yic(i4)
z4=zic(i4)
call inside_quad2d(x1,y1,z1,x2,y2,z2,
* x3,y3,z3,x4,y4,z4,
* xa,ya,za,
* in_element)
elseif(itettyp(it).eq.ifelmtet) then
i1=itet1(itetoff(it)+1)
i2=itet1(itetoff(it)+2)
i3=itet1(itetoff(it)+3)
i4=itet1(itetoff(it)+4)
x1=xic(i1)
y1=yic(i1)
z1=zic(i1)
x2=xic(i2)
y2=yic(i2)
z2=zic(i2)
x3=xic(i3)
y3=yic(i3)
z3=zic(i3)
x4=xic(i4)
y4=yic(i4)
z4=zic(i4)
call inside_tet(x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4,
* xa,ya,za,
* in_element)
elseif(itettyp(it).eq.ifelmhex) then
i1=itet1(itetoff(it)+1)
i2=itet1(itetoff(it)+2)
i3=itet1(itetoff(it)+3)
i4=itet1(itetoff(it)+4)
i5=itet1(itetoff(it)+5)
i6=itet1(itetoff(it)+6)
i7=itet1(itetoff(it)+7)
i8=itet1(itetoff(it)+8)
x1=xic(i1)
y1=yic(i1)
z1=zic(i1)
x2=xic(i2)
y2=yic(i2)
z2=zic(i2)
x3=xic(i3)
y3=yic(i3)
z3=zic(i3)
x4=xic(i4)
y4=yic(i4)
z4=zic(i4)
x5=xic(i5)
y5=yic(i5)
z5=zic(i5)
x6=xic(i6)
y6=yic(i6)
z6=zic(i6)
x7=xic(i7)
y7=yic(i7)
z7=zic(i7)
x8=xic(i8)
y8=yic(i8)
z8=zic(i8)
call inside_hex(x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4,
* x5,y5,z5,x6,y6,z6,x7,y7,z7,x8,y8,z8,
* xa,ya,za,
* in_element)
endif
if(idist.gt.0) then
write(logmess,'(a,4i8)') 'Throw out duplicate point',
* i,idist,iadd(i),idup
call writloga('default',0,logmess,0,ier)
if(iabs(iadd(i)).gt.0) then
itp1(iabs(iadd(i)))=ifitpdud
endif
elseif(in_element.eq.0) then
naddelm1=naddelm1+1
itadd(naddelm1)=itadd(i)
iadd(naddelm1)=iadd(i)
xadd(naddelm1)=xadd(i)
yadd(naddelm1)=yadd(i)
zadd(naddelm1)=zadd(i)
else
nadd2=nadd2+1
iadd2(nadd2)=iadd(i)
xadd2(nadd2)=xadd(i)
yadd2(nadd2)=yadd(i)
zadd2(nadd2)=zadd(i)
endif
else
if(iabs(iadd(i)).gt.0) then
itp1(iabs(iadd(i)))=ifitpdud
endif
endif
enddo
C
naddelm=naddelm1
C
if(naddelm.gt.0) then
C
call cmo_get_info('nnodes',cmo,npoints,ilen,ityp,ier)
call cmo_get_info('nelements',cmo,ntets,ilen,ityp,ier)
length=ntets
call mmgetblk("itcheck",isubname,ipitcheck,length,1,icscode)
C
do it=1,ntets
itcheck(it)=0
enddo
naddelm1=0
itcount=0
do i=1,naddelm
it=itadd(i)
if(itcheck(it).eq.0) then
itcheck(it)=i
itcount=itcount+1
itadd(itcount)=itadd(i)
iadd(itcount)=iadd(i)
xadd(itcount)=xadd(i)
yadd(itcount)=yadd(i)
zadd(itcount)=zadd(i)
else
naddelm1=naddelm1+1
iadd1(naddelm1)=iadd(i)
xadd1(naddelm1)=xadd(i)
yadd1(naddelm1)=yadd(i)
zadd1(naddelm1)=zadd(i)
endif
enddo
C
naddelm=itcount
C
naddtotal=naddtotal+naddelm
npoints_save=npoints
if(idebug .ge. 3)then
write(logmess,'(a,i9)')
* 'Refine addpts Volume:#candidates = ',naddelm
call writloga('default',0,logmess,0,ierrw)
endif
call refine_tet_add(cmo,
* naddelm,
* ipitadd,
* iadd,xadd,yadd,zadd)
C***** call refine_element_add(cmo,
C***** * naddelm,
C***** * ipitadd,
C***** * ipiadd,ipxadd,ipyadd,ipzadd)
C
call cmo_get_name(cmo,ierror)
call cmo_get_info('nnodes',cmo,npoints,ilen,ityp,ier)
call cmo_get_info('nelements',cmo,ntets,ilen,ityp,ier)
call cmo_get_info('mbndry',cmo,mbndry,ilen,ityp,ier)
call cmo_get_info('itetclr',cmo,ipitetclr,ilen,
* ityp,ier)
call cmo_get_info('itettyp',cmo,ipitettyp,ilen,
* ityp,ier)
call cmo_get_info('jtetoff',cmo,ipjtetoff,ilen,
* ityp,ier)
call cmo_get_info('jtet',cmo,ipjtet,ilen,ityp,ier)
if(npoints_save.ne.npoints) then
ipointi=npoints_save+1
ipointj=npoints
call cmo_set_info('ipointi',cmo,
& ipointi,1,1,icscode)
if (icscode .ne. 0)
& call x3d_error(isubname,'get_info_i')
call cmo_set_info('ipointj',cmo,
& ipointj,1,1,icscode)
if (icscode .ne. 0)
& call x3d_error(isubname,'get_info_i')
endif
C
do it=1,ntets
do i=1,nelmnef(itettyp(it))
if(jtet1(jtetoff(it)+i).ge.mbndry) then
else
jt=1+(jtet1(jtetoff(it)+i)-1)/nef
jf=jtet1(jtetoff(it)+i)-nef*(jt-1)
if(itetclr(it).ne.itetclr(jt)) then
jtet1(jtetoff(it)+i)=mbndry+jtet1(jtetoff(it)+i)
jtet1(jtetoff(jt)+jf)=mbndry+
* nef*(it-1)+i
endif
endif
enddo
enddo
C
naddelm=0
do i=1,naddelm1
naddelm=naddelm+1
iadd(naddelm)=iadd1(i)
xadd(naddelm)=xadd1(i)
yadd(naddelm)=yadd1(i)
zadd(naddelm)=zadd1(i)
enddo
do i=1,nadd2
naddelm=naddelm+1
iadd(naddelm)=iadd2(i)
xadd(naddelm)=xadd2(i)
yadd(naddelm)=yadd2(i)
zadd(naddelm)=zadd2(i)
enddo
nadd2=0
C
call mmrelblk("itcheck",isubname,ipitcheck,icscode)
C
endif
C
enddo
C
if(nadd2.gt.0) then
naddelm=nadd2
do i=1,nadd2
iadd(i)=iadd2(i)
xadd(i)=xadd2(i)
yadd(i)=yadd2(i)
zadd(i)=zadd2(i)
enddo
endif
C
nadd2=0
C
dowhile(((ctopo(1:4).eq.'face'.or.ctopo(1:5).eq.'-all-') .or.
* (ctopo(1:4).eq.'edge'.and.nsdtopo.eq.2))
* .and.naddelm.gt.0)
if(irecon.eq.1) then
if(nsdtopo.eq.2 .and.
* nen.eq.nelmnen(ifelmtri) .and.
* nef.eq.nelmnef(ifelmtri)) then
call dotaskx3d('recon/0 ; finish',ierror)
elseif(nsdtopo.eq.3 .and.
* nen.eq.nelmnen(ifelmtet) .and.
* nef.eq.nelmnef(ifelmtet)) then
call dotaskx3d('recon ; finish',ierror)
endif
else
write(logmess,'(a)') 'REFINE NOT USING RECON.'
call writloga('default',0,logmess,0,ier)
endif
C
call cmo_get_info('xic',cmo,ipxic,ilen,icmotype,ier)
call cmo_get_info('yic',cmo,ipyic,ilen,icmotype,ier)
call cmo_get_info('zic',cmo,ipzic,ilen,icmotype,ier)
call cmo_get_info('itetclr',cmo,
* ipitetclr,ilen,icmotype,ier)
call cmo_get_info('itettyp',cmo,
* ipitettyp,ilen,icmotype,ier)
call cmo_get_info('itetoff',cmo,
* ipitetoff,ilen,icmotype,ier)
call cmo_get_info('jtetoff',cmo,
* ipjtetoff,ilen,icmotype,ier)
call cmo_get_info('itet',cmo,ipitet,ilen,icmotype,ierror)
call cmo_get_info('jtet',cmo,ipjtet,ilen,icmotype,ierror)
C
call table_element(cmo,
& ipxadd,ipyadd,ipzadd,naddelm,
& ipitadd,
& ierr2)
if(idebug .ge. 4)then
do i = 1, naddelm
write(logmess,'(a,i8,i8)')
* 'Face Candidate Elements', i, itadd(i)
call writloga('default',0,logmess,0,ier)
enddo
endif
naddelm1=0
do i=1,naddelm
if(itadd(i).gt.0) then
it=itadd(i)
xa=xadd(i)
ya=yadd(i)
za=zadd(i)
if(itettyp(it).eq.ifelmtri) then
i1=itet1(itetoff(it)+1)
i2=itet1(itetoff(it)+2)
i3=itet1(itetoff(it)+3)
x1=xic(i1)
y1=yic(i1)
z1=zic(i1)
x2=xic(i2)
y2=yic(i2)
z2=zic(i2)
x3=xic(i3)
y3=yic(i3)
z3=zic(i3)
call inside_tri2d(x1,y1,z1,x2,y2,z2,x3,y3,z3,
* xa,ya,za,
* in_element)
elseif(itettyp(it).eq.ifelmqud) then
i1=itet1(itetoff(it)+1)
i2=itet1(itetoff(it)+2)
i3=itet1(itetoff(it)+3)
i4=itet1(itetoff(it)+4)
x1=xic(i1)
y1=yic(i1)
z1=zic(i1)
x2=xic(i2)
y2=yic(i2)
z2=zic(i2)
x3=xic(i3)
y3=yic(i3)
z3=zic(i3)
x4=xic(i4)
y4=yic(i4)
z4=zic(i4)
call inside_quad2d(x1,y1,z1,x2,y2,z2,
* x3,y3,z3,x4,y4,z4,
* xa,ya,za,
* in_element)
elseif(itettyp(it).eq.ifelmtet) then
i1=itet1(itetoff(it)+1)
i2=itet1(itetoff(it)+2)
i3=itet1(itetoff(it)+3)
i4=itet1(itetoff(it)+4)
x1=xic(i1)
y1=yic(i1)
z1=zic(i1)
x2=xic(i2)
y2=yic(i2)
z2=zic(i2)
x3=xic(i3)
y3=yic(i3)
z3=zic(i3)
x4=xic(i4)
y4=yic(i4)
z4=zic(i4)
call inside_tet(x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4,
* xa,ya,za,
* in_element)
elseif(itettyp(it).eq.ifelmhex) then
i1=itet1(itetoff(it)+1)
i2=itet1(itetoff(it)+2)
i3=itet1(itetoff(it)+3)
i4=itet1(itetoff(it)+4)
i5=itet1(itetoff(it)+5)
i6=itet1(itetoff(it)+6)
i7=itet1(itetoff(it)+7)
i8=itet1(itetoff(it)+8)
x1=xic(i1)
y1=yic(i1)
z1=zic(i1)
x2=xic(i2)
y2=yic(i2)
z2=zic(i2)
x3=xic(i3)
y3=yic(i3)
z3=zic(i3)
x4=xic(i4)
y4=yic(i4)
z4=zic(i4)
x5=xic(i5)
y5=yic(i5)
z5=zic(i5)
x6=xic(i6)
y6=yic(i6)
z6=zic(i6)
x7=xic(i7)
y7=yic(i7)
z7=zic(i7)
x8=xic(i8)
y8=yic(i8)
z8=zic(i8)
call inside_hex(x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4,
* x5,y5,z5,x6,y6,z6,x7,y7,z7,x8,y8,z8,
* xa,ya,za,
* in_element)
endif
if(in_element.gt.0) then
if(itettyp(it).eq.ifelmtri) then
iface=in_element
j1=itet1(itetoff(it)+
* ielmface1(1,iface,itettyp(it)))
j2=itet1(itetoff(it)+
* ielmface1(2,iface,itettyp(it)))
x1=xic(j1)
y1=yic(j1)
z1=zic(j1)
x2=xic(j2)
y2=yic(j2)
z2=zic(j2)
xa=xadd(i)
ya=yadd(i)
za=zadd(i)
ds12=(x2-x1)**2+(y2-y1)**2+(z2-z1)**2
dsa2=(x2-xa)**2+(y2-ya)**2+(z2-za)**2
dsa1=(xa-x1)**2+(ya-y1)**2+(za-z1)**2
if(dsa2.lt.1.0e-06*ds12 .or.
* dsa1.lt.1.0d-06*ds12) then
nadd2=nadd2+1
iadd2(nadd2)=iadd(i)
xadd2(nadd2)=xadd(i)
yadd2(nadd2)=yadd(i)
zadd2(nadd2)=zadd(i)
else
naddelm1=naddelm1+1
itadd(naddelm1)=itadd(i)
ifadd(naddelm1)=in_element
iadd(naddelm1)=iadd(i)
xadd(naddelm1)=xadd(i)
yadd(naddelm1)=yadd(i)
zadd(naddelm1)=zadd(i)
endif
elseif(itettyp(it).eq.ifelmqud) then
nadd2=nadd2+1
iadd2(nadd2)=iadd(i)
xadd2(nadd2)=xadd(i)
yadd2(nadd2)=yadd(i)
zadd2(nadd2)=zadd(i)
elseif(itettyp(it).eq.ifelmtet) then
iface=in_element
j1=itet1(itetoff(it)+
* ielmface1(1,iface,itettyp(it)))
j2=itet1(itetoff(it)+
* ielmface1(2,iface,itettyp(it)))
j3=itet1(itetoff(it)+
* ielmface1(3,iface,itettyp(it)))
x1=xic(j1)
y1=yic(j1)
z1=zic(j1)
x2=xic(j2)
y2=yic(j2)
z2=zic(j2)
x3=xic(j3)
y3=yic(j3)
z3=zic(j3)
xa=xadd(i)
ya=yadd(i)
za=zadd(i)
call inside_tri2d(x1,y1,z1,x2,y2,z2,x3,y3,z3,
* xa,ya,za,
* in_face)
if(in_face.eq.0) then
naddelm1=naddelm1+1
itadd(naddelm1)=itadd(i)
ifadd(naddelm1)=in_element
iadd(naddelm1)=iadd(i)
xadd(naddelm1)=xadd(i)
yadd(naddelm1)=yadd(i)
zadd(naddelm1)=zadd(i)
else
nadd2=nadd2+1
iadd2(nadd2)=iadd(i)
xadd2(nadd2)=xadd(i)
yadd2(nadd2)=yadd(i)
zadd2(nadd2)=zadd(i)
endif
elseif(itettyp(it).eq.ifelmhex) then
nadd2=nadd2+1
iadd2(nadd2)=iadd(i)
xadd2(nadd2)=xadd(i)
yadd2(nadd2)=yadd(i)
zadd2(nadd2)=zadd(i)
endif
endif
else
if(iabs(iadd(i)).gt.0) then
itp1(iabs(iadd(i)))=ifitpdud
endif
endif
if(idebug .ge. 4)then
write(logmess,'(a,i8,a,i8)')
* 'Face Search:in_element =',in_element,' in_face=',in_face
call writloga('default',0,logmess,0,ier)
endif
enddo
C
naddelm=naddelm1
C
if(idebug .ge. 4)then
write(logmess,'(a,i8)')'Face Search:naddelm =',naddelm
call writloga('default',0,logmess,0,ier)
endif
if(naddelm.gt.0) then
C
call cmo_get_info('nnodes',cmo,npoints,ilen,ityp,ier)
call cmo_get_info('nelements',cmo,ntets,ilen,ityp,ier)
length=ntets
call mmgetblk("itcheck",isubname,ipitcheck,length,1,icscode)
C
do it=1,ntets
itcheck(it)=0
enddo
naddelm1=0
itcount=0
do i=1,naddelm
it=itadd(i)
if(itcheck(it).eq.0) then
itcheck(it)=i
itcount=itcount+1
itadd(itcount)=itadd(i)
ifadd(itcount)=ifadd(i)
iadd(itcount)=iadd(i)
xadd(itcount)=xadd(i)
yadd(itcount)=yadd(i)
zadd(itcount)=zadd(i)
else
naddelm1=naddelm1+1
iadd1(naddelm1)=iadd(i)
xadd1(naddelm1)=xadd(i)
yadd1(naddelm1)=yadd(i)
zadd1(naddelm1)=zadd(i)
endif
enddo
C
if(idebug .ge. 4)then
write(logmess,'(a,i8,a,i8)')
* 'Face Search:itcount =',itcount,' naddelm1=',naddelm1
call writloga('default',0,logmess,0,ier)
endif
C
naddelm=itcount
C
naddtotal=naddtotal+naddelm
npoints_save=npoints
if(idebug .ge. 3)then
write(logmess,'(a,i9)')
* 'Refine addpts Face:#candidates = ',naddelm
call writloga('default',0,logmess,0,ierrw)
endif
call refine_face_add(cmo,
* naddelm,
* ipitadd,ipifadd,
* ipiadd,ipxadd,ipyadd,ipzadd)
C
call cmo_get_name(cmo,ierror)
call cmo_get_info('nnodes',cmo,npoints,ilen,ityp,ier)
call cmo_get_info('nelements',cmo,ntets,ilen,ityp,ier)
call cmo_get_info('mbndry',cmo,mbndry,ilen,ityp,ier)
call cmo_get_info('itetclr',cmo,ipitetclr,ilen,
* ityp,ier)
call cmo_get_info('itettyp',cmo,ipitettyp,ilen,
* ityp,ier)
call cmo_get_info('jtetoff',cmo,ipjtetoff,ilen,
* ityp,ier)
call cmo_get_info('jtet',cmo,ipjtet,ilen,ityp,ier)
if(npoints_save.ne.npoints) then
ipointi=npoints_save+1
ipointj=npoints
call cmo_set_info('ipointi',cmo,
& ipointi,1,1,icscode)
if (icscode .ne. 0)
& call x3d_error(isubname,'get_info_i')
call cmo_set_info('ipointj',cmo,
& ipointj,1,1,icscode)
if (icscode .ne. 0)
& call x3d_error(isubname,'get_info_i')
endif
do it=1,ntets
do i=1,nelmnef(itettyp(it))
if(jtet1(jtetoff(it)+i).ge.mbndry) then
else
jt=1+(jtet1(jtetoff(it)+i)-1)/nef
jf=jtet1(jtetoff(it)+i)-nef*(jt-1)
if(itetclr(it).ne.itetclr(jt)) then
jtet1(jtetoff(it)+i)=mbndry+jtet1(jtetoff(it)+i)
jtet1(jtetoff(jt)+jf)=mbndry+
* nef*(it-1)+i
endif
endif
enddo
enddo
C
naddelm=0
do i=1,naddelm1
naddelm=naddelm+1
iadd(naddelm)=iadd1(i)
xadd(naddelm)=xadd1(i)
yadd(naddelm)=yadd1(i)
zadd(naddelm)=zadd1(i)
enddo
do i=1,nadd2
naddelm=naddelm+1
iadd(naddelm)=iadd2(i)
xadd(naddelm)=xadd2(i)
yadd(naddelm)=yadd2(i)
zadd(naddelm)=zadd2(i)
enddo
nadd2=0
C
call mmrelblk("itcheck",isubname,ipitcheck,icscode)
goto 100
C
endif
C
enddo
C
if(nadd2.gt.0) then
naddelm=nadd2
do i=1,nadd2
iadd(i)=iadd2(i)
xadd(i)=xadd2(i)
yadd(i)=yadd2(i)
zadd(i)=zadd2(i)
enddo
endif
C
nadd2=0
C
dowhile((ctopo(1:4).eq.'edge'.or.ctopo(1:5).eq.'-all-') .and.
* naddelm.gt.0)
if(irecon.eq.1) then
if(nsdtopo.eq.2 .and.
* nen.eq.nelmnen(ifelmtri) .and.
* nef.eq.nelmnef(ifelmtri)) then
call dotaskx3d('recon/0 ; finish',ierror)
elseif(nsdtopo.eq.3 .and.
* nen.eq.nelmnen(ifelmtet) .and.
* nef.eq.nelmnef(ifelmtet)) then
call dotaskx3d('recon ; finish',ierror)
endif
else
write(logmess,'(a)') 'REFINE NOT USING RECON.'
call writloga('default',0,logmess,0,ier)
endif
C
call cmo_get_info('xic',cmo,ipxic,ilen,icmotype,ier)
call cmo_get_info('yic',cmo,ipyic,ilen,icmotype,ier)
call cmo_get_info('zic',cmo,ipzic,ilen,icmotype,ier)
call cmo_get_info('itetclr',cmo,
* ipitetclr,ilen,icmotype,ier)
call cmo_get_info('itettyp',cmo,
* ipitettyp,ilen,icmotype,ier)
call cmo_get_info('itetoff',cmo,
* ipitetoff,ilen,icmotype,ier)
call cmo_get_info('jtetoff',cmo,
* ipjtetoff,ilen,icmotype,ier)
call cmo_get_info('itet',cmo,ipitet,ilen,icmotype,ierror)
call cmo_get_info('jtet',cmo,ipjtet,ilen,icmotype,ierror)
C
call table_element(cmo,
& ipxadd,ipyadd,ipzadd,naddelm,
& ipitadd,
& ierr2)
if(idebug .ge. 4)then
do i = 1, naddelm
write(logmess,'(a,i8,i8)')
* 'Edge Candidate Elements', i, itadd(i)
call writloga('default',0,logmess,0,ier)
enddo
endif
naddelm1=0
do i=1,naddelm
if(itadd(i).gt.0) then
it=itadd(i)
xa=xadd(i)
ya=yadd(i)
za=zadd(i)
if(itettyp(it).eq.ifelmtri) then
i1=itet1(itetoff(it)+1)
i2=itet1(itetoff(it)+2)
i3=itet1(itetoff(it)+3)
x1=xic(i1)
y1=yic(i1)
z1=zic(i1)
x2=xic(i2)
y2=yic(i2)
z2=zic(i2)
x3=xic(i3)
y3=yic(i3)
z3=zic(i3)
call inside_tri2d(x1,y1,z1,x2,y2,z2,x3,y3,z3,
* xa,ya,za,
* in_element)
elseif(itettyp(it).eq.ifelmqud) then
i1=itet1(itetoff(it)+1)
i2=itet1(itetoff(it)+2)
i3=itet1(itetoff(it)+3)
i4=itet1(itetoff(it)+4)
x1=xic(i1)
y1=yic(i1)
z1=zic(i1)
x2=xic(i2)
y2=yic(i2)
z2=zic(i2)
x3=xic(i3)
y3=yic(i3)
z3=zic(i3)
x4=xic(i4)
y4=yic(i4)
z4=zic(i4)
call inside_quad2d(x1,y1,z1,x2,y2,z2,
* x3,y3,z3,x4,y4,z4,
* xa,ya,za,
* in_element)
elseif(itettyp(it).eq.ifelmtet) then
i1=itet1(itetoff(it)+1)
i2=itet1(itetoff(it)+2)
i3=itet1(itetoff(it)+3)
i4=itet1(itetoff(it)+4)
x1=xic(i1)
y1=yic(i1)
z1=zic(i1)
x2=xic(i2)
y2=yic(i2)
z2=zic(i2)
x3=xic(i3)
y3=yic(i3)
z3=zic(i3)
x4=xic(i4)
y4=yic(i4)
z4=zic(i4)
call inside_tet(x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4,
* xa,ya,za,
* in_element)
elseif(itettyp(it).eq.ifelmhex) then
i1=itet1(itetoff(it)+1)
i2=itet1(itetoff(it)+2)
i3=itet1(itetoff(it)+3)
i4=itet1(itetoff(it)+4)
i5=itet1(itetoff(it)+5)
i6=itet1(itetoff(it)+6)
i7=itet1(itetoff(it)+7)
i8=itet1(itetoff(it)+8)
x1=xic(i1)
y1=yic(i1)
z1=zic(i1)
x2=xic(i2)
y2=yic(i2)
z2=zic(i2)
x3=xic(i3)
y3=yic(i3)
z3=zic(i3)
x4=xic(i4)
y4=yic(i4)
z4=zic(i4)
x5=xic(i5)
y5=yic(i5)
z5=zic(i5)
x6=xic(i6)
y6=yic(i6)
z6=zic(i6)
x7=xic(i7)
y7=yic(i7)
z7=zic(i7)
x8=xic(i8)
y8=yic(i8)
z8=zic(i8)
call inside_hex(x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4,
* x5,y5,z5,x6,y6,z6,x7,y7,z7,x8,y8,z8,
* xa,ya,za,
* in_element)
endif
if(in_element.gt.0) then
if(itettyp(it).eq.ifelmtri) then
elseif(itettyp(it).eq.ifelmtet) then
iface=in_element
j1=itet1(itetoff(it)+
* ielmface1(1,iface,itettyp(it)))
j2=itet1(itetoff(it)+
* ielmface1(2,iface,itettyp(it)))
j3=itet1(itetoff(it)+
* ielmface1(3,iface,itettyp(it)))
x1=xic(j1)
y1=yic(j1)
z1=zic(j1)
x2=xic(j2)
y2=yic(j2)
z2=zic(j2)
x3=xic(j3)
y3=yic(j3)
z3=zic(j3)
xa=xadd(i)
ya=yadd(i)
za=zadd(i)
call inside_tri2d(x1,y1,z1,x2,y2,z2,x3,y3,z3,
* xa,ya,za,
* in_face)
if(in_face.gt.0) then
if(in_face.eq.1) then
k1=j2
k2=j3
elseif(in_face.eq.2) then
k1=j3
k2=j1
elseif(in_face.eq.3) then
k1=j1
k2=j2
endif
do k=1,6
l1=itet1(itetoff(it)+
* ielmedge1(1,k,itettyp(it)))
l2=itet1(itetoff(it)+
* ielmedge1(2,k,itettyp(it)))
if((k1.eq.l1.and.k2.eq.l2) .or.
* (k2.eq.l1.and.k1.eq.l2)) then
iedge=k
endif
enddo
naddelm1=naddelm1+1
itadd(naddelm1)=itadd(i)
ieadd(naddelm1)=iedge
iadd(naddelm1)=iadd(i)
xadd(naddelm1)=xadd(i)
yadd(naddelm1)=yadd(i)
zadd(naddelm1)=zadd(i)
else
nadd2=nadd2+1
iadd2(nadd2)=iadd(i)
xadd2(nadd2)=xadd(i)
yadd2(nadd2)=yadd(i)
zadd2(nadd2)=zadd(i)
endif
endif
endif
else
if(iabs(iadd(i)).gt.0) then
itp1(iabs(iadd(i)))=ifitpdud
endif
endif
enddo
C
naddelm=naddelm1
C
if(naddelm.gt.0) then
C
call cmo_get_info('nnodes',cmo,npoints,ilen,ityp,ier)
call cmo_get_info('nelements',cmo,ntets,ilen,ityp,ier)
length=ntets
call mmgetblk("itcheck",isubname,ipitcheck,length,1,icscode)
C
do it=1,ntets
itcheck(it)=0
enddo
naddelm1=0
itcount=0
do i=1,naddelm
it=itadd(i)
if(itcheck(it).eq.0) then
itcheck(it)=i
itcount=itcount+1
itadd(itcount)=itadd(i)
ieadd(itcount)=ieadd(i)
iadd(itcount)=iadd(i)
xadd(itcount)=xadd(i)
yadd(itcount)=yadd(i)
zadd(itcount)=zadd(i)
else
naddelm1=naddelm1+1
iadd1(naddelm1)=iadd(i)
xadd1(naddelm1)=xadd(i)
yadd1(naddelm1)=yadd(i)
zadd1(naddelm1)=zadd(i)
endif
enddo
C
if(idebug .ge. 4)then
write(logmess,'(a,i8,a,i8)')
* 'Face Search:itcount =',itcount,' naddelm1=',naddelm1
call writloga('default',0,logmess,0,ier)
endif
naddelm=itcount
C
itcount=0
do i=1,naddelm
it=itadd(i)
if(it.gt.0) then
ie=ieadd(i)
i2p=itet1(itetoff(it)+ielmedge1(1,ie,itettyp(it)))
i3p=itet1(itetoff(it)+ielmedge1(2,ie,itettyp(it)))
do j=i+1,naddelm
jt=itadd(j)
if(jt.gt.0) then
je=ieadd(j)
j2p=itet1(itetoff(jt)+
* ielmedge1(1,je,itettyp(jt)))
j3p=itet1(itetoff(jt)+
* ielmedge1(2,je,itettyp(jt)))
if((j2p.eq.i2p.and.j3p.eq.i3p) .or.
* (j3p.eq.i2p.and.j2p.eq.i3p)) then
naddelm1=naddelm1+1
iadd1(naddelm1)=iadd(j)
xadd1(naddelm1)=xadd(j)
yadd1(naddelm1)=yadd(j)
zadd1(naddelm1)=zadd(j)
itadd(j)=0
ieadd(j)=0
endif
endif
enddo
itcount=itcount+1
itadd(itcount)=itadd(i)
ieadd(itcount)=ieadd(i)
iadd(itcount)=iadd(i)
xadd(itcount)=xadd(i)
yadd(itcount)=yadd(i)
zadd(itcount)=zadd(i)
endif
enddo
C
naddelm=itcount
C
naddtotal=naddtotal+naddelm
npoints_save=npoints
if(idebug .ge. 3)then
write(logmess,'(a,i9)')
* 'Refine addpts Edge:#candidates = ',naddelm
call writloga('default',0,logmess,0,ier)
endif
call refine_edge_add(cmo,
* naddelm,
* ipitadd,ipieadd,
* ipiadd,ipxadd,ipyadd,ipzadd)
C
call cmo_get_name(cmo,ierror)
call cmo_get_info('nnodes',cmo,npoints,ilen,ityp,ier)
call cmo_get_info('nelements',cmo,ntets,ilen,ityp,ier)
call cmo_get_info('mbndry',cmo,mbndry,ilen,ityp,ier)
call cmo_get_info('itetclr',cmo,ipitetclr,ilen,
* ityp,ier)
call cmo_get_info('itettyp',cmo,ipitettyp,ilen,
* ityp,ier)
call cmo_get_info('jtetoff',cmo,ipjtetoff,ilen,
* ityp,ier)
call cmo_get_info('jtet',cmo,ipjtet,ilen,ityp,ier)
if(npoints_save.ne.npoints) then
ipointi=npoints_save+1
ipointj=npoints
call cmo_set_info('ipointi',cmo,
& ipointi,1,1,icscode)
if (icscode .ne. 0)
& call x3d_error(isubname,'get_info_i')
call cmo_set_info('ipointj',cmo,
& ipointj,1,1,icscode)
if (icscode .ne. 0)
& call x3d_error(isubname,'get_info_i')
endif
do it=1,ntets
do i=1,nelmnef(itettyp(it))
if(jtet1(jtetoff(it)+i).ge.mbndry) then
else
jt=1+(jtet1(jtetoff(it)+i)-1)/nef
jf=jtet1(jtetoff(it)+i)-nef*(jt-1)
if(itetclr(it).ne.itetclr(jt)) then
jtet1(jtetoff(it)+i)=mbndry+jtet1(jtetoff(it)+i)
jtet1(jtetoff(jt)+jf)=mbndry+
* nef*(it-1)+i
endif
endif
enddo
enddo
C
naddelm=0
do i=1,naddelm1
naddelm=naddelm+1
iadd(naddelm)=iadd1(i)
xadd(naddelm)=xadd1(i)
yadd(naddelm)=yadd1(i)
zadd(naddelm)=zadd1(i)
enddo
do i=1,nadd2
naddelm=naddelm+1
iadd(naddelm)=iadd2(i)
xadd(naddelm)=xadd2(i)
yadd(naddelm)=yadd2(i)
zadd(naddelm)=zadd2(i)
enddo
nadd2=0
C
call mmrelblk("itcheck",isubname,ipitcheck,icscode)
goto 100
C
endif
C
enddo
C
if(irecon.eq.1) then
if(nsdtopo.eq.2 .and.
* nen.eq.nelmnen(ifelmtri) .and.
* nef.eq.nelmnef(ifelmtri)) then
call dotaskx3d('recon/0 ; finish',ierror)
elseif(nsdtopo.eq.3 .and.
* nen.eq.nelmnen(ifelmtet) .and.
* nef.eq.nelmnef(ifelmtet)) then
call dotaskx3d('recon ; finish',ierror)
endif
else
write(logmess,'(a)') 'REFINE NOT USING RECON.'
call writloga('default',0,logmess,0,ier)
endif
C
call cmo_get_info('nnodes',cmo,npoints,ilen,ityp,ier)
ipointi=npoints_start+1
ipointj=npoints
call cmo_set_info('ipointi',cmo,ipointi,1,1,icscode)
if (icscode .ne. 0) call x3d_error(isubname,'get_info_i')
call cmo_set_info('ipointj',cmo,ipointj,1,1,icscode)
if (icscode .ne. 0) call x3d_error(isubname,'get_info_i')
C
call mmrelprt(isubname,icscode)
C
goto 9999
9999 continue
C
return
end
Reference in New Issue Copy Permalink