6404 lines
237 KiB
Fortran
Executable File
6404 lines
237 KiB
Fortran
Executable File
Cdk,lower_d_lg
|
|
C
|
|
c23456789012345678901234567890123456789012345678901234567890123456789012
|
|
C #####################################################################
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C This suite of subroutines handles the "lower_d" commands which
|
|
C deal with creating and using the lower_d structures within the
|
|
C mesh object.
|
|
C
|
|
C LOWER D DATA STRUCTURES -
|
|
C
|
|
C For each dimension from the dimension of the input "top" mesh (d0)
|
|
C down to points, the data strucutures which parallel the basic lagrit data
|
|
C structures of the "bare" mesh are created.
|
|
C If ndimensions_topo=3, then
|
|
C the 2D surfaces separating regions are called the "d1" structures,
|
|
C the 1D lines separating surfaces are called the "d2" structures, and
|
|
C the 0D points where lines meet are called the "d3" structures.
|
|
C For ndimensions_topo=2, then
|
|
C the 1D lines separating regions are called the "d1" structures,
|
|
C the 0D points where lines meet are called the "d2" structures.
|
|
C For ndimensions_topo=1, then
|
|
C the 0D points where regions meet are called the "d1" structures.
|
|
C The new attributes added live in the same mesh object as the parent mesh,
|
|
C although they can be extracted using the "lower_d/extract" command.
|
|
C
|
|
C new attributes in the top dimension "d0":
|
|
C d0 nnodes attributes:
|
|
C d0_node_topo - 0 = in the interior of a region of the mesh
|
|
C 1 = an interior point of the surfaces/
|
|
C a point at which regions meet
|
|
C 2 = an interior point of the edges/
|
|
C a point at which surfaces intersect
|
|
C 3 = a point at which edges intersect
|
|
C
|
|
C new attributes in the 1-lower dimension "d1" (if not points):
|
|
C d1 scalar attributes:
|
|
C d1_nnodes - the number of nodes (after filtering) in this topology class.
|
|
C d1_nelements - the number of elements in this topology class.
|
|
C d1_nef_cmo - the number of faces per element in this topology class.
|
|
C d1_nee_cmo - the number of edges per element in this topology class.
|
|
C d1_nen_cmo - the number of nodes per element in this topology class.
|
|
C d1_jtet_cycle_max - the longest jtet cycle in this topology class.
|
|
C d1 nnodes attributes: none
|
|
C d1 nelements attributes:
|
|
C d1_itettyp - lagrit element type
|
|
C d1_itetclr - packed color (see clor table note below)
|
|
C d1_itetoff - offset for the d1_itet
|
|
C d1_itet - list of nodes for each d1 element
|
|
C d1_jtetoff - offset for the d1_jtet
|
|
C d1_jtet - face neighbor table for each d1 element
|
|
C d1_elm_d0 - packed d0 element and face from which this d1 element came.
|
|
C
|
|
C new attributes in the 2-lower dimension "d2" (if not points and d1 not points):
|
|
C d2 scalar attributes:
|
|
C d2_nnodes - the number of nodes (after filtering) in this topology class.
|
|
C d2_nelements - the number of elements in this topology class.
|
|
C d2_nef_cmo - the number of faces per element in this topology class.
|
|
C d2_nee_cmo - the number of edges per element in this topology class.
|
|
C d2_nen_cmo - the number of nodes per element in this topology class.
|
|
C d2_jtet_cycle_max - the longest jtet cycle in this topology class.
|
|
C d2 nnodes attributes: none
|
|
C d2 nelements attributes:
|
|
C d2_itettyp - lagrit element type
|
|
C d2_itetclr - packed color (see clor table note below)
|
|
C d2_itetoff - offset for the d2_itet
|
|
C d2_itet - list of nodes for each d2 element
|
|
C d2_jtetoff - offset for the d2_jtet
|
|
C d2_jtet - face neighbor table for each d2 element
|
|
C d2_elm_d1 - packed d1 element and face from which this d2 element came.
|
|
C ( create_d2_elm_d0_lower_d_lg will create the packed d0 element and edge
|
|
C from which this d2 element came if desired )
|
|
C
|
|
C new attributes for the lower d which is points
|
|
C (if ndimensions_topo=3, the "d3" structure;
|
|
C 2 "d2"
|
|
C 1 "d1"
|
|
C "dp" is used here to represent it, which has to be replaced
|
|
C with the appropriate "d#" for the current ndimensions_topo)
|
|
C dp scalar attributes:
|
|
C dp_nnodes - the number of nodes (after filtering) in this topology class.
|
|
C dp nnodes attributes: none
|
|
C dp nelements attributes: none
|
|
C
|
|
C other new attributes:
|
|
C flags:
|
|
C lower_d_flag = 0 - no lower d structures
|
|
C = 1 - lower d structures are valid
|
|
C = 2 - lower d structures need updating
|
|
C interior_icr_flag = 0 - all constrained surface types can exist
|
|
C = 1 - no virtual constrained surfaces exist
|
|
C = 2 - no intrcons constrained surfaces exist
|
|
C = 3 - no virtual or intrcons constrained surfaces exist
|
|
C = 4 - no reflect constrained surfaces exist
|
|
C = 5 - no reflect or virtual constrained surfaces exist
|
|
C = 6 - no reflect or intrcons constrained surfaces exist
|
|
C = 7 - no constrained surfaces exist
|
|
C note: interior_icr_flag must be created by the user
|
|
C and is only used by the subroutines sizes_lower_d_lg
|
|
C and itetclr_lower_d_lg (passed from create_lower_d_lg).
|
|
C It is assumed 0 if not defined. Hence if it is defined
|
|
C after the lower_d structures are created, the color table
|
|
C and/or itetclr values may not be correct.
|
|
C color table attributes:
|
|
C itetclr is a packed representation of the ipt1,icr1,imt1's
|
|
C for the given lower d element, and d0_clrtab is used to unpack it.
|
|
C d0_nclrs - the number of colors
|
|
C d0_clrlen - the length of the d0_clrtab storage
|
|
C d0_clroff - offset to the entry in the color table
|
|
C d0_clrtab - the color table
|
|
C for iclr=d1_itetclr(iel) [ or d2_itetclr(iel) ]
|
|
C d0_clrtab(d0_clroff(iclr)+1) = the itp1 value
|
|
C associated with lower d elements of this iclr
|
|
C d0_clrtab(d0_clroff(iclr)+2) = the icr1 value
|
|
C associated with lower d elements of this color
|
|
C d0_clrtab(d0_clroff(iclr)+3) = the number of imt1
|
|
C associated with lower d elements of this iclr
|
|
C d0_clrtab(d0_clroff(iclr)+3) = the number of imt1
|
|
C associated with lower d elements of this iclr
|
|
C No entries in the color table are generated for the
|
|
C top dimension or the point dimension, and the d1_itetclr
|
|
C entries start with d1_itetclr=1, which does not have
|
|
C the same meaning as itetclr=1 for d0 elements:
|
|
C a d1_itetclr value corresponding
|
|
C d0_clrtab(d0_clroff(iclr)+1)=0
|
|
C d0_clrtab(d0_clroff(iclr)+2)=0
|
|
C d0_clrtab(d0_clroff(iclr)+3)=0
|
|
C d0_clrtab(d0_clroff(iclr)+4)=imt1
|
|
C would be need to be added if the d0 element colors were
|
|
C to be included in the color table. Since there are
|
|
C no elements associated with the point mesh, I decided
|
|
C not to pack their colors (essentially ipt1,icr1,imt1(isn1)
|
|
C on that point's parent node).
|
|
C
|
|
C COMMAND FORMAT -
|
|
C (* marks defaults; cmo0 is the current "bare" or "top" mesh object name)
|
|
C
|
|
C lower_d/*create[/cmo0|*-def-][/recreate|refilter|*new]
|
|
C creates lower d structures in cmo0
|
|
C (to modify how selected, use filter after create; see filter)
|
|
C "recreate" indicates that exisiting color table if any should be used
|
|
C rather than being re-created
|
|
C
|
|
C lower_d/release[/cmo0|*-def-]
|
|
C releases the lower d structures in cmo0
|
|
C
|
|
C lower_d/extract[/cmo0|*-def-][/cmo1|*-none-,cmo2|*-none-,cmo3|*-none-]
|
|
C /[*itetclr|no_color|recolor]
|
|
C if -none- for given dimension (default), lower d cmo not created
|
|
c otherwise overwrites cmo1-3 if already exist
|
|
C should add option to create lower d structures in cmo0 if not
|
|
C already extant: for now, just return error
|
|
C cmo1,cmo2,cmo3 are the names of the mesh objects to extract
|
|
C the corresponding d1,d2,d3 structures to.
|
|
C Unlike other extracts, node attibutes are copied to the extracted mesh.
|
|
C
|
|
C lower_d/print[/cmo0|*-def-][/*clrtab]
|
|
C print the color table
|
|
C
|
|
C lower_d/filter[/cmo0|*-def-]/[icr|itp|imt|clr]/#[/and|*or|new]
|
|
C increment the filter to select (set itetclr>0)
|
|
C lower d elements with the specified icr or itp or imt or clr #
|
|
C lower_d/filter[/cmo0|*-def-]/[no_icr|no_itp|no_imt|no_clr]/#[/and|*or|new]
|
|
C increment the filter to unselect (set itetclr<0)
|
|
C lower d elements with the specified icr or itp or imt or clr #
|
|
C lower_d/filter[/cmo0|*-def-]/[ext|int|vrt|real][/-not_used-/and|*or|new]
|
|
C increment the filter to select (set itetclr>0)
|
|
C lower d elements with the specified itp type class
|
|
C lower_d/filter[/cmo0|*-def-]/[no_ext|no_int|no_vrt|no_real][/-not_used-/and|*or|new]
|
|
C increment the filter to unselect (set itetclr<0)
|
|
C lower d elements with the specified itp type class
|
|
C lower_d/filter[/cmo0|*-def-]/reset
|
|
C reset to no filter
|
|
C lower_d/filter[/cmo0|*-def-]/refilter[/#]
|
|
C re-filter the lower_d elements using the stored filter commands
|
|
C for this mesh object, if # is specified, the stored filters
|
|
C will be (permanently) truncated to the last # filters
|
|
C
|
|
C NON-COMMAND SUBROUTINES -
|
|
C These may be of use when writing code which uses the lower d structures.
|
|
C Hopefully the intent is obvious from the name -
|
|
C see the notes above the subroutine for a detailed explanation.
|
|
C
|
|
C reset_mbndry_lower_d_lg
|
|
C create_d2_elm_d0_lower_d_lg
|
|
C create_d0d1_node_lower_d_lg
|
|
C create_d0_elm_d1_lower_d_lg
|
|
C create_d0_elm_d2_lower_d_lg
|
|
C order_surface_lower_d_lg
|
|
C
|
|
C USAGE NOTES / CAVEATS -
|
|
C
|
|
C WARNING: "alpha" version: Once the way this suite is used becomes established,
|
|
C some data storage/usage conventions may need to be changed....
|
|
C
|
|
C - The initial assumption is that having the lower d structures parallel
|
|
C the top-dimension structures is the best way to handle it.
|
|
C The main changes are that jtet is a loop similar to isn1,
|
|
C and the itetclr refers to an entry in d0_clrtab similar to icr1.
|
|
C Currently jtet uses the same mbndry convention and mbndry as the
|
|
C top dimension, except that if the jtet loop is longer than 3 it is
|
|
C treated as an interface even if all 3 surfaces have the same itetclr.
|
|
C Eventually I will recode so that it usees the jtet <>0 convention rather
|
|
C than the <> mbndry convention to signal interfaces.
|
|
C Because jtet is now a loop, only subroutines which have been modified
|
|
C to accept jtet loops (and eventually jtet<0) will work.
|
|
C See the coding below for examples using the jtet loop, or, eg, compare
|
|
C Ver 1.16 and Ver 1.17 of tettestd.f for an example of the conversion
|
|
C from no jtet loops allowed to jtet loops permitted.
|
|
C
|
|
C - currently, the itetclr <-> imt1 translation table is not ordered.
|
|
C for "d1" structures, it may be desireable to order it so that
|
|
C one distinguishes between the imt1 above vs below (if 2d, or on the
|
|
C left vs right if 1d)
|
|
C Also, while it is attempted to order the surfaces consistently, there
|
|
C is no guarantee. The subroutine order_surface_lower_d_lg is provided
|
|
C which returns an integer flag "order(1:d#_nelements)" (where #=1 or 2)
|
|
C the sign of which tells if an elements needs to be flipped to have
|
|
C the surface order consistently. Possibly the flip should just be done
|
|
C after creating the data structure, but I got tired of coding ...
|
|
C
|
|
C - It is assumed no tet can touch itself with 2 different faces.
|
|
C This means that I can just test if I am back in the original element
|
|
C to see if I am finished looping around the jtet chain of a given face,
|
|
C rather than having to test that I am back in the same element at the
|
|
C same face.
|
|
C
|
|
C - For coding convenience, I may have assumed in some subroutines
|
|
C that if the topological dimension is three, then the jtet loops
|
|
C are at most 2 long (ie: for 3D elements I assumes at most one
|
|
C other element touches a given face, which rules out the
|
|
C mesh coming from the surfaces of a 4-D object)
|
|
C
|
|
C - While the user can create attributes which, eg, have length
|
|
C d1_nelements or d1_nnodes, they will probably not be correctly
|
|
C maintained if any command which changes the numbering or topology
|
|
C is executed (eg, massage, rmpoint compress, etc).
|
|
C Only fields which live on nodes should be considered robust:
|
|
C if used only for the lower d structures their values on the
|
|
C interior nodes will simply be ignored.
|
|
C The lower d data structures are "quasi-maintained" in the sense
|
|
C that I have attempted to maintain the mesh attribute lower_d_flag
|
|
C which signals that the data strucutres need to be refreshed.
|
|
C (lower_d_flag=2 means the lower d data structures need updating,
|
|
C lower_d_flag=1 means with any luck the lower d data structures are OK,
|
|
C and lower_d_flag=0 or not existing means the data structures are not
|
|
C desired; currently only geniee and rmpoint reset lower_d_flag=1 to
|
|
C lower_d_flag=2, but hopefully this gets almost all topology-changing
|
|
C commands....)
|
|
C The sequence of filters should be remembered when the lower d
|
|
C structures are refreshed, although this has not been extensively tested.
|
|
C
|
|
C - When filtering, the lower d elements are not removed from
|
|
C the data structure: the itetclr is simply set to negative.
|
|
C Thus, eg, when writing a smoothing routine, one could still
|
|
C use the full hierarchy but only restrict damage on the positve
|
|
C itetclr elements.
|
|
C Once the way this suite is used becomes established,
|
|
C this convention may need to be changed.
|
|
C
|
|
C - Rather than keeping separate node lists for each topological
|
|
C hierarchy, the lower d elements point to the parent nodes
|
|
C of the top dimension's mesh. The field d0_node_topo tells
|
|
C the lowest relative dimension the node belongs to, and can
|
|
C thus be used to create psets of nodes in the dimension of
|
|
C interest.
|
|
C
|
|
C - see also the notes above each subroutine
|
|
C
|
|
C CHANGE HISTORY -
|
|
C
|
|
C $Log: lower_d_lg.f,v $
|
|
C Revision 2.00 2007/11/05 19:46:00 spchu
|
|
C Import to CVS
|
|
C
|
|
CPVCS
|
|
CPVCS Rev 1.21 28 Jul 2001 14:13:04 jtg
|
|
CPVCS fixed test for increasing d0_clrlen_att
|
|
CPVCS
|
|
CPVCS Rev 1.20 18 Sep 2000 15:13:56 dcg
|
|
CPVCS initialize correctly
|
|
CPVCS
|
|
CPVCS Rev 1.19 18 Sep 2000 12:47:26 dcg
|
|
CPVCS initialize d0_clrlen_att and d0_nclrs_att
|
|
CPVCS
|
|
CPVCS Rev 1.18 17 Aug 2000 17:31:00 jtg
|
|
CPVCS ibtype added to discriminate intrcons from reflect surfaces;
|
|
CPVCS also interior_icr_flag for controlling this by hand, or when
|
|
CPVCS ibtype doesn't exist. (for ibtype, see surface routines)
|
|
CPVCS
|
|
CPVCS Rev 1.17 27 Jul 2000 12:07:36 dcg
|
|
CPVCS fix another place where ioff was not defined
|
|
CPVCS
|
|
CPVCS Rev 1.16 27 Jul 2000 08:28:20 dcg
|
|
CPVCS define ioff before using it
|
|
CPVCS fix dimension on tmsgout
|
|
CPVCS
|
|
CPVCS Rev 1.15 03 May 2000 01:25:56 jtg
|
|
CPVCS vor2d set to "no" in d1 mesh,
|
|
CPVCS and io flag for d0_node_topo set to "agx" instead of "x"
|
|
CPVCS
|
|
CPVCS Rev 1.14 02 May 2000 12:14:08 jtg
|
|
CPVCS added child points to extracted lower_d meshes
|
|
CPVCS
|
|
CPVCS Rev 1.13 24 Apr 2000 12:19:08 jtg
|
|
CPVCS mbndry values set using same conventions as in set_mbndry
|
|
CPVCS (multiple of 1000000 .ge. 16000000, 1000000*int(1.2e-6*nelements*nef))
|
|
CPVCS and when creating lower_d cmos mbndry set after calling cmo_newlen
|
|
CPVCS so that mbndry consistent in the lower d meshes.
|
|
CPVCS
|
|
CPVCS Rev 1.12 24 Apr 2000 11:46:56 jtg
|
|
CPVCS
|
|
CPVCS Rev 1.11 17 Feb 2000 20:41:30 jtg
|
|
CPVCS toned down verbosity
|
|
CPVCS
|
|
CPVCS Rev 1.10 08 Feb 2000 16:37:10 jtg
|
|
CPVCS if icontab exists but the constraint surf corresponding to the
|
|
CPVCS surfaces in a lower_d element does not have a corresponding icr1 value,
|
|
CPVCS print warning and use "minimum constraint" (rather than incrementing
|
|
CPVCS nconbnd,icontab as is perhaps more correct)
|
|
CPVCS
|
|
CPVCS Rev 1.9 27 Jan 2000 19:51:44 jtg
|
|
CPVCS fixed error setting itet when extracting a d2 cmo with filters in effect.
|
|
CPVCS
|
|
CPVCS Rev 1.8 27 Jan 2000 16:34:22 jtg
|
|
CPVCS Log line was incorrect. Since the last log, this is jtet-loop, jtet_cycle_max
|
|
CPVCS and mbndry=0 safe, and uses mbndry=0 when creating the lower d but
|
|
CPVCS resetsit to the "input convention" at the end. Also it calls the cmo_delatt_all_lg
|
|
CPVCS to delete the scalar attributes and all attributes that depend on them.
|
|
CPVCS And the "lower_d/print" command has been added.
|
|
CPVCS
|
|
CPVCS Rev 1.2 Mon Jan 03 14:40:20 2000 nnc
|
|
CPVCS Fixed minor errors reported by the Dec compiler: out-of-order statements,
|
|
CPVCS null character strings, multiply declared variables.
|
|
CPVCS
|
|
CPVCS Rev 1.1 Tue Nov 30 19:31:44 1999 jtg
|
|
CPVCS changed io field of attributes created when extracting from 'x' to 'agx'
|
|
CPVCS
|
|
CPVCS Rev 1.0 Tue Nov 30 16:48:36 1999 jtg
|
|
CPVCS Initial revision.
|
|
C
|
|
C #####################################################################
|
|
c-----------------------------------------------------------------------
|
|
C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|
|
|
c-----------------------------------------------------------------------
|
|
C #####################################################################
|
|
C control_lower_d_lg
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C control_lower_d_lg is the command interface for the commands which
|
|
C deal with creating and using the lower_d structures within the
|
|
C mesh object.
|
|
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 msgtyp() - 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 USAGE NOTES / CAVEATS / CHANGES -
|
|
C
|
|
C #####################################################################
|
|
|
|
subroutine control_lower_d_lg(imsgin,xmsgin,cmsgin,msgtyp,nwds
|
|
& ,ierror)
|
|
|
|
c ........................................................................
|
|
|
|
implicit none
|
|
|
|
C arguments
|
|
integer nwds,ierror
|
|
character*(*) cmsgin(nwds)
|
|
integer imsgin(nwds),msgtyp(nwds)
|
|
real*8 xmsgin(nwds)
|
|
|
|
C variables
|
|
|
|
integer lenaction,lcmo0,lcmo1,lcmo2,lcmo3
|
|
& ,ierr,local_debug,nwds_skip,iwd,n_extract
|
|
& ,lower_d_flag,len,ityp,ivalue,new_storage
|
|
& ,d0_nfilters,rankfilter,lact2,d0_nclrs
|
|
|
|
pointer (ip_d0_clrtab,d0_clrtab),(ip_d0_clroff,d0_clroff)
|
|
integer d0_clrtab(*),d0_clroff(*)
|
|
|
|
integer icharlnf
|
|
|
|
character*32 cmo0,cmo1,cmo2,cmo3,action,cmo_save,action2
|
|
character*132 cbuf
|
|
|
|
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
|
C BEGIN begin
|
|
C
|
|
call cmo_get_name(cmo_save,ierr)
|
|
local_debug=0
|
|
|
|
ierror=0
|
|
|
|
c modify if command root changed ..............
|
|
|
|
nwds_skip=1
|
|
iwd=nwds_skip
|
|
|
|
c find action ................
|
|
|
|
iwd=iwd+1
|
|
if (nwds.lt.iwd.or.msgtyp(iwd).ne.3) then
|
|
action='create'
|
|
else
|
|
lenaction=icharlnf(cmsgin(iwd))
|
|
action=cmsgin(iwd)(1:lenaction)
|
|
endif
|
|
lenaction=icharlnf(action)
|
|
|
|
c find cmo0 - the name of the "parent" cmo ................
|
|
|
|
iwd=iwd+1
|
|
if (nwds.lt.iwd.or.msgtyp(iwd).ne.3) then
|
|
cmo0='-def-'
|
|
else
|
|
lcmo0=icharlnf(cmsgin(iwd))
|
|
cmo0=cmsgin(iwd)(1:lcmo0)
|
|
endif
|
|
lcmo0=icharlnf(cmo0)
|
|
if (cmo0(1:lcmo0).eq.'-def-'.or.cmo0(1:lcmo0).eq.'-cmo-') then
|
|
call cmo_get_name(cmo0,ierror)
|
|
if (ierror.ne.0) goto 9999
|
|
lcmo0=icharlnf(cmo0)
|
|
endif
|
|
call cmo_exist(cmo0,ierror)
|
|
if (ierror.ne.0) goto 9999
|
|
|
|
call cmo_get_info('lower_d_flag',cmo0(1:lcmo0)
|
|
& ,lower_d_flag,len,ityp,ierr)
|
|
if (ierror.ne.0) lower_d_flag=0
|
|
c .....................................................
|
|
|
|
if (action(1:lenaction).eq.'create') then
|
|
|
|
c -----------------------------------------------------
|
|
c lower_d/*create[/cmo0|*-def-][/recreate|refilter|*new]
|
|
c (* marks default)
|
|
c creates lower d structures in cmo0
|
|
c (to modify how selected, use filter after create; see filter)
|
|
c "recreate" indicates that exisiting color table if any should be used
|
|
c rather than being re-created
|
|
c -----------------------------------------------------
|
|
|
|
new_storage=1
|
|
iwd=iwd+1
|
|
if (nwds.ge.iwd.and.msgtyp(iwd).ne.3.and.
|
|
& (lower_d_flag.eq.2.or.lower_d_flag.eq.1)) then
|
|
lenaction=icharlnf(cmsgin(iwd))
|
|
action=cmsgin(iwd)(1:lenaction)
|
|
if (action(1:lenaction).eq.'recreate') then
|
|
! new_storage=2 indicates don't destroy color table
|
|
! but do destroy filter table
|
|
new_storage=2
|
|
elseif (action(1:lenaction).eq.'refilter') then
|
|
! new_storage=0 indicates don't destroy color table
|
|
! and re-use filter table
|
|
new_storage=0
|
|
endif
|
|
endif
|
|
|
|
call create_lower_d_lg(cmo0(1:lcmo0),new_storage,ierror)
|
|
if (ierror.ne.0) goto 9999
|
|
|
|
c .....................................................
|
|
|
|
elseif (action(1:lenaction).eq.'print') then
|
|
|
|
c -----------------------------------------------------
|
|
c lower_d/print[/cmo0|*-def-][/*clrtab][filename|*-def-]
|
|
c (* marks default)
|
|
c + print the color table
|
|
c + "filename" option not yet implemented
|
|
c -----------------------------------------------------
|
|
|
|
call cmo_get_info('d0_nclrs',cmo0,d0_nclrs,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d0_nclrs.le.0) d0_nclrs=0
|
|
call cmo_get_info('d0_clrtab',cmo0,ip_d0_clrtab,len,ityp,ierr)
|
|
call cmo_get_info('d0_clroff',cmo0,ip_d0_clroff,len,ityp,ierr)
|
|
call print_clrtab_lower_d_lg(d0_nclrs,d0_clroff,d0_clrtab)
|
|
|
|
c .....................................................
|
|
|
|
elseif (action(1:lenaction).eq.'release') then
|
|
|
|
c -----------------------------------------------------
|
|
c lower_d/release[/cmo0|*-def-]
|
|
c (* marks default)
|
|
c + releases lower d structure in cmo0
|
|
c -----------------------------------------------------
|
|
|
|
call release_lower_d_lg(cmo0(1:lcmo0),ierror)
|
|
|
|
c .....................................................
|
|
|
|
elseif (action(1:lenaction).eq.'extract') then
|
|
|
|
c -----------------------------------------------------
|
|
c lower_d/extract[/cmo0|*-def-][/cmo1|*-none-,cmo2|*-none-,cmo3|*-none-]
|
|
c /[*itetclr|no_color|recolor]
|
|
c (* marks default; recolor recommended)
|
|
c + if -none- for given dimension (default), lower d cmo not created
|
|
c otherwise overwrites cmo1-3 if already exist
|
|
c + should add option to create lower d strucutres in cmo0 if not already extant: for now, just return error
|
|
c -----------------------------------------------------
|
|
|
|
iwd=iwd+1
|
|
if (nwds.lt.iwd.or.msgtyp(iwd).ne.3) then
|
|
cmo1='-none-'
|
|
else
|
|
lcmo1=icharlnf(cmsgin(iwd))
|
|
cmo1=cmsgin(iwd)(1:lcmo1)
|
|
if (lcmo1.lt.1.or.cmo1(1:1).eq.'-') cmo1='-none-'
|
|
endif
|
|
lcmo1=icharlnf(cmo1)
|
|
if ( cmo1(1:lcmo1).eq.cmo0(1:lcmo0) ) then
|
|
cmo1='-none-'
|
|
lcmo1=6
|
|
cbuf='ERROR IN lower_d/extract: not extracting d1'
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
endif
|
|
|
|
iwd=iwd+1
|
|
if (nwds.lt.iwd.or.msgtyp(iwd).ne.3) then
|
|
cmo2='-none-'
|
|
else
|
|
lcmo2=icharlnf(cmsgin(iwd))
|
|
cmo2=cmsgin(iwd)(1:lcmo2)
|
|
if (lcmo2.lt.1.or.cmo2(1:1).eq.'-') cmo2='-none-'
|
|
endif
|
|
lcmo2=icharlnf(cmo2)
|
|
if ( cmo2(1:lcmo2).eq.cmo0(1:lcmo0)
|
|
& .or. cmo2(1:lcmo2).eq.cmo1(1:lcmo1) ) then
|
|
cmo2='-none-'
|
|
lcmo2=6
|
|
cbuf='ERROR IN lower_d/extract: not extracting d2'
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
endif
|
|
|
|
iwd=iwd+1
|
|
if (nwds.lt.iwd.or.msgtyp(iwd).ne.3) then
|
|
cmo3='-none-'
|
|
else
|
|
lcmo3=icharlnf(cmsgin(iwd))
|
|
cmo3=cmsgin(iwd)(1:lcmo3)
|
|
if (lcmo3.lt.1.or.cmo3(1:1).eq.'-') cmo3='-none-'
|
|
endif
|
|
lcmo3=icharlnf(cmo3)
|
|
if ( cmo3(1:lcmo3).eq.cmo0(1:lcmo0)
|
|
& .or. cmo3(1:lcmo3).eq.cmo1(1:lcmo1)
|
|
& .or. cmo3(1:lcmo3).eq.cmo2(1:lcmo2) ) then
|
|
cmo3='-none-'
|
|
lcmo3=6
|
|
cbuf='ERROR IN lower_d/extract: not extracting d3'
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
endif
|
|
|
|
n_extract=0
|
|
if (cmo1(1:1).ne.'-') n_extract=n_extract+1
|
|
if (cmo2(1:1).ne.'-') n_extract=n_extract+1
|
|
if (cmo3(1:1).ne.'-') n_extract=n_extract+1
|
|
if (n_extract.eq.0) goto 9999
|
|
|
|
iwd=iwd+1
|
|
if (nwds.lt.iwd.or.msgtyp(iwd).ne.3) then
|
|
action='itetclr'
|
|
else
|
|
lenaction=icharlnf(cmsgin(iwd))
|
|
action=cmsgin(iwd)(1:lenaction)
|
|
if (action(1:lenaction).ne.'no_color' .and.
|
|
& action(1:lenaction).ne.'recolor') action='itetclr'
|
|
endif
|
|
|
|
if (lower_d_flag.ne.1) then
|
|
new_storage=0
|
|
if (lower_d_flag.ne.2.and.lower_d_flag.ne.1) new_storage=1
|
|
call create_lower_d_lg(cmo0(1:lcmo0),new_storage,ierror)
|
|
if (ierror.ne.0) goto 9999
|
|
endif
|
|
|
|
call extract_lower_d_lg(cmo0(1:lcmo0),cmo1(1:lcmo1)
|
|
& ,cmo2(1:lcmo2),cmo3(1:lcmo3)
|
|
& ,action,ierror)
|
|
if (ierror.ne.0) goto 9999
|
|
|
|
if (lower_d_flag.eq.0) then
|
|
call release_lower_d_lg(cmo0(1:lcmo0),ierror)
|
|
!NO - KEEP! call cmo_release(cmo1(1:lcmo1),ierror)
|
|
!NO - KEEP! call cmo_release(cmo2(1:lcmo2),ierror)
|
|
!NO - KEEP! call cmo_release(cmo3(1:lcmo3),ierror)
|
|
endif
|
|
|
|
c .....................................................
|
|
|
|
elseif (action(1:lenaction).eq.'filter'
|
|
& .or.action(1:lenaction).eq.'refilter'
|
|
& .or.action(1:lenaction).eq.'recreate') then
|
|
|
|
c -----------------------------------------------------
|
|
|
|
c lower_d/filter[/cmo0|*-def-]/[icr|itp|imt|clr]/#[/and|*or|new]
|
|
c lower_d/filter[/cmo0|*-def-]/[no_icr|no_itp|no_imt|no_clr]/#[/and|*or|new]
|
|
c lower_d/filter[/cmo0|*-def-]/[ext|int|vrt|real][/-not_used-/and|*or|new]
|
|
c lower_d/filter[/cmo0|*-def-]/[no_ext|no_int|no_vrt|no_real][/-not_used-/and|*or|new]
|
|
c lower_d/filter[/cmo0|*-def-]/reset
|
|
c lower_d/filter[/cmo0|*-def-]/refilter[/#]
|
|
c lower_d/filter[/cmo0|*-def-]/recreate
|
|
|
|
C$$ vs (old idea):
|
|
C$$ [/*all|interior|exterior|(imt #)][/*color_icr|nocolor_icr]
|
|
C$$ + if color_icr, then the "color" of the interface
|
|
C$$ is a unique number for each constraint + material colors combination
|
|
C$$ itetclr{surface} = serially packed {icr,imt 1-n}
|
|
C$$ (and constraint interfaces within a material DO appear in lower d structures)
|
|
C$$ otherwise the interface color depends only on the material colors encountered
|
|
C$$ itetclr{surface} = serially packed {imt 1-n}
|
|
C$$ (and constraint interfaces within a material do NOT appear in lower d structures)
|
|
c -----------------------------------------------------
|
|
|
|
|
|
iwd=iwd+1
|
|
if (action(1:lenaction).eq.'refilter'
|
|
& .or.action(1:lenaction).eq.'recreate') then
|
|
continue
|
|
elseif (nwds.ge.iwd.and.msgtyp(iwd).eq.3) then
|
|
lenaction=icharlnf(cmsgin(iwd))
|
|
if (lenaction.gt.0) then
|
|
action=cmsgin(iwd)(1:lenaction)
|
|
else
|
|
action='reset'
|
|
lenaction=5
|
|
endif
|
|
else
|
|
action='reset'
|
|
lenaction=5
|
|
endif
|
|
|
|
iwd=iwd+1
|
|
if (nwds.ge.iwd.and.msgtyp(iwd).eq.2) then
|
|
ivalue=xmsgin(iwd)
|
|
elseif (nwds.ge.iwd.and.msgtyp(iwd).eq.1) then
|
|
ivalue=xmsgin(iwd)
|
|
else
|
|
ivalue=0
|
|
endif
|
|
|
|
iwd=iwd+1
|
|
if (nwds.ge.iwd.and.msgtyp(iwd).eq.3) then
|
|
lact2=icharlnf(cmsgin(iwd))
|
|
if (lact2.gt.0) then
|
|
action2=cmsgin(iwd)(1:lact2)
|
|
else
|
|
action2='or'
|
|
lact2=2
|
|
endif
|
|
else
|
|
action2='or'
|
|
lact2=2
|
|
endif
|
|
|
|
if (action(1:lenaction).eq.'refilter'.and.ivalue.gt.0) then
|
|
call cmo_get_info('d0_nfilters',cmo0(1:lcmo0)
|
|
& ,d0_nfilters,len,ityp,ierr)
|
|
if (ierr.ne.0.and.d0_nfilters.gt.0) then
|
|
! coding caution:
|
|
! rankfilter must be consistent with rankfilter in filter_lower_d_lg
|
|
rankfilter=3
|
|
d0_nfilters=d0_nfilters-rankfilter*ivalue
|
|
if (d0_nfilters.lt.0) d0_nfilters=0
|
|
len=1
|
|
ityp=1
|
|
call cmo_set_info('d0_nfilters',cmo0(1:lcmo0)
|
|
& ,d0_nfilters,len,ityp,ierr)
|
|
endif
|
|
endif
|
|
|
|
if (lower_d_flag.ne.1
|
|
& .or.action(1:lenaction).eq.'refilter'
|
|
& .or.action(1:lenaction).eq.'recreate') then
|
|
! new_storage: 0=reuse color and filter tables
|
|
! 1=reuse neither
|
|
! 2=reuse color table only
|
|
new_storage=0
|
|
if (action(1:lenaction).eq.'recreate') new_storage=2
|
|
if (lower_d_flag.ne.1.and.lower_d_flag.ne.2) new_storage=1
|
|
call create_lower_d_lg(cmo0(1:lcmo0),new_storage,ierror)
|
|
if (ierror.ne.0) goto 9999
|
|
endif
|
|
if (action(1:lenaction).ne.'refilter'
|
|
& .or.action(1:lenaction).eq.'recreate') then
|
|
! filtering done in create call for refilter
|
|
call filter_lower_d_lg(cmo0,action,ivalue,action2,ierror)
|
|
if (ierror.ne.0) goto 9999
|
|
endif
|
|
|
|
c .....................................................
|
|
|
|
else
|
|
|
|
c -----------------------------------------------------
|
|
c what other commands would one want?
|
|
c
|
|
c lower_d/dump/....
|
|
c not coded: use, eg to dump just the 1-dimension lower mesh
|
|
c use the command sequence:
|
|
c lower_d/create/cmo0/(options)
|
|
c lower_d/extract/cmo0/cmo1
|
|
c dump/gmv/gmv.cmo1/cmo1
|
|
c cmo release cmo1
|
|
c lower_d/release/cmo0
|
|
c to code, translate above sequence into single command,
|
|
c including creates and releases as desired....
|
|
c
|
|
c -----------------------------------------------------
|
|
|
|
goto 9999
|
|
|
|
c .....................................................
|
|
endif
|
|
|
|
|
|
c........ (sucessful return) ..................
|
|
1000 ierror=0
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'finished control_lower_d_lg succesfully'
|
|
call mmverify()
|
|
endif
|
|
len=icharlnf(cmo_save)
|
|
cbuf='cmo select '//cmo_save(1:len)//'; finish'
|
|
call cmo_get_name(cmo_save,ierr)
|
|
return
|
|
|
|
c........ (failure return) ..................
|
|
9999 if (ierror.eq.0) ierror=1
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'finished control_lower_d_lg unsuccesfully'
|
|
call mmverify()
|
|
endif
|
|
cbuf='ERROR IN ROUTINE control_lower_d_lg: ABORTING'
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
cbuf='cmo select '//cmo_save(1:len)//'; finish'
|
|
call cmo_get_name(cmo_save,ierr)
|
|
return
|
|
c .....................................................
|
|
end
|
|
|
|
c-----------------------------------------------------------------------
|
|
C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|
|
|
c-----------------------------------------------------------------------
|
|
C #####################################################################
|
|
C create_lower_d_lg
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C create the lower d structures witin the mesh object cmo
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C cmo - name of mesh object
|
|
C new_storage - flag to indicate whether storage exists
|
|
C 0=reuse color and filter tables
|
|
C 1=reuse neither
|
|
C 2=reuse color table only
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
|
|
C
|
|
C USAGE NOTES / CAVEATS / CHANGES -
|
|
C
|
|
C #####################################################################
|
|
|
|
subroutine create_lower_d_lg(cmo,new_storage,ierror)
|
|
|
|
c ........................................................................
|
|
|
|
implicit none
|
|
|
|
include 'local_element.h'
|
|
include 'chydro.h'
|
|
|
|
character*(*) cmo
|
|
integer ierror,new_storage
|
|
|
|
integer mbndry,d0_nelements,nnodes,nconbnd,mbndry_save
|
|
integer d0_topo,d0_nee_cmo,d0_nef_cmo,d0_nen_cmo,d0_geom
|
|
& ,d0_nclrs,jtet_reduce_nnd
|
|
& ,d0_jtet_cycle_max,interior_icr_flag
|
|
|
|
pointer (ip_jtet,jtet),(ip_jtetoff,jtetoff)
|
|
& ,(ip_itet,itet),(ip_itetoff,itetoff)
|
|
& ,(ip_itettyp,itettyp),(ip_itetclr,itetclr)
|
|
& ,(ip_itp1,itp1),(ip_icr1,icr1)
|
|
& ,(ip_isn1,isn1),(ip_iparent,iparent)
|
|
& ,(ip_icontab,icontab)
|
|
& ,(ip_d0_node_topo,d0_node_topo)
|
|
& ,(ip_d0_clrtab,d0_clrtab),(ip_d0_clroff,d0_clroff)
|
|
integer jtet(*),jtetoff(*)
|
|
& ,itet(*),itetoff(*)
|
|
& ,itettyp(*),itetclr(*)
|
|
& ,itp1(*),icr1(*)
|
|
& ,isn1(*),iparent(*)
|
|
& ,icontab(50,*)
|
|
& ,d0_node_topo(*)
|
|
& ,d0_clrtab(*),d0_clroff(*)
|
|
|
|
character*32 geom_name
|
|
pointer (ip_ibtype,ibtype)
|
|
character*32 ibtype(*)
|
|
|
|
integer d1_nnodes,d1_nelements
|
|
& ,d1_nef_cmo,d1_nee_cmo,d1_nen_cmo
|
|
& ,d1_jtet_cycle_max
|
|
|
|
pointer (ip_d1_itet,d1_itet),(ip_d1_itetoff,d1_itetoff)
|
|
& ,(ip_d1_jtet,d1_jtet),(ip_d1_jtetoff,d1_jtetoff)
|
|
& ,(ip_d1_itettyp,d1_itettyp),(ip_d1_itetclr,d1_itetclr)
|
|
& ,(ip_d1_elm_d0,d1_elm_d0)
|
|
integer d1_itet(*),d1_itetoff(*)
|
|
& ,d1_jtet(*),d1_jtetoff(*)
|
|
& ,d1_itettyp(*),d1_itetclr(*)
|
|
& ,d1_elm_d0(*)
|
|
|
|
integer d2_nnodes,d2_nelements
|
|
& ,d2_nef_cmo,d2_nee_cmo,d2_nen_cmo
|
|
& ,d2_jtet_cycle_max
|
|
|
|
pointer (ip_d2_itet,d2_itet),(ip_d2_itetoff,d2_itetoff)
|
|
& ,(ip_d2_jtet,d2_jtet),(ip_d2_jtetoff,d2_jtetoff)
|
|
& ,(ip_d2_itettyp,d2_itettyp),(ip_d2_itetclr,d2_itetclr)
|
|
& ,(ip_d2_elm_d1,d2_elm_d1)
|
|
integer d2_itet(*),d2_itetoff(*)
|
|
& ,d2_jtet(*),d2_jtetoff(*)
|
|
& ,d2_itettyp(*),d2_itetclr(*)
|
|
& ,d2_elm_d1(*)
|
|
|
|
pointer (ipd2_elm_tmp, d2_elm_tmp)
|
|
integer d2_elm_tmp(*)
|
|
|
|
integer d3_nnodes,d3_nelements
|
|
& ,d3_nef_cmo,d3_nee_cmo,d3_nen_cmo
|
|
|
|
pointer (ip_dn_elm,dn_elm)
|
|
integer dn_elm(*)
|
|
|
|
integer j,len,ityp,ierr,ioff
|
|
& ,iel
|
|
& ,d_topo,local_debug
|
|
real*8 xxx
|
|
|
|
|
|
character*132 cbuf
|
|
character*32 isubname
|
|
|
|
integer icharlnf,lcmo
|
|
external icharlnf
|
|
|
|
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
|
local_debug=0
|
|
|
|
lcmo=icharlnf(cmo)
|
|
call cmo_exist(cmo(1:lcmo),ierr)
|
|
if (ierr.ne.0) goto 9998
|
|
|
|
isubname='tmp_lower_d_lg'
|
|
|
|
if (local_debug.ne.0) then
|
|
write(*,*) 'reached create_lower_d_lg'
|
|
write(cbuf,*)'cmo status; finish'
|
|
call dotask(cbuf,ierr)
|
|
endif
|
|
|
|
c........ (create new attributes) ..................
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'starting storage_lower_d_lg'
|
|
call mmverify()
|
|
endif
|
|
call storage_lower_d_lg(cmo,new_storage,ierror)
|
|
if (ierror.ne.0) goto 9998
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'finished storage_lower_d_lg'
|
|
call mmverify()
|
|
endif
|
|
|
|
c........ (reset mbndry to mbndry=0 convention) ..................
|
|
|
|
call cmo_get_info('mbndry',cmo,mbndry,len,ityp,ierr)
|
|
if (ierr.ne.0) mbndry=0
|
|
mbndry_save=mbndry
|
|
|
|
! reset mbndry to use mbndry=0 convention
|
|
if (mbndry_save.ne.0) then
|
|
mbndry=0
|
|
call reset_mbndry_lower_d_lg(cmo,mbndry,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
endif
|
|
|
|
c........ (get d0 info) ..................
|
|
|
|
! if jtet_reduce_nnd exists (created by user), then
|
|
! pass to geniee, otherwise just pass zero
|
|
! (faces of different nnd cannot touch)
|
|
call cmo_get_info('jtet_reduce_nnd',cmo,jtet_reduce_nnd
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) jtet_reduce_nnd=0
|
|
call cmo_get_info('jtet_cycle_max',cmo,d0_jtet_cycle_max
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) d0_jtet_cycle_max=2
|
|
|
|
call cmo_get_info('nnodes',cmo,nnodes,len,ityp,ierr)
|
|
if (ierr.ne.0.or.nnodes.lt.1) goto 9999
|
|
call cmo_get_info('nelements',cmo,d0_nelements,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d0_nelements.lt.1) goto 9999
|
|
call cmo_get_info('ndimensions_topo',cmo,d0_topo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
c no lower dimensional structures if d0_topo=0
|
|
if (d0_topo.lt.1) goto 500
|
|
|
|
call cmo_get_info('faces_per_element',cmo,d0_nef_cmo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0.or.
|
|
& (d0_nelements.gt.0.and.d0_nef_cmo.lt.d0_topo+1)) goto 9999
|
|
call cmo_get_info('edges_per_element',cmo,d0_nee_cmo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d0_nee_cmo.lt.0) goto 9999
|
|
call cmo_get_info('nodes_per_element',cmo,d0_nen_cmo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0.or.
|
|
& (d0_nelements.gt.0.and.d0_nen_cmo.lt.d0_topo+1)) goto 9999
|
|
call cmo_get_info('ndimensions_geom',cmo,d0_geom
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d0_geom.lt.1.or.d0_geom.gt.3) goto 9999
|
|
|
|
call cmo_get_info('jtet',cmo,ip_jtet,len,ityp,ierr)
|
|
call cmo_get_info('jtetoff',cmo,ip_jtetoff,len,ityp,ierr)
|
|
call cmo_get_info('itet',cmo,ip_itet,len,ityp,ierr)
|
|
call cmo_get_info('itetoff',cmo,ip_itetoff,len,ityp,ierr)
|
|
call cmo_get_info('itetclr',cmo,ip_itetclr,len,ityp,ierr)
|
|
call cmo_get_info('itettyp',cmo,ip_itettyp,len,ityp,ierr)
|
|
call cmo_get_info('isn1',cmo,ip_isn1,len,ityp,ierr)
|
|
call cmo_get_info('itp1',cmo,ip_itp1,len,ityp,ierr)
|
|
call cmo_get_info('icr1',cmo,ip_icr1,len,ityp,ierr)
|
|
call cmo_get_info('nconbnd',cmo,nconbnd,len,ityp,ierr)
|
|
if (ierr.ne.0.or.nconbnd.le.0) then
|
|
nconbnd=0
|
|
else
|
|
call cmo_get_info('icontab',cmo,ip_icontab,len,ityp,ierr)
|
|
if (ierr.ne.0) nconbnd=0
|
|
endif
|
|
|
|
call mmggetbk('iparent',isubname,ip_iparent,nnodes,1,ierr)
|
|
call unpackpc(nnodes,itp1,isn1,iparent)
|
|
|
|
call cmo_get_info('d0_node_topo',cmo,ip_d0_node_topo
|
|
& ,len,ityp,ierr)
|
|
if (d0_topo.gt.1) call mmggetbk('dn_elm',isubname
|
|
& ,ip_dn_elm,d0_nelements*d0_nef_cmo,1,ierr)
|
|
|
|
! no need to check mbndry: using mbndry=0 convention
|
|
|
|
c lower_d_flag ...............
|
|
c lower_d_flag=0: no lower d; =1: has lower d; =2: lower d wanted but not set
|
|
|
|
call cmo_set_info('lower_d_flag',cmo,2,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
c interior_icr_flag .........
|
|
! check for global flag to ignore possibly spurious
|
|
! interior interface or virtual constraints
|
|
call cmo_get_info('interior_icr_flag',cmo,interior_icr_flag
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0.or.interior_icr_flag.gt.7
|
|
& .or.interior_icr_flag.lt.0) interior_icr_flag=0
|
|
|
|
! get info for checking surfaces defns as virtual,intrcons,etc
|
|
call cmo_get_attinfo('geom_name',cmo,iel,xxx,geom_name,
|
|
& j,len,ityp,ierr)
|
|
if (ierr.ne.0) geom_name='-defaultgeom-'
|
|
call mmfindbk('ibtype',geom_name,ip_ibtype,len,ierr)
|
|
if (ierr.ne.0) geom_name='-none-'
|
|
|
|
c =======================================================================
|
|
|
|
c........ (find d1 lengths) ..................
|
|
|
|
c d1_nnodes,d1_nelements
|
|
c d1_nef_cmo,d1_nee_cmo,d1_nen_cmo
|
|
c to find d1_nnodes, use d0_node_topo
|
|
c also find dn_elm if d0_topo>1
|
|
|
|
d_topo=d0_topo
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'starting d1 sizes_lower_d_lg'
|
|
call mmverify()
|
|
endif
|
|
call sizes_lower_d_lg(d0_topo,d_topo
|
|
& ,nnodes,d0_nelements,d0_nef_cmo,mbndry,nconbnd
|
|
& ,d0_jtet_cycle_max,interior_icr_flag,ibtype,geom_name
|
|
& ,itettyp,itetclr,itet,itetoff,jtet,jtetoff
|
|
& ,itp1,icr1,icontab,isn1,iparent
|
|
& ,d1_nnodes,d1_nelements
|
|
& ,d1_nef_cmo,d1_nee_cmo,d1_nen_cmo
|
|
& ,d0_node_topo,dn_elm
|
|
& ,ierror)
|
|
if (ierror.ne.0) goto 9999
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'finished d1 sizes_lower_d_lg'
|
|
& ,d1_nnodes,d1_nelements
|
|
& ,d1_nef_cmo,d1_nee_cmo,d1_nen_cmo
|
|
call mmverify()
|
|
endif
|
|
! write(*,*)'d1_nnodes,d1_nelements',d1_nnodes,d1_nelements
|
|
|
|
c........ (assign d1 storage) ..................
|
|
c Note: aborted above for d0_topo<1 ...
|
|
c for d0_topo=1 => set d1_nelements=0 as not using elements for dim=0
|
|
|
|
if (d0_topo.eq.1) then
|
|
d1_nelements=0
|
|
d1_nef_cmo=0
|
|
d1_nee_cmo=0
|
|
d1_nen_cmo=0
|
|
endif
|
|
|
|
len=1
|
|
ityp=1
|
|
call cmo_set_info('d1_nnodes',cmo,d1_nnodes,len,ityp,ierr)
|
|
|
|
!! nothing more to do if no elements ......
|
|
if (d1_nelements.eq.0.or.d0_topo.le.1) goto 500
|
|
|
|
call cmo_set_info('d1_nelements',cmo,d1_nelements,len,ityp,ierr)
|
|
call cmo_set_info('d1_nef_cmo',cmo,d1_nef_cmo,len,ityp,ierr)
|
|
call cmo_set_info('d1_nee_cmo',cmo,d1_nee_cmo,len,ityp,ierr)
|
|
call cmo_set_info('d1_nen_cmo',cmo,d1_nen_cmo,len,ityp,ierr)
|
|
|
|
call cmo_newlen(cmo,ierr) ! OK re mbndry as using mbndry=0
|
|
|
|
call cmo_get_info('d1_itet',cmo,ip_d1_itet,len,ityp,ierr)
|
|
call cmo_get_info('d1_itetoff',cmo,ip_d1_itetoff,len,ityp,ierr)
|
|
call cmo_get_info('d1_jtet',cmo,ip_d1_jtet,len,ityp,ierr)
|
|
call cmo_get_info('d1_jtetoff',cmo,ip_d1_jtetoff,len,ityp,ierr)
|
|
call cmo_get_info('d1_itettyp',cmo,ip_d1_itettyp,len,ityp,ierr)
|
|
call cmo_get_info('d1_itetclr',cmo,ip_d1_itetclr,len,ityp,ierr)
|
|
call cmo_get_info('d1_elm_d0',cmo,ip_d1_elm_d0,len,ityp,ierr)
|
|
|
|
! re-get re newlen ...
|
|
call cmo_get_info('jtet',cmo,ip_jtet,len,ityp,ierr)
|
|
call cmo_get_info('jtetoff',cmo,ip_jtetoff,len,ityp,ierr)
|
|
call cmo_get_info('itet',cmo,ip_itet,len,ityp,ierr)
|
|
call cmo_get_info('itetoff',cmo,ip_itetoff,len,ityp,ierr)
|
|
call cmo_get_info('itetclr',cmo,ip_itetclr,len,ityp,ierr)
|
|
call cmo_get_info('itettyp',cmo,ip_itettyp,len,ityp,ierr)
|
|
call cmo_get_info('isn1',cmo,ip_isn1,len,ityp,ierr)
|
|
call cmo_get_info('itp1',cmo,ip_itp1,len,ityp,ierr)
|
|
call cmo_get_info('icr1',cmo,ip_icr1,len,ityp,ierr)
|
|
if (nconbnd.gt.0)
|
|
& call cmo_get_info('icontab',cmo,ip_icontab,len,ityp,ierr)
|
|
call mmfindbk('iparent',isubname,ip_iparent,len,ierr)
|
|
call cmo_get_info('d0_node_topo',cmo,ip_d0_node_topo
|
|
& ,len,ityp,ierr)
|
|
if (d0_topo.gt.1) call mmfindbk('dn_elm',isubname
|
|
& ,ip_dn_elm,len,ierr)
|
|
if (geom_name(1:6).ne.'-none-')
|
|
& call mmfindbk('ibtype',geom_name,ip_ibtype,len,ierr)
|
|
|
|
if (local_debug.ne.0) then
|
|
!write(cbuf,*)'cmo status; finish'
|
|
!call dotask(cbuf,ierr)
|
|
endif
|
|
|
|
c........ (assign d1 itet info) ..................
|
|
c assign d1_elm_d0,itettyp,d1_itet,d1_itetoff,d1_jtetoff
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'starting d1 itet_lower_d_lg'
|
|
call mmverify()
|
|
endif
|
|
d_topo=d0_topo
|
|
call itet_lower_d_lg(d0_nelements,d0_nef_cmo
|
|
& ,iparent,itettyp,itetoff,itet,dn_elm,jtetoff
|
|
& ,d1_nelements,d1_nef_cmo
|
|
& ,d1_elm_d0,d1_itettyp,d1_itetoff,d1_itet,d1_jtetoff
|
|
& ,ierror)
|
|
if (ierror.ne.0) goto 9999
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'finished d1 itet_lower_d_lg'
|
|
call mmverify()
|
|
endif
|
|
|
|
c........ (find d1 itetclr) ..................
|
|
c increment color table as necessary...
|
|
|
|
d_topo=1
|
|
call itetclr_lower_d_lg(cmo
|
|
& ,d_topo,nconbnd,mbndry
|
|
& ,d0_jtet_cycle_max,jtet_reduce_nnd
|
|
& ,interior_icr_flag,ibtype,geom_name
|
|
& ,d0_nelements,d0_nef_cmo
|
|
& ,icontab,itp1,icr1,isn1,iparent
|
|
& ,itetclr,jtetoff,jtet
|
|
& ,d1_nelements,d1_nef_cmo
|
|
& ,d1_itettyp,d1_itetclr,d1_itetoff,d1_itet,d1_elm_d0
|
|
& ,ierror)
|
|
if (ierror.ne.0) goto 9999
|
|
! need to re-get pointers ...
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'finished d1 itetclr_lower_d_lg'
|
|
call mmverify()
|
|
endif
|
|
|
|
! do I need to re-get info re itetclr_lower_d_lg
|
|
! increasing clrtab block?? Hopefully not ...
|
|
|
|
c........ (find jtet from itet) ..................
|
|
c note: aborted above for d0_topo<2 => jtet exists
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'starting d1 sub_geniee_cmo_lg'
|
|
call mmverify()
|
|
endif
|
|
call sub_geniee_cmo_lg(
|
|
& jtet_reduce_nnd,d1_nelements,d1_nef_cmo,mbndry
|
|
& ,ip_d1_itetclr,ip_d1_itettyp,ip_d1_itetoff
|
|
& ,ip_d1_jtetoff,ip_d1_itet
|
|
& ,ip_iparent,ip_d1_jtet,d1_jtet_cycle_max,ierror)
|
|
if (ierror.ne.0) goto 9999
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'finished d1 sub_geniee_cmo_lg'
|
|
call mmverify()
|
|
endif
|
|
! set d1_jtet_cycle_max
|
|
call cmo_set_info('d1_jtet_cycle_max',cmo,d1_jtet_cycle_max
|
|
& ,len,ityp,ierr)
|
|
|
|
c ...... (see if need to order surfaces) ....
|
|
call mmggetbk('dn_elm',isubname,ip_dn_elm,d1_nelements,1,ierr)
|
|
call order_surface_lower_d_lg(
|
|
& d1_nelements,d1_nef_cmo,mbndry,iparent
|
|
& ,d1_itettyp,d1_itetoff,d1_jtetoff,d1_itet,d1_jtet
|
|
& ,dn_elm,ierror)
|
|
do iel=1,d1_nelements
|
|
ityp=d1_itettyp(iel)
|
|
if (dn_elm(iel).lt.0 .and. (ityp.eq.ifelmtri
|
|
& .or.ityp.eq.ifelmqud.or.ityp.eq.ifelmlin)
|
|
& ) goto 440
|
|
enddo
|
|
goto 442
|
|
440 continue
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'd1 surfaces required re-ordering'
|
|
endif
|
|
! this should not occur except for virtual surfaces
|
|
! and parents being a network
|
|
! for now, do lazy way: re-order itet and call jtet.
|
|
! should fix parent as no longer ordered same as parent...
|
|
! for now, ignore.
|
|
do iel=1,d1_nelements
|
|
if (dn_elm(iel).lt.0) then
|
|
ityp=d1_itettyp(iel)
|
|
ioff=d1_itetoff(iel)
|
|
if (ityp.ne.ifelmtri.and.ityp.ne.ifelmqud
|
|
& .and.ityp.ne.ifelmlin ) goto 441
|
|
if (ityp.eq.ifelmlin) then
|
|
j=d1_itet(ioff+1)
|
|
d1_itet(ioff+1)=d1_itet(ioff+2)
|
|
d1_itet(ioff+2)=j
|
|
elseif (ityp.eq.ifelmtri) then
|
|
j=d1_itet(ioff+1)
|
|
d1_itet(ioff+1)=d1_itet(ioff+3)
|
|
d1_itet(ioff+3)=j
|
|
else ! if (ityp.eq.ifelmqud) then
|
|
j=d1_itet(ioff+1)
|
|
d1_itet(ioff+1)=d1_itet(ioff+4)
|
|
d1_itet(ioff+4)=j
|
|
j=d1_itet(ioff+2)
|
|
d1_itet(ioff+2)=d1_itet(ioff+3)
|
|
d1_itet(ioff+3)=j
|
|
endif
|
|
endif
|
|
441 continue
|
|
enddo
|
|
call sub_geniee_cmo_lg(
|
|
& jtet_reduce_nnd,d1_nelements,d1_nef_cmo,mbndry
|
|
& ,ip_d1_itetclr,ip_d1_itettyp,ip_d1_itetoff
|
|
& ,ip_d1_jtetoff,ip_d1_itet
|
|
& ,ip_iparent,ip_d1_jtet,d1_jtet_cycle_max,ierror)
|
|
if (ierror.ne.0) goto 9999
|
|
! set d1_jtet_cycle_max
|
|
call cmo_set_info('d1_jtet_cycle_max',cmo,d1_jtet_cycle_max
|
|
& ,len,ityp,ierr)
|
|
442 continue
|
|
|
|
|
|
c =======================================================================
|
|
c........ (start d2 structures) ..................
|
|
|
|
c........ (find d2 lengths) ..................
|
|
|
|
c d2_nnodes,d2_nelements
|
|
c d2_nef_cmo,d2_nee_cmo,d2_nen_cmo
|
|
c to find d2_nnodes
|
|
c also find dn_elm if d0_topo>2
|
|
|
|
d_topo=d0_topo-1
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'starting d2 sizes_lower_d_lg'
|
|
call mmverify()
|
|
endif
|
|
if (d_topo.gt.1) call mmggetbk('dn_elm',isubname
|
|
& ,ip_dn_elm,d1_nelements*d1_nef_cmo,1,ierr)
|
|
call sizes_lower_d_lg(d0_topo,d_topo
|
|
& ,nnodes,d1_nelements,d1_nef_cmo,mbndry,nconbnd
|
|
& ,d1_jtet_cycle_max,interior_icr_flag,ibtype,geom_name
|
|
& ,d1_itettyp,d1_itetclr,d1_itet,d1_itetoff
|
|
& ,d1_jtet,d1_jtetoff
|
|
& ,itp1,icr1,icontab,isn1,iparent
|
|
& ,d2_nnodes,d2_nelements
|
|
& ,d2_nef_cmo,d2_nee_cmo,d2_nen_cmo
|
|
& ,d0_node_topo,dn_elm
|
|
& ,ierror)
|
|
if (ierror.ne.0) goto 9999
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'finished d2 sizes_lower_d_lg'
|
|
& ,d2_nnodes,d2_nelements
|
|
& ,d2_nef_cmo,d2_nee_cmo,d2_nen_cmo
|
|
call mmverify()
|
|
endif
|
|
! write(*,*)'d2_nnodes,d2_nelements',d2_nnodes,d2_nelements
|
|
|
|
c Note: aborted above for d0_topo<2 ...
|
|
c for d0_topo=2 => set d2_nelements=0 as not using elements for dim=0
|
|
if (d0_topo.eq.2) then
|
|
d2_nelements=0
|
|
d2_nef_cmo=0
|
|
d2_nee_cmo=0
|
|
d2_nen_cmo=0
|
|
endif
|
|
|
|
c........ (assign d2 storage, d1 to d2 storage) ..................
|
|
|
|
len=1
|
|
ityp=1
|
|
call cmo_set_info('d2_nnodes',cmo,d2_nnodes,len,ityp,ierr)
|
|
|
|
!! nothing more to do if no elements ....
|
|
if (d2_nelements.eq.0.or.d0_topo.le.2) goto 500
|
|
|
|
call cmo_set_info('d2_nelements',cmo,d2_nelements,len,ityp,ierr)
|
|
call cmo_set_info('d2_nef_cmo',cmo,d2_nef_cmo,len,ityp,ierr)
|
|
call cmo_set_info('d2_nee_cmo',cmo,d2_nee_cmo,len,ityp,ierr)
|
|
call cmo_set_info('d2_nen_cmo',cmo,d2_nen_cmo,len,ityp,ierr)
|
|
|
|
call cmo_newlen(cmo,ierr) ! OK re mbndry as using mbndry=0
|
|
|
|
call cmo_get_info('d2_itet',cmo,ip_d2_itet,len,ityp,ierr)
|
|
call cmo_get_info('d2_itetoff',cmo,ip_d2_itetoff,len,ityp,ierr)
|
|
call cmo_get_info('d2_jtet',cmo,ip_d2_jtet,len,ityp,ierr)
|
|
call cmo_get_info('d2_jtetoff',cmo,ip_d2_jtetoff,len,ityp,ierr)
|
|
call cmo_get_info('d2_itettyp',cmo,ip_d2_itettyp,len,ityp,ierr)
|
|
call cmo_get_info('d2_itetclr',cmo,ip_d2_itetclr,len,ityp,ierr)
|
|
call cmo_get_info('d2_elm_d1',cmo,ip_d2_elm_d1,len,ityp,ierr)
|
|
|
|
C this is not expected to be used, but pass into routines
|
|
C with correct length in case it is
|
|
call cmo_get_info('d2_elm_tmp',cmo,ipd2_elm_tmp,len,ityp,ierr)
|
|
|
|
! re-get re newlen ...
|
|
call cmo_get_info('d1_jtet',cmo,ip_d1_jtet,len,ityp,ierr)
|
|
call cmo_get_info('d1_jtetoff',cmo,ip_d1_jtetoff,len,ityp,ierr)
|
|
call cmo_get_info('d1_itet',cmo,ip_d1_itet,len,ityp,ierr)
|
|
call cmo_get_info('d1_itetoff',cmo,ip_d1_itetoff,len,ityp,ierr)
|
|
call cmo_get_info('d1_itetclr',cmo,ip_d1_itetclr,len,ityp,ierr)
|
|
call cmo_get_info('d1_itettyp',cmo,ip_d1_itettyp,len,ityp,ierr)
|
|
if (geom_name(1:6).ne.'-none-')
|
|
& call mmfindbk('ibtype',geom_name,ip_ibtype,len,ierr)
|
|
if (nconbnd.gt.0)
|
|
& call cmo_get_info('icontab',cmo,ip_icontab,len,ityp,ierr)
|
|
call mmfindbk('iparent',isubname,ip_iparent,len,ierr)
|
|
call cmo_get_info('d0_node_topo',cmo,ip_d0_node_topo
|
|
& ,len,ityp,ierr)
|
|
if (d0_topo.gt.2) call mmfindbk('dn_elm',isubname
|
|
& ,ip_dn_elm,len,ierr)
|
|
|
|
if (local_debug.ne.0) then
|
|
!write(cbuf,*)'cmo status; finish'
|
|
!call dotask(cbuf,ierr)
|
|
endif
|
|
|
|
c........ (find d2 itet info) ..................
|
|
c d2_elm_d1
|
|
c and find d2_itet,d2_itetoff,d2_jtetoff,d2_itettyp
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'starting d2 itet_lower_d_lg'
|
|
call mmverify()
|
|
endif
|
|
|
|
d_topo=d0_topo-1
|
|
call itet_lower_d_lg(d1_nelements,d1_nef_cmo
|
|
& ,iparent,d1_itettyp,d1_itetoff,d1_itet,dn_elm,d1_jtetoff
|
|
& ,d2_nelements,d2_nef_cmo
|
|
& ,d2_elm_d1,d2_itettyp,d2_itetoff,d2_itet,d2_jtetoff
|
|
& ,ierror)
|
|
if (ierror.ne.0) goto 9999
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'finished d2 itet_lower_d_lg'
|
|
call mmverify()
|
|
endif
|
|
|
|
c........ (find d2_itetclr) ..................
|
|
c increment color table as necessary...
|
|
|
|
d_topo=2
|
|
call itetclr_lower_d_lg(cmo
|
|
& ,d_topo,nconbnd,mbndry
|
|
& ,d1_jtet_cycle_max,jtet_reduce_nnd
|
|
& ,interior_icr_flag,ibtype,geom_name
|
|
& ,d1_nelements,d1_nef_cmo
|
|
& ,icontab,itp1,icr1,isn1,iparent
|
|
& ,d1_itetclr,d1_jtetoff,d1_jtet
|
|
& ,d2_nelements,d2_nef_cmo
|
|
& ,d2_itettyp,d2_itetclr,d2_itetoff,d2_itet,d2_elm_d1
|
|
& ,ierror)
|
|
if (ierror.ne.0) goto 9999
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'finished d2 itetclr_lower_d_lg'
|
|
call mmverify()
|
|
endif
|
|
|
|
! do I need to re-get info re itetclr_lower_d_lg
|
|
! increasing clrtab block?? Hopefully not ...
|
|
|
|
c........ (now find jtet from itet) ..................
|
|
c note: aborted above for d0_topo<3 => jtet exists
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'starting d2 sub_geniee_cmo_lg'
|
|
call mmverify()
|
|
endif
|
|
|
|
call sub_geniee_cmo_lg(
|
|
& jtet_reduce_nnd,d2_nelements,d2_nef_cmo,mbndry
|
|
& ,ip_d2_itetclr,ip_d2_itettyp
|
|
& ,ip_d2_itetoff,ip_d2_jtetoff,ip_d2_itet
|
|
& ,ip_iparent,ip_d2_jtet,d2_jtet_cycle_max,ierror)
|
|
if (ierror.ne.0) goto 9999
|
|
! set d2_jtet_cycle_max
|
|
call cmo_set_info('d2_jtet_cycle_max',cmo,d2_jtet_cycle_max
|
|
& ,len,ityp,ierr)
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'finished d2 sub_geniee_cmo_lg'
|
|
call mmverify()
|
|
endif
|
|
|
|
c ...... (see if need to order surfaces) ....
|
|
call mmggetbk('dn_elm',isubname,ip_dn_elm,d2_nelements,1,ierr)
|
|
call order_surface_lower_d_lg(
|
|
& d2_nelements,d2_nef_cmo,mbndry,iparent
|
|
& ,d2_itettyp,d2_itetoff,d2_jtetoff,d2_itet,d2_jtet
|
|
& ,dn_elm,ierror)
|
|
do iel=1,d1_nelements
|
|
ityp=d2_itettyp(iel)
|
|
if (dn_elm(iel).lt.0 .and. (ityp.eq.ifelmtri
|
|
& .or.ityp.eq.ifelmqud.or.ityp.eq.ifelmlin)
|
|
& ) goto 450
|
|
enddo
|
|
goto 452
|
|
450 continue
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'd2 surfaces required re-ordering'
|
|
endif
|
|
! this should not occur except for virtual surfaces
|
|
! and parents being a network
|
|
! for now, do lazy way: re-order itet and call jtet.
|
|
! should fix parent as no longer ordered same as parent...
|
|
! for now, ignore.
|
|
do iel=1,d2_nelements
|
|
if (dn_elm(iel).lt.0) then
|
|
ityp=d2_itettyp(iel)
|
|
ioff=d2_itetoff(iel)
|
|
if (ityp.ne.ifelmtri.and.ityp.ne.ifelmqud
|
|
& .and.ityp.ne.ifelmlin ) goto 451
|
|
if (ityp.eq.ifelmlin) then
|
|
j=d2_itet(ioff+1)
|
|
d2_itet(ioff+1)=d2_itet(ioff+2)
|
|
d2_itet(ioff+2)=j
|
|
elseif (ityp.eq.ifelmtri) then
|
|
j=d2_itet(ioff+1)
|
|
d2_itet(ioff+1)=d2_itet(ioff+3)
|
|
d2_itet(ioff+3)=j
|
|
else ! if (ityp.eq.ifelmqud) then
|
|
j=d2_itet(ioff+1)
|
|
d2_itet(ioff+1)=d1_itet(ioff+4)
|
|
d2_itet(ioff+4)=j
|
|
j=d2_itet(ioff+2)
|
|
d2_itet(ioff+2)=d2_itet(ioff+3)
|
|
d2_itet(ioff+3)=j
|
|
endif
|
|
endif
|
|
451 continue
|
|
enddo
|
|
call sub_geniee_cmo_lg(
|
|
& jtet_reduce_nnd,d2_nelements,d2_nef_cmo,mbndry
|
|
& ,ip_d2_itetclr,ip_d2_itettyp,ip_d2_itetoff
|
|
& ,ip_d2_jtetoff,ip_d2_itet
|
|
& ,ip_iparent,ip_d2_jtet,d2_jtet_cycle_max,ierror)
|
|
if (ierror.ne.0) goto 9999
|
|
! set d2_jtet_cycle_max
|
|
call cmo_set_info('d2_jtet_cycle_max',cmo,d2_jtet_cycle_max
|
|
& ,len,ityp,ierr)
|
|
452 continue
|
|
|
|
c =======================================================================
|
|
|
|
c........ (start d3 structures) ..................
|
|
|
|
c........ (find d3 lengths) ..................
|
|
|
|
c d3_nnodes,d3_nelements
|
|
c d3_nef_cmo,d3_nee_cmo,d3_nen_cmo
|
|
|
|
C TAM - can not pass j scalar just because d2_elm_d3 is not used
|
|
C need to pass appropriate non scalar
|
|
C ,d0_node_topo,j changed to 0_node_topo,d2_elm_tmp
|
|
|
|
j=0 ! d2_elm_d3 -> not used as d_topo=1
|
|
d_topo=d0_topo-2
|
|
|
|
c for d0_topo>3, not enough storage was created,
|
|
c but press on just creating node translation
|
|
if (d_topo.gt.1) d_topo=1 ! goto 9999
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'starting d3 sizes_lower_d_lg'
|
|
call mmverify()
|
|
endif
|
|
call sizes_lower_d_lg(d0_topo,d_topo
|
|
& ,nnodes,d2_nelements,d2_nef_cmo,mbndry,nconbnd
|
|
& ,d2_jtet_cycle_max,interior_icr_flag,ibtype,geom_name
|
|
& ,d2_itettyp,d2_itetclr,d2_itet,d2_itetoff
|
|
& ,d2_jtet,d2_jtetoff
|
|
& ,itp1,icr1,icontab,isn1,iparent
|
|
& ,d3_nnodes,d3_nelements
|
|
& ,d3_nef_cmo,d3_nee_cmo,d3_nen_cmo
|
|
& ,d0_node_topo,d2_elm_tmp
|
|
& ,ierror)
|
|
if (ierror.ne.0) goto 9999
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'finished d3 sizes_lower_d_lg'
|
|
& ,d3_nnodes,d3_nelements
|
|
& ,d3_nef_cmo,d3_nee_cmo,d3_nen_cmo
|
|
call mmverify()
|
|
endif
|
|
|
|
c Note: aborted above for d0_topo<3, and just doing node transl if d0_topo>3
|
|
c => set d3_nelements=0 as not using elements for dim=0
|
|
d3_nelements=0
|
|
d3_nef_cmo=0
|
|
d3_nee_cmo=0
|
|
d3_nen_cmo=0
|
|
|
|
c........ (assign d3 storage) ..................
|
|
c note there are no elements -> no element storage
|
|
|
|
! .............
|
|
|
|
len=1
|
|
ityp=1
|
|
call cmo_set_info('d3_nnodes',cmo,d3_nnodes,len,ityp,ierr)
|
|
|
|
!call cmo_set_info('d3_nelements',cmo,d3_nelements,len,ityp,ierr)
|
|
!call cmo_set_info('d3_nef_cmo',cmo,d3_nef_cmo,len,ityp,ierr)
|
|
!call cmo_set_info('d3_nee_cmo',cmo,d3_nee_cmo,len,ityp,ierr)
|
|
!call cmo_set_info('d3_nen_cmo',cmo,d3_nen_cmo,len,ityp,ierr)
|
|
|
|
! not needed as nothing depends on d3_nnodes
|
|
! call cmo_newlen(cmo,ierr) ! OK re mbndry as using mbndry=0
|
|
|
|
|
|
c =======================================================================
|
|
|
|
c........ (sucessful return) ..................
|
|
500 ierror=0
|
|
|
|
if (new_storage.eq.0) then
|
|
call filter_lower_d_lg(cmo,'refilter',ityp,'-not_used-',ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
endif
|
|
|
|
! do this re "dangerous" lack of it in itetclr_lower_d_lg
|
|
call cmo_newlen(cmo,ierr) ! OK re mbndry as using mbndry=0
|
|
|
|
! set lower_d_flag ...............
|
|
call cmo_set_info('lower_d_flag',cmo,1,len,ityp,ierr)
|
|
|
|
call mmrelprt(isubname,ierr)
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'finished create_lower_d_lg succesfully'
|
|
call mmverify()
|
|
write(cbuf,*)'cmo status; finish'
|
|
call dotask(cbuf,ierr)
|
|
call cmo_get_info('d0_nclrs',cmo,d0_nclrs,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d0_nclrs.le.0) goto 9999
|
|
call cmo_get_info('d0_clrtab',cmo,ip_d0_clrtab,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d0_clroff',cmo,ip_d0_clroff,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
write(*,*) 'd0_nclrs=',d0_nclrs
|
|
call print_clrtab_lower_d_lg(d0_nclrs,d0_clroff,d0_clrtab)
|
|
endif
|
|
|
|
! reset mbndry to use input mbndry convention
|
|
! make even multiple of 1000000 using same rule as set_mbndry
|
|
! so not increased by that routine
|
|
if (mbndry_save.ne.0) then
|
|
mbndry=mbndry_save
|
|
if (mbndry.le.16000000) mbndry=16000000
|
|
j=1000000*int(1.2e-6*float(d0_nelements*d0_nef_cmo)+0.5)
|
|
if (mbndry.le.j) mbndry=j
|
|
j=1000000*int(1.2e-6*float(d1_nelements*d1_nef_cmo)+0.5)
|
|
if (mbndry.le.j) mbndry=j
|
|
j=1000000*int(1.2e-6*float(d2_nelements*d2_nef_cmo)+0.5)
|
|
if (mbndry.le.j) mbndry=j
|
|
call reset_mbndry_lower_d_lg(cmo,mbndry,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
endif
|
|
|
|
return
|
|
|
|
c........ (failure return) ..................
|
|
9999 continue
|
|
! reset mbndry to use input mbndry convention
|
|
if (mbndry_save.ne.0) then
|
|
mbndry=mbndry_save
|
|
if (mbndry.le.d0_nelements*d0_nef_cmo)
|
|
& mbndry=d0_nelements*d0_nef_cmo+10000
|
|
if (mbndry.le.d1_nelements*d1_nef_cmo)
|
|
& mbndry=d1_nelements*d1_nef_cmo+10000
|
|
if (mbndry.le.d2_nelements*d2_nef_cmo)
|
|
& mbndry=d2_nelements*d2_nef_cmo+10000
|
|
call reset_mbndry_lower_d_lg(cmo,mbndry,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
endif
|
|
|
|
9998 ierror=1
|
|
call mmrelprt(isubname,ierr)
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'finished create_lower_d_lg unsuccesfully'
|
|
call mmverify()
|
|
stop
|
|
endif
|
|
cbuf='ERROR IN ROUTINE create_lower_d_lg: ABORTING'
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
return
|
|
c .....................................................
|
|
end
|
|
|
|
c-----------------------------------------------------------------------
|
|
C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|
|
|
c-----------------------------------------------------------------------
|
|
C #####################################################################
|
|
C extract_lower_d_lg
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C extract low d structures and place in the desired mesh object
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C cmo0 - name of the mesh to extract from
|
|
C cmo1 - name of mesh to extract d1 structure to (if -none-, not extracted)
|
|
C cmo2 - name of mesh to extract d2 structure to (if -none-, not extracted)
|
|
C cmo3 - name of mesh to extract d3 structure to (if -none-, not extracted)
|
|
C action - flag to recolor extracted mesh:
|
|
C = "recolor", use gcolor routines in neighbor_recolor_lg.f
|
|
C = "no_color", make single material mesh, saving itetclr in d0_clr_up
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
|
|
C
|
|
C USAGE NOTES / CAVEATS / CHANGES -
|
|
C
|
|
C #####################################################################
|
|
|
|
subroutine extract_lower_d_lg(cmo0,cmo1,cmo2,cmo3,action,ierror)
|
|
|
|
c ........................................................................
|
|
|
|
implicit none
|
|
|
|
include 'local_element.h'
|
|
include 'chydro.h'
|
|
|
|
character*(*) cmo0,cmo1,cmo2,cmo3,action
|
|
integer ierror
|
|
|
|
integer mbndry,nelements,nnodes
|
|
integer d0_topo,d0_nee_cmo,d0_nef_cmo,d0_nen_cmo,d0_geom
|
|
& ,d0_jtet_cycle_max,jtet_reduce_nnd
|
|
|
|
pointer (ip_jtet,jtet),(ip_jtetoff,jtetoff)
|
|
& ,(ip_itet,itet),(ip_itetoff,itetoff)
|
|
& ,(ip_itettyp,itettyp),(ip_itetclr,itetclr)
|
|
& ,(ip_itp1,itp1),(ip_imt1,imt1),(ip_icr1,icr1)
|
|
& ,(ip_isn1,isn1),(ip_iparent,iparent)
|
|
& ,(ip_d0_node_topo,d0_node_topo)
|
|
& ,(ip_d0_node_up,d0_node_up),(ip_d0_elm_up,d0_elm_up)
|
|
& ,(ip_d0_clr_up,d0_clr_up)
|
|
integer jtet(*),jtetoff(*)
|
|
& ,itet(*),itetoff(*)
|
|
& ,itettyp(*),itetclr(*)
|
|
& ,itp1(*),imt1(*),icr1(*)
|
|
& ,isn1(*),iparent(*)
|
|
& ,d0_node_topo(*)
|
|
& ,d0_node_up(*),d0_elm_up(*),d0_clr_up(*)
|
|
|
|
integer d1_nnodes,d1_nelements
|
|
& ,d1_nef_cmo,d1_nee_cmo,d1_nen_cmo
|
|
& ,d1_jtet_cycle_max
|
|
|
|
pointer (ip_d1_itet,d1_itet),(ip_d1_itetoff,d1_itetoff)
|
|
& ,(ip_d1_jtet,d1_jtet),(ip_d1_jtetoff,d1_jtetoff)
|
|
& ,(ip_d1_itettyp,d1_itettyp),(ip_d1_itetclr,d1_itetclr)
|
|
& ,(ip_d1_elm_d0,d1_elm_d0)
|
|
integer d1_itet(*),d1_itetoff(*)
|
|
& ,d1_jtet(*),d1_jtetoff(*)
|
|
& ,d1_itettyp(*),d1_itetclr(*)
|
|
& ,d1_elm_d0(*)
|
|
|
|
integer d2_nnodes,d2_nelements
|
|
& ,d2_nef_cmo,d2_nee_cmo,d2_nen_cmo
|
|
& ,d2_jtet_cycle_max
|
|
|
|
pointer (ip_d2_itet,d2_itet),(ip_d2_itetoff,d2_itetoff)
|
|
& ,(ip_d2_jtet,d2_jtet),(ip_d2_jtetoff,d2_jtetoff)
|
|
& ,(ip_d2_itettyp,d2_itettyp),(ip_d2_itetclr,d2_itetclr)
|
|
& ,(ip_d2_elm_d1,d2_elm_d1)
|
|
integer d2_itet(*),d2_itetoff(*)
|
|
& ,d2_jtet(*),d2_jtetoff(*)
|
|
& ,d2_itettyp(*),d2_itetclr(*)
|
|
& ,d2_elm_d1(*)
|
|
|
|
integer d3_nnodes,d3_nelements
|
|
& ,d3_nef_cmo,d3_nee_cmo,d3_nen_cmo
|
|
|
|
pointer (ip_xic,xic),(ip_yic,yic),(ip_zic,zic)
|
|
real*8 xic(*),yic(*),zic(*)
|
|
pointer (ip_xic2,xic2),(ip_yic2,yic2),(ip_zic2,zic2)
|
|
real*8 xic2(*),yic2(*),zic2(*)
|
|
pointer (ip_icr2,icr2),(ip_node_dn,node_dn)
|
|
integer icr2(*),node_dn(*)
|
|
|
|
|
|
integer i,j,len,ityp,ierr,ind,ioff,joff
|
|
& ,iel,jel,iface,jface,jt,iclr,lact
|
|
& ,i1,local_debug,kel,kface
|
|
& ,nclrs,d0_nclrs
|
|
|
|
character*132 cbuf
|
|
character*32 isubname
|
|
character*40 cmo_save
|
|
|
|
integer icharlnf,lcmo1,lcmo2,lcmo3,lcmo0
|
|
external icharlnf
|
|
|
|
character*32 cmsgout(12)
|
|
real*8 xmsgout(12)
|
|
integer imsgout(12),nwdsout,tmsgout(12)
|
|
|
|
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
|
local_debug=0
|
|
isubname='tmp_lower_d_lg'
|
|
lact=icharlnf(action)
|
|
call cmo_get_name(cmo_save,ierr)
|
|
|
|
if (local_debug.ne.0) then
|
|
write(*,*) 'reached extract_lower_d_lg'
|
|
write(cbuf,*)'cmo status; finish'
|
|
call dotask(cbuf,ierr)
|
|
call mmverify()
|
|
endif
|
|
|
|
nwdsout=12
|
|
do i=1,12
|
|
xmsgout(i)=0.d0
|
|
imsgout(i)=0
|
|
tmsgout(i)=3
|
|
cmsgout(i)=' '
|
|
enddo
|
|
tmsgout(11)=1
|
|
cmsgout(1)='cmo'
|
|
cmsgout(2)='addatt'
|
|
cmsgout(6)='scalar'
|
|
cmsgout(9)='temporary'
|
|
cmsgout(10)='agx'
|
|
cmsgout(11)=' '
|
|
tmsgout(12)=1
|
|
imsgout(12)=0
|
|
|
|
c........ (check if cmo0 and lower d cmo names legal
|
|
c and set lcmo1-lcmo3 as flag to extract) ..................
|
|
|
|
lcmo0=icharlnf(cmo0)
|
|
if (lcmo0.lt.1) goto 9999
|
|
call cmo_exist(cmo0,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
if (local_debug.ne.0) then
|
|
call mmverify()
|
|
endif
|
|
|
|
call cmo_get_info('ndimensions_topo',cmo0,d0_topo,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d0_topo.lt.0) goto 9999
|
|
if (d0_topo.eq.0) goto 4000
|
|
call cmo_get_info('ndimensions_geom',cmo0,d0_geom,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d0_geom.lt.1.or.d0_geom.gt.3) goto 9999
|
|
call cmo_get_info('nnodes',cmo0,nnodes,len,ityp,ierr)
|
|
if (ierr.ne.0.or.nnodes.lt.1) goto 9999
|
|
call cmo_get_info('nelements',cmo0,nelements,len,ityp,ierr)
|
|
if (ierr.ne.0.or.nelements.lt.1) nelements=0
|
|
call cmo_get_info('faces_per_element',cmo0,d0_nef_cmo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d0_nef_cmo.lt.d0_topo+1) nelements=0
|
|
call cmo_get_info('edges_per_element',cmo0,d0_nee_cmo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d0_nee_cmo.lt.0) nelements=0
|
|
call cmo_get_info('nodes_per_element',cmo0,d0_nen_cmo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d0_nen_cmo.lt.d0_topo+1) nelements=0
|
|
call cmo_get_info('mbndry',cmo0,mbndry,len,ityp,ierr)
|
|
if (ierr.ne.0) mbndry=0
|
|
if (mbndry.le.d0_nef_cmo*nelements
|
|
& .and.mbndry.ne.0) goto 9999
|
|
call cmo_get_info('d0_nclrs',cmo0,d0_nclrs,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d0_nclrs.lt.0) d0_nclrs=0
|
|
call cmo_get_info('jtet_reduce_nnd',cmo0,jtet_reduce_nnd
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) jtet_reduce_nnd=0
|
|
call cmo_get_info('jtet_cycle_max',cmo0,d0_jtet_cycle_max
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d0_jtet_cycle_max.lt.2) d0_jtet_cycle_max=2
|
|
|
|
! get lower d cmo names
|
|
lcmo1=icharlnf(cmo1)
|
|
if (lcmo1.lt.1 .or. cmo1(1:1).eq.'-' .or. d0_topo.lt.1 ) lcmo1=0
|
|
if (lcmo1.gt.0 .and. cmo0(1:lcmo0).eq.cmo1(1:lcmo1) ) lcmo1=-1
|
|
lcmo2=icharlnf(cmo2)
|
|
if (lcmo2.lt.1 .or. cmo2(1:1).eq.'-' .or. d0_topo.lt.2 ) lcmo2=0
|
|
if (lcmo2.gt.0
|
|
& .and. ( cmo0(1:lcmo0).eq.cmo2(1:lcmo2)
|
|
& .or. cmo1(1:lcmo1).eq.cmo2(1:lcmo2) ) ) lcmo2=-1
|
|
lcmo3=icharlnf(cmo3)
|
|
if (lcmo3.lt.1 .or. cmo3(1:1).eq.'-' .or. d0_topo.lt.3 ) lcmo3=0
|
|
if (lcmo2.gt.0
|
|
& .and. ( cmo0(1:lcmo0).eq.cmo3(1:lcmo3)
|
|
& .or. cmo1(1:lcmo1).eq.cmo3(1:lcmo3)
|
|
& .or. cmo2(1:lcmo2).eq.cmo3(1:lcmo3) ) ) lcmo3=-1
|
|
|
|
c........ (get sizes for lower d) ..................
|
|
|
|
! get lower d nnode info
|
|
if (lcmo1.gt.0) then
|
|
call cmo_get_info('d1_nnodes',cmo0,d1_nnodes,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d1_nnodes.lt.1) lcmo1=-2
|
|
endif
|
|
if (lcmo2.gt.0) then
|
|
call cmo_get_info('d2_nnodes',cmo0,d2_nnodes,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d2_nnodes.lt.1) lcmo2=-2
|
|
endif
|
|
if (lcmo3.gt.0) then
|
|
call cmo_get_info('d3_nnodes',cmo0,d3_nnodes,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d3_nnodes.lt.1) lcmo3=-2
|
|
endif
|
|
|
|
if (lcmo1.gt.0) then
|
|
call cmo_get_info('d1_nelements',cmo0,d1_nelements
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) d1_nelements=0
|
|
call cmo_get_info('d1_nef_cmo',cmo0,d1_nef_cmo,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d1_nef_cmo.lt.d0_topo) d1_nelements=0
|
|
call cmo_get_info('d1_nee_cmo',cmo0,d1_nee_cmo,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d1_nee_cmo.lt.0) d1_nelements=0
|
|
call cmo_get_info('d1_nen_cmo',cmo0,d1_nen_cmo,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d1_nen_cmo.lt.d0_topo) d1_nelements=0
|
|
call cmo_get_info('d1_jtet_cycle_max',cmo0,d1_jtet_cycle_max
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d1_jtet_cycle_max.lt.2) d1_jtet_cycle_max=2
|
|
if (d1_nelements.le.0.or.d0_topo.eq.1.or.nelements.eq.0) then
|
|
d1_nelements=0
|
|
d1_nef_cmo=0
|
|
d1_nee_cmo=0
|
|
d1_nen_cmo=0
|
|
endif
|
|
endif
|
|
if (lcmo2.gt.0) then
|
|
call cmo_get_info('d2_nelements',cmo0,d2_nelements
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) d2_nelements=0
|
|
call cmo_get_info('d2_nef_cmo',cmo0,d2_nef_cmo,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d2_nef_cmo.lt.d0_topo-1) d2_nelements=0
|
|
call cmo_get_info('d2_nee_cmo',cmo0,d2_nee_cmo,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d2_nee_cmo.lt.0) d2_nelements=0
|
|
call cmo_get_info('d2_nen_cmo',cmo0,d2_nen_cmo,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d2_nen_cmo.lt.d0_topo-1) d2_nelements=0
|
|
call cmo_get_info('d2_jtet_cycle_max',cmo0,d2_jtet_cycle_max
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d2_jtet_cycle_max.lt.2) d2_jtet_cycle_max=2
|
|
if (d2_nelements.le.0.or.d0_topo.eq.2
|
|
& .or.nelements.eq.0.or.d1_nelements.eq.0) then
|
|
d2_nelements=0
|
|
d2_nef_cmo=0
|
|
d2_nee_cmo=0
|
|
d2_nen_cmo=0
|
|
endif
|
|
endif
|
|
if (lcmo3.gt.0) then
|
|
d3_nelements=0
|
|
d3_nef_cmo=0
|
|
d3_nee_cmo=0
|
|
d3_nen_cmo=0
|
|
endif
|
|
|
|
if (local_debug.ne.0) then
|
|
call mmverify()
|
|
endif
|
|
|
|
c........ (check that any valid nodes) ..................
|
|
|
|
! this should be equivalent to nnodes test above!!
|
|
if (local_debug.gt.0) then
|
|
|
|
call cmo_get_info('itp1',cmo0,ip_itp1,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('isn1',cmo0,ip_isn1,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
call mmggetbk('iparent',isubname,ip_iparent,nnodes,1,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call unpackpc(nnodes,itp1,isn1,iparent)
|
|
|
|
call cmo_get_info('d0_node_topo',cmo0,ip_d0_node_topo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
! check that any valid nodes
|
|
if (lcmo1.gt.0) then
|
|
do i=1,nnodes
|
|
if (abs(d0_node_topo(i)).ge.1
|
|
& .and.i.eq.iparent(i)) goto 501
|
|
enddo
|
|
stop ! lcmo1=-lcmo1
|
|
endif
|
|
501 if (lcmo2.gt.0) then
|
|
do i=1,nnodes
|
|
if (abs(d0_node_topo(i)).ge.1
|
|
& .and.i.eq.iparent(i)) goto 502
|
|
enddo
|
|
cbuf=' lower_d/extract not creating cmo2= '//cmo2(1:lcmo2)
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
stop ! lcmo2=-lcmo2
|
|
endif
|
|
502 if (lcmo3.gt.0) then
|
|
do i=1,nnodes
|
|
if (abs(d0_node_topo(i)).ge.1
|
|
& .and.i.eq.iparent(i)) goto 503
|
|
enddo
|
|
cbuf=' lower_d/extract not creating cmo3= '//cmo3(1:lcmo3)
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
stop ! lcmo3=-lcmo3
|
|
endif
|
|
503 continue
|
|
|
|
endif
|
|
|
|
c........ (create lower d cmos) ..................
|
|
|
|
if (lcmo1.gt.0) then
|
|
C$ cbuf='cmo/release/'//cmo1(1:lcmo1)
|
|
C$ & //'; cmo/create /'//cmo1(1:lcmo1)//'; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
call cmo_exist(cmo1,ierr)
|
|
if (ierr.eq.0) call cmo_release(cmo1,ierr)
|
|
call cmo_create(cmo1,ierr)
|
|
len=1
|
|
ityp=1
|
|
call cmo_set_info('ndimensions_topo',cmo1,d0_topo-1
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo1=-3
|
|
call cmo_set_info('ndimensions_geom',cmo1,d0_geom
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo1=-3
|
|
call cmo_set_info('nnodes',cmo1,d1_nnodes,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo1=-3
|
|
call cmo_set_info('nelements',cmo1,d1_nelements
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo1=-3
|
|
call cmo_set_info('faces_per_element',cmo1,d1_nef_cmo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo1=-3
|
|
call cmo_set_info('edges_per_element',cmo1,d1_nee_cmo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo1=-3
|
|
call cmo_set_info('nodes_per_element',cmo1,d1_nen_cmo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo1=-3
|
|
call cmo_newlen(cmo1,ierr)
|
|
if (ierr.ne.0) lcmo1=-3
|
|
! set mbndry to same as higher-d mesh
|
|
call cmo_set_info('mbndry',cmo1,mbndry,len,ityp,ierr)
|
|
if (ierr.ne.0.and.mbndry.ne.0) lcmo1=-3
|
|
if (lcmo1.eq.-3) then
|
|
C$ cbuf='cmo/release/'//cmo1(1:lcmo1)//'; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
call cmo_release(cmo1,ierr)
|
|
else
|
|
C$ cbuf=cmo/addatt/'//cmo1(1:lcmo1)//'/d0_node_up'
|
|
C$ & //'/VINT/scalar/nnodes/user/temporary/agx/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(3)=cmo1
|
|
cmsgout(4)='d0_node_up'
|
|
cmsgout(5)='VINT'
|
|
cmsgout(7)='nnodes'
|
|
cmsgout(8)='user'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
if (d1_nelements.gt.0.and.jtet_reduce_nnd.eq.1) then
|
|
C$ cbuf='cmo/addatt/'//cmo1(1:lcmo1)//'/jtet_cycle_max'
|
|
C$ & //'/INT/scalar/scalar//temporary/x/2/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='jtet_cycle_max'
|
|
cmsgout(5)='INT'
|
|
cmsgout(7)='scalar'
|
|
cmsgout(8)='constant'
|
|
imsgout(11)=2
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
imsgout(11)=0
|
|
len=1
|
|
ityp=1
|
|
call cmo_set_info('jtet_cycle_max',cmo1(1:lcmo1)
|
|
& ,d1_jtet_cycle_max,len,ityp,ierr)
|
|
endif
|
|
if (d1_nelements.gt.0.and.d1_jtet_cycle_max.gt.2) then
|
|
C$ cbuf='cmo/addatt/'//cmo1(1:lcmo1)//'/jtet_cycle_max'
|
|
C$ & //'/INT/scalar/scalar//temporary/x/2/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='jtet_cycle_max'
|
|
cmsgout(5)='INT'
|
|
cmsgout(7)='scalar'
|
|
cmsgout(8)='constant'
|
|
imsgout(11)=2
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
imsgout(11)=0
|
|
len=1
|
|
ityp=1
|
|
call cmo_set_info('jtet_cycle_max',cmo1(1:lcmo1)
|
|
& ,d1_jtet_cycle_max,len,ityp,ierr)
|
|
endif
|
|
if (d1_nelements.gt.0) then
|
|
C$ cbuf='cmo/addatt/'//cmo1(1:lcmo1)//'/d0_elm_up'
|
|
C$ & //'/VINT/scalar/nelements//temporary/agx/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d0_elm_up'
|
|
cmsgout(5)='VINT'
|
|
cmsgout(7)='nelements'
|
|
cmsgout(8)='user'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
if (action(1:lact).eq.'recolor'
|
|
& .or.action(1:lact).eq.'no_color') then
|
|
C$ cbuf='cmo/addatt/'//cmo1(1:lcmo1)//'/d0_clr_up'
|
|
C$ & //'/VINT/scalar/nelements//temporary/agx/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d0_clr_up'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
endif
|
|
endif
|
|
endif
|
|
endif
|
|
if (lcmo1.lt.0) then
|
|
cbuf=' lower_d/extract not creating cmo1= '
|
|
& //cmo1(1:icharlnf(cmo1))
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
endif
|
|
|
|
if (lcmo2.gt.0) then
|
|
C$ cbuf='cmo/release/'//cmo2(1:lcmo2)
|
|
C$ & //'; cmo/create /'//cmo2(1:lcmo2)//'; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
call cmo_exist(cmo2,ierr)
|
|
if (ierr.eq.0) call cmo_release(cmo2,ierr)
|
|
call cmo_create(cmo2,ierr)
|
|
len=1
|
|
ityp=1
|
|
call cmo_set_info('ndimensions_topo',cmo2,d0_topo-2
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo2=-3
|
|
call cmo_set_info('ndimensions_geom',cmo2,d0_geom
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo2=-3
|
|
call cmo_set_info('nnodes',cmo2,d2_nnodes,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo2=-3
|
|
call cmo_set_info('nelements',cmo2,d2_nelements
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo2=-3
|
|
call cmo_set_info('faces_per_element',cmo2,d2_nef_cmo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo2=-3
|
|
call cmo_set_info('edges_per_element',cmo2,d2_nee_cmo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo2=-3
|
|
call cmo_set_info('nodes_per_element',cmo2,d2_nen_cmo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo2=-3
|
|
i=0
|
|
call cmo_newlen(cmo2,ierr)
|
|
if (ierr.ne.0) lcmo2=-3
|
|
! set mbndry to same as higher-d mesh
|
|
call cmo_set_info('mbndry',cmo2,mbndry,len,ityp,ierr)
|
|
if (ierr.ne.0.and.mbndry.ne.0) lcmo2=-3
|
|
if (lcmo2.eq.-3) then
|
|
C$ cbuf='cmo/release/'//cmo2(1:lcmo2)//'; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
call cmo_release(cmo2,ierr)
|
|
else
|
|
C$ cbuf=cmo/addatt/'//cmo2(1:lcmo2)//'/d0_node_up'
|
|
C$ & //'/VINT/scalar/nnodes/user/temporary/agx/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(3)=cmo2(1:lcmo2)
|
|
cmsgout(4)='d0_node_up'
|
|
cmsgout(5)='VINT'
|
|
cmsgout(7)='nnodes'
|
|
cmsgout(8)='user'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
if (d2_nelements.gt.0.and.d2_jtet_cycle_max.gt.2) then
|
|
C$ cbuf='cmo/addatt/'//cmo2(1:lcmo2)//'/jtet_cycle_max'
|
|
C$ & //'/INT/scalar/scalar//temporary/x/2/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='jtet_cycle_max'
|
|
cmsgout(5)='INT'
|
|
cmsgout(7)='scalar'
|
|
cmsgout(8)='constant'
|
|
imsgout(11)=2
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
imsgout(11)=0
|
|
len=1
|
|
ityp=1
|
|
call cmo_set_info('jtet_cycle_max',cmo2(1:lcmo2)
|
|
& ,d2_jtet_cycle_max,len,ityp,ierr)
|
|
endif
|
|
if (d2_nelements.gt.0) then
|
|
C$ cbuf='cmo/addatt/'//cmo2(1:lcmo2)//'/d0_elm_up'
|
|
C$ & //'/VINT/scalar/nelements//temporary/agx/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d0_elm_up'
|
|
cmsgout(5)='VINT'
|
|
cmsgout(7)='nelements'
|
|
cmsgout(8)='user'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
if (action(1:lact).eq.'recolor'
|
|
& .or.action(1:lact).eq.'no_color') then
|
|
C$ cbuf='cmo/addatt/'//cmo2(1:lcmo2)//'/d0_clr_up'
|
|
C$ & //'/VINT/scalar/nelements//temporary/agx/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d0_clr_up'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
endif
|
|
endif
|
|
endif
|
|
endif
|
|
if (lcmo2.lt.0) then
|
|
cbuf=' lower_d/extract not creating cmo2= '
|
|
& //cmo2(1:icharlnf(cmo2))
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
endif
|
|
|
|
if (lcmo3.gt.0) then
|
|
C$ cbuf='cmo/release/'//cmo3(1:lcmo3)
|
|
C$ & //'; cmo/create /'//cmo3(1:lcmo3)//'; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
call cmo_exist(cmo3,ierr)
|
|
if (ierr.eq.0) call cmo_release(cmo3,ierr)
|
|
call cmo_create(cmo3,ierr)
|
|
len=1
|
|
ityp=1
|
|
call cmo_set_info('ndimensions_topo',cmo3,d0_topo-3
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo3=-3
|
|
call cmo_set_info('ndimensions_geom',cmo3,d0_geom
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo3=-3
|
|
call cmo_set_info('nnodes',cmo3,d3_nnodes,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo3=-3
|
|
call cmo_set_info('nelements',cmo3,d3_nelements
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo3=-3
|
|
call cmo_set_info('faces_per_element',cmo3,d3_nef_cmo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo3=-3
|
|
call cmo_set_info('edges_per_element',cmo3,d3_nee_cmo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo3=-3
|
|
call cmo_set_info('nodes_per_element',cmo3,d3_nen_cmo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) lcmo3=-3
|
|
call cmo_newlen(cmo3,ierr)
|
|
if (ierr.ne.0) lcmo3=-3
|
|
! set mbndry to same as higher-d mesh
|
|
call cmo_set_info('mbndry',cmo3,mbndry,len,ityp,ierr)
|
|
if (ierr.ne.0.and.mbndry.ne.0) lcmo3=-3
|
|
if (lcmo3.eq.-3) then
|
|
C$ cbuf='cmo/release/'//cmo3(1:lcmo3)//'; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
call cmo_release(cmo3,ierr)
|
|
endif
|
|
endif
|
|
if (lcmo3.lt.0) then
|
|
cbuf=' lower_d/extract not creating cmo3= '
|
|
& //cmo3(1:icharlnf(cmo3))
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
else
|
|
C$ cbuf=cmo/addatt/'//cmo3(1:lcmo3)//'/d0_node_up'
|
|
C$ & //'/VINT/scalar/nnodes/user/temporary/agx/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(3)=cmo3(1:lcmo3)
|
|
cmsgout(4)='d0_node_up'
|
|
cmsgout(5)='VINT'
|
|
cmsgout(7)='nnodes'
|
|
cmsgout(8)='user'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
|
|
if (local_debug.ne.0) then
|
|
call mmverify()
|
|
endif
|
|
|
|
! make sure that at least one mesh to extract
|
|
if (lcmo1.le.0 .and. lcmo2.le.0 .and. lcmo3.le.0) goto 4000
|
|
|
|
c........ (get d0 info) ..................
|
|
|
|
call cmo_get_info('itp1',cmo0,ip_itp1,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('isn1',cmo0,ip_isn1,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('icr1',cmo0,ip_icr1,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('xic',cmo0,ip_xic,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('yic',cmo0,ip_yic,len,ityp,ierr)
|
|
if (ierr.ne.0.and.d0_geom.ge.2) goto 9999
|
|
call cmo_get_info('zic',cmo0,ip_zic,len,ityp,ierr)
|
|
if (ierr.ne.0.and.d0_geom.ge.3) goto 9999
|
|
|
|
call mmggetbk('iparent',isubname,ip_iparent,nnodes,1,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call mmggetbk('node_dn',isubname,ip_node_dn,nnodes,1,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call unpackpc(nnodes,itp1,isn1,iparent)
|
|
|
|
call cmo_get_info('d0_node_topo',cmo0,ip_d0_node_topo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
c =======================================================================
|
|
|
|
c........ (extract d1 into cmo1) ..................
|
|
|
|
1000 if (lcmo1.le.0) goto 2000
|
|
|
|
if (local_debug.ne.0) then
|
|
call mmverify()
|
|
endif
|
|
|
|
call cmo_get_info('d0_node_up',cmo1,ip_d0_node_up,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('isn1',cmo1,ip_isn1,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('imt1',cmo1,ip_imt1,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('itp1',cmo1,ip_itp1,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
call cmo_get_info('icr1',cmo1,ip_icr2,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('xic',cmo1,ip_xic2,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('yic',cmo1,ip_yic2,len,ityp,ierr)
|
|
if (ierr.ne.0.and.d0_geom.ge.2) goto 9999
|
|
call cmo_get_info('zic',cmo1,ip_zic2,len,ityp,ierr)
|
|
if (ierr.ne.0.and.d0_geom.ge.3) goto 9999
|
|
|
|
j=0
|
|
do i=1,nnodes
|
|
if (d0_node_topo(i).ne.0.and.i.eq.iparent(i)) then
|
|
j=j+1
|
|
d0_node_up(j)=i
|
|
node_dn(i)=j
|
|
else
|
|
node_dn(i)=0
|
|
endif
|
|
enddo
|
|
if (j.ne.d1_nnodes) then
|
|
goto 9999
|
|
endif
|
|
|
|
do i=1,d1_nnodes
|
|
j=d0_node_up(i)
|
|
icr2(i)=icr1(j)
|
|
imt1(i)=0
|
|
isn1(i)=0
|
|
itp1(i)=0
|
|
xic2(i)=xic(j)
|
|
if (d0_geom.gt.1) yic2(i)=yic(j)
|
|
if (d0_geom.gt.2) zic2(i)=zic(j)
|
|
enddo
|
|
|
|
! add scalar and node attributes to cmo1, plus the constraint table
|
|
call copyatt_mpary_lg(cmo0,cmo1,'NNODES'
|
|
& ,d0_node_up,d1_nnodes,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
! but don't print vor and med to gmv (only affects cmo1)
|
|
if (lcmo1.gt.0) then
|
|
cbuf='cmo/setatt/'//cmo1(1:lcmo1)//'/vor2d////no; finish'
|
|
call dotask(cbuf,ierr)
|
|
endif
|
|
|
|
if (d1_nelements.eq.0.or.d0_topo.le.1) then
|
|
! mark unselcted points for deletion
|
|
do i=1,d1_nnodes
|
|
j=d0_node_up(i)
|
|
if (d0_node_topo(j).lt.0) itp1(i)=21
|
|
enddo
|
|
goto 2000
|
|
endif
|
|
|
|
call cmo_get_info('d1_itet',cmo0,ip_d1_itet,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d1_itetoff',cmo0,ip_d1_itetoff,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d1_jtet',cmo0,ip_d1_jtet,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d1_jtetoff',cmo0,ip_d1_jtetoff,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d1_itettyp',cmo0,ip_d1_itettyp,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d1_itetclr',cmo0,ip_d1_itetclr,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d1_elm_d0',cmo0,ip_d1_elm_d0,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
call cmo_get_info('itet',cmo1,ip_itet,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('itetoff',cmo1,ip_itetoff,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('jtet',cmo1,ip_jtet,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('jtetoff',cmo1,ip_jtetoff,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('itettyp',cmo1,ip_itettyp,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('itetclr',cmo1,ip_itetclr,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d0_elm_up',cmo1,ip_d0_elm_up,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
if (action(1:lact).eq.'recolor'
|
|
& .or.action(1:lact).eq.'no_color') then
|
|
call cmo_get_info('d0_clr_up',cmo1,ip_d0_clr_up
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
endif
|
|
|
|
! for now: don't attempt free vs reflective vs virtual distinction ...
|
|
! note: positions already set above,
|
|
! defaults also set (but need pointers re even lower d)
|
|
|
|
nclrs=0
|
|
do iel=1,d1_nelements
|
|
d0_elm_up(iel)=d1_elm_d0(iel)
|
|
ityp=d1_itettyp(iel)
|
|
itettyp(iel)=ityp
|
|
ioff=d1_itetoff(iel)
|
|
itetoff(iel)=ioff
|
|
joff=d1_jtetoff(iel)
|
|
jtetoff(iel)=joff
|
|
iclr=d1_itetclr(iel)
|
|
if (abs(iclr).gt.nclrs) nclrs=abs(iclr)
|
|
itetclr(iel)=abs(iclr)
|
|
if (action(1:lact).eq.'recolor'
|
|
& .or.action(1:lact).eq.'no_color') then
|
|
d0_clr_up(iel)=abs(iclr)
|
|
if (action(1:lact).eq.'no_color') itetclr(iel)=1
|
|
endif
|
|
if (iclr.lt.0) then
|
|
do ind=1,nelmnen(ityp)
|
|
i=node_dn(d1_itet(ioff+ind))
|
|
if (i.eq.0) i=1
|
|
itet(ioff+ind)=i
|
|
enddo
|
|
do iface=1,nelmnef(ityp)
|
|
jtet(joff+iface)=d1_jtet(joff+iface)
|
|
enddo
|
|
! mark element for deletion as clr<0
|
|
itet(ioff+1)=-itet(ioff+1)
|
|
else
|
|
do ind=1,nelmnen(ityp)
|
|
! d1_itet refers only to parent nodes so OK
|
|
i=d1_itet(ioff+ind)
|
|
i=node_dn(i)
|
|
if (i.eq.0) stop 'err'
|
|
itet(ioff+ind)=i
|
|
! flag imt for interface faces
|
|
if (imt1(i).eq.0) then
|
|
imt1(i)=iclr
|
|
elseif (imt1(i).gt.0) then
|
|
imt1(i)=-imt1(i)
|
|
endif
|
|
enddo
|
|
do iface=1,nelmnef(ityp)
|
|
jt=d1_jtet(joff+iface)
|
|
jtet(joff+iface)=jt
|
|
! flag imt for external boundary faces
|
|
if ((jt.eq.mbndry.and.mbndry.gt.0)
|
|
& .or.(jt.eq.0.and.mbndry.eq.0)) then
|
|
do ind=1,ielmface0(iface,ityp)
|
|
i1=ielmface1(ind,iface,ityp)
|
|
i=itet(ioff+i1)
|
|
itp1(i)=10
|
|
enddo
|
|
endif
|
|
enddo
|
|
endif
|
|
enddo
|
|
nclrs=max(nclrs,d0_nclrs)
|
|
do i=1,d1_nnodes
|
|
if (imt1(i).eq.0) then
|
|
! mark elementless points for deletion
|
|
itp1(i)=21
|
|
elseif (imt1(i).lt.0) then
|
|
imt1(i)=nclrs+1
|
|
if (itp1(i).eq.10) then
|
|
itp1(i)=12
|
|
else
|
|
itp1(i)=2
|
|
endif
|
|
endif
|
|
enddo
|
|
if (action(1:lact).eq.'recolor') then
|
|
cbuf='colormap/isn/lower_d_map_lg/recolor/'//cmo1(1:lcmo1)
|
|
& //'; colormap/isn/lower_d_map_lg/release/; finish'
|
|
call dotask(cbuf,ierr)
|
|
elseif (action(1:lact).eq.'no_color') then
|
|
do iel=1,d1_nelements
|
|
ityp=d1_itettyp(iel)
|
|
ioff=d1_jtetoff(iel)
|
|
do iface=1,nelmnef(ityp)
|
|
jt=d1_jtet(ioff+iface)
|
|
jtet(ioff+iface)=jt
|
|
if ((jt.gt.mbndry.and.mbndry.gt.0)
|
|
& .or.(jt.lt.0.and.mbndry.eq.0)) then
|
|
jt=abs(jt)-mbndry
|
|
jel=1+(jt-1)/d1_nef_cmo
|
|
jface=jt-(jt-1)*d1_nef_cmo
|
|
joff=jtetoff(jel)
|
|
jt=abs(jtet(joff+jface))-mbndry
|
|
kel=1+(jt-1)/d1_nef_cmo
|
|
kface=jt-(kel-1)*d1_nef_cmo
|
|
if (kel.eq.iel.and.kface.eq.iface) then
|
|
! jtet_reduce_nnd: should check nnd,dtopo
|
|
jtet(ioff+iface)=abs(jtet(ioff+iface))-mbndry
|
|
jtet(joff+jface)=abs(jtet(joff+jface))-mbndry
|
|
endif
|
|
endif
|
|
enddo
|
|
enddo
|
|
endif
|
|
|
|
if (local_debug.ne.0) then
|
|
call mmverify()
|
|
endif
|
|
|
|
c =======================================================================
|
|
|
|
c........ (extract d2 into cmo2) ..................
|
|
|
|
2000 if (lcmo2.le.0) goto 3000
|
|
|
|
if (local_debug.ne.0) then
|
|
call mmverify()
|
|
endif
|
|
|
|
call cmo_get_info('d0_node_up',cmo2,ip_d0_node_up,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('isn1',cmo2,ip_isn1,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('imt1',cmo2,ip_imt1,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('itp1',cmo2,ip_itp1,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
call cmo_get_info('icr1',cmo2,ip_icr2,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('xic',cmo2,ip_xic2,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('yic',cmo2,ip_yic2,len,ityp,ierr)
|
|
if (ierr.ne.0.and.d0_geom.ge.2) goto 9999
|
|
call cmo_get_info('zic',cmo2,ip_zic2,len,ityp,ierr)
|
|
if (ierr.ne.0.and.d0_geom.ge.3) goto 9999
|
|
|
|
j=0
|
|
do i=1,nnodes
|
|
if (abs(d0_node_topo(i)).gt.1.and.i.eq.iparent(i)) then
|
|
j=j+1
|
|
d0_node_up(j)=i
|
|
node_dn(i)=j
|
|
else
|
|
node_dn(i)=0
|
|
endif
|
|
enddo
|
|
if (j.ne.d2_nnodes) goto 9999
|
|
|
|
do i=1,d2_nnodes
|
|
j=d0_node_up(i)
|
|
icr2(i)=icr1(j)
|
|
imt1(i)=0
|
|
isn1(i)=0
|
|
itp1(i)=0
|
|
xic2(i)=xic(j)
|
|
if (d0_geom.gt.1) yic2(i)=yic(j)
|
|
if (d0_geom.gt.2) zic2(i)=zic(j)
|
|
enddo
|
|
|
|
! add node attributes to cmo2
|
|
call copyatt_mpary_lg(cmo0,cmo2,'NNODES'
|
|
& ,d0_node_up,d2_nnodes,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
if (d2_nelements.eq.0.or.d0_topo.le.2) then
|
|
! mark unselected points for deletion
|
|
do i=1,d2_nnodes
|
|
j=d0_node_up(i)
|
|
if (d0_node_topo(j).lt.0) itp1(i)=21
|
|
enddo
|
|
goto 3000
|
|
endif
|
|
|
|
call cmo_get_info('d2_itet',cmo0,ip_d2_itet,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d2_itetoff',cmo0,ip_d2_itetoff,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d2_jtet',cmo0,ip_d2_jtet,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d2_jtetoff',cmo0,ip_d2_jtetoff,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d2_itettyp',cmo0,ip_d2_itettyp,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d2_itetclr',cmo0,ip_d2_itetclr,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
call cmo_get_info('itet',cmo2,ip_itet,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('itetoff',cmo2,ip_itetoff,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('jtet',cmo2,ip_jtet,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('jtetoff',cmo2,ip_jtetoff,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('itetclr',cmo2,ip_itetclr,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
if (action(1:lact).eq.'recolor'
|
|
& .or.action(1:lact).eq.'no_color') then
|
|
call cmo_get_info('d0_clr_up',cmo2,ip_d0_clr_up
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
endif
|
|
|
|
! d0_elm_up has to be done slightly differently than d1 case
|
|
! as I think using d2_elm_d0 here is more logical than d2_elm_d1
|
|
call cmo_get_info('itettyp',cmo0,ip_itettyp,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d1_elm_d0',cmo0,ip_d1_elm_d0,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d1_nef_cmo',cmo0,d1_nef_cmo,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d1_nef_cmo.lt.d0_topo) d1_nelements=0
|
|
call cmo_get_info('d2_elm_d1',cmo0,ip_d2_elm_d1,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d0_elm_up',cmo2,ip_d0_elm_up,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call create_d2_elm_d0_lower_d_lg(d2_nelements,d1_nef_cmo
|
|
& ,d0_nef_cmo,d0_nee_cmo,d2_elm_d1,d1_elm_d0,itettyp
|
|
& ,d0_elm_up,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
! back to itettyp being for cmo2
|
|
call cmo_get_info('itettyp',cmo2,ip_itettyp,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
! for now: don't attempt free vs reflective vs virtual distinction ...
|
|
! note: positions already set above,
|
|
! defaults also set (but need pointers re even lower d)
|
|
|
|
nclrs=0
|
|
do iel=1,d2_nelements
|
|
ityp=d2_itettyp(iel)
|
|
itettyp(iel)=ityp
|
|
ioff=d2_itetoff(iel)
|
|
itetoff(iel)=ioff
|
|
joff=d2_jtetoff(iel)
|
|
jtetoff(iel)=joff
|
|
iclr=d2_itetclr(iel)
|
|
if (abs(iclr).gt.nclrs) nclrs=abs(iclr)
|
|
itetclr(iel)=abs(iclr)
|
|
if (action(1:lact).eq.'recolor'
|
|
& .or.action(1:lact).eq.'no_color') then
|
|
d0_clr_up(iel)=abs(iclr)
|
|
if (action(1:lact).eq.'no_color') itetclr(iel)=1
|
|
endif
|
|
if (iclr.lt.0) then
|
|
do ind=1,nelmnen(ityp)
|
|
i=node_dn(d2_itet(ioff+ind))
|
|
if (i.eq.0) i=1
|
|
itet(ioff+ind)=i
|
|
enddo
|
|
do iface=1,nelmnef(ityp)
|
|
jtet(joff+iface)=d2_jtet(joff+iface)
|
|
enddo
|
|
! mark element for deletion as clr<0
|
|
itet(ioff+1)=-itet(ioff+1)
|
|
else
|
|
do ind=1,nelmnen(ityp)
|
|
! d2_itet refers only to parent nodes so OK
|
|
i=d2_itet(ioff+ind)
|
|
i=node_dn(i)
|
|
if (i.eq.0) stop 'err'
|
|
itet(ioff+ind)=i
|
|
if (imt1(i).eq.0) then
|
|
imt1(i)=iclr
|
|
elseif (imt1(i).gt.0) then
|
|
imt1(i)=-imt1(i)
|
|
endif
|
|
enddo
|
|
do iface=1,nelmnef(ityp)
|
|
jt=d2_jtet(joff+iface)
|
|
jtet(joff+iface)=jt
|
|
if ((jt.eq.mbndry.and.mbndry.gt.0)
|
|
& .or.(jt.eq.0.and.mbndry.eq.0)) then
|
|
do ind=1,ielmface0(iface,ityp)
|
|
i1=ielmface1(ind,iface,ityp)
|
|
i=itet(ioff+i1)
|
|
itp1(i)=10
|
|
enddo
|
|
endif
|
|
enddo
|
|
endif
|
|
enddo
|
|
nclrs=max(nclrs,d0_nclrs)
|
|
do i=1,d2_nnodes
|
|
if (imt1(i).eq.0) then
|
|
! mark elementless points for deletion
|
|
itp1(i)=21
|
|
elseif (imt1(i).lt.0) then
|
|
imt1(i)=nclrs+1
|
|
if (itp1(i).eq.10) then
|
|
itp1(i)=12
|
|
else
|
|
itp1(i)=2
|
|
endif
|
|
endif
|
|
enddo
|
|
if (action(1:lact).eq.'recolor') then
|
|
cbuf='colormap/isn/lower_d_map_lg/recolor/'//cmo2(1:lcmo2)
|
|
& //'; colormap/isn/lower_d_map_lg/release/; finish'
|
|
call dotask(cbuf,ierr)
|
|
elseif (action(1:lact).eq.'no_color') then
|
|
do iel=1,d2_nelements
|
|
ityp=d2_itettyp(iel)
|
|
ioff=d2_jtetoff(iel)
|
|
do iface=1,nelmnef(ityp)
|
|
jt=d2_jtet(ioff+iface)
|
|
jtet(ioff+iface)=jt
|
|
if ((jt.gt.mbndry.and.mbndry.gt.0)
|
|
& .or.(jt.lt.0.and.mbndry.eq.0)) then
|
|
jt=abs(jt)-mbndry
|
|
jel=1+(jt-1)/d2_nef_cmo
|
|
jface=jt-(jt-1)*d2_nef_cmo
|
|
joff=jtetoff(jel)
|
|
jt=abs(jtet(joff+jface))-mbndry
|
|
kel=1+(jt-1)/d2_nef_cmo
|
|
kface=jt-(kel-1)*d2_nef_cmo
|
|
if (kel.eq.iel.and.kface.eq.iface) then
|
|
! jtet_reduce_nnd: should check nnd,topo
|
|
jtet(ioff+iface)=abs(jtet(ioff+iface))-mbndry
|
|
jtet(joff+jface)=abs(jtet(joff+jface))-mbndry
|
|
endif
|
|
endif
|
|
enddo
|
|
enddo
|
|
endif
|
|
|
|
if (local_debug.ne.0) then
|
|
call mmverify()
|
|
endif
|
|
|
|
c =======================================================================
|
|
|
|
c........ (extract d3 into cmo3) ..................
|
|
|
|
3000 if (lcmo3.le.0) goto 4000
|
|
|
|
if (local_debug.ne.0) then
|
|
call mmverify()
|
|
endif
|
|
|
|
call cmo_get_info('d0_node_up',cmo3,ip_d0_node_up,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('isn1',cmo3,ip_isn1,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('imt1',cmo3,ip_imt1,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('itp1',cmo3,ip_itp1,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
call cmo_get_info('icr1',cmo3,ip_icr2,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('xic',cmo3,ip_xic2,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('yic',cmo3,ip_yic2,len,ityp,ierr)
|
|
if (ierr.ne.0.and.d0_geom.ge.2) goto 9999
|
|
call cmo_get_info('zic',cmo3,ip_zic2,len,ityp,ierr)
|
|
if (ierr.ne.0.and.d0_geom.ge.3) goto 9999
|
|
|
|
j=0
|
|
do i=1,nnodes
|
|
if (abs(d0_node_topo(i)).gt.2.and.i.eq.iparent(i)) then
|
|
j=j+1
|
|
d0_node_up(j)=i
|
|
node_dn(i)=j
|
|
else
|
|
node_dn(i)=0
|
|
endif
|
|
enddo
|
|
if (j.ne.d3_nnodes) goto 9999
|
|
|
|
do i=1,d3_nnodes
|
|
j=d0_node_up(i)
|
|
icr2(i)=icr1(j)
|
|
imt1(i)=d0_nclrs+1
|
|
isn1(i)=0
|
|
if (d0_node_topo(j).lt.0) then
|
|
! mark unselected points for deletion
|
|
itp1(i)=21
|
|
else
|
|
itp1(i)=0
|
|
endif
|
|
xic2(i)=xic(j)
|
|
if (d0_geom.gt.1) yic2(i)=yic(j)
|
|
if (d0_geom.gt.2) zic2(i)=zic(j)
|
|
enddo
|
|
|
|
! add node attributes to cmo3
|
|
call copyatt_mpary_lg(cmo0,cmo3,'NNODES'
|
|
& ,d0_node_up,d3_nnodes,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
if (local_debug.ne.0) then
|
|
call mmverify()
|
|
endif
|
|
|
|
c =======================================================================
|
|
|
|
c........ (sucessful return) ..................
|
|
4000 ierror=0
|
|
call mmrelprt(isubname,ierr)
|
|
if (lcmo1.gt.0) then
|
|
cbuf='cmo/select/'//cmo1(1:lcmo1)//'; rmpoint element'
|
|
& //'; rmpoint compress; settets color_points; finish'
|
|
call dotask(cbuf,ierr)
|
|
endif
|
|
if (lcmo2.gt.0) then
|
|
cbuf='cmo/select/'//cmo2(1:lcmo2)//'; rmpoint element'
|
|
& //'; rmpoint compress; settets color_points; finish'
|
|
call dotask(cbuf,ierr)
|
|
endif
|
|
if (lcmo3.gt.0) then
|
|
cbuf='cmo/select/'//cmo3(1:lcmo3)
|
|
& //'; rmpoint compress; finish'
|
|
call dotask(cbuf,ierr)
|
|
endif
|
|
cbuf='cmo/select/'//cmo_save(1:icharlnf(cmo_save))//'; finish'
|
|
call dotask(cbuf,ierr)
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'finished extract_lower_d_lg succesfully'
|
|
call mmverify()
|
|
write(cbuf,*)'cmo status; finish'
|
|
call dotask(cbuf,ierr)
|
|
endif
|
|
return
|
|
|
|
c........ (failure return) ..................
|
|
9999 ierror=1
|
|
call mmrelprt(isubname,ierr)
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'finished extract_lower_d_lg unsuccesfully'
|
|
call mmverify()
|
|
stop
|
|
endif
|
|
cbuf='ERROR IN ROUTINE extract_lower_d_lg: ABORTING'
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
cbuf='cmo/select/'//cmo_save(1:icharlnf(cmo_save))//'; finish'
|
|
call dotask(cbuf,ierr)
|
|
return
|
|
c .....................................................
|
|
end
|
|
|
|
c-----------------------------------------------------------------------
|
|
C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|
|
|
c-----------------------------------------------------------------------
|
|
C #####################################################################
|
|
C filter_lower_d_lg
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C filter the lower d elements by setting d1_itetclr/d2_itetclr/d3_itetclr
|
|
C to negative if they are not to be considered, or to positive if they are,
|
|
C and update d0_node_topo, d1_nnodes, d2_nnodes, d3_nnodes, to reflect this.
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C cmo_in - the cmo to filter
|
|
C input_action1 - the field to filter
|
|
C input_value - the value to filter on
|
|
C input_action2 - the and/or flag to use with the filter
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
|
|
C
|
|
C USAGE NOTES / CAVEATS / CHANGES -
|
|
C
|
|
C it is probably not advisable to call this routine outside this
|
|
C lower_d command suite.
|
|
C
|
|
C less clear notes to myself for code development .......................
|
|
|
|
c lower_d/filter[/cmo0|*-def-]/[icr|itp|imt|clr]/#
|
|
c lower_d/filter[/cmo0|*-def-]/[no_icr|no_itp|no_imt|no_clr]/#
|
|
c lower_d/filter[/cmo0|*-def-]/[ext|int|vrt|real|no_int|no_vrt|no_real]
|
|
c set lower_d element itetclr to negative if don't exist with this criterion,
|
|
c lower_d/filter[/cmo0|*-def-]/reset
|
|
c reset lower_d element itetclr to all positive
|
|
|
|
c also reset d0_node_topo to reflect new topology
|
|
c note jtet is NOT reset -> filter on positive itetclr (and d0_node_topo) for usage
|
|
c Q re d0_node_topo set to <0 vs d0_node_topo from new topology:
|
|
c for now, reset...
|
|
c for eg smooth, compare d0_node_topo with effective one set from elements...
|
|
|
|
c this is used, eg, by smooth to distinguish surfaces with no damage
|
|
c and d0_node_topo rather than jtet is used to distinguish topology class of node
|
|
|
|
c except for reset, multiple calls to this routine treated as "or"
|
|
c (current itetclr left alone if negative,
|
|
c positive reset to negative if fail criterion)
|
|
c
|
|
c not the icr,itp,clr filters are not smart enough to
|
|
c keep lower d children of kept higher d
|
|
c -> the "no_" versions are safer...
|
|
|
|
c note re "or" default - add coding later to have "and|or|new"
|
|
c appended as modifier to action -> "or" and "new" trivial,
|
|
c for "and" would have to save old itetclr, redo as here,
|
|
c "and" the two itetclr signs, then reset d0_node_topo...
|
|
c right now, input_action2 is not used, but eventually will be the "and/or"...
|
|
|
|
c is this "jtet_reduce_nnd" safe?
|
|
|
|
c test that set d0_nnodes right for mixed-d case, also new endpts with filter
|
|
|
|
C #####################################################################
|
|
|
|
subroutine filter_lower_d_lg(cmo_in,input_action1
|
|
& ,input_value,input_action2,ierror)
|
|
|
|
c ........................................................................
|
|
|
|
|
|
implicit none
|
|
include 'chydro.h'
|
|
include 'local_element.h'
|
|
|
|
C arguments
|
|
character*(*) cmo_in,input_action1,input_action2
|
|
integer input_value,ierror,ivalue
|
|
|
|
C variables
|
|
|
|
pointer (ip_itetclr,itetclr),(ip_clrtab,clrtab)
|
|
& ,(ip_clroff,clroff),(ip_d0_node_topo,d0_node_topo)
|
|
& ,(ip_itetoff,itetoff),(ip_itettyp,itettyp)
|
|
& ,(ip_itet,itet),(ip_jtet,jtet),(ip_jtetoff,jtetoff)
|
|
& ,(ip_iparent,iparent),(ip_itp1,itp1),(ip_isn1,isn1)
|
|
& ,(ip_imt1,imt1),(ip_icr1,icr1),(ip_filters,filters)
|
|
integer itetclr(*),clrtab(*),clroff(*),d0_node_topo(*)
|
|
& ,itetoff(*),itettyp(*),iparent(*),itp1(*),isn1(*)
|
|
& ,itet(*),jtet(*),jtetoff(*),imt1(*),icr1(*),filters(*)
|
|
|
|
integer laction,local_debug,len,ityp,ierr,nelts,iel
|
|
& ,mbndry,d_topo,iclr,d0_nnodes,i,j,ind,ioff,d0_nclrs
|
|
& ,iface,d1_nelements,d2_nelements,d0_nelements
|
|
& ,nef_cmo,jel,jt,jclr,pttyp,linact,iaction,d0_nfilters
|
|
& ,d1_nnodes,d2_nnodes,d3_nnodes,last_action
|
|
& ,d1_nelts,d2_nelts,lact2
|
|
|
|
|
|
integer icharlnf
|
|
|
|
C coding caution: rankfilter in filter_lower_d_lg
|
|
C must be consistent with rankfilter in control_lower_d_lg
|
|
integer nactions,rankfilter
|
|
parameter(nactions=17,rankfilter=3)
|
|
character*32 transl_action(nactions)
|
|
|
|
character*32 isubname,action,action2,cmo
|
|
|
|
c -----------------------------------------------------
|
|
C BEGIN begin
|
|
C
|
|
local_debug=0
|
|
isubname='filter_lower_d_lg'
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'filter action 1 :',input_action1
|
|
write(*,*) 'filter action 2 :',input_action2
|
|
write(*,*) 'filter value: ',input_value
|
|
endif
|
|
|
|
c ... !! set up the translate table
|
|
transl_action(1)='reset'
|
|
transl_action(2)='ext'
|
|
transl_action(3)='int'
|
|
transl_action(4)='vrt'
|
|
transl_action(5)='real'
|
|
transl_action(6)='no_ext'
|
|
transl_action(7)='no_int'
|
|
transl_action(8)='no_vrt'
|
|
transl_action(9)='no_real'
|
|
transl_action(10)='imt'
|
|
transl_action(11)='icr'
|
|
transl_action(12)='itp'
|
|
transl_action(13)='clr'
|
|
transl_action(14)='no_imt'
|
|
transl_action(15)='no_icr'
|
|
transl_action(16)='no_itp'
|
|
transl_action(17)='no_clr'
|
|
|
|
c ... !! get the cmo
|
|
cmo=cmo_in
|
|
if (icharlnf(cmo).lt.1.or.cmo(1:1).eq.'-') then
|
|
call cmo_get_name(cmo,ierr)
|
|
endif
|
|
|
|
c ... !! make action icr1 equiv to icr, etc
|
|
laction=icharlnf(input_action1)
|
|
if (laction.le.1.or.laction.gt.32) then
|
|
action='reset'
|
|
laction=5
|
|
else
|
|
if (input_action1(laction:laction).eq."1") laction=laction-1
|
|
action=input_action1(1:laction)
|
|
endif
|
|
lact2=icharlnf(input_action2)
|
|
if (lact2.le.0.or.lact2.gt.32) then
|
|
action2='or'
|
|
lact2=2
|
|
else
|
|
action2=input_action2(1:lact2)
|
|
endif
|
|
|
|
ivalue=input_value
|
|
|
|
c ... !! save the current filter into the filters table
|
|
!! (unless resetting or refiltering)
|
|
|
|
linact=laction
|
|
|
|
call cmo_get_info('d0_nfilters',cmo,d0_nfilters
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'filter d0_nfilters before ',d0_nfilters
|
|
endif
|
|
if (action(1:laction).eq.'refilter') then
|
|
if (d0_nfilters.ge.rankfilter) then
|
|
call cmo_get_info('d0_filters',cmo,ip_filters
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
last_action=d0_nfilters/rankfilter
|
|
endif
|
|
else
|
|
last_action=1
|
|
len=1
|
|
ityp=1
|
|
if (action(1:laction).eq.'reset'
|
|
& .or.action2(1:lact2).eq.'new') then
|
|
d0_nfilters=0
|
|
call cmo_set_info('d0_nfilters',cmo,d0_nfilters
|
|
& ,len,ityp,ierr)
|
|
else
|
|
d0_nfilters=d0_nfilters+rankfilter
|
|
call cmo_set_info('d0_nfilters',cmo,d0_nfilters
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call mmnewlen('d0_filters',cmo,ip_filters
|
|
& ,d0_nfilters,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d0_filters',cmo,ip_filters
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
filters(d0_nfilters-rankfilter+2)=ivalue
|
|
filters(d0_nfilters-rankfilter+1)=1
|
|
if (action2(1:lact2).eq.'new') then
|
|
filters(d0_nfilters-rankfilter+3)=2 ! should never happen ...
|
|
elseif (action2(1:lact2).eq.'and') then
|
|
filters(d0_nfilters-rankfilter+3)=1
|
|
else ! if (action2(1:lact2).eq.'or') then
|
|
filters(d0_nfilters-rankfilter+3)=0
|
|
endif
|
|
do i=2,nactions
|
|
len=icharlnf(transl_action(i))
|
|
if (action(1:laction).eq.transl_action(i)(1:len)) then
|
|
filters(d0_nfilters-rankfilter+1)=i
|
|
goto 222
|
|
endif
|
|
enddo
|
|
222 continue
|
|
endif
|
|
endif
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'filter d0_nfilters after ',d0_nfilters
|
|
endif
|
|
|
|
c ... !! get the node info .................
|
|
|
|
call cmo_get_info('d0_nclrs',cmo,d0_nclrs,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d0_nclrs.le.0) goto 9999
|
|
call cmo_get_info('d0_clrtab',cmo,ip_clrtab,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d0_clroff',cmo,ip_clroff,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'd0_nclrs=',d0_nclrs
|
|
call print_clrtab_lower_d_lg(d0_nclrs,clroff,clrtab)
|
|
endif
|
|
|
|
call cmo_get_info('mbndry',cmo,mbndry,len,ityp,ierr)
|
|
if (ierr.ne.0) mbndry=0
|
|
|
|
call cmo_get_info('nnodes',cmo,d0_nnodes,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d0_nnodes.le.0) goto 9999
|
|
call cmo_get_info('nelements',cmo,d0_nelements,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d0_nelements.le.0) goto 9999
|
|
call cmo_get_info('d0_node_topo',cmo,ip_d0_node_topo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('itp1',cmo,ip_itp1,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('isn1',cmo,ip_isn1,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('imt1',cmo,ip_imt1,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('icr1',cmo,ip_icr1,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
call mmggetbk('iparent',isubname,ip_iparent,d0_nnodes,1,ierr)
|
|
call unpackpc(d0_nnodes,itp1,isn1,iparent)
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'd0_node_topo before'
|
|
write(*,*) (d0_node_topo(i),i=1,d0_nnodes)
|
|
endif
|
|
|
|
c ===================================================
|
|
do iaction=1,last_action
|
|
|
|
if (input_action1(1:linact).eq.'refilter') then
|
|
j=(iaction-1)*rankfilter
|
|
action=transl_action(filters(j+1))
|
|
ivalue=filters(j+2)
|
|
laction=icharlnf(action)
|
|
j=filters(j+3)
|
|
if (j.eq.2) then
|
|
action2='new' ! should never happen ...
|
|
elseif (j.eq.1) then
|
|
action2='and'
|
|
else ! if (j.eq.0) then
|
|
action2='or'
|
|
endif
|
|
lact2=icharlnf(action2)
|
|
endif
|
|
|
|
do i=1,d0_nnodes
|
|
d0_node_topo(i)=0 ! -abs(d0_node_topo(i))
|
|
enddo
|
|
|
|
c -----------------------------------------------------
|
|
do d_topo=1,2
|
|
|
|
c ... !! get the current d element info
|
|
|
|
if (d_topo.eq.1) then
|
|
call cmo_get_info('d1_nelements',cmo,nelts,len,ityp,ierr)
|
|
if (ierr.ne.0.or.nelts.le.0) then
|
|
d1_nelements=0
|
|
d2_nelements=0
|
|
d1_nelts=d1_nelements
|
|
d2_nelts=d2_nelements
|
|
nelts=d0_nelements
|
|
goto 8000
|
|
else
|
|
d1_nelements=nelts
|
|
d1_nelts=d1_nelements
|
|
endif
|
|
call cmo_get_info('d1_itetclr',cmo,ip_itetclr
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d1_itetoff',cmo,ip_itetoff
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d1_jtetoff',cmo,ip_jtetoff
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d1_itettyp',cmo,ip_itettyp
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d1_itet',cmo,ip_itet,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d1_jtet',cmo,ip_jtet,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d1_nef_cmo',cmo,nef_cmo,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
else ! if (d_topo.eq.2) then
|
|
call cmo_get_info('d2_nelements',cmo,nelts,len,ityp,ierr)
|
|
if (ierr.ne.0.or.nelts.le.0) then
|
|
d2_nelements=0
|
|
d2_nelts=d2_nelements
|
|
nelts=d1_nelements
|
|
goto 8000
|
|
else
|
|
d2_nelements=nelts
|
|
d2_nelts=d2_nelements
|
|
endif
|
|
call cmo_get_info('d2_itetclr',cmo,ip_itetclr
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d2_itetoff',cmo,ip_itetoff
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d2_jtetoff',cmo,ip_jtetoff
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d2_itettyp',cmo,ip_itettyp
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d2_itet',cmo,ip_itet,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d2_jtet',cmo,ip_jtet,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d2_nef_cmo',cmo,nef_cmo,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
endif
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'itetclr before for d_topo = ',d_topo
|
|
write(*,*) (itetclr(iel),iel=1,nelts)
|
|
endif
|
|
|
|
if (action2(1:lact2).eq.'new') then
|
|
do iel=1,nelts
|
|
itetclr(iel)=abs(itetclr(iel))
|
|
enddo
|
|
endif
|
|
|
|
c ... !! only d2 elements with valid d1 parents are allowed
|
|
if (d_topo.eq.2) then
|
|
do iel=1,nelts
|
|
iclr=itetclr(iel)
|
|
if (iclr.gt.0) then
|
|
ityp=itettyp(iel)
|
|
ioff=itetoff(iel)
|
|
do ind=1,nelmnen(ityp)
|
|
i=iparent(itet(ioff+ind))
|
|
if (d0_node_topo(i).ne.d_topo-1) then
|
|
itetclr(iel)=-iclr
|
|
goto 300
|
|
endif
|
|
enddo
|
|
300 continue
|
|
endif
|
|
enddo
|
|
endif
|
|
|
|
c ... !! perform the desired action ............
|
|
!! -- modify itetclr and d0_node_topo
|
|
|
|
c .........................................
|
|
if (action(1:laction).eq.'no_ext'
|
|
& .or.action(1:laction).eq.'int') then
|
|
|
|
do iel=1,nelts
|
|
iclr=itetclr(iel)
|
|
if (iclr.gt.0.and.iclr.le.d0_nclrs) then
|
|
ityp=clrtab(clroff(iclr)+1)
|
|
if (ityp.ne.ifitpint.and.ityp.ne.ifitpini
|
|
& .and.ityp.ne.ifitpvrt.and.ityp.ne.ifitpvin
|
|
& ) itetclr(iel)=-iclr
|
|
endif
|
|
enddo
|
|
|
|
c .........................................
|
|
elseif (action(1:laction).eq.'ext'
|
|
& .or.action(1:laction).eq.'no_int') then
|
|
|
|
do iel=1,nelts
|
|
iclr=itetclr(iel)
|
|
if (iclr.gt.0) then
|
|
if (iclr.le.d0_nclrs) ityp=clrtab(clroff(iclr)+1)
|
|
if (iclr.gt.d0_nclrs
|
|
& .or.ityp.eq.ifitpint.or.ityp.eq.ifitpini
|
|
& .or.ityp.eq.ifitpvrt.or.ityp.eq.ifitpvin
|
|
& ) itetclr(iel)=-iclr
|
|
endif
|
|
enddo
|
|
|
|
c .........................................
|
|
elseif (action(1:laction).eq.'vrt'
|
|
& .or.action(1:laction).eq.'no_real') then
|
|
|
|
do iel=1,nelts
|
|
iclr=itetclr(iel)
|
|
if (iclr.gt.0.and.iclr.le.d0_nclrs) then
|
|
ityp=clrtab(clroff(iclr)+1)
|
|
if (ityp.ne.ifitpvrt.and.ityp.ne.ifitpvrb
|
|
& .and.ityp.ne.ifitpvin.and.ityp.ne.ifitpvfb
|
|
& .and.ityp.ne.ifitpvrf.and.ityp.ne.ifitpvif
|
|
& .and.ityp.ne.ifitpvir.and.ityp.ne.ifitpalb
|
|
& ) itetclr(iel)=-iclr
|
|
endif
|
|
enddo
|
|
|
|
c .........................................
|
|
elseif (action(1:laction).eq.'no_vrt'
|
|
& .or.action(1:laction).eq.'real') then
|
|
|
|
do iel=1,nelts
|
|
iclr=itetclr(iel)
|
|
if (iclr.gt.0) then
|
|
ityp=clrtab(clroff(iclr)+1)
|
|
if (iclr.le.d0_nclrs) ityp=clrtab(clroff(iclr)+1)
|
|
if (iclr.gt.d0_nclrs
|
|
& .or.ityp.eq.ifitpvin.or.ityp.eq.ifitpvfb
|
|
& .or.ityp.eq.ifitpvrf.or.ityp.eq.ifitpvif
|
|
& .or.ityp.eq.ifitpvir.or.ityp.eq.ifitpalb
|
|
& .or.ityp.eq.ifitpvrb
|
|
& ) itetclr(iel)=-iclr
|
|
endif
|
|
enddo
|
|
|
|
c .........................................
|
|
elseif (action(1:laction).eq.'clr'
|
|
& .or.action(1:laction).eq.'no_clr') then
|
|
|
|
! this removes bndry of kept lower_d ->
|
|
! "use caution" (or fix to know about this...)
|
|
do iel=1,nelts
|
|
iclr=itetclr(iel)
|
|
if (iclr.ge.0) then
|
|
if (iclr.ne.ivalue
|
|
& .and.action(1:laction).eq.'clr') then
|
|
itetclr(iel)=-iclr
|
|
elseif (iclr.eq.ivalue
|
|
& .and.action(1:laction).eq.'no_clr') then
|
|
itetclr(iel)=-iclr
|
|
endif
|
|
endif
|
|
enddo
|
|
|
|
c .........................................
|
|
elseif (action(1:laction).eq.'icr'
|
|
& .or.action(1:laction).eq.'no_icr'
|
|
& .or.action(1:laction).eq.'itp'
|
|
& .or.action(1:laction).eq.'no_itp') then
|
|
|
|
if (action(1:laction).eq.'icr'.or.
|
|
& action(1:laction).eq.'no_icr') then
|
|
ioff=2
|
|
else
|
|
ioff=1
|
|
endif
|
|
do iel=1,nelts
|
|
iclr=itetclr(iel)
|
|
if (iclr.gt.d0_nclrs
|
|
& .and.action(1:3).ne.'no_') then
|
|
itetclr(iel)=-iclr
|
|
elseif (iclr.gt.0.and.iclr.le.d0_nclrs) then
|
|
ityp=clrtab(clroff(iclr)+ioff)
|
|
if (ityp.eq.ivalue
|
|
& .and.action(1:3).eq.'no_') then
|
|
itetclr(iel)=-iclr
|
|
elseif (ityp.ne.ivalue
|
|
& .and.action(1:3).ne.'no_') then
|
|
itetclr(iel)=-iclr
|
|
endif
|
|
endif
|
|
enddo
|
|
|
|
c .........................................
|
|
elseif (action(1:laction).eq.'imt'
|
|
& .or.action(1:laction).eq.'no_imt') then
|
|
|
|
do iel=1,nelts
|
|
iclr=itetclr(iel)
|
|
if (iclr.gt.d0_nclrs
|
|
& .and.action(1:3).ne.'no_') then
|
|
itetclr(iel)=-iclr
|
|
elseif (iclr.gt.0.and.iclr.le.d0_nclrs) then
|
|
do i=1,clrtab(clroff(iclr)+3)
|
|
if (clrtab(clroff(iclr)+3+i).eq.ivalue) then
|
|
ityp=1
|
|
goto 600
|
|
endif
|
|
enddo
|
|
ityp=0
|
|
600 if (ityp.eq.1.and.action(1:3).eq.'no_') then
|
|
itetclr(iel)=-iclr
|
|
elseif (ityp.eq.0.and.action(1:3).ne.'no_') then
|
|
itetclr(iel)=-iclr
|
|
endif
|
|
endif
|
|
enddo
|
|
|
|
c .........................................
|
|
else ! if (action(1:laction).eq.'reset') then
|
|
|
|
! any other action interpreted as reset
|
|
|
|
if (local_debug.gt.0
|
|
& .and.action(1:laction).ne.'reset') then
|
|
write(*,*) 'add filter lower_d '//action(1:laction)
|
|
write(*,*) 'using reset as default'
|
|
endif
|
|
|
|
do iel=1,nelts
|
|
itetclr(iel)=abs(itetclr(iel))
|
|
enddo
|
|
|
|
if (action(1:laction).eq.'reset') then
|
|
len=1
|
|
ityp=1
|
|
d0_nfilters=0
|
|
call cmo_set_info('d0_nfilters',cmo,d0_nfilters
|
|
& ,len,ityp,ierr)
|
|
elseif (d_topo.eq.1
|
|
& .and.input_action1(1:linact).ne.'refilter') then
|
|
call writloga('default',0,
|
|
& 'caution: no such filter so reset',0,ierr)
|
|
call writloga('default',0,
|
|
& '- use lower_d/filter/-cmo-/refilter/1 to restore previous'
|
|
& ,0,ierr)
|
|
endif
|
|
|
|
c .........................................
|
|
endif
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'itetclr after for d_topo = ',d_topo
|
|
write(*,*) (itetclr(iel),iel=1,nelts)
|
|
endif
|
|
|
|
c ... !! fix d0_node_topo for this d_topo .........
|
|
|
|
len=0
|
|
do iel=1,nelts
|
|
iclr=itetclr(iel)
|
|
if (iclr.ge.0) then ! vs gt.0 -> but =0 should never happen?
|
|
len=len+1
|
|
ityp=itettyp(iel)
|
|
ioff=itetoff(iel)
|
|
do ind=1,nelmnen(ityp)
|
|
i=iparent(itet(ioff+ind))
|
|
d0_node_topo(i)=d_topo
|
|
enddo
|
|
endif
|
|
enddo
|
|
if (d_topo.eq.1) then
|
|
d1_nelts=len
|
|
else
|
|
d2_nelts=len
|
|
endif
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'd0_node_topo after for d_topo = ',d_topo
|
|
write(*,*) (d0_node_topo(i),i=1,d0_nnodes)
|
|
endif
|
|
|
|
c -----------------------------------------------------
|
|
enddo
|
|
|
|
8000 continue
|
|
|
|
c ... !! get the element info corresponding to 1-up from the the points
|
|
if (d1_nelements.eq.0) then
|
|
d_topo=1
|
|
call cmo_get_info('itetclr',cmo,ip_itetclr,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('itetoff',cmo,ip_itetoff,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('jtetoff',cmo,ip_jtetoff,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('itettyp',cmo,ip_itettyp,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('itet',cmo,ip_itet,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('jtet',cmo,ip_jtet,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('faces_per_element',cmo,nef_cmo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
elseif (d2_nelements.eq.0) then
|
|
d_topo=2
|
|
else
|
|
d_topo=3
|
|
endif
|
|
|
|
c ... !! fix for d0_node_topo for points ...............
|
|
|
|
do iel=1,nelts
|
|
iclr=itetclr(iel)
|
|
ityp=itettyp(iel)
|
|
if (iclr.ge.0) then
|
|
ioff=jtetoff(iel)
|
|
do iface=1,nelmnef(ityp)
|
|
jt=jtet(ioff+iface)
|
|
if ((jt.lt.mbndry.and.mbndry.gt.0)
|
|
& .or.(jt.gt.0.and.mbndry.eq.0)) then
|
|
jel=1+(jt-1)/nef_cmo
|
|
jclr=itetclr(jel)
|
|
endif
|
|
if ((jt.ge.mbndry.and.mbndry.gt.0)
|
|
& .or.(jt.le.0.and.mbndry.eq.0)
|
|
& .or.jclr.lt.0) then
|
|
! should really only get here if ityp=ifelmlin ...
|
|
! WHY??
|
|
do ind=1,ielmface0(iface,ityp)
|
|
i=ielmface1(ind,iface,ityp)
|
|
i=iparent(itet(ioff+i))
|
|
pttyp=isn1(i)
|
|
if (pttyp.ne.0) then
|
|
pttyp=itp1(pttyp)
|
|
else
|
|
pttyp=itp1(i)
|
|
endif
|
|
if (d0_node_topo(i).ne.d_topo-1) goto 700
|
|
if (action(1:laction).eq.'no_icr') then
|
|
if (icr1(i).eq.ivalue) goto 700
|
|
elseif (action(1:laction).eq.'icr') then
|
|
if (icr1(i).ne.ivalue) goto 700
|
|
elseif (action(1:laction).eq.'no_itp') then
|
|
if (pttyp.eq.ivalue) goto 700
|
|
elseif (action(1:laction).eq.'itp') then
|
|
if (pttyp.ne.ivalue) goto 700
|
|
elseif (action(1:laction).eq.'no_clr') then
|
|
if (ivalue.gt.d0_nclrs) goto 700
|
|
elseif (action(1:laction).eq.'clr') then
|
|
if (ivalue.le.d0_nclrs) goto 700
|
|
elseif (action(1:laction).eq.'no_imt'
|
|
& .or.action(1:laction).eq.'imt') then
|
|
pttyp=0
|
|
j=isn1(i)
|
|
if (j.eq.0) then
|
|
if (imt1(i).eq.ivalue) pttyp=1
|
|
else
|
|
do while (j.ne.i)
|
|
if (imt1(i).eq.ivalue) then
|
|
pttyp=1
|
|
goto 650
|
|
endif
|
|
j=isn1(j)
|
|
enddo
|
|
endif
|
|
650 if (action(1:laction).eq.'no_imt'
|
|
& .and.pttyp.eq.1) goto 700
|
|
if (action(1:laction).eq.'imt'
|
|
& .and.pttyp.eq.0) goto 700
|
|
elseif (action(1:laction).eq.'no_vrt'
|
|
& .or.action(1:laction).eq.'real') then
|
|
if (pttyp.eq.ifitpvrt.or.pttyp.eq.ifitpvrb
|
|
& .or.pttyp.eq.ifitpvin.or.pttyp.eq.ifitpvfb
|
|
& .or.pttyp.eq.ifitpvrf.or.pttyp.eq.ifitpvif
|
|
& .or.pttyp.eq.ifitpvir.or.pttyp.eq.ifitpalb
|
|
& ) goto 700
|
|
elseif (action(1:laction).eq.'no_real'
|
|
& .or.action(1:laction).eq.'vrt') then
|
|
if (pttyp.ne.ifitpvrt.and.pttyp.ne.ifitpvrb
|
|
& .and.pttyp.ne.ifitpvin.and.pttyp.ne.ifitpvfb
|
|
& .and.pttyp.ne.ifitpvrf.and.pttyp.ne.ifitpvif
|
|
& .and.pttyp.ne.ifitpvir.and.pttyp.ne.ifitpalb
|
|
& ) goto 700
|
|
elseif (action(1:laction).eq.'no_int'
|
|
& .or.action(1:laction).eq.'ext') then
|
|
if (pttyp.eq.ifitpint.or.pttyp.eq.ifitpini
|
|
& .or.pttyp.eq.ifitpvrt.or.pttyp.eq.ifitpvin
|
|
& ) goto 700
|
|
elseif (action(1:laction).eq.'no_ext'
|
|
& .or.action(1:laction).eq.'int') then
|
|
if (pttyp.ne.ifitpint.and.pttyp.ne.ifitpini
|
|
& .and.pttyp.ne.ifitpvrt.and.pttyp.ne.ifitpvin
|
|
& ) goto 700
|
|
endif
|
|
d0_node_topo(i)=d_topo
|
|
700 continue
|
|
enddo
|
|
endif
|
|
enddo
|
|
endif
|
|
enddo
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'd0_node_topo after for d_topo = ',d_topo
|
|
write(*,*) (d0_node_topo(i),i=1,d0_nnodes)
|
|
endif
|
|
|
|
d1_nnodes=0
|
|
d2_nnodes=0
|
|
d3_nnodes=0
|
|
do i=1,d0_nnodes
|
|
ityp=d0_node_topo(i)
|
|
if (ityp.gt.0.and.i.eq.iparent(i)) then
|
|
if (ityp.ge.1) d1_nnodes=d1_nnodes+1
|
|
if (ityp.ge.2) d2_nnodes=d2_nnodes+1
|
|
if (ityp.ge.3) d3_nnodes=d3_nnodes+1
|
|
j=isn1(i)
|
|
do while (j.ne.i.and.j.ne.0)
|
|
d0_node_topo(j)=-d0_node_topo(i)
|
|
j=isn1(j)
|
|
enddo
|
|
endif
|
|
enddo
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'd0_node_topo after isn'
|
|
write(*,*) (d0_node_topo(i),i=1,d0_nnodes)
|
|
write(*,*) 'nnodes:',d0_nnodes,d1_nnodes,d2_nnodes,d3_nnodes
|
|
endif
|
|
|
|
call cmo_get_info('d1_nnodes',cmo,i,len,ityp,ierr)
|
|
if (ierr.eq.0) then
|
|
ityp=1
|
|
len=1
|
|
call cmo_set_info('d1_nnodes',cmo,d1_nnodes,len,ityp,ierr)
|
|
endif
|
|
|
|
call cmo_get_info('d2_nnodes',cmo,i,len,ityp,ierr)
|
|
if (ierr.eq.0) then
|
|
ityp=1
|
|
len=1
|
|
call cmo_set_info('d2_nnodes',cmo,d2_nnodes,len,ityp,ierr)
|
|
endif
|
|
|
|
call cmo_get_info('d3_nnodes',cmo,i,len,ityp,ierr)
|
|
if (ierr.eq.0) then
|
|
ityp=1
|
|
len=1
|
|
call cmo_set_info('d3_nnodes',cmo,d3_nnodes,len,ityp,ierr)
|
|
endif
|
|
|
|
c ===================================================
|
|
enddo ! last_action
|
|
|
|
write(*,*)
|
|
& 'total d0_nelements,d1_nelements,d2_nelements='
|
|
& ,d0_nelements,d1_nelements,d2_nelements
|
|
write(*,*) ' valid d0_nnodes,d1_nnodes,d2_nnodes,d3_nnodes='
|
|
& ,d0_nnodes,d1_nnodes,d2_nnodes,d3_nnodes
|
|
write(*,*)
|
|
& 'valid d1_nelements,d2_nelements=',d1_nelts,d2_nelts
|
|
|
|
c -----------------------------------------------------
|
|
9000 continue
|
|
ierror=0
|
|
return
|
|
|
|
c -----------------------------------------------------
|
|
9999 continue
|
|
ierror=1
|
|
if (local_debug.gt.0) stop
|
|
call writloga('default',0,'ERROR in filter_lower_d_lg',0,ierr)
|
|
return
|
|
end
|
|
|
|
c-----------------------------------------------------------------------
|
|
C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|
|
|
c-----------------------------------------------------------------------
|
|
C #####################################################################
|
|
C itet_lower_d_lg
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C Set itettyp,itetoff,jtetoff,itet for the lower d structures.
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C nelements,d0_nef_cmo
|
|
C iparent,itettyp,itetoff,itet,d0_elm_d1,jtetoff
|
|
C d1_nelements,d1_nef_cmo
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C d1_elm_d0,d1_itettyp,d1_itetoff,d1_itet,d1_jtetoff
|
|
C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
|
|
C
|
|
C USAGE NOTES / CAVEATS / CHANGES -
|
|
C
|
|
C it is probably not advisable to call this routine outside this
|
|
C lower_d command suite.
|
|
C
|
|
C #####################################################################
|
|
|
|
subroutine itet_lower_d_lg(
|
|
& nelements,d0_nef_cmo
|
|
& ,iparent,itettyp,itetoff,itet,d0_elm_d1,jtetoff
|
|
& ,d1_nelements,d1_nef_cmo
|
|
& ,d1_elm_d0,d1_itettyp,d1_itetoff,d1_itet,d1_jtetoff
|
|
& ,ierror)
|
|
|
|
c ........................................................................
|
|
|
|
implicit none
|
|
include 'local_element.h'
|
|
|
|
integer nelements,d0_nef_cmo,ierror
|
|
|
|
integer iparent(*),itettyp(*),itetoff(*),itet(*)
|
|
& ,d0_elm_d1(*),jtetoff(*)
|
|
|
|
integer d1_nelements,d1_nef_cmo
|
|
|
|
integer d1_elm_d0(*),d1_itettyp(*)
|
|
& ,d1_itetoff(*),d1_itet(*),d1_jtetoff(*)
|
|
|
|
integer iel,jel,iface,jface,ioff,joff,ityp,jtyp
|
|
& ,ioffsum,joffsum,jt,ind,nnd,i,ierr
|
|
|
|
character*132 cbuf
|
|
|
|
integer local_debug
|
|
|
|
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
|
local_debug=0
|
|
|
|
c........ (check if anything to do) ..................
|
|
|
|
if (d1_nelements.eq.0) goto 1000
|
|
|
|
c........ (assign d1 element translation info) ..................
|
|
c d0_elm_d1 is input -> set d1_elm_d0
|
|
|
|
do iel=1,nelements
|
|
ioff=jtetoff(iel)
|
|
ityp=itettyp(iel)
|
|
do iface=1,nelmnef(ityp)
|
|
ioff=ioff+1
|
|
jel=d0_elm_d1(ioff)
|
|
if (jel.gt.0.and.jel.le.d1_nelements) then
|
|
d1_elm_d0(jel)=(iel-1)*d0_nef_cmo+iface
|
|
elseif (jel.lt.-d1_nelements.or.jel.gt.d1_nelements) then
|
|
goto 9999
|
|
endif
|
|
enddo
|
|
enddo
|
|
|
|
! check
|
|
do iel=1,d1_nelements
|
|
jt=d1_elm_d0(iel)
|
|
if (jt.gt.nelements*d0_nef_cmo.or.jt.lt.1) goto 9999
|
|
jel=1+(jt-1)/d0_nef_cmo
|
|
jface=jt-(jel-1)*d0_nef_cmo
|
|
if (d0_elm_d1(jtetoff(jel)+jface).ne.iel) goto 9999
|
|
enddo
|
|
|
|
c........ (assign d1 element info) ..................
|
|
c d1_itettyp, d1_itetoff, d1_jtetoff, d1_itet
|
|
|
|
ioffsum=0
|
|
joffsum=0
|
|
do iel=1,d1_nelements
|
|
jt=d1_elm_d0(iel)
|
|
jel=1+(jt-1)/d0_nef_cmo
|
|
jface=jt-(jel-1)*d0_nef_cmo
|
|
joff=itetoff(jel)
|
|
jtyp=itettyp(jel)
|
|
ityp=ielmface3(jface,jtyp)
|
|
nnd=nelmnen(ityp)
|
|
!! set d1_itettyp, d1_itetoff, d1_jtetoff ......
|
|
d1_itettyp(iel)=ityp
|
|
d1_itetoff(iel)=ioffsum
|
|
d1_jtetoff(iel)=joffsum
|
|
!! set d1_itet ......
|
|
do ind=1,nnd
|
|
i=iparent(itet(joff+ielmface1(ind,jface,jtyp)))
|
|
d1_itet(ioffsum+ind)=i
|
|
enddo
|
|
ioffsum=ioffsum+nnd
|
|
joffsum=joffsum+nelmnef(ityp)
|
|
enddo
|
|
|
|
c =======================================================================
|
|
|
|
c........ (sucessful return) ..................
|
|
1000 ierror=0
|
|
!(release in lower_d_control)! call mmrelprt(isubname,ierr)
|
|
if (local_debug.gt.0) call mmverify()
|
|
return
|
|
|
|
c........ (failure return) ..................
|
|
9999 ierror=1
|
|
!(release in lower_d_control)! call mmrelprt(isubname,ierr)
|
|
if (local_debug.gt.0) call mmverify()
|
|
cbuf='ERROR IN ROUTINE itet_lower_d_lg: ABORTING'
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
if (local_debug.gt.0) stop
|
|
return
|
|
c .....................................................
|
|
end
|
|
|
|
c-----------------------------------------------------------------------
|
|
C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|
|
|
c-----------------------------------------------------------------------
|
|
C #####################################################################
|
|
C itetclr_lower_d_lg
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C set the itetclr for the lower d elements,
|
|
C incrementing the color table as necessary.
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C cmo,d_topo,nconbnd,mbndry
|
|
C d0_nelements,d0_nef_cmo
|
|
C icontab,itp1,icr1,isn1,iparent
|
|
C d0_itetclr,d0_jtetoff,d0_jtet
|
|
C d1_nelements,d1_nef_cmo
|
|
C d1_itettyp,d1_itetoff,d1_itet,d1_elm_d0
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C d1_itetclr
|
|
C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
|
|
C
|
|
C USAGE NOTES / CAVEATS / CHANGES -
|
|
C
|
|
C it is probably not advisable to call this routine outside this
|
|
C lower_d command suite.
|
|
C
|
|
C Note: if an icr1 value is not in the icontab table,
|
|
C then treated as icr1="minimum constraint".
|
|
C
|
|
C see notes for create_lower_d_lg for interior_icr_flag
|
|
C
|
|
|
|
C less clear notes to myself for code development .......................
|
|
|
|
c set itetclr to packed itp,icr,{imt}
|
|
c d_topo is RELATIVE dimension, not current
|
|
|
|
! pass input to avoid all those "gets"
|
|
! pass output?? or just let user get?
|
|
! & ,d0_nclrs,ip_d0_clroff,ip_d0_clrtab
|
|
|
|
c dang: jtet_reduce_nnd:
|
|
c ought to pack dimensionality into the itetclr....
|
|
c and should the "diff # nnd" connections get a "vrt"??
|
|
|
|
c if icontab exists and find lower_d icr1 with no corresponding entry,
|
|
c should increment icontab,ncontab instead of using mincon...
|
|
|
|
C #####################################################################
|
|
|
|
subroutine itetclr_lower_d_lg(cmo
|
|
& ,d_topo,nconbnd,mbndry
|
|
& ,jtet_cycle_max,jtet_reduce_nnd
|
|
& ,interior_icr_flag,ibtype,geom_name
|
|
& ,d0_nelements,d0_nef_cmo
|
|
& ,icontab,itp1,icr1,isn1,iparent ! iparent only needed for debug...
|
|
& ,d0_itetclr,d0_jtetoff,d0_jtet
|
|
& ,d1_nelements,d1_nef_cmo
|
|
& ,d1_itettyp,d1_itetclr,d1_itetoff,d1_itet,d1_elm_d0
|
|
& ,ierror)
|
|
|
|
c ........................................................................
|
|
|
|
implicit none
|
|
|
|
include 'local_element.h'
|
|
include 'chydro.h'
|
|
|
|
character*(*) cmo
|
|
|
|
integer d_topo,nconbnd,mbndry,ierror
|
|
& ,jtet_cycle_max,jtet_reduce_nnd
|
|
& ,interior_icr_flag
|
|
|
|
character*(*) ibtype(*),geom_name ! need re testing if virtual constraint
|
|
|
|
integer icontab(50,*),itp1(*),icr1(*),isn1(*),iparent(*)
|
|
|
|
integer d0_nelements,d0_nef_cmo
|
|
|
|
integer d0_jtet(*),d0_jtetoff(*)
|
|
& ,d0_itetclr(*)
|
|
|
|
integer d1_nelements,d1_nef_cmo
|
|
|
|
integer d1_itet(*),d1_itetoff(*)
|
|
& ,d1_elm_d0(*),d1_itettyp(*),d1_itetclr(*)
|
|
|
|
integer d0_nclrs,d0_clrlen
|
|
pointer (ip_srfs,srfs),(ip_d0_clrtab,d0_clrtab)
|
|
& ,(ip_d0_clroff,d0_clroff)
|
|
integer srfs(*),d0_clrtab(*),d0_clroff(*)
|
|
|
|
integer iel,jel,kel,jface,kface,ioff,joff
|
|
& ,ityp,jtyp,ktyp,jt,kt,ieltyp,ielcon
|
|
& ,i,j,len,ierr,ind,iclr,nsrfs,mxsrfs
|
|
& ,nnd,minicr,maxicr,ncon,mincon,icon,jclr,kclr
|
|
& ,k,d0_nclrs_att,d0_clrlen_att,icycle
|
|
& ,loc_icr(maxnee1),loc_itp(maxnee1),isrf
|
|
& ,loc_par(maxnee1)
|
|
|
|
character*132 cbuf
|
|
character*32 isubname2
|
|
|
|
integer local_debug,missing_icr1
|
|
|
|
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
|
|
|
isubname2='tmp2_lower_d_lg'
|
|
local_debug=0
|
|
missing_icr1=0
|
|
d0_nclrs_att=0
|
|
d0_clrlen_att=0
|
|
|
|
if (jtet_reduce_nnd.eq.1) then
|
|
cbuf='WARNING: itetclr_lower_d_lg not jtet_reduce_nnd=1 safe'
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
endif
|
|
|
|
c........ (get info, initialize table if d_topo=1) ..................
|
|
|
|
! check if anything to do
|
|
if (d0_nelements.le.0.or.d1_nelements.le.0
|
|
& .or.d_topo.lt.1.or.d_topo.gt.2) goto 9999
|
|
|
|
! get color table info
|
|
call cmo_get_info('d0_nclrs',cmo,d0_nclrs,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d0_clrlen',cmo,d0_clrlen,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
if (d_topo.eq.1) then
|
|
! don't set to zero in case want to save over re-creates.
|
|
! should be OK as set to zero when created...
|
|
if (d0_nclrs.lt.0) goto 9999 ! d0_nclrs=0
|
|
if (d0_clrlen.lt.0) goto 9999 ! d0_clrlen=0
|
|
else
|
|
if (d0_nclrs.lt.0) goto 9999
|
|
if (d0_clrlen.lt.0) goto 9999
|
|
endif
|
|
|
|
! increase clr lengths by default amount (will be corrected later)
|
|
nsrfs=min(100,d1_nelements)
|
|
call cmo_get_info('d0_clrtab',cmo,ip_d0_clrtab,d0_clrlen_att,
|
|
* ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('d0_clroff',cmo,ip_d0_clroff,d0_nclrs_att,
|
|
* ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
d0_nclrs_att=d0_nclrs_att+nsrfs
|
|
d0_clrlen_att=d0_clrlen_att+50*nsrfs
|
|
call mmnewlen('d0_clroff',cmo,ip_d0_clroff,d0_nclrs_att,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call mmnewlen('d0_clrtab',cmo,ip_d0_clrtab,d0_clrlen_att,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
c........ (assign d1 element info) ..................
|
|
c d1_itetclr
|
|
|
|
ityp=1
|
|
mxsrfs=500
|
|
call mmggetbk('srfs',isubname2,ip_srfs,mxsrfs,ityp,ierr)
|
|
|
|
do iel=1,d1_nelements
|
|
|
|
d1_itetclr(iel)=0
|
|
|
|
ityp=d1_itettyp(iel)
|
|
nnd=nelmnen(ityp)
|
|
ioff=d1_itetoff(iel)
|
|
do ind=1,nnd
|
|
i=d1_itet(ioff+ind)
|
|
j=itp1(i)
|
|
! fix
|
|
if (isn1(i).ne.0.and.j.eq.ifitpcup) i=isn1(i)
|
|
loc_icr(ind)=icr1(i)
|
|
loc_itp(ind)=itp1(i)
|
|
loc_par(ind)=iparent(i)
|
|
enddo
|
|
if (local_debug.gt.9) then
|
|
write(*,*) 'iel',iel,'--------------'
|
|
write(*,*) 'icr',(loc_icr(ind),ind=1,nnd)
|
|
write(*,*) 'itp',(loc_itp(ind),ind=1,nnd)
|
|
write(*,*) 'par',(loc_par(ind),ind=1,nnd)
|
|
endif
|
|
|
|
jt=d1_elm_d0(iel)
|
|
jel=1+(jt-1)/d0_nef_cmo
|
|
jface=jt-(jel-1)*d0_nef_cmo
|
|
joff=d0_jtetoff(jel)
|
|
jt=d0_jtet(joff+jface)
|
|
jclr=d0_itetclr(jel)
|
|
if (jclr.gt.0.and.jclr.le.d0_nclrs) then
|
|
jtyp=d0_clrtab(d0_clroff(jclr)+1)
|
|
else
|
|
jtyp=0
|
|
endif
|
|
|
|
!! find ieltyp......
|
|
ieltyp=0
|
|
if (d_topo.eq.1) then
|
|
! only possible types are ini,rfl,fre,vrt
|
|
if ((jt.gt.mbndry.and.mbndry.gt.0)
|
|
& .or.(jt.lt.0.and.mbndry.eq.0)) then
|
|
! must be ini
|
|
ieltyp=ifitpini
|
|
elseif ((jt.lt.mbndry.and.mbndry.gt.0)
|
|
& .or.(jt.gt.0.and.mbndry.eq.0)) then
|
|
! must be vrt
|
|
ieltyp=ifitpvrt
|
|
else
|
|
! must be fre or rfl
|
|
ieltyp=ifitprfl
|
|
do ind=1,nnd
|
|
i=loc_itp(ind)
|
|
if ( i.eq.ifitpfre.or.i.eq.ifitpvfb
|
|
& .or.i.eq.ifitpifb.or.i.eq.ifitpvif
|
|
& ) ieltyp=ifitpfre
|
|
enddo
|
|
endif
|
|
else ! if (d_topo.eq.2) then
|
|
if ((jt.lt.mbndry.and.mbndry.gt.0)
|
|
& .or.(jt.gt.0.and.mbndry.eq.0)) then
|
|
! WHY WAS THIS ".le.mbndry" in old version??
|
|
! must be vrt giving fake bndry
|
|
ieltyp=ifitpvrt
|
|
else
|
|
! above types ini,rfl,fre,vrt
|
|
! plus vin,vrb,vfb,vrf,vir,vif,alb
|
|
! ,rfb,irb,ifb,irf now possible
|
|
! cycle around parent edge rather than setting from nodes
|
|
! since node info may be misleading re "interior" edges
|
|
do i=1,4
|
|
srfs(i)=0
|
|
enddo
|
|
if (jtyp.eq.ifitpfre) then
|
|
srfs(1)=1
|
|
elseif (jtyp.eq.ifitprfl) then
|
|
srfs(2)=1
|
|
elseif (jtyp.eq.ifitpvrt) then
|
|
srfs(3)=1
|
|
elseif (jtyp.eq.ifitpini) then
|
|
srfs(4)=1
|
|
endif
|
|
kt=abs(jt)-mbndry
|
|
kel=1+(kt-1)/d0_nef_cmo
|
|
kface=kt-(kel-1)*d0_nef_cmo
|
|
icycle=0
|
|
do while ((kel.ne.jel.or.kface.ne.jface)
|
|
& .and.kt.gt.0
|
|
& .and.icycle.lt.jtet_cycle_max)
|
|
icycle=icycle+1
|
|
kclr=d0_itetclr(kel)
|
|
if (kclr.le.d0_nclrs.and.kclr.gt.0) then
|
|
ktyp=d0_clrtab(d0_clroff(kclr)+1)
|
|
if (ktyp.eq.ifitpfre) then
|
|
srfs(1)=1
|
|
elseif (ktyp.eq.ifitprfl) then
|
|
srfs(2)=1
|
|
elseif (ktyp.eq.ifitpvrt) then
|
|
srfs(3)=1
|
|
elseif (ktyp.eq.ifitpini) then
|
|
srfs(4)=1
|
|
endif
|
|
endif
|
|
kt=d0_jtet(d0_jtetoff(kel)+kface)
|
|
kt=abs(kt)-mbndry
|
|
kel=1+(kt-1)/d0_nef_cmo
|
|
kface=kt-(kel-1)*d0_nef_cmo
|
|
enddo
|
|
if (kt.eq.0) srfs(3)=0
|
|
len=srfs(1)+srfs(2)+srfs(3)+srfs(4)
|
|
if (len.eq.4) then
|
|
ieltyp=ifitpalb
|
|
elseif (len.eq.0) then
|
|
ieltyp=0
|
|
elseif (len.eq.3.and.srfs(1).eq.0) then
|
|
ieltyp=ifitpvir
|
|
elseif (len.eq.3.and.srfs(2).eq.0) then
|
|
ieltyp=ifitpvif
|
|
elseif (len.eq.3.and.srfs(3).eq.0) then
|
|
ieltyp=ifitpirf
|
|
elseif (len.eq.3.and.srfs(4).eq.0) then
|
|
ieltyp=ifitpvrf
|
|
elseif (len.eq.1.and.srfs(1).eq.1) then
|
|
ieltyp=ifitpfre
|
|
elseif (len.eq.1.and.srfs(2).eq.1) then
|
|
ieltyp=ifitprfl
|
|
elseif (len.eq.1.and.srfs(3).eq.1) then
|
|
ieltyp=ifitpvrt
|
|
elseif (len.eq.1.and.srfs(4).eq.1) then
|
|
ieltyp=ifitpini
|
|
elseif (srfs(1).eq.1.and.srfs(2).eq.1) then
|
|
ieltyp=ifitprfb
|
|
elseif (srfs(1).eq.1.and.srfs(3).eq.1) then
|
|
ieltyp=ifitpvfb
|
|
elseif (srfs(1).eq.1.and.srfs(4).eq.1) then
|
|
ieltyp=ifitpifb
|
|
elseif (srfs(2).eq.1.and.srfs(3).eq.1) then
|
|
ieltyp=ifitpvrb
|
|
elseif (srfs(2).eq.1.and.srfs(4).eq.1) then
|
|
ieltyp=ifitpirb
|
|
elseif (srfs(3).eq.1.and.srfs(4).eq.1) then
|
|
ieltyp=ifitpvin
|
|
endif
|
|
endif
|
|
endif
|
|
|
|
!! find constraint ......
|
|
|
|
c first "correct" virtual ieltyp's if interior_icr_flag value prohibits virtual...
|
|
if (interior_icr_flag.eq.1.or.interior_icr_flag.eq.3
|
|
& .or.interior_icr_flag.eq.5.or.interior_icr_flag.eq.7) then
|
|
endif
|
|
|
|
c first "correct" ieltyp and/or loc_icr/ielcon based on interior_icr_flag value
|
|
C = 0 - all constrained surface types can exist
|
|
C = 1 - no virtual constrained surfaces exist
|
|
C = 2 - no intrcons constrained surfaces exist
|
|
C = 3 - no virtual or intrcons constrained surfaces exist
|
|
C = 4 - no reflect constrained surfaces exist
|
|
C = 5 - no reflect or virtual constrained surfaces exist
|
|
C = 6 - no reflect or intrcons constrained surfaces exist
|
|
C = 7 - no constrained surfaces exist
|
|
|
|
if (interior_icr_flag.ne.0) then
|
|
if ( interior_icr_flag.eq.1.or.interior_icr_flag.eq.3
|
|
& .or.interior_icr_flag.eq.5.or.interior_icr_flag.eq.7
|
|
& ) then
|
|
! "correct" virtual ieltyp's as no virtual allowed
|
|
if (ieltyp.eq.ifitpvin) then
|
|
ieltyp=ifitpini
|
|
elseif (ieltyp.eq.ifitpvrb) then
|
|
ieltyp=ifitprfl
|
|
elseif (ieltyp.eq.ifitpvfb) then
|
|
ieltyp=ifitpfre
|
|
do ind=1,nnd
|
|
loc_icr(ind)=0
|
|
enddo
|
|
elseif (ieltyp.eq.ifitpvrf) then
|
|
ieltyp=ifitprfb
|
|
elseif (ieltyp.eq.ifitpvir) then
|
|
ieltyp=ifitpirb
|
|
elseif (ieltyp.eq.ifitpvif) then
|
|
ieltyp=ifitpifb
|
|
elseif (ieltyp.eq.ifitpalb) then
|
|
ieltyp=ifitpirf
|
|
elseif (ieltyp.eq.ifitpvrt) then
|
|
do ind=1,nnd
|
|
loc_icr(ind)=0
|
|
enddo
|
|
if (local_debug.ne.0) stop 'err'
|
|
goto 9999
|
|
endif
|
|
endif
|
|
if (interior_icr_flag.eq.7) then
|
|
! no constrained interfaces exist as far as lower_d is concerned
|
|
do ind=1,nnd
|
|
loc_icr(ind)=0
|
|
enddo
|
|
elseif (interior_icr_flag.eq.2
|
|
& .or.interior_icr_flag.eq.3) then
|
|
! intrcons surfaces are not allowed
|
|
if (ieltyp.eq.ifitpini.or.ieltyp.eq.ifitpifb) then
|
|
do ind=1,nnd
|
|
loc_icr(ind)=0
|
|
enddo
|
|
endif
|
|
elseif (interior_icr_flag.eq.4
|
|
& .or.interior_icr_flag.eq.5) then
|
|
! reflect surfaces are not allowed
|
|
if (ieltyp.eq.ifitprfl.or.ieltyp.eq.ifitprfb) then
|
|
do ind=1,nnd
|
|
loc_icr(ind)=0
|
|
enddo
|
|
endif
|
|
elseif (interior_icr_flag.eq.6) then
|
|
! intrcons surfaces are not allowed
|
|
! and reflect surfaces are not allowed
|
|
if (ieltyp.eq.ifitpini.or.ieltyp.eq.ifitpifb
|
|
& .or.ieltyp.eq.ifitprfl.or.ieltyp.eq.ifitprfb
|
|
& .or.ieltyp.eq.ifitpirb.or.ieltyp.eq.ifitpirf) then
|
|
do ind=1,nnd
|
|
loc_icr(ind)=0
|
|
enddo
|
|
endif
|
|
endif
|
|
endif
|
|
|
|
c now continue using the "interior_icr_flag corrected" loc_icr and ieltyp
|
|
|
|
if (nnd.gt.0) then
|
|
minicr=loc_icr(1)
|
|
else
|
|
minicr=0
|
|
endif
|
|
maxicr=minicr
|
|
ncon=-50
|
|
do ind=1,nnd
|
|
if (loc_icr(ind).lt.minicr) minicr=loc_icr(ind)
|
|
if (loc_icr(ind).gt.maxicr) maxicr=loc_icr(ind)
|
|
if (nconbnd.gt.0.and.loc_icr(ind).gt.0) then
|
|
if (icontab(1,loc_icr(ind)).lt.ncon
|
|
& .or.ncon.lt.0) then
|
|
mincon=loc_icr(ind)
|
|
ncon=icontab(1,mincon)
|
|
if (ncon.le.0) minicr=0
|
|
endif
|
|
endif
|
|
enddo
|
|
|
|
! define surface constraint
|
|
! use smallest as best guess when icontab does not exist
|
|
if (ieltyp.eq.ifitpfre) then
|
|
! free surfaces can't be constrained
|
|
ielcon=0
|
|
elseif (minicr.eq.0.or.nconbnd.eq.0.or.ncon.le.0
|
|
& .or.(minicr.eq.maxicr.and.geom_name(1:6)
|
|
& .eq.'-none-'.and.interior_icr_flag.eq.0)
|
|
& ) then
|
|
ielcon=minicr
|
|
else
|
|
! find set of constraints common to all nodes
|
|
! and use this for surface
|
|
! (must be more than 1 ind or would not be here)
|
|
nsrfs=0
|
|
do icon=1,ncon
|
|
isrf=icontab(2+icon,mincon)
|
|
if (geom_name(1:6).ne.'-none-') then
|
|
! ------------------
|
|
! test that constraint agrees with ieltyp
|
|
! ------------------
|
|
if (ibtype(isrf).eq.'virtual'
|
|
& .and.ieltyp.ne.ifitpvrt.and.ieltyp.ne.ifitpvin
|
|
& .and.ieltyp.ne.ifitpvrb.and.ieltyp.ne.ifitpvfb
|
|
& .and.ieltyp.ne.ifitpvrf.and.ieltyp.ne.ifitpvir
|
|
& .and.ieltyp.ne.ifitpvif.and.ieltyp.ne.ifitpalb
|
|
& ) then
|
|
goto 111
|
|
elseif (ibtype(isrf).eq.'intrcons'
|
|
& .and.ieltyp.ne.ifitpini.and.ieltyp.ne.ifitpvin
|
|
& .and.ieltyp.ne.ifitpvir.and.ieltyp.ne.ifitpvif
|
|
& .and.ieltyp.ne.ifitpalb.and.ieltyp.ne.ifitpirb
|
|
& .and.ieltyp.ne.ifitpifb.and.ieltyp.ne.ifitpirf
|
|
& ) then
|
|
goto 111
|
|
elseif (ibtype(isrf).eq.'reflect'
|
|
& .and.ieltyp.ne.ifitprfl.and.ieltyp.ne.ifitpvrb
|
|
& .and.ieltyp.ne.ifitpvrf.and.ieltyp.ne.ifitpvir
|
|
& .and.ieltyp.ne.ifitpalb.and.ieltyp.ne.ifitprfb
|
|
& .and.ieltyp.ne.ifitpirb.and.ieltyp.ne.ifitpirf
|
|
& ) then
|
|
goto 111
|
|
elseif (ibtype(isrf).eq.'intrface'
|
|
7 .or.ibtype(isrf).eq.'free') then
|
|
if (local_debug.gt.0)
|
|
& stop 'error: no icr for intrface or free?'
|
|
goto 9999
|
|
endif
|
|
! ------------------
|
|
endif
|
|
do ind=1,nnd
|
|
if (loc_icr(ind).eq.mincon) goto 110
|
|
do i=1,icontab(1,loc_icr(ind))
|
|
if (icontab(2+i,loc_icr(ind)).eq.isrf)
|
|
& goto 110
|
|
enddo
|
|
goto 111
|
|
110 continue
|
|
enddo
|
|
nsrfs=nsrfs+1
|
|
srfs(nsrfs)=isrf
|
|
111 continue
|
|
enddo
|
|
if (nsrfs.eq.0) then
|
|
ielcon=0
|
|
elseif (nsrfs.eq.ncon) then
|
|
ielcon=mincon
|
|
else
|
|
! find corresp constraint
|
|
ielcon=0
|
|
do icon=1,nconbnd
|
|
if (icontab(1,icon).eq.nsrfs) then
|
|
do i=1,nsrfs
|
|
isrf=srfs(i)
|
|
do j=1,icontab(1,icon)
|
|
if (icontab(2+j,icon).eq.isrf) goto 112
|
|
enddo
|
|
goto 113
|
|
112 continue
|
|
enddo
|
|
ielcon=icon
|
|
goto 114
|
|
endif
|
|
113 continue
|
|
enddo
|
|
! if get here, icr1 entry not in table
|
|
! report error vs update nconbbnd,icontab...
|
|
! for now: use mincon even though incorrect ...
|
|
ielcon=mincon
|
|
missing_icr1=missing_icr1+1
|
|
if (local_debug.gt.0) then
|
|
write(*,*)
|
|
& 'warning: these surfs have no corresp icr1'
|
|
endif
|
|
114 continue
|
|
endif
|
|
endif
|
|
|
|
!! have ieltyp and ielcon, now find imt's
|
|
if (d_topo.eq.1) then
|
|
srfs(1)=d0_itetclr(jel)
|
|
nsrfs=1
|
|
kt=abs(jt)
|
|
if (kt.ge.mbndry.and.mbndry.gt.0) kt=kt-mbndry
|
|
kel=1+(kt-1)/d0_nef_cmo
|
|
kface=kt-(kel-1)*d0_nef_cmo
|
|
icycle=0
|
|
do while ((kel.ne.jel.or.kface.ne.jface)
|
|
& .and.kt.gt.0
|
|
& .and.icycle.lt.jtet_cycle_max)
|
|
icycle=icycle+1
|
|
iclr=d0_itetclr(kel)
|
|
do j=1,nsrfs
|
|
if (srfs(j).eq.iclr) goto 443
|
|
enddo
|
|
if (nsrfs.eq.mxsrfs) then
|
|
call mmincblk('srfs',isubname2,ip_srfs,100,ierr)
|
|
mxsrfs=mxsrfs+100
|
|
endif
|
|
nsrfs=nsrfs+1
|
|
srfs(nsrfs)=iclr
|
|
443 continue
|
|
kt=abs(d0_jtet(d0_jtetoff(kel)+kface))
|
|
if (kt.ge.mbndry.and.mbndry.gt.0) kt=kt-mbndry
|
|
kel=1+(kt-1)/d0_nef_cmo
|
|
kface=kt-(kel-1)*d0_nef_cmo
|
|
enddo
|
|
else
|
|
iclr=d0_itetclr(jel)
|
|
nsrfs=0
|
|
if (iclr.gt.0.and.iclr.lt.d0_nclrs) then
|
|
ioff=d0_clroff(iclr)
|
|
nsrfs=d0_clrtab(ioff+3)
|
|
do i=1,nsrfs
|
|
srfs(i)=d0_clrtab(ioff+3+i)
|
|
enddo
|
|
endif
|
|
kt=abs(jt)
|
|
if (kt.ge.mbndry.and.mbndry.gt.0) kt=kt-mbndry
|
|
kel=1+(kt-1)/d0_nef_cmo
|
|
kface=kt-(kel-1)*d0_nef_cmo
|
|
icycle=0
|
|
do while ((kel.ne.jel.or.kface.ne.jface)
|
|
& .and.kt.gt.0
|
|
& .and.icycle.lt.jtet_cycle_max)
|
|
icycle=icycle+1
|
|
iclr=d0_itetclr(kel)
|
|
if (iclr.gt.0.and.iclr.lt.d0_nclrs) then
|
|
ioff=d0_clroff(iclr)
|
|
nnd=d0_clrtab(ioff+3)
|
|
do i=1,nnd
|
|
iclr=d0_clrtab(ioff+3+i)
|
|
do j=1,nsrfs
|
|
if (srfs(j).eq.iclr) goto 444
|
|
enddo
|
|
if (nsrfs.eq.mxsrfs) then
|
|
call mmincblk('srfs',isubname2
|
|
& ,ip_srfs,100,ierr)
|
|
mxsrfs=mxsrfs+100
|
|
endif
|
|
nsrfs=nsrfs+1
|
|
srfs(nsrfs)=iclr
|
|
444 continue
|
|
enddo
|
|
endif
|
|
kt=abs(d0_jtet(d0_jtetoff(kel)+kface))
|
|
if (kt.ge.mbndry.and.mbndry.gt.0) kt=kt-mbndry
|
|
kel=1+(kt-1)/d0_nef_cmo
|
|
kface=kt-(kel-1)*d0_nef_cmo
|
|
enddo
|
|
endif
|
|
! order srfs
|
|
445 i=0
|
|
do j=2,nsrfs
|
|
if (srfs(j).lt.srfs(j-1)) then
|
|
k=srfs(j)
|
|
srfs(j)=srfs(j-1)
|
|
srfs(j-1)=k
|
|
i=1
|
|
endif
|
|
enddo
|
|
if (i.ne.0) goto 445
|
|
|
|
!! set d1_itetclr
|
|
!! see if previously existing color
|
|
do i=1,d0_nclrs
|
|
ioff=d0_clroff(i)
|
|
ityp=d0_clrtab(ioff+1)
|
|
icon=d0_clrtab(ioff+2)
|
|
nnd=d0_clrtab(ioff+3)
|
|
if (ityp.eq.ieltyp.and.icon.eq.ielcon
|
|
& .and.nnd.eq.nsrfs) then
|
|
do j=1,nsrfs
|
|
if (srfs(j).ne.d0_clrtab(ioff+3+j)) goto 446
|
|
enddo
|
|
d1_itetclr(iel)=i
|
|
goto 447
|
|
endif
|
|
446 continue
|
|
enddo
|
|
!! if not, increment table.....
|
|
if (d0_nclrs.ge.d0_nclrs_att) then
|
|
d0_nclrs_att=d0_nclrs+100
|
|
call mmnewlen('d0_clroff',cmo,ip_d0_clroff
|
|
& ,d0_nclrs_att,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
endif
|
|
if (d0_clrlen+3+nsrfs.gt.d0_clrlen_att) then
|
|
d0_clrlen_att=d0_clrlen+5000
|
|
call mmnewlen('d0_clrtab',cmo,ip_d0_clrtab
|
|
& ,d0_clrlen_att,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
endif
|
|
d0_nclrs=d0_nclrs+1
|
|
d1_itetclr(iel)=d0_nclrs
|
|
d0_clroff(d0_nclrs)=d0_clrlen
|
|
d0_clrtab(d0_clrlen+1)=ieltyp
|
|
d0_clrtab(d0_clrlen+2)=ielcon
|
|
d0_clrtab(d0_clrlen+3)=nsrfs
|
|
do i=1,nsrfs
|
|
d0_clrtab(d0_clrlen+3+i)=srfs(i)
|
|
enddo
|
|
d0_clrlen=d0_clrlen+3+nsrfs
|
|
|
|
447 continue
|
|
|
|
if (local_debug.gt.9) then
|
|
write(*,'(a,3i7)') 'jel,jface,jclr',jel,jface,jclr
|
|
kt=abs(jt)
|
|
if (kt.ge.mbndry.and.mbndry.gt.0) kt=kt-mbndry
|
|
kel=1+(kt-1)/d0_nef_cmo
|
|
kface=kt-(kel-1)*d0_nef_cmo
|
|
icycle=0
|
|
do while ((kel.ne.jel.or.kface.ne.jface)
|
|
& .and.kt.gt.0
|
|
& .and.icycle.lt.jtet_cycle_max)
|
|
icycle=icycle+1
|
|
kclr=d0_itetclr(kel)
|
|
write(*,'(a,3i7)') 'kel,kface,kclr',kel,kface,kclr
|
|
kt=abs(d0_jtet(d0_jtetoff(kel)+kface))
|
|
if (kt.ge.mbndry.and.mbndry.gt.0) kt=kt-mbndry
|
|
kel=1+(kt-1)/d0_nef_cmo
|
|
kface=kt-(kel-1)*d0_nef_cmo
|
|
enddo
|
|
call print_clrtab_lower_d_lg(d0_nclrs,d0_clroff,d0_clrtab)
|
|
write(*,*) 'itetclr chosen is ',d1_itetclr(iel)
|
|
endif
|
|
|
|
|
|
enddo
|
|
|
|
if (local_debug.gt.0) then
|
|
call print_clrtab_lower_d_lg(d0_nclrs,d0_clroff,d0_clrtab)
|
|
j=min(d1_nelements,100)
|
|
if (local_debug.gt.9) j=d1_nelements
|
|
write(*,*) (d1_itetclr(i),i=1,j)
|
|
endif
|
|
|
|
! reset d0_nclrs to current length
|
|
len=1
|
|
ityp=1
|
|
call cmo_set_info('d0_nclrs',cmo,d0_nclrs,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_set_info('d0_clrlen',cmo,d0_clrlen,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call mmnewlen('d0_clroff',cmo,ip_d0_clroff,d0_nclrs,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call mmnewlen('d0_clrtab',cmo,ip_d0_clrtab,d0_clrlen,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
! do this way to avoid messing up other pointers.
|
|
! actually, nothing should be changed but these 2 since recently got pointers.
|
|
! Re-get on return anyway to be safe ??
|
|
! call cmo_newlen(cmo,ierr)
|
|
! for now, "live dangerously"...
|
|
|
|
c .....................................................
|
|
! write(*,*)'d1_nnodes,d1_nelements',d1_nnodes,d1_nelements
|
|
|
|
c =======================================================================
|
|
|
|
c........ (sucessful return) ..................
|
|
1000 ierror=0
|
|
|
|
if (missing_icr1.gt.0) then
|
|
write(cbuf,*) 'lower_d warning: ',missing_icr1
|
|
& ,d_topo,'-elements with icr1 missing from icontab'
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
endif
|
|
if (local_debug.gt.0) then
|
|
call print_clrtab_lower_d_lg(d0_nclrs,d0_clroff,d0_clrtab)
|
|
endif
|
|
if (local_debug.gt.1) stop
|
|
|
|
!(release in lower_d_control)! call mmrelprt(isubname2,ierr)
|
|
if (local_debug.gt.0) call mmverify()
|
|
return
|
|
|
|
c........ (failure return) ..................
|
|
9999 ierror=1
|
|
!(release in lower_d_control)! call mmrelprt(isubname2,ierr)
|
|
if (local_debug.gt.0) call mmverify()
|
|
cbuf='ERROR IN ROUTINE itetclr_lower_d_lg: ABORTING'
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
if (local_debug.gt.0) stop
|
|
return
|
|
c .....................................................
|
|
end
|
|
|
|
c-----------------------------------------------------------------------
|
|
C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|
|
|
c-----------------------------------------------------------------------
|
|
C #####################################################################
|
|
C release_lower_d_lg
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C release storage associated with lower d data structures
|
|
C in the specified mesh, and reset lower_d_flag to indicate no
|
|
C lower d structures desired.
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C cmo - the mesh object to release the lower d structures in
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
|
|
C
|
|
C USAGE NOTES / CAVEATS / CHANGES -
|
|
C
|
|
C #####################################################################
|
|
|
|
subroutine release_lower_d_lg(cmo,ierror)
|
|
|
|
c ........................................................................
|
|
|
|
implicit none
|
|
|
|
character*(*) cmo
|
|
integer ierror
|
|
|
|
integer local_debug,lower_d_flag,len
|
|
& ,lcmo,i,ityp,ierr,d0_topo
|
|
|
|
character*200 cbuf
|
|
|
|
character*32 cmsgout(4)
|
|
real*8 xmsgout(4)
|
|
integer imsgout(4),nwdsout,tmsgout(4)
|
|
|
|
integer icharlnf
|
|
external icharlnf
|
|
|
|
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
|
|
|
local_debug=0
|
|
if (local_debug.gt.0) call mmverify()
|
|
|
|
lcmo=icharlnf(cmo)
|
|
call cmo_exist(cmo(1:lcmo),ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('ndimensions_topo',cmo,d0_topo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.eq.0) d0_topo=3
|
|
|
|
nwdsout=4
|
|
do i=1,4
|
|
xmsgout(i)=0.d0
|
|
imsgout(i)=0
|
|
tmsgout(i)=3
|
|
cmsgout(i)=' '
|
|
enddo
|
|
cmsgout(1)='cmo'
|
|
cmsgout(2)='DELATT'
|
|
cmsgout(3)=cmo
|
|
if (cmo(1:1).eq.'-') then
|
|
call cmo_get_name(cmsgout(3),ierr)
|
|
endif
|
|
|
|
c .................................................................
|
|
|
|
c lower_d_flag ...............
|
|
c ! just set back to flag to indicate no lower d structures
|
|
call cmo_get_info('lower_d_flag',cmo,lower_d_flag
|
|
& ,len,ityp,ierr)
|
|
if (ierr.eq.0) then
|
|
len=1
|
|
ityp=1
|
|
lower_d_flag=0
|
|
call cmo_set_info('lower_d_flag',cmo,lower_d_flag
|
|
& ,len,ityp,ierr)
|
|
endif
|
|
|
|
c .................................................................
|
|
c delete d0 vector attribute d0_node_topo
|
|
|
|
cmsgout(4)='d0_node_topo'
|
|
call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
|
|
c .................................................................
|
|
c delete scalar attributes and all attributes with them as length or rank
|
|
c d0_nclrs,d0_clrlen,d0_nfilters
|
|
c d1_nnodes,d1_nelements,d1_nen_cmo,d1_nef_cmo,d1_nee_cmo,d1_jtet_cycle_max
|
|
c d2_nnodes,d2_nelements,d2_nen_cmo,d2_nef_cmo,d2_nee_cmo,d2_jtet_cycle_max
|
|
c d3_nnodes,d3_nelements,d3_nen_cmo,d3_nef_cmo,d3_nee_cmo
|
|
|
|
cmsgout(4)='d1_nnodes'
|
|
call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
|
|
if (d0_topo.le.1) goto 100
|
|
cmsgout(4)='d1_nelements'
|
|
call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
cmsgout(4)='d1_nen_cmo'
|
|
call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
cmsgout(4)='d1_nef_cmo'
|
|
call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
cmsgout(4)='d1_nee_cmo'
|
|
call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
cmsgout(4)='d1_jtet_cycle_max'
|
|
call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
|
|
cmsgout(4)='d2_nnodes'
|
|
call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
|
|
if (d0_topo.le.2) goto 100
|
|
cmsgout(4)='d2_nelements'
|
|
call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
cmsgout(4)='d2_nen_cmo'
|
|
call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
cmsgout(4)='d2_nef_cmo'
|
|
call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
cmsgout(4)='d2_nee_cmo'
|
|
call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
cmsgout(4)='d2_jtet_cycle_max'
|
|
call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
|
|
cmsgout(4)='d3_nnodes'
|
|
call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
|
|
C$ cmsgout(4)='d3_nelements'
|
|
C$ call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
C$ & ,nwdsout,ierr)
|
|
C$ cmsgout(4)='d3_nen_cmo'
|
|
C$ call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
C$ & ,nwdsout,ierr)
|
|
C$ cmsgout(4)='d3_nef_cmo'
|
|
C$ call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
C$ & ,nwdsout,ierr)
|
|
C$ cmsgout(4)='d3_nee_cmo'
|
|
C$ call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
C$ & ,nwdsout,ierr)
|
|
|
|
100 cmsgout(4)='d0_nclrs'
|
|
call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
cmsgout(4)='d0_clrlen'
|
|
call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
cmsgout(4)='d0_nfilters'
|
|
call cmo_delatt_all_lg(imsgout,xmsgout,cmsgout,tmsgout
|
|
& ,nwdsout,ierr)
|
|
|
|
c .................................................................
|
|
|
|
c........ (successful return) ..................
|
|
|
|
1000 ierror=0
|
|
if (local_debug.gt.0) call mmverify()
|
|
return
|
|
|
|
c........ (failure return) ..................
|
|
9999 ierror=1
|
|
if (local_debug.gt.0) call mmverify()
|
|
cbuf=' LOWER D ERROR'
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
return
|
|
c .....................................................
|
|
end
|
|
|
|
c-----------------------------------------------------------------------
|
|
C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|
|
|
c-----------------------------------------------------------------------
|
|
C #####################################################################
|
|
C sizes_lower_d_lg
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C figure out how much storage we need to reserve
|
|
C for the lower d strucutures.
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C max_topo,d0_topo
|
|
C nnodes,nelements,d0_nef_cmo,mbndry,nconbnd
|
|
C itettyp,itetclr,itet,itetoff,jtet,jtetoff
|
|
C itp1,icr1,icontab,isn1,iparent
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C d1_nnodes,d1_nelements
|
|
C d1_nef_cmo,d1_nee_cmo,d1_nen_cmo
|
|
C d0_node_topo,d0_elm_d1
|
|
C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
|
|
C
|
|
C USAGE NOTES / CAVEATS / CHANGES -
|
|
C
|
|
C it is probably not advisable to call this routine outside this
|
|
C lower_d command suite.
|
|
C
|
|
C see notes for create_lower_d_lg for interior_icr_flag
|
|
C
|
|
|
|
C less clear notes to myself for code development .......................
|
|
|
|
c if d0_topo=1, don't create element array
|
|
c d0 refers to input mesh, d1 refers to 1 dimension lower (output) mesh
|
|
|
|
C #####################################################################
|
|
|
|
subroutine sizes_lower_d_lg(max_topo,d0_topo
|
|
& ,nnodes,nelements,d0_nef_cmo,mbndry,nconbnd
|
|
& ,jtet_cycle_max,interior_icr_flag,ibtype,geom_name
|
|
& ,itettyp,itetclr,itet,itetoff,jtet,jtetoff
|
|
& ,itp1,icr1,icontab,isn1,iparent
|
|
& ,d1_nnodes,d1_nelements
|
|
& ,d1_nef_cmo,d1_nee_cmo,d1_nen_cmo
|
|
& ,d0_node_topo,d0_elm_d1
|
|
& ,ierror)
|
|
c ........................................................................
|
|
|
|
implicit none
|
|
|
|
include 'local_element.h'
|
|
include 'chydro.h'
|
|
|
|
! passed variables
|
|
|
|
integer max_topo ! topological dimension of the highest mesh
|
|
& ,d0_topo ! topological dimension of the input
|
|
& ,nnodes ! standard lagrit scalars for d0 mesh
|
|
& ,nelements
|
|
& ,d0_nef_cmo ! (=faces_per_element)
|
|
& ,mbndry
|
|
& ,nconbnd
|
|
& ,jtet_cycle_max ! longest jtet cycle length
|
|
& ,interior_icr_flag ! flag as to whether constraints exist in the interior
|
|
|
|
character*(*) ibtype(*),geom_name ! need re testing if virtual constraint
|
|
|
|
integer itettyp(*) ! standard lagrit arrays for d0 mesh
|
|
& ,itetclr(*)
|
|
& ,itet(*)
|
|
& ,itetoff(*)
|
|
& ,jtet(*)
|
|
& ,jtetoff(*)
|
|
& ,itp1(*)
|
|
& ,icr1(*)
|
|
& ,icontab(50,*)
|
|
& ,isn1(*)
|
|
& ,iparent(*)
|
|
|
|
integer d1_nnodes ! lagrit scalars for lower d output
|
|
& ,d1_nelements
|
|
& ,d1_nef_cmo ! (=faces per element)
|
|
& ,d1_nee_cmo ! (=edges per element)
|
|
& ,d1_nen_cmo ! (=nodes per element)
|
|
|
|
integer d0_node_topo(*) ! max lower d in which node participates
|
|
& ,d0_elm_d1(*) ! element translation from input to lower d
|
|
|
|
integer ierror ! error flag: 0 on return if successful
|
|
|
|
! local variables
|
|
|
|
integer i,j,ityp,jtyp,ind,nnd,nef,ioff,joff,iuse
|
|
& ,iel,jel,kel,iface,jface,kface,it,jt
|
|
& ,local_debug,ierr,iclr,jclr,kclr,d1_topo
|
|
& ,d1_nef_min,d1_nee_min,d1_nen_min
|
|
& ,isurf,n_surf,icon,ncon,mincon
|
|
& ,loc_icr(maxnee1),icycle,examine
|
|
|
|
character*132 cbuf
|
|
|
|
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
|
|
|
local_debug=0
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'in sizes_lower_d_lg'
|
|
call mmverify()
|
|
write(*,*) 'fix for mixed-d meshes: no ifelmpnts...'
|
|
endif
|
|
|
|
c........ (find one dimension lower lengths) ..................
|
|
c and create translation from current topological dimension
|
|
c to one-dimension lower, ie, find:
|
|
c d1_nnodes : nnodes
|
|
c d1_nelements : nelements
|
|
c d1_nef_cmo : faces_per_element
|
|
c d1_nee_cmo : edges_per_element
|
|
c d1_nen_cmo : nodes_per_element
|
|
c d0_node_topo : max lower d in which node participates
|
|
c will have values from previous calls if max_topo.ne.d0_topo
|
|
c d0_elm_d1 : element of current d to element of lower d translation -
|
|
c
|
|
c on output:
|
|
c d0_node_topo >0 for the parent nodes which have lower-d "child" nodes
|
|
c <0 for the d0 children of d0 parent nodes with d1 "children"
|
|
c =0 for all other nodes
|
|
c d0_elm_d1 >0 for the "parent" faces of lower-d elements
|
|
c (the "parent" faces are in the element with the lowest itetclr)
|
|
c <0 for other faces which touch lower-d elements
|
|
c =0 for all other faces
|
|
c
|
|
c if d0_topo=1, then don't create element arrays
|
|
c if d0_topo=0, then don't do anything
|
|
c
|
|
c Note:
|
|
c The parent choice is meant to give consistently oriented surfaces.
|
|
c However, note for virtual surfaces (or any other case
|
|
c where itetclr is not a unique direction indicator),
|
|
c the surfaces will not be consistently oriented
|
|
c simply from the parent choice, and should be re-oriented
|
|
c once jtet on the lower d surface is known
|
|
c
|
|
c As may be coming from lower-d, jtet is a linked list
|
|
c pointing to all element faces of the d0 mesh which have
|
|
c the given face in common.
|
|
c It is assumed that only a single face of a given element
|
|
c occurs in any jtet loop (no 'folded' elements), and that
|
|
c each face occurs in at most one jtet loop.
|
|
c Note also that the standard jtet also has this definition,
|
|
c except that the maximim loop length is two.
|
|
c This is similar to the standard isn1 for parent/child nodes,
|
|
c except there is no "parent": the smallest element number
|
|
c could be used as a marker if a marker was desired.
|
|
c..........................
|
|
|
|
d1_nef_cmo=0
|
|
d1_nen_cmo=0
|
|
d1_nee_cmo=0
|
|
d1_nef_min=maxnef
|
|
d1_nen_min=maxnen
|
|
d1_nee_min=maxnee2
|
|
d1_nnodes=0
|
|
d1_nelements=0
|
|
d1_nnodes=0
|
|
|
|
! if d0_topo=max_topo, zero d0_node_topo to indicate node belongs
|
|
! to default highest dimension class (eg, interior nodes of original mesh)
|
|
if (d0_topo.eq.max_topo) then
|
|
do i=1,nnodes
|
|
d0_node_topo(i)=0
|
|
enddo
|
|
endif
|
|
|
|
! return if nothing to do
|
|
if (d0_topo.lt.1.or.nnodes.lt.1.or.nelements.lt.1) goto 1000
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'at test 1 in sizes_lower_d_lg'
|
|
call mmverify()
|
|
endif
|
|
|
|
! set "examine" greater than largest possible d1_nelements,d1_nnodes
|
|
examine=abs(nelements*d0_nef_cmo)+10
|
|
if (examine.lt.nnodes+10) examine=nnodes+10
|
|
|
|
! first set d0_elm_d1=examine to mark for examination
|
|
if (d0_topo.gt.1) then
|
|
do iel=1,nelements
|
|
ioff=jtetoff(iel)
|
|
do iface=1,nelmnef(itettyp(iel))
|
|
d0_elm_d1(ioff+iface)=examine
|
|
enddo
|
|
enddo
|
|
endif
|
|
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'at test 2 in sizes_lower_d_lg'
|
|
call mmverify()
|
|
endif
|
|
|
|
! now mark interface nodes and faces.
|
|
|
|
! mark interface nodes only for case d0_topo=1.
|
|
if (d0_topo.eq.1) then
|
|
do iel=1,nelements
|
|
ioff=itetoff(iel)
|
|
joff=jtetoff(iel)
|
|
ityp=itettyp(iel)
|
|
iclr=itetclr(iel)
|
|
nef=nelmnef(ityp)
|
|
!! mark all nodes on interface faces
|
|
do iface=1,nef
|
|
it=jtet(joff+iface)
|
|
if ((it.le.0.and.mbndry.eq.0)
|
|
& .or.(it.ge.mbndry.and.mbndry.gt.0)) then
|
|
jtyp=ielmface3(iface,ityp)
|
|
nnd=nelmnen(jtyp)
|
|
do ind=1,nnd
|
|
j=ielmface1(ind,iface,ityp)
|
|
j=iparent(itet(ioff+j))
|
|
d0_node_topo(j)=examine
|
|
enddo
|
|
endif
|
|
enddo
|
|
!! mark all virtual nodes if d0_topo=max_topo
|
|
!! (note vrt are own parent)
|
|
if (d0_topo.eq.max_topo) then
|
|
do ind=1,nelmnen(ityp)
|
|
j=itet(ioff+ind)
|
|
if (itp1(j).eq.ifitpvrt) d0_node_topo(j)=examine
|
|
enddo
|
|
endif
|
|
enddo
|
|
goto 600
|
|
endif
|
|
|
|
! mark interface nodes and faces for case d0_topo>1.
|
|
|
|
do iel=1,nelements
|
|
ioff=jtetoff(iel)
|
|
ityp=itettyp(iel)
|
|
iclr=itetclr(iel)
|
|
nef=nelmnef(ityp)
|
|
do iface=1,nef
|
|
!! skip if already examined
|
|
if (d0_elm_d1(ioff+iface).ne.examine) goto 500
|
|
!! check if real or virtual interface face
|
|
it=jtet(ioff+iface)
|
|
iuse=0
|
|
if ((it.ge.mbndry.and.mbndry.gt.0)
|
|
& .or.(it.le.0.and.mbndry.eq.0)) then
|
|
!! exterior or interface face -> use
|
|
iuse=1
|
|
it=abs(it)-mbndry
|
|
elseif (d0_topo.eq.max_topo) then
|
|
!! for top dimension, check if all nodes virtual
|
|
!! and part of same (virtual) constraint surface. Use only if so.
|
|
jel=1+(it-1)/d0_nef_cmo
|
|
jface=it-(jel-1)*d0_nef_cmo
|
|
! only 2 elements border as otherwise jtet>mbndry
|
|
if ( 1+(jtet(jtetoff(jel)+jface)-1)/d0_nef_cmo
|
|
& .ne. iel) goto 9999
|
|
! check if all virtual pts
|
|
joff=itetoff(iel)
|
|
nnd=nelmnen(ielmface3(iface,ityp))
|
|
iuse=0
|
|
do ind=1,nnd
|
|
j=ielmface1(ind,iface,ityp)
|
|
j=itet(joff+j) ! NOT parent as need itp
|
|
if (itp1(j).eq.ifitpcup) j=isn1(j)
|
|
i=itp1(j)
|
|
loc_icr(ind)=icr1(j)
|
|
if (loc_icr(ind).ne.0 .and.
|
|
& (i.eq.ifitpvrt.or.i.eq.ifitpalb
|
|
& .or.i.eq.ifitpvin.or.i.eq.ifitpvif
|
|
& .or.i.eq.ifitpvrb.or.i.eq.ifitpvfb
|
|
& .or.i.eq.ifitpvrf.or.i.eq.ifitpvir)) iuse=iuse+1
|
|
enddo
|
|
if (iuse.ne.nnd
|
|
& .or.interior_icr_flag.eq.1
|
|
& .or.interior_icr_flag.eq.3
|
|
& .or.interior_icr_flag.eq.5
|
|
& .or.interior_icr_flag.eq.7) then
|
|
iuse=0
|
|
elseif (nconbnd.gt.0.and.nnd.gt.1) then
|
|
! find if share non-zero constraint
|
|
! (must be more than 1 ind or would not be here)
|
|
mincon=loc_icr(1)
|
|
ncon=icontab(1,mincon)
|
|
do ind=2,nnd
|
|
icon=icontab(1,loc_icr(ind))
|
|
if (icon.lt.ncon) then
|
|
mincon=loc_icr(ind)
|
|
ncon=icon
|
|
endif
|
|
enddo
|
|
n_surf=0
|
|
do icon=1,ncon
|
|
isurf=icontab(2+icon,mincon)
|
|
! test isurf is vrt
|
|
if (geom_name.ne.'-none-') then
|
|
if (ibtype(isurf)(1:7).ne.'virtual') goto 711
|
|
endif
|
|
do ind=1,nnd
|
|
if (loc_icr(ind).eq.mincon) goto 710
|
|
do i=1,icontab(1,loc_icr(ind))
|
|
if (icontab(2+i,loc_icr(ind)).eq.isurf)
|
|
& goto 710
|
|
enddo
|
|
goto 711
|
|
710 continue
|
|
enddo
|
|
n_surf=n_surf+1
|
|
711 continue
|
|
enddo
|
|
if (n_surf.eq.0) then
|
|
iuse=0
|
|
else
|
|
iuse=1
|
|
endif
|
|
else
|
|
! assume lowest icr1 is constraint of surface
|
|
iuse=1
|
|
endif
|
|
else
|
|
!! interior face in lower d -> don't use
|
|
iuse=0
|
|
jel=1+(it-1)/d0_nef_cmo
|
|
jface=it-(jel-1)*d0_nef_cmo
|
|
endif
|
|
if (iuse.eq.0) then
|
|
!! set d0_elm_d1 to indicate no d1 element for these faces
|
|
! must be case it<mbndry above
|
|
! -> exactly 1 opposite face and jel,jface calc'd above
|
|
d0_elm_d1(ioff+iface)=0
|
|
d0_elm_d1(jtetoff(jel)+jface)=0
|
|
else
|
|
!! set d0_elm_d1 to indicate these faces are a d1 element
|
|
!! and mark d0_node_topo
|
|
! first find "parent" face (smallest element # in lowest color)
|
|
! this will help to "order" the surface consistently
|
|
! (will need to re-check once jtet known if really want ordered)
|
|
kel=iel
|
|
kface=iface
|
|
kclr=iclr
|
|
jt=it
|
|
jel=1+(it-1)/d0_nef_cmo
|
|
jface=jt-(jel-1)*d0_nef_cmo
|
|
icycle=0
|
|
do while ( jt.gt.0
|
|
& .and. (jel.ne.iel.or.jface.ne.iface)
|
|
& .and. icycle.le.jtet_cycle_max )
|
|
icycle=icycle+1
|
|
jclr=itetclr(jel)
|
|
if (kclr.gt.jclr .or.
|
|
& (kclr.eq.jclr.and.jel.lt.kel) ) then
|
|
kclr=jclr
|
|
kel=jel
|
|
kface=jface
|
|
endif
|
|
joff=jtetoff(jel)
|
|
jt=abs(jtet(joff+jface))
|
|
if (jt.ge.mbndry) jt=jt-mbndry
|
|
jel=1+(jt-1)/d0_nef_cmo
|
|
jface=jt-(jel-1)*d0_nef_cmo
|
|
enddo
|
|
d1_nelements=d1_nelements+1
|
|
d0_elm_d1(ioff+iface)=d1_nelements
|
|
jtyp=ielmface3(iface,ityp)
|
|
if (d1_nef_cmo.lt.nelmnef(jtyp))
|
|
& d1_nef_cmo = nelmnef(jtyp)
|
|
if (d1_nee_cmo.lt.nelmnee(jtyp))
|
|
& d1_nee_cmo = nelmnee(jtyp)
|
|
if (d1_nen_cmo.lt.nelmnen(jtyp))
|
|
& d1_nen_cmo = nelmnen(jtyp)
|
|
if (d1_nef_min.gt.nelmnef(jtyp))
|
|
& d1_nef_min = nelmnef(jtyp)
|
|
if (d1_nee_min.gt.nelmnee(jtyp))
|
|
& d1_nee_min = nelmnee(jtyp)
|
|
if (d1_nen_min.gt.nelmnen(jtyp))
|
|
& d1_nen_min = nelmnen(jtyp)
|
|
jt=jtetoff(kel)+kface
|
|
d0_elm_d1(jt)=d1_nelements
|
|
jt=abs(jtet(jt))
|
|
if (jt.ge.mbndry) jt=jt-mbndry
|
|
jel=1+(jt-1)/d0_nef_cmo
|
|
jface=jt-(jel-1)*d0_nef_cmo
|
|
icycle=0
|
|
do while ( jt.gt.0
|
|
& .and. (jel.ne.kel .or. jface.ne.kface)
|
|
& .and. icycle.le.jtet_cycle_max )
|
|
icycle=icycle+1
|
|
jclr=itetclr(jel)
|
|
joff=jtetoff(jel)+jface
|
|
d0_elm_d1(joff)=-d1_nelements
|
|
jt=abs(jtet(joff))
|
|
if (jt.ge.mbndry) jt=jt-mbndry
|
|
jel=1+(jt-1)/d0_nef_cmo
|
|
jface=jt-(jel-1)*d0_nef_cmo
|
|
enddo
|
|
jtyp=ielmface3(iface,ityp)
|
|
nnd=nelmnen(jtyp)
|
|
do ind=1,nnd
|
|
j=ielmface1(ind,iface,ityp)
|
|
j=iparent(itet(itetoff(iel)+j))
|
|
d0_node_topo(j)=examine
|
|
enddo
|
|
! ioffsum=ioffsum+nnd
|
|
! joffsum=joffsum+nelmnef(jtyp)
|
|
endif
|
|
500 continue
|
|
enddo
|
|
enddo
|
|
|
|
600 if (local_debug.gt.0) then
|
|
write(*,*) 'at test 3 in sizes_lower_d_lg'
|
|
call mmverify()
|
|
endif
|
|
|
|
d1_topo=max_topo-d0_topo+1
|
|
do i=1,nnodes
|
|
if (d0_node_topo(i).eq.examine) then
|
|
d1_nnodes=d1_nnodes+1
|
|
d0_node_topo(i)=d1_topo ! d1_nnodes
|
|
j=isn1(i)
|
|
do while (j.ne.i.and.j.ne.0)
|
|
d0_node_topo(j)=-d1_topo ! -d1_nnodes
|
|
j=isn1(j)
|
|
enddo
|
|
endif
|
|
enddo
|
|
|
|
if (d1_nef_min.ne.d1_nef_cmo.or.d1_nee_min.ne.d1_nee_cmo
|
|
& .or.d1_nen_min.ne.d1_nen_cmo) then
|
|
d1_nef_cmo=nelmnef(ifelmhyb)
|
|
d1_nee_cmo=nelmnee(ifelmhyb)
|
|
d1_nen_cmo=nelmnen(ifelmhyb)
|
|
endif
|
|
|
|
c........ (successful return) ..................
|
|
|
|
1000 ierror=0
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'returning from sizes_lower_d_lg succesfully'
|
|
call mmverify()
|
|
endif
|
|
return
|
|
|
|
c........ (failure return) ..................
|
|
9999 ierror=1
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'returning from sizes_lower_d_lg unsuccesfully'
|
|
call mmverify()
|
|
stop
|
|
endif
|
|
cbuf='ERROR IN ROUTINE lower_d_sizes: ABORTING'
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
return
|
|
c .....................................................
|
|
end
|
|
|
|
c-----------------------------------------------------------------------
|
|
C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|
|
|
c-----------------------------------------------------------------------
|
|
C #####################################################################
|
|
C storage_lower_d_lg
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C create the needed lower d attribute storage.
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C cmo - the mesh object of interest
|
|
C new_storage - flag to delete old before reserving new (or not)
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
|
|
C
|
|
C USAGE NOTES / CAVEATS / CHANGES -
|
|
C
|
|
C it is probably not advisable to call this routine outside this
|
|
C lower_d command suite.
|
|
C
|
|
C set default d0,d1,d2,d3 nelements,nnodes,nef_cmo,nen_cmo,nee_cmo to 0
|
|
C and lower_d_flag to 1
|
|
C
|
|
C it is assumed that is the attribute exists, the length,type,etc are correct
|
|
C -- could add test and fix as needed ...
|
|
C
|
|
C less clear notes to myself for code development .......................
|
|
|
|
c !NO! release any pre-existing blocks/attributes/meshes as needed
|
|
|
|
C #####################################################################
|
|
|
|
subroutine storage_lower_d_lg(cmo,new_storage,ierror)
|
|
c ........................................................................
|
|
|
|
implicit none
|
|
|
|
include 'local_element.h'
|
|
|
|
character*(*) cmo
|
|
integer ierror,new_storage
|
|
|
|
integer d0_topo
|
|
|
|
integer local_debug,lower_d_flag,len,ityp,ierr,ip,lcmo
|
|
|
|
character*132 cbuf
|
|
character*32 cmsgout(11)
|
|
real*8 xmsgout(11)
|
|
integer imsgout(11),nwdsout,tmsgout(11)
|
|
|
|
integer icharlnf
|
|
external icharlnf
|
|
|
|
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
|
|
|
local_debug=0
|
|
if (local_debug.gt.0) then
|
|
write(*,*) 'fix interp...'
|
|
call mmverify()
|
|
endif
|
|
|
|
nwdsout=11
|
|
do ip=1,11
|
|
xmsgout(ip)=0.d0
|
|
imsgout(ip)=0
|
|
tmsgout(ip)=3
|
|
cmsgout(ip)=' '
|
|
enddo
|
|
tmsgout(11)=1
|
|
cmsgout(1)='cmo'
|
|
cmsgout(2)='addatt'
|
|
cmsgout(3)=cmo
|
|
if (cmo(1:1).eq.'-') then
|
|
call cmo_get_name(cmsgout(3),ierr)
|
|
endif
|
|
cmsgout(9)='temporary'
|
|
cmsgout(10)='x'
|
|
cmsgout(11)=' '
|
|
|
|
c........ (make sure cmo exists) ..................
|
|
|
|
lcmo=icharlnf(cmo)
|
|
call cmo_exist(cmo(1:lcmo),ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
c........ (release old storage if any) ..................
|
|
|
|
! no: presume OK ...., hence should add "cmo_get_info" checks
|
|
! call release_lower_d_lg(cmo(1:lcmo),ierr)
|
|
! if (ierr.ne.0) goto 9999
|
|
|
|
c........ (get d0 info: abort if not legal) ..................
|
|
c abort only on d0_topo and not sizes as might want to call this
|
|
c before nnodes,nelements have a value since it is only allocation...
|
|
|
|
call cmo_get_info('ndimensions_topo',cmo,d0_topo
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
if (d0_topo.lt.1) goto 1000
|
|
call cmo_get_info('nnodes',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
call cmo_get_info('nelements',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
! d0_topo>3: not enough structures built ..., for now, press on ...
|
|
! if (d0_topo.gt.3) goto 9999
|
|
|
|
c........ (assign defaults) ..................
|
|
|
|
c .................................................................
|
|
c *-*-*-*-*-* (create lower d attributes) *-*-*-*-*-*-*-*
|
|
|
|
c new attributes -- Q:
|
|
c - ioflag: x vs agx ???
|
|
c - persistence: temporary vs permanent ???
|
|
c - deleting if exists vs checking fields vs assuming OK??
|
|
c for now: just delete so "clean"....
|
|
|
|
c ==== create d0 storage ====
|
|
|
|
cmsgout(5)='INT'
|
|
cmsgout(6)='scalar'
|
|
cmsgout(7)='scalar'
|
|
cmsgout(8)='constant'
|
|
|
|
c... flag d0 attributes
|
|
c lower_d_flag ...............
|
|
call cmo_get_info('lower_d_flag',cmo,lower_d_flag
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/lower_d_flag'
|
|
C$ & //'/INT/scalar/scalar/constant/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='lower_d_flag'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
len=1
|
|
ityp=1
|
|
lower_d_flag=2
|
|
call cmo_set_info('lower_d_flag',cmo,lower_d_flag
|
|
& ,len,ityp,ierr)
|
|
|
|
c... filter d0 attributes
|
|
|
|
c d0_nfilters ...............
|
|
call cmo_get_info('d0_nfilters',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
cmsgout(4)='d0_nfilters'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
if (new_storage.ne.0) then
|
|
len=1
|
|
ityp=1
|
|
ip=0
|
|
call cmo_set_info('d0_nfilters',cmo,ip,len,ityp,ierr)
|
|
endif
|
|
|
|
c d0_filters ...............
|
|
call cmo_get_info('d0_filters',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
cmsgout(4)='d0_filters'
|
|
cmsgout(5)='VINT'
|
|
cmsgout(7)='d0_nfilters'
|
|
cmsgout(8)='user'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
|
|
c... color d0 attributes
|
|
cmsgout(5)='INT'
|
|
cmsgout(6)='scalar'
|
|
cmsgout(7)='scalar'
|
|
cmsgout(8)='constant'
|
|
c d0_nclrs ...............
|
|
call cmo_get_info('d0_nclrs',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d0_nclrs'
|
|
C$ & //'/INT/scalar/scalar/constant/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d0_nclrs'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
if (new_storage.eq.1) then
|
|
len=1
|
|
ityp=1
|
|
ip=0
|
|
call cmo_set_info('d0_nclrs',cmo,ip,len,ityp,ierr)
|
|
endif
|
|
c d0_clrlen ...............
|
|
call cmo_get_info('d0_clrlen',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d0_clrlen'
|
|
C$ & //'/INT/scalar/scalar/constant/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d0_clrlen'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
if (new_storage.eq.1) then
|
|
len=1
|
|
ityp=1
|
|
ip=0
|
|
call cmo_set_info('d0_clrlen',cmo,ip,len,ityp,ierr)
|
|
endif
|
|
|
|
cmsgout(5)='VINT'
|
|
cmsgout(8)='user'
|
|
c d0_clroff ...............
|
|
call cmo_get_info('d0_clroff',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d0_clroff'
|
|
C$ & //'/VINT/scalar/d0_nclrs/user/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d0_clroff'
|
|
cmsgout(7)='d0_nclrs'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
c d0_clrtab ...............
|
|
call cmo_get_info('d0_clrtab',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d0_clrtab'
|
|
C$ & //'/VINT/scalar/d0_clrlen/user/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d0_clrtab'
|
|
cmsgout(7)='d0_clrlen'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
|
|
c... node d0 attributes
|
|
c d0_node_topo ...............
|
|
call cmo_get_info('d0_node_topo',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d0_node_topo'
|
|
C$ & //'/VINT/scalar/nnodes/max/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d0_node_topo'
|
|
cmsgout(7)='nnodes'
|
|
cmsgout(8)='max'
|
|
cmsgout(10)='agx'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
cmsgout(10)='x'
|
|
endif
|
|
|
|
c... element d0 attributes
|
|
c don't create as default....
|
|
|
|
c ==== create d1 storage ====
|
|
|
|
cmsgout(5)='INT'
|
|
cmsgout(6)='scalar'
|
|
cmsgout(7)='scalar'
|
|
cmsgout(8)='constant'
|
|
|
|
c... size d1 attributes
|
|
c d1_nnodes ...............
|
|
call cmo_get_info('d1_nnodes',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d1_nnodes'
|
|
C$ & //'/INT/scalar/scalar/constant/temporary/x/0; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d1_nnodes'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
|
|
c... check if need d1 element info
|
|
if (d0_topo.eq.1) goto 1000
|
|
|
|
c d1_nelements ...............
|
|
call cmo_get_info('d1_nelements',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d1_nelements'
|
|
C$ & //'/INT/scalar/scalar/constant/temporary/x/0; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d1_nelements'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
c d1_nef_cmo ...............
|
|
call cmo_get_info('d1_nef_cmo',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d1_nef_cmo'
|
|
C$ & //'/INT/scalar/scalar/constant/temporary/x/0; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d1_nef_cmo'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
c d1_nee_cmo ...............
|
|
call cmo_get_info('d1_nee_cmo',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d1_nee_cmo'
|
|
C$ & //'/INT/scalar/scalar/constant/temporary/x/0; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d1_nee_cmo'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
c d1_nen_cmo ...............
|
|
call cmo_get_info('d1_nen_cmo',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d1_nen_cmo'
|
|
C$ & //'/INT/scalar/scalar/constant/temporary/x/0; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d1_nen_cmo'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
c d1_jtet_cycle_max...............
|
|
call cmo_get_info('d1_jtet_cycle_max',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d1_jtet_cycle_max'
|
|
C$ & //'/INT/scalar/scalar/constant/temporary/x/0; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d1_jtet_cycle_max'
|
|
imsgout(11)=2
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
imsgout(11)=0
|
|
endif
|
|
|
|
c... element d1 attributes
|
|
|
|
cmsgout(5)='VINT'
|
|
cmsgout(6)='scalar'
|
|
cmsgout(7)='d1_nelements'
|
|
cmsgout(8)='user'
|
|
|
|
c d1_itettyp ...............
|
|
call cmo_get_info('d1_itettyp',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d1_itettyp'
|
|
C$ & //'/VINT/scalar/d1_nelements/user/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d1_itettyp'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
c d1_itetclr ...............
|
|
call cmo_get_info('d1_itetclr',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d1_itetclr'
|
|
C$ & //'/VINT/scalar/d1_nelements/user/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d1_itetclr'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
c d1_itetoff ...............
|
|
call cmo_get_info('d1_itetoff',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d1_itetoff'
|
|
C$ & //'/VINT/scalar/d1_nelements/user/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d1_itetoff'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
c d1_jtetoff ...............
|
|
call cmo_get_info('d1_jtetoff',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d1_jtetoff'
|
|
C$ & //'/VINT/scalar/d1_nelements/user/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d1_jtetoff'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
|
|
c d1_elm_d0 ...............
|
|
call cmo_get_info('d1_elm_d0',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d1_elm_d0'
|
|
C$ & //'/VINT/scalar/d1_nelements/user/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d1_elm_d0'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
|
|
c d1_itet ...............
|
|
call cmo_get_info('d1_itet',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d1_itet'
|
|
C$ & //'/VINT/d1_nen_cmo/d1_nelements'
|
|
C$ & //'/user/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d1_itet'
|
|
cmsgout(6)='d1_nen_cmo'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
c d1_jtet ...............
|
|
call cmo_get_info('d1_jtet',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d1_jtet'
|
|
C$ & //'/VINT/d1_nef_cmo/d1_nelements'
|
|
C$ & //'/user/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d1_jtet'
|
|
cmsgout(6)='d1_nef_cmo'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
|
|
c don't create as default:
|
|
c... node d1->d0 attributes
|
|
c... d0->d1 attributes
|
|
|
|
c ==== create d2 storage ====
|
|
|
|
c... check if need d2 info
|
|
if (d0_topo.lt.2) goto 1000
|
|
|
|
cmsgout(5)='INT'
|
|
cmsgout(6)='scalar'
|
|
cmsgout(7)='scalar'
|
|
cmsgout(8)='constant'
|
|
|
|
c... size d2 attributes
|
|
c d2_nnodes ...............
|
|
call cmo_get_info('d2_nnodes',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d2_nnodes'
|
|
C$ & //'/INT/scalar/scalar/constant/temporary/x/0; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d2_nnodes'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
|
|
c... check if need element info
|
|
if (d0_topo.eq.2) goto 1000
|
|
|
|
c d2_nelements ...............
|
|
call cmo_get_info('d2_nelements',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d2_nelements'
|
|
C$ & //'/INT/scalar/scalar/constant/temporary/x/0; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d2_nelements'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
c d2_nef_cmo ...............
|
|
call cmo_get_info('d2_nef_cmo',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d2_nef_cmo'
|
|
C$ & //'/INT/scalar/scalar/constant/temporary/x/0; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d2_nef_cmo'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
c d2_nee_cmo ...............
|
|
call cmo_get_info('d2_nee_cmo',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d2_nee_cmo'
|
|
C$ & //'/INT/scalar/scalar/constant/temporary/x/0; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d2_nee_cmo'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
c d2_nen_cmo ...............
|
|
call cmo_get_info('d2_nen_cmo',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d2_nen_cmo'
|
|
C$ & //'/INT/scalar/scalar/constant/temporary/x/0; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d2_nen_cmo'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
c d2_jtet_cycle_max...............
|
|
call cmo_get_info('d2_jtet_cycle_max',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d2_jtet_cycle_max'
|
|
C$ & //'/INT/scalar/scalar/constant/temporary/x/0; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d2_jtet_cycle_max'
|
|
imsgout(11)=2
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
imsgout(11)=0
|
|
endif
|
|
|
|
c... element d2 attributes
|
|
|
|
cmsgout(5)='VINT'
|
|
cmsgout(6)='scalar'
|
|
cmsgout(7)='d2_nelements'
|
|
cmsgout(8)='user'
|
|
|
|
c d2_itettyp ...............
|
|
call cmo_get_info('d2_itettyp',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d2_itettyp'
|
|
C$ & //'/VINT/scalar/d2_nelements/user/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d2_itettyp'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
c d2_itetclr ...............
|
|
call cmo_get_info('d2_itetclr',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d2_itetclr'
|
|
C$ & //'/VINT/scalar/d2_nelements/user/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d2_itetclr'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
c d2_itetoff ...............
|
|
call cmo_get_info('d2_itetoff',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d2_itetoff'
|
|
C$ & //'/VINT/scalar/d2_nelements/user/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d2_itetoff'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
c d2_jtetoff ...............
|
|
call cmo_get_info('d2_jtetoff',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d2_jtetoff'
|
|
C$ & //'/VINT/scalar/d2_nelements/user/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d2_jtetoff'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
|
|
c d2_elm_d1 ...............
|
|
call cmo_get_info('d2_elm_d1',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d2_elm_d1'
|
|
C$ & //'/VINT/scalar/d2_nelements/user/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d2_elm_d1'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
|
|
c d2_itet ...............
|
|
call cmo_get_info('d2_itet',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d2_itet'
|
|
C$ & //'/VINT/d2_nen_cmo/d2_nelements'
|
|
C$ & //'/user/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d2_itet'
|
|
cmsgout(6)='d2_nen_cmo'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
c d2_jtet ...............
|
|
call cmo_get_info('d2_jtet',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d2_jtet'
|
|
C$ & //'/VINT/d2_nef_cmo/d2_nelements'
|
|
C$ & //'/user/temporary/x/0/; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d2_jtet'
|
|
cmsgout(6)='d2_nef_cmo'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
|
|
c don't create as default:
|
|
c... node d2->d0 attributes
|
|
c... d0->d2 attributes
|
|
c... d1<->d2 attributes
|
|
|
|
c ==== create d3 storage ====
|
|
|
|
cmsgout(5)='INT'
|
|
cmsgout(6)='scalar'
|
|
cmsgout(7)='scalar'
|
|
cmsgout(8)='constant'
|
|
|
|
c... node size d3 attributes
|
|
c d3_nnodes ...............
|
|
call cmo_get_info('d3_nnodes',cmo,ip,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
C$ write(cbuf,*)'cmo/addatt/'//cmo(1:lcmo)//'/d3_nnodes'
|
|
C$ & //'/INT/scalar/scalar/constant/temporary/x/0; finish'
|
|
C$ call dotask(cbuf,ierr)
|
|
cmsgout(4)='d3_nnodes'
|
|
call cmo_addatt(imsgout,xmsgout,cmsgout,tmsgout,nwdsout,ierr)
|
|
endif
|
|
|
|
c no elements so don't create:
|
|
c... element size d3 attributes
|
|
c... element d3 attributes
|
|
c... element d3->d0 attributes
|
|
|
|
c... d0 attributes for d3 - don't create as default
|
|
c don't create as default:
|
|
c... node d3->d0 attributes
|
|
c... d0->d3 attributes
|
|
c... d2<->d3 attributes
|
|
c... d1<->d3 attributes
|
|
|
|
c........ (successful return) ..................
|
|
|
|
1000 ierror=0
|
|
if (local_debug.gt.0) then
|
|
cbuf='cmo status; finish'
|
|
call dotask(cbuf,ierr)
|
|
call mmverify()
|
|
endif
|
|
return
|
|
|
|
c........ (failure return) ..................
|
|
9999 ierror=1
|
|
if (local_debug.gt.0) call mmverify()
|
|
if (local_debug.gt.9) stop
|
|
cbuf=' LOWER D ERROR'
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
return
|
|
c .....................................................
|
|
end
|
|
|
|
c-----------------------------------------------------------------------
|
|
C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|
|
|
c-----------------------------------------------------------------------
|
|
C #####################################################################
|
|
C reset_mbndry_lower_d_lg
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C increment mbndry as needed so that it can be used for all
|
|
C topological hierarchies within this mesh object
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C cmo - mesh object of interest
|
|
C mbndry_new - new value of mbndry
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
|
|
C
|
|
C USAGE NOTES / CAVEATS / CHANGES -
|
|
C
|
|
C - should work even if lower_d_structures don't exist
|
|
C - if prior mbndry storage does not exist, then it is assumed to be zero
|
|
C - if prior mbndry storage does not exist and mbndry_new is not zero,
|
|
C currently returns error rather than creating mbndry storage
|
|
C
|
|
C #####################################################################
|
|
|
|
subroutine reset_mbndry_lower_d_lg(cmo,mbndry_new,ierror)
|
|
|
|
c ........................................................................
|
|
implicit none
|
|
include 'local_element.h'
|
|
character*(*) cmo
|
|
integer mbndry_old,mbndry_new,ierror
|
|
& ,sign_old,sign_new
|
|
|
|
pointer (ip_jtetoff,jtetoff),(ip_jtet,jtet)
|
|
& ,(ip_itettyp,itettyp)
|
|
integer jtetoff(*),jtet(*),itettyp(*)
|
|
integer iel,iface,ityp,ioff,len,ierr
|
|
& ,d0_nelements,d0_nef_cmo
|
|
& ,d1_nelements,d1_nef_cmo
|
|
& ,d2_nelements,d2_nef_cmo
|
|
character*132 cbuf
|
|
c -------------------------------------------------
|
|
|
|
! get current mbndry
|
|
call cmo_get_info('mbndry',cmo,mbndry_old
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) then
|
|
mbndry_old=0
|
|
if (mbndry_new.ne.0) then
|
|
! if cmo exists, then could create mbndry instead:
|
|
! for now, just report error
|
|
goto 9999
|
|
endif
|
|
endif
|
|
if (mbndry_old.eq.mbndry_new) goto 3000
|
|
|
|
! get size info
|
|
call cmo_get_info('nelements',cmo,d0_nelements
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
if (d0_nelements.le.0) d0_nelements=0
|
|
call cmo_get_info('faces_per_element',cmo
|
|
& ,d0_nef_cmo,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
if (d0_nef_cmo.le.0) d0_nef_cmo=0
|
|
call cmo_get_info('d1_nelements',cmo,d1_nelements
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d1_nelements.le.0) d1_nelements=0
|
|
call cmo_get_info('d1_nef_cmo',cmo,d1_nef_cmo,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d1_nef_cmo.le.0) d1_nef_cmo=0
|
|
call cmo_get_info('d2_nelements',cmo,d2_nelements
|
|
& ,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d2_nelements.le.0) d2_nelements=0
|
|
call cmo_get_info('d2_nef_cmo',cmo,d2_nef_cmo,len,ityp,ierr)
|
|
if (ierr.ne.0.or.d2_nef_cmo.le.0) d2_nef_cmo=0
|
|
|
|
! check sizes are legal
|
|
if (mbndry_old.ne.0) then
|
|
if (d0_nelements*d0_nef_cmo.ge.mbndry_old) goto 9999
|
|
if (d1_nelements*d1_nef_cmo.ge.mbndry_old) goto 9999
|
|
if (d2_nelements*d2_nef_cmo.ge.mbndry_old) goto 9999
|
|
sign_old=+1
|
|
else
|
|
sign_old=-1
|
|
endif
|
|
if (mbndry_new.ne.0) then
|
|
if (d0_nelements*d0_nef_cmo.ge.mbndry_new) goto 9999
|
|
if (d1_nelements*d1_nef_cmo.ge.mbndry_new) goto 9999
|
|
if (d2_nelements*d2_nef_cmo.ge.mbndry_new) goto 9999
|
|
sign_new=+1
|
|
else
|
|
sign_new=-1
|
|
endif
|
|
|
|
! reset mbndry
|
|
len=1
|
|
ityp=1
|
|
call cmo_set_info('mbndry',cmo,mbndry_new,len,ityp,ierr)
|
|
if (ierr.ne.0.and.mbndry_new.ne.0) goto 9999
|
|
|
|
if (d0_nelements.le.0 .or. d0_nef_cmo.le.0) goto 1000
|
|
|
|
! get info for d0
|
|
call cmo_get_info('itettyp',cmo,ip_itettyp,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9998
|
|
call cmo_get_info('jtetoff',cmo,ip_jtetoff,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9998
|
|
call cmo_get_info('jtet',cmo,ip_jtet,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9998
|
|
|
|
! reset jtet for d0
|
|
do iel=1,d0_nelements
|
|
ityp=itettyp(iel)
|
|
ioff=jtetoff(iel)
|
|
do iface=1,nelmnef(ityp)
|
|
if (sign_old*jtet(ioff+iface).ge.mbndry_old)
|
|
& jtet(ioff+iface) = mbndry_new + sign_new
|
|
& * (sign_old*jtet(ioff+iface) - mbndry_old)
|
|
enddo
|
|
enddo
|
|
|
|
|
|
1000 if (d1_nelements.le.0 .or. d1_nef_cmo.le.0) goto 2000
|
|
|
|
! get info for d1
|
|
call cmo_get_info('d1_itettyp',cmo,ip_itettyp,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9998
|
|
call cmo_get_info('d1_jtetoff',cmo,ip_jtetoff,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9998
|
|
call cmo_get_info('d1_jtet',cmo,ip_jtet,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9998
|
|
|
|
! reset jtet for d1
|
|
do iel=1,d1_nelements
|
|
ityp=itettyp(iel)
|
|
ioff=jtetoff(iel)
|
|
do iface=1,nelmnef(ityp)
|
|
if (sign_old*jtet(ioff+iface).ge.mbndry_old)
|
|
& jtet(ioff+iface) = mbndry_new + sign_new
|
|
& * (sign_old*jtet(ioff+iface) - mbndry_old)
|
|
enddo
|
|
enddo
|
|
|
|
2000 if (d2_nelements.le.0 .or. d2_nef_cmo.le.0) goto 3000
|
|
|
|
! get info for d2
|
|
call cmo_get_info('d2_itettyp',cmo,ip_itettyp,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9998
|
|
call cmo_get_info('d2_jtetoff',cmo,ip_jtetoff,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9998
|
|
call cmo_get_info('d2_jtet',cmo,ip_jtet,len,ityp,ierr)
|
|
if (ierr.ne.0) goto 9998
|
|
|
|
! reset jtet for d2
|
|
do iel=1,d2_nelements
|
|
ityp=itettyp(iel)
|
|
ioff=jtetoff(iel)
|
|
do iface=1,nelmnef(ityp)
|
|
if (sign_old*jtet(ioff+iface).ge.mbndry_old)
|
|
& jtet(ioff+iface) = mbndry_new + sign_new
|
|
& * (sign_old*jtet(ioff+iface) - mbndry_old)
|
|
enddo
|
|
enddo
|
|
|
|
3000 continue
|
|
|
|
ierror=0
|
|
return
|
|
|
|
9998 ierror=2
|
|
cbuf='WARNING: reset_mbndry_lower_d_lg - jtet may be incorrect'
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
return
|
|
|
|
9999 ierror=1
|
|
cbuf='ERROR: reset_mbndry_lower_d_lg - mbndry not reset'
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
return
|
|
|
|
end
|
|
|
|
C-----------------------------------------------------------------------
|
|
C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|
|
|
C-----------------------------------------------------------------------
|
|
C #####################################################################
|
|
C print_clrtab_lower_d_lg
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C print the color table used to decode the lower d itetclrs
|
|
C (currently only to screen)
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C d0_nclrs,d0_clroff,d0_clrtab
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
|
|
C
|
|
C USAGE NOTES / CAVEATS / CHANGES -
|
|
C
|
|
C should modify so that can print to file if desired
|
|
C (in which case, need "read_clrtab_lower_d_lg" also?)
|
|
C
|
|
C #####################################################################
|
|
|
|
subroutine print_clrtab_lower_d_lg(d0_nclrs,d0_clroff,d0_clrtab)
|
|
|
|
c ........................................................................
|
|
implicit none
|
|
integer d0_nclrs,d0_clroff(*),d0_clrtab(*)
|
|
integer iclr,ioff,itp,icr,nmat,imat,imat1,imat2,line,ierr
|
|
character*132 cbuf
|
|
|
|
line=8
|
|
write(cbuf,*) 'lower d color table, # colors=',d0_nclrs
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
if (d0_nclrs.gt.0) then
|
|
write(cbuf,'(a)')' iclr: itp, icr, (imt1(imat),imat=1,nmat)'
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
do iclr=1,d0_nclrs
|
|
ioff=d0_clroff(iclr)
|
|
itp=d0_clrtab(ioff+1)
|
|
icr=d0_clrtab(ioff+2)
|
|
nmat=d0_clrtab(ioff+3)
|
|
imat1=1
|
|
imat2=imat1+line-2
|
|
if (imat2.gt.nmat) imat2=nmat
|
|
write(cbuf,'(i7,a,2i4,a,7i8)') iclr,':',itp,icr,';'
|
|
& ,(d0_clrtab(ioff+3+imat),imat=imat1,imat2)
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
10 if (imat2.lt.nmat) then
|
|
imat1=imat2+1
|
|
imat2=imat1+line-1
|
|
if (imat2.gt.nmat) imat2=nmat
|
|
write(cbuf,'(9x,8i8)') (d0_clrtab(ioff+3+imat)
|
|
& ,imat=imat1,imat2)
|
|
call writloga('default',0,cbuf,0,ierr)
|
|
goto 10
|
|
endif
|
|
enddo
|
|
endif
|
|
|
|
return
|
|
end
|
|
C-----------------------------------------------------------------------
|
|
C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|
|
|
C-----------------------------------------------------------------------
|
|
C #####################################################################
|
|
C create_d2_elm_d0_lower_d_lg
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C create the "2-up" d2 element to d0 element,edge translation
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C d2_nelements,d1_nef_cmo,d0_nef_cmo
|
|
C d2_elm_d1,d1_elm_d0,d0_itettyp
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C d2_elm_d0
|
|
C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
|
|
C
|
|
C USAGE NOTES / CAVEATS / CHANGES -
|
|
C
|
|
C ignores negative d2_itetclr
|
|
C
|
|
C #####################################################################
|
|
|
|
subroutine create_d2_elm_d0_lower_d_lg(
|
|
& d2_nelements,d1_nef_cmo,d0_nef_cmo,d0_nee_cmo
|
|
& ,d2_elm_d1,d1_elm_d0,d0_itettyp
|
|
& ,d2_elm_d0
|
|
& ,ierror)
|
|
c ........................................................................
|
|
implicit none
|
|
include 'local_element.h'
|
|
|
|
integer d2_nelements,d1_nef_cmo,d0_nef_cmo,ierror
|
|
integer d2_elm_d1(*),d1_elm_d0(*),d0_itettyp(*)
|
|
& ,d2_elm_d0(*)
|
|
|
|
integer jel,iel,it,jface,iface,d0_nee_cmo
|
|
|
|
! element to edges translation
|
|
do jel=1,d2_nelements
|
|
it=d2_elm_d1(jel)
|
|
iel=1+(it-1)/d1_nef_cmo
|
|
jface=it-(iel-1)*d1_nef_cmo
|
|
it=d1_elm_d0(iel)
|
|
iel=1+(it-1)/d0_nef_cmo
|
|
iface=it-(iel-1)*d0_nef_cmo
|
|
d2_elm_d0(jel)=(iel-1)*d0_nee_cmo
|
|
& +ielmface2(jface,iface,d0_itettyp(iel))
|
|
enddo
|
|
|
|
ierror=0
|
|
return
|
|
end
|
|
|
|
C-----------------------------------------------------------------------
|
|
C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|
|
|
C-----------------------------------------------------------------------
|
|
C #####################################################################
|
|
C create_d0d1_node_lower_d_lg
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C create the lower d to higher d node translation tables
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C standard d0 mesh info:
|
|
C d0_nnodes,d1_nnodes,d0_node_topo,iparent,isn1
|
|
C d_lower - the relative lower dimension for which
|
|
C the translation is desired.
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C d0_node_d1,d1_node_d0 - the d0 node to lower d node translation tables.
|
|
C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
|
|
C
|
|
C USAGE NOTES / CAVEATS / CHANGES -
|
|
C
|
|
C For d0_node_d1, if it is zero, then there is no lower d child node,
|
|
C if it is >0, then it is the value of the lower d child node
|
|
C and if it is negative, then it's parent has the node as a lower d child.
|
|
C
|
|
C less clear notes to myself for code development .......................
|
|
|
|
c negative d0_node_topo: how to handle??
|
|
|
|
C #####################################################################
|
|
|
|
subroutine create_d0d1_node_lower_d_lg(
|
|
& d0_nnodes,d1_nnodes,d_lower
|
|
& ,d0_node_topo,iparent,isn1
|
|
& ,d0_node_d1,d1_node_d0
|
|
& ,ierror)
|
|
c ........................................................................
|
|
implicit none
|
|
integer d0_nnodes,d1_nnodes,d_lower,ierror
|
|
integer d0_node_topo(d0_nnodes)
|
|
& ,iparent(d0_nnodes),isn1(d0_nnodes)
|
|
& ,d0_node_d1(d0_nnodes),d1_node_d0(d1_nnodes)
|
|
|
|
integer i,j,nnd
|
|
|
|
do i=1,d1_nnodes
|
|
d1_node_d0(i)=0
|
|
enddo
|
|
|
|
nnd=0
|
|
do i=1,d0_nnodes
|
|
if (i.eq.iparent(i)) then
|
|
|
|
! which way ....
|
|
! if (abs(d0_node_topo(i)).eq.d_lower) then
|
|
if (d0_node_topo(i).eq.d_lower) then
|
|
|
|
nnd=nnd+1
|
|
d0_node_d1(i)=nnd
|
|
d1_node_d0(nnd)=i
|
|
|
|
! cycle around isn chain
|
|
j=isn1(i)
|
|
do while (j.ne.0.and.j.ne.i)
|
|
d0_node_d1(j)=-nnd
|
|
j=isn1(j)
|
|
enddo
|
|
|
|
else
|
|
|
|
d0_node_d1(i)=0
|
|
|
|
endif
|
|
|
|
endif
|
|
enddo
|
|
|
|
ierror=d1_nnodes-nnd
|
|
|
|
return
|
|
end
|
|
|
|
C-----------------------------------------------------------------------
|
|
C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|
|
|
C-----------------------------------------------------------------------
|
|
C #####################################################################
|
|
C create_d0_elm_d1_lower_d_lg
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C create the "1-down" version of the element translation table.
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C standard mesh info for the d0 dimension:
|
|
C d0_nelements,d0_nef_cmo,mbndry
|
|
C d0_itettyp,d0_jtetoff,d0_jtet
|
|
C standard mesh info for the d1 dimension:
|
|
C d1_nelements,d1_elm_d0
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C d0_elm_d1 - the d0 to d1 translation
|
|
C for faces with no d1 child, d0_elm_d1=0
|
|
C for parent faces of d1 child iel's, d0_elm_d1
|
|
C points to the element number in the d1 structure
|
|
C for non-parent faces with d1 child iel, -d0_elm_d1
|
|
C points to the element number in the d1 structure
|
|
C
|
|
C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
|
|
C
|
|
C USAGE NOTES / CAVEATS / CHANGES -
|
|
C
|
|
C if the "d0" input refers to the actual d1 structure and
|
|
C the "d1" inout refers to the actuak d2 structure, then
|
|
C this code acn be used to create the d1_elm_d2 translation.
|
|
C
|
|
C less clear notes to myself for code development .......................
|
|
|
|
c negative d1_itetclr: how to handle??
|
|
|
|
C #####################################################################
|
|
|
|
subroutine create_d0_elm_d1_lower_d_lg(
|
|
& d0_nelements,d1_nelements,d0_nef_cmo,mbndry
|
|
& ,d0_jtet_cycle_max
|
|
& ,d1_elm_d0,d0_itettyp,d0_jtetoff,d0_jtet
|
|
& ,d0_elm_d1
|
|
& ,ierror)
|
|
c ........................................................................
|
|
|
|
implicit none
|
|
include 'local_element.h'
|
|
|
|
integer d0_nelements,d1_nelements,d0_nef_cmo,mbndry,ierror
|
|
& ,d0_jtet_cycle_max
|
|
integer d0_elm_d1(*)
|
|
& ,d1_elm_d0(*),d0_itettyp(*),d0_jtetoff(*),d0_jtet(*)
|
|
|
|
integer iel,jel,kel,iface,it,ityp,ioff,kface,icycle
|
|
|
|
! element to faces translation
|
|
|
|
do iel=1,d0_nelements
|
|
ityp=d0_itettyp(iel)
|
|
ioff=d0_jtetoff(iel)
|
|
do iface=1,nelmnef(ityp)
|
|
d0_elm_d1(ioff+iface)=0
|
|
enddo
|
|
enddo
|
|
|
|
do jel=1,d1_nelements
|
|
|
|
! mark parent face
|
|
it=d1_elm_d0(jel)
|
|
iel=1+(it-1)/d0_nef_cmo
|
|
iface=it-(iel-1)*d0_nef_cmo
|
|
ioff=d0_jtetoff(iel)
|
|
d0_elm_d1(ioff+iface)=jel
|
|
|
|
! mark rest of jtet chain
|
|
it=abs(d0_jtet(ioff+iface))
|
|
if (mbndry.gt.0.and.it.ge.mbndry) it=it-mbndry
|
|
kel=1+(it-1)/d0_nef_cmo
|
|
iface=it-(kel-1)*d0_nef_cmo
|
|
kface=iface
|
|
icycle=0
|
|
do while ((kel.ne.iel.or.kface.ne.iface) .and. it.gt.0
|
|
& .and. icycle.le.d0_jtet_cycle_max)
|
|
icycle=icycle+1
|
|
ioff=d0_jtetoff(kel)
|
|
if (d0_elm_d1(ioff+iface).ne.0) goto 9999
|
|
d0_elm_d1(ioff+iface)=-jel
|
|
it=abs(d0_jtet(ioff+iface))
|
|
if (mbndry.gt.0.and.it.ge.mbndry) then
|
|
it=it-mbndry
|
|
endif
|
|
kel=1+(it-1)/d0_nef_cmo
|
|
iface=it-(kel-1)*d0_nef_cmo
|
|
enddo
|
|
|
|
enddo
|
|
|
|
ierror=0
|
|
return
|
|
|
|
9999 ierror=1
|
|
return
|
|
end
|
|
|
|
C-----------------------------------------------------------------------
|
|
C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|
|
|
C-----------------------------------------------------------------------
|
|
C #####################################################################
|
|
C create_d0_elm_d2_lower_d_lg
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C create the 2-down version of the element translation table.
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C standard mesh info for the d0 dimension:
|
|
C d0_nelements,d0_nee_cmo,d0_nef_cmo
|
|
C ,d0_itettyp,d0_jtetoff,d0_itetoff,d0_jtet
|
|
C standard mesh info for the d2 dimension:
|
|
C d2_nelements
|
|
C d2_elm_d0 - d2 to d0 translation
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C d0_elm_d2 - d0 to d2 translation
|
|
C for edges with no lower d child, d0_elm_d2=0
|
|
C for parent edge of lower d child iel, d0_elm_d2
|
|
C points to the element number in the d2 structure
|
|
C for non-parent edges with lower d child iel, -d0_elm_d2
|
|
C should points to the element number in the d2 structure
|
|
C but currently is is just 0
|
|
C
|
|
C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
|
|
C
|
|
C USAGE NOTES / CAVEATS / CHANGES -
|
|
C
|
|
C for now, only the parent edge is marked.
|
|
C I need to add code to cycle around and add the translation
|
|
C on the child nodes.
|
|
C
|
|
C less clear notes to myself for code development .......................
|
|
|
|
c negative d2_itetclr: how to handle??
|
|
c Note:
|
|
c in 3D: iedgeoff=itetoff+jtetoff-2*(iel-1)
|
|
c as in 3-d, nnodes+nface-2=nedges
|
|
c in 2D: iedgeoff=itetoff=jtetoff
|
|
c in 0D/1D: (no edges)
|
|
c dang: but what about mixed-d meshes? -> just use neecmo?, or d0_edgeoff?
|
|
c for now, just pack d0_elm_d2 using neecmo
|
|
|
|
c how about an edgetet,edgetetoff ??
|
|
c could create with current sub_geniee_cmo and using the effective itet
|
|
c of all the faces...
|
|
c better to do from known jtet re huge number of "elements"...
|
|
c would be convenient if needed, but more storage...
|
|
|
|
C #####################################################################
|
|
|
|
subroutine create_d0_elm_d2_lower_d_lg(
|
|
& d0_nelements,d2_nelements,d0_nee_cmo,d0_nef_cmo
|
|
& ,d2_elm_d0,d0_itettyp,d0_jtetoff,d0_itetoff,d0_jtet
|
|
& ,d0_elm_d2
|
|
& ,ierror)
|
|
|
|
c ........................................................................
|
|
|
|
implicit none
|
|
include 'local_element.h'
|
|
|
|
integer d0_nelements,d2_nelements
|
|
& ,d0_nee_cmo,d0_nef_cmo,ierror
|
|
integer d0_elm_d2(*),d0_itetoff(*)
|
|
& ,d2_elm_d0(*),d0_itettyp(*),d0_jtetoff(*),d0_jtet(*)
|
|
|
|
integer iel,jel,iedge,it,ityp,ioff
|
|
|
|
! element to edges translation
|
|
! only get here if d0=3d, d2=1d
|
|
! assume 3d parent is NOT network?
|
|
! or just create generalized "get elements around edge/node"...
|
|
|
|
do iel=1,d0_nelements
|
|
ityp=d0_itettyp(iel)
|
|
!no! ioff=d0_jtetoff(iel)+d0_itetoff(iel)-2*(iel-1)
|
|
ioff=(iel-1)*d0_nee_cmo
|
|
do iedge=1,nelmnef(ityp)
|
|
d0_elm_d2(ioff+iedge)=0
|
|
enddo
|
|
enddo
|
|
|
|
do jel=1,d2_nelements
|
|
|
|
! mark parent edge
|
|
it=d2_elm_d0(jel)
|
|
iel=1+(it-1)/d0_nee_cmo
|
|
iedge=it-(iel-1)*d0_nee_cmo
|
|
ioff=d0_jtetoff(iel)
|
|
d0_elm_d2(ioff+iedge)=jel
|
|
|
|
! mark rest of elements sharing this edge
|
|
! face with this edge -> ielmedge2
|
|
|
|
! iface=ielmedge2(1,iedge,iel)+d0_nef_cmo*(iel-1)
|
|
! (etc: copy from "get elements around...")
|
|
|
|
! heck: just don't mark them for now...
|
|
! and create this when I actually need it.
|
|
! stop 'not finished'
|
|
|
|
enddo
|
|
|
|
ierror=0
|
|
return
|
|
|
|
9999 ierror=1
|
|
return
|
|
end
|
|
|
|
C-----------------------------------------------------------------------
|
|
C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|
|
|
C-----------------------------------------------------------------------
|
|
C #####################################################################
|
|
C order_surface_lower_d_lg
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C find sign need to order elements within a given surface consistently
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C standard mesh info for the current topological class:
|
|
C nelements,nef_cmo,mbndry
|
|
C iparent,itettyp,itetoff,jtetoff,itet,jtet
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C order - +1 if orientation of the given element is correct,
|
|
C -1 if it should be flipped in order for the
|
|
C surface to be ordered consistently
|
|
C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
|
|
C
|
|
C USAGE NOTES / CAVEATS / CHANGES -
|
|
C
|
|
C less clear notes to myself for code development .......................
|
|
|
|
c oh dang: have to redo jtet as well as itet....
|
|
c which might affect other things don't know about here
|
|
c -> just return in "order" a +/-1 to indicate if flipped
|
|
c order=0 on return means that couldn't decide order
|
|
c as not allowed element typ (tri,qud,lin)
|
|
c The lowest element number in a given piece of surface determines
|
|
c the "positive" direction.
|
|
|
|
c for a 2d mobius strip this will result in a "boundary"
|
|
c between the two equivalent orientations, but otherwise
|
|
c it will be ordered.
|
|
|
|
C #####################################################################
|
|
|
|
subroutine order_surface_lower_d_lg(
|
|
& nelements,nef_cmo,mbndry
|
|
& ,iparent,itettyp,itetoff,jtetoff,itet,jtet
|
|
& ,order
|
|
& ,ierror)
|
|
|
|
c ........................................................................
|
|
implicit none
|
|
include 'local_element.h'
|
|
|
|
integer nelements,nef_cmo,mbndry,ierror
|
|
integer itettyp(*),itetoff(*),jtetoff(*),itet(*),jtet(*)
|
|
& ,iparent(*),order(*)
|
|
character*32 isubname
|
|
|
|
pointer (ip_isearch,isearch)
|
|
integer isearch(*)
|
|
|
|
integer jtyp,ktyp,iel,jel,kel,ioff,joff,jface,kface
|
|
& ,jt,ierr,nsearch,j,k
|
|
|
|
c -----------------------------------------------------
|
|
isubname="order_surface_lower_d_lg"
|
|
|
|
do iel=1,nelements
|
|
order(iel)=0
|
|
enddo
|
|
|
|
call mmggetbk('isearch',isubname,ip_isearch,nelements,1,ierr)
|
|
if (ierr.ne.0) goto 9999
|
|
|
|
do iel=1,nelements
|
|
jtyp=itettyp(iel)
|
|
if (order(iel).ne.0 .or.
|
|
& (jtyp.ne.ifelmlin.and.jtyp.ne.ifelmtri
|
|
& .and.jtyp.ne.ifelmqud ) ) goto 1000
|
|
nsearch=0
|
|
order(iel)=1
|
|
jel=iel
|
|
100 joff=jtetoff(jel)
|
|
ioff=itetoff(jel)
|
|
jtyp=itettyp(jel)
|
|
! order the neighbors, and add them to the search bin
|
|
do jface=1,nelmnef(jtyp)
|
|
jt=jtet(joff+jface)
|
|
if ((mbndry.gt.0.and.jt.lt.mbndry)
|
|
& .or.(mbndry.eq.0.and.jt.gt.0)) then
|
|
kel=1+(jt-1)/nef_cmo
|
|
kface=jt-(kel-1)*nef_cmo
|
|
ktyp=itettyp(kel)
|
|
if (order(kel).eq.0 .and. (jtyp.eq.ifelmlin
|
|
& .or.jtyp.eq.ifelmtri.or.jtyp.eq.ifelmqud)) then
|
|
nsearch=nsearch+1
|
|
isearch(nsearch)=kel
|
|
if (kel.eq.ifelmlin.and.jel.eq.ifelmlin) then
|
|
j=ielmface1(1,jface,jtyp)
|
|
k=ielmface1(1,kface,ktyp)
|
|
if (j.eq.k) then
|
|
order(kel)=-order(jel)
|
|
else
|
|
order(kel)=order(jel)
|
|
endif
|
|
elseif (jel.eq.ifelmlin.or.kel.eq.ifelmlin) then
|
|
! goto 9999 ! shouldn't have lines joining surfaces
|
|
! press on .... remove kel from current search list
|
|
nsearch=nsearch-1
|
|
else
|
|
j=ielmface1(1,jface,jtyp)
|
|
j=iparent(itet(ioff+j))
|
|
k=ielmface1(1,kface,ktyp)
|
|
k=iparent(itet(itetoff(kel)+k))
|
|
if (j.eq.k) then
|
|
order(kel)=-order(jel)
|
|
else
|
|
order(kel)=order(jel)
|
|
endif
|
|
endif
|
|
endif
|
|
endif
|
|
enddo
|
|
if (nsearch.gt.0) then
|
|
jel=isearch(nsearch)
|
|
nsearch=nsearch-1
|
|
goto 100
|
|
endif
|
|
1000 continue
|
|
enddo
|
|
|
|
c -----------------------------------------------------
|
|
9000 call mmrelblk('isearch',isubname,ip_isearch,ierr)
|
|
return
|
|
|
|
c -----------------------------------------------------
|
|
9999 call mmrelblk('isearch',isubname,ip_isearch,ierr)
|
|
ierror=1
|
|
write(*,*)
|
|
& 'add coding to order surfaces consistently'
|
|
return
|
|
end
|
|
|
|
C-----------------------------------------------------------------------
|
|
C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|C|
|
|
C-----------------------------------------------------------------------
|