admordr.F

Go to the documentation of this file.

Copyright>        OpenRadioss
Copyright>        Copyright (C) 1986-2025 Altair Engineering Inc.
Copyright>
Copyright>        This program is free software: you can redistribute it and/or modify
Copyright>        it under the terms of the GNU Affero General Public License as published by
Copyright>        the Free Software Foundation, either version 3 of the License, or
Copyright>        (at your option) any later version.
Copyright>
Copyright>        This program is distributed in the hope that it will be useful,
Copyright>        but WITHOUT ANY WARRANTY; without even the implied warranty of
Copyright>        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Copyright>        GNU Affero General Public License for more details.
Copyright>
Copyright>        You should have received a copy of the GNU Affero General Public License
Copyright>        along with this program.  If not, see <https://www.gnu.org/licenses/>.
Copyright>
Copyright>
Copyright>        Commercial Alternative: Altair Radioss Software
Copyright>
Copyright>        As an alternative to this open-source version, Altair also offers Altair Radioss
Copyright>        software under a commercial license.  Contact Altair to discuss further if the
Copyright>        commercial version may interest you: https://www.altair.com/radioss/.
!||====================================================================
!||    admordr        ../engine/source/model/remesh/admordr.F
!||--- called by ------------------------------------------------------
!||    resol          ../engine/source/engine/resol.F
!||    resol_init     ../engine/source/engine/resol_init.F
!||--- calls      -----------------------------------------------------
!||    my_orders      ../common_source/tools/sort/my_orders.c
!||--- uses       -----------------------------------------------------
!||    element_mod    ../common_source/modules/elements/element_mod.F90
!||    my_alloc_mod   ../common_source/tools/memory/my_alloc.F90
!||    remesh_mod     ../engine/share/modules/remesh_mod.F
!||====================================================================
      SUBROUTINE admordr(SH4TREE,SH3TREE,IXC,IXTG)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE remesh_mod
      USE my_alloc_mod
      use element_mod , only : nixc,nixtg
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
#include      "comlock.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "param_c.inc"
#include      "parit_c.inc"
#include      "remesh_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER SH4TREE(KSH4TREE,*), SH3TREE(KSH3TREE,*),
     .        IXC(NIXC,*), IXTG(NIXTG,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER N,NN,LEVEL,IP,NLEV,PTR,SON,
     .        J,NI,IERR
      INTEGER,DIMENSION(:),ALLOCATABLE :: LTMP4
      INTEGER,DIMENSION(:),ALLOCATABLE :: LTMP3
      INTEGER,DIMENSION(:),ALLOCATABLE :: ITRI
      INTEGER,DIMENSION(:),ALLOCATABLE :: SORT_INDEX
      INTEGER WORK(70000)
C-----------------------------------------------
      CALL my_alloc(ltmp4,nsh4act)
      CALL my_alloc(ltmp3,nsh3act)
      CALL my_alloc(itri,max(nsh4act,nsh3act))
      CALL my_alloc(sort_index,2*max(nsh4act,nsh3act))
C-----------------------------------------------
      IF(iparit/=0)THEN
 
        DO nn = 1, nsh4act
          itri(nn) = ixc(nixc,lsh4act(nn))
        ENDDO
        CALL my_orders(0,work,itri,sort_index,nsh4act,1)
        ltmp4(1:nsh4act)=lsh4act(1:nsh4act)
        DO nn = 1, nsh4act
          lsh4act(nn)=ltmp4(sort_index(nn))
        END DO
 
        DO nn = 1, nsh3act
          itri(nn) = ixtg(nixtg,lsh3act(nn))
        ENDDO
        CALL my_orders(0,work,itri,sort_index,nsh3act,1)
        ltmp3(1:nsh3act)=lsh3act(1:nsh3act)
        DO nn = 1, nsh3act
          lsh3act(nn)=ltmp3(sort_index(nn))
        END DO
 
      END IF
    
      psh4act=0
 
      DO nn=1,nsh4act
        n    =lsh4act(nn)
        level=sh4tree(3,n)
        psh4act(level)=psh4act(level)+1
        ltmp4(nn)=n
      END DO 
C
      DO level=1,levelmax
        psh4act(level)=psh4act(level)+psh4act(level-1)
      END DO
C
      DO level=levelmax+1,1,-1
        psh4act(level)=psh4act(level-1)
      END DO
      psh4act(0)=0
C
      DO nn=1,nsh4act
        n    =ltmp4(nn)
        level=sh4tree(3,n)
        psh4act(level)=psh4act(level)+1
        lsh4act(psh4act(level))=n
      END DO
C
      DO level=levelmax+1,1,-1
        psh4act(level)=psh4act(level-1)
      END DO
      psh4act(0)=0
C
      psh4kin(0)=0
      lsh4kin(1:psh4act(1))=lsh4act(1:psh4act(1))
 
      ptr = psh4act(1)
      DO level=0,levelmax-1
        psh4kin(level+1)=ptr
        DO nn=psh4kin(level)+1,psh4kin(level+1)
          n    =lsh4kin(nn)
          son=sh4tree(2,n)
          ptr=ptr+1
          lsh4kin(ptr)=son
          ptr=ptr+1
          lsh4kin(ptr)=son+1
          ptr=ptr+1
          lsh4kin(ptr)=son+2
          ptr=ptr+1
          lsh4kin(ptr)=son+3
        END DO
        DO nn=psh4act(level+1)+1,psh4act(level+2)
          ptr=ptr+1
          lsh4kin(ptr)=lsh4act(nn)
        END DO
      END DO
      psh4kin(levelmax+1)=ptr
 
C--------------------------------------------
C     TRIANGLES
C--------------------------------------------
      psh3act=0
 
      DO nn=1,nsh3act
        n    =lsh3act(nn)
        level=sh3tree(3,n)
        psh3act(level)=psh3act(level)+1
        ltmp3(nn)=n
      END DO 
C
      DO level=1,levelmax
        psh3act(level)=psh3act(level)+psh3act(level-1)
      END DO
C
      DO level=levelmax+1,1,-1
        psh3act(level)=psh3act(level-1)
      END DO
      psh3act(0)=0
C
      DO nn=1,nsh3act
        n    =ltmp3(nn)
        level=sh3tree(3,n)
        psh3act(level)=psh3act(level)+1
        lsh3act(psh3act(level))=n
      END DO
C
      DO level=levelmax+1,1,-1
        psh3act(level)=psh3act(level-1)
      END DO
      psh3act(0)=0
C
      psh3kin(0)=0
      lsh3kin(1:psh3act(1))=lsh3act(1:psh3act(1))
 
      ptr = psh3act(1)
      DO level=0,levelmax-1
        psh3kin(level+1)=ptr
        DO nn=psh3kin(level)+1,psh3kin(level+1)
          n    =lsh3kin(nn)
          son=sh3tree(2,n)
          ptr=ptr+1
          lsh3kin(ptr)=son
          ptr=ptr+1
          lsh3kin(ptr)=son+1
          ptr=ptr+1
          lsh3kin(ptr)=son+2
          ptr=ptr+1
          lsh3kin(ptr)=son+3
        END DO
        DO nn=psh3act(level+1)+1,psh3act(level+2)
          ptr=ptr+1
          lsh3kin(ptr)=lsh3act(nn)
        END DO
      END DO
      psh3kin(levelmax+1)=ptr
C--------------------------------------------
      DEALLOCATE(ltmp4)
      DEALLOCATE(ltmp3)
      DEALLOCATE(itri)
      DEALLOCATE(sort_index)
 
      RETURN
      END