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-----------------------------------------------------------------------