remn_self24.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/.
!||====================================================================
!||    remn_self24            ../starter/source/interfaces/inter3d1/remn_self24.F
!||--- called by ------------------------------------------------------
!||    inintr                 ../starter/source/interfaces/interf1/inintr.F
!||    inintr2                ../starter/source/interfaces/inter3d1/inintr2.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                 ../starter/source/output/message/message.f
!||    fretitl2               ../starter/source/starter/freform.F
!||    insol3et               ../starter/source/interfaces/inter3d1/i24sti3.F
!||    upgrade_remnode2       ../starter/source/interfaces/interf1/upgrade_remnode.F
!||--- uses       -----------------------------------------------------
!||    message_mod            ../starter/share/message_module/message_mod.F
!||====================================================================
      SUBROUTINE remn_self24(
     .               X   ,IXS   ,IXS10 ,IXS16,IXS20   ,
     .               KNOD2ELS,NOD2ELS,IPARI ,INTBUF_TAB ,
     .               ITAB , NOM_OPT,NREMOV,S_NOD2ELS,IDDLEVEL)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE my_alloc_mod
      USE message_mod
      USE intbufdef_mod
      USE names_and_titles_mod , ONLY : nchartitle
      use element_mod , only :nixs
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "param_c.inc"
#include      "com04_c.inc"
#include      "scr17_c.inc"
#include      "tabsiz_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, DIMENSION(NPARI,NINTER)    ,INTENT(INOUT) :: IPARI
      INTEGER, DIMENSION(NIXS,NUMELS)     ,INTENT(IN) :: IXS
      INTEGER, DIMENSION(6,NUMELS10)      ,INTENT(IN) :: IXS10
      INTEGER, DIMENSION(8,NUMELS16)      ,INTENT(IN) :: IXS16
      INTEGER, DIMENSION(12,NUMELS20)     ,INTENT(IN) :: IXS20
      INTEGER, DIMENSION(NUMNOD+1)        ,INTENT(IN) :: KNOD2ELS
      INTEGER,                             INTENT(IN) :: S_NOD2ELS
      INTEGER, DIMENSION(S_NOD2ELS)       ,INTENT(IN) :: NOD2ELS
      INTEGER, DIMENSION(NUMNOD)          ,INTENT(IN) :: ITAB
      INTEGER, DIMENSION(LNOPT1,SNOM_OPT) ,INTENT(IN) :: NOM_OPT
      INTEGER, DIMENSION(NINTER)      ,INTENT(INOUT) :: NREMOV
      my_real, DIMENSION(NUMNOD*3)       ,INTENT(IN) :: x
      TYPE(intbuf_struct_), DIMENSION(NINTER),INTENT(INOUT):: INTBUF_TAB
      INTEGER, INTENT(in) :: IDDLEVEL !< flag : 0 for the 1rst step, 1 for the 2nd step
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER N,NTY,FLAGREMNODE,I,NI
      INTEGER II,J,NSN,NRTM,
     .        IFLAG,
     .        nnod,nnrem,
     .        ki,kl,jj,nremov1(ninter),ns,maxnm
      INTEGER, DIMENSION(:),ALLOCATABLE :: TAGD,TAGNOD
      INTEGER ID,NC(20),NMC(4)
      CHARACTER(LEN=NCHARTITLE) :: TITR
 
 
      INTEGER :: JJJ,NOINT,E_ID,IADA
      INTEGER :: FIRST,LAST,NNREM_SAVE
      INTEGER :: OFFSET, NBR_INTRA,NBR_EXTRA,TOTAL_INSERTED
      INTEGER :: SIZE_INSERTED_NODE,MAX_INSERTED_NODE
      INTEGER, DIMENSION(:), ALLOCATABLE :: NBR_INSERT_II,ADRESS_II
      INTEGER, DIMENSION(:), ALLOCATABLE :: KREMNODE_SAVE,INSERTED_NODE,REMNODE
      my_real
     .   area
!       -------------------------------
!       FIRST : integer , first block of inserted nodes
!       LAST : integer , last block of inserted nodes
!       NNREM_SAVE : integer , internal counter
!       OFFSET : integer , internal offset for the REMNODE array
!       NBR_INTRA : integer , number of old nodes between 2 blocks
!       NBR_EXTRA : integer , number of old remaining nodes
!       TOTAL_INSERTED : integer , total number of inserted nodes
!       NBR_INSERT_II : integer, dimension = NRTM , number of inserted nodes for each II segment
!       ADRESS_II : integer, dimension = NRTM , adress of the first inserted nodes for each II segment
!       KREMNODE_SAVE : integer, dimension = NRTM+1 , list of old nodes
!       SIZE_INSERTED_NODE : integer, size of the INSERTED_NODE array ; SIZE_INSERTED_NODE is an upper bound,
!                            can be optimized!
!       inserted_node : integer, dimension = size_inserted_node, list inserted nodes
!       remnode : integer, dimension = nrtm + total_inserted, new array with old and inserted nodes
!       -------------------------------
C-----------------------------------------------
C----creat list of SECONDARY nodes of self-contact to be removed per M_seg
      max_inserted_node = 1
      ALLOCATE(tagnod(numnod),tagd(numnod))
      DO n=1,ninter
        nty=ipari(7,n)
        nremov1(n)=0
        IF (nty/=24) cycle
        nsn   =ipari(5,n)
        nrtm  =ipari(4,n)
        noint =ipari(15,n)
        tagnod(1:numnod)=0
        DO jj=1,nsn
          ns = intbuf_tab(n)%NSV(jj)
          IF (ns<=numnod) tagnod(ns)=1
        ENDDO
C----- dimensioning
        DO ii=1,nrtm
          CALL insol3et(x   ,intbuf_tab(n)%IRECTM,ixs   ,
     .                  n   ,e_id,ii ,area ,
     .                  noint ,knod2els,nod2els,ixs10 ,
     .                  ixs16,ixs20 ,nnod)
          SELECT CASE (nnod)
           CASE(8)
            nc(1:8)=ixs(2:9,e_id)
           CASE(10)
            nc(1) =ixs(2,e_id)
            nc(2) =ixs(4,e_id)
            nc(3) =ixs(7,e_id)
            nc(4) =ixs(6,e_id)
            nc(5:10)=ixs10(1:6,e_id-numels8)
           CASE(20)
            nc(1:8)=ixs(2:9,e_id)
            nc(9:20)=ixs20(1:12,e_id-numels8-numels10)
           CASE(16)
            nc(1:8)=ixs(2:9,e_id)
            nc(9:16)=ixs16(1:8,e_id-numels8-numels10-numels20)
          END SELECT
C
          nmc(1:4)=intbuf_tab(n)%IRECTM(4*(ii-1)+1:4*(ii-1)+4)
          maxnm = 0
          DO i = 1,nnod
            ni= nc(i)
            IF (ni==0) cycle
            IF (tagnod(ni)>0 .AND.ni/=nmc(1).AND.ni/=nmc(2)
     .                     .AND.ni/=nmc(3).AND.ni/=nmc(4)) THEN
              nremov1(n) =  nremov1(n)+ 1
              maxnm = maxnm + 1
            END IF
          END DO
          max_inserted_node = max(max_inserted_node,maxnm)
        END DO
      END DO !N=1,NINTER
 
 
 
!   ------------------------------------------------
C---------
      DO n=1,ninter
        IF(nremov1(n)==0) cycle
        nty=ipari(7,n)
        nsn   =ipari(5,n)
        nrtm  =ipari(4,n)
 
        ALLOCATE( nbr_insert_ii(nrtm) )
        ALLOCATE( adress_ii(nrtm) )
        ALLOCATE( kremnode_save(nrtm+1) )
        nbr_insert_ii(1:nrtm) = 0
        adress_ii(1:nrtm) = 0
        kremnode_save(1:nrtm+1) = 0
 
C----- --
        tagnod(1:numnod)=0
        tagd(1:numnod)=2
        jjj = 0
C--------dim first
        nnrem = 0
        DO jj=1,nsn
          ns = intbuf_tab(n)%NSV(jj)
          IF (ns<=numnod) tagd(ns)=0
          IF (ns<=numnod) tagnod(ns)=1
        ENDDO
        iflag =0
        nremov(n) = ipari(62,n)
        flagremnode=ipari(63,n)
        IF(iddlevel==0.AND.flagremnode==1.AND.nremov(n)>0) flagremnode = 2
        iada= 1
        IF(nremov(n)>0) kremnode_save(1:nrtm+1) = intbuf_tab(n)%KREMNODE(1:nrtm+1)
 
        size_inserted_node = max_inserted_node*nrtm
        CALL my_alloc(inserted_node,size_inserted_node)
 
        DO ii=1,nrtm
          nnrem_save = nnrem
C
          IF (flagremnode==2)THEN
            ki = intbuf_tab(n)%KREMNODE(ii)+1
            kl = intbuf_tab(n)%KREMNODE(ii+1)
            DO j=ki,kl
              ns = intbuf_tab(n)%REMNODE(j)
              tagd(ns)=1
            END DO
          END IF !IF(FLAGREMNODE==2)THEN
C
          CALL insol3et(x   ,intbuf_tab(n)%IRECTM,ixs   ,
     .                  n   ,e_id,ii,area ,
     .                  noint ,knod2els,nod2els,ixs10 ,
     .                  ixs16,ixs20 ,nnod)
          SELECT CASE (nnod)
           CASE(8)
            nc(1:8)=ixs(2:9,e_id)
           CASE(10)
            nc(1) =ixs(2,e_id)
            nc(2) =ixs(4,e_id)
            nc(3) =ixs(7,e_id)
            nc(4) =ixs(6,e_id)
            nc(5:10)=ixs10(1:6,e_id-numels8)
           CASE(20)
            nc(1:8)=ixs(2:9,e_id)
            nc(9:20)=ixs20(1:12,e_id-numels8-numels10)
           CASE(16)
            nc(1:8)=ixs(2:9,e_id)
            nc(9:16)=ixs16(1:8,e_id-numels8-numels10-numels20)
          END SELECT
C
          nmc(1:4)=intbuf_tab(n)%IRECTM(4*(ii-1)+1:4*(ii-1)+4)
          DO i = 1,nnod
            ni= nc(i)
            IF (ni==0) cycle
            IF (tagnod(ni)>0 .AND.ni/=nmc(1).AND.ni/=nmc(2)
     .                     .AND.ni/=nmc(3).AND.ni/=nmc(4)) THEN
              IF(tagd(ni)==0) THEN
                nnrem = nnrem + 1
                tagd(ni)=1
                jjj = jjj + 1
                inserted_node(jjj) = ni
              ENDIF
            END IF
          END DO
          !   -------------------
          !   number of inserted nodes
          nbr_insert_ii(ii) = nnrem - nnrem_save
          kremnode_save(ii) = kremnode_save(ii+1) - kremnode_save(ii)
          iada = iada + kremnode_save(ii)
          !   adress of the first inserted node
          adress_ii(ii) = iada
          kremnode_save(ii) = iada + nbr_insert_ii(ii) - 1
          iada = iada + nbr_insert_ii(ii)
          !   -------------------
 
C-----reset    TAGD=0
          DO i = 1,nnod
            ni= nc(i)
            IF (ni==0) cycle
            IF (tagnod(ni)>0 .AND.ni/=nmc(1).AND.ni/=nmc(2)
     .                     .AND.ni/=nmc(3).AND.ni/=nmc(4)) THEN
              IF(tagd(ni)==1) tagd(ni)=0
            END IF
          END DO
          IF (flagremnode==2)THEN
            DO j=ki,kl
              ns = intbuf_tab(n)%REMNODE(j)
              tagd(ns)=0
            END DO
          END IF 
C
        END DO !II=1,NRTM
 
 
        IF(nnrem>0) THEN
 
          ! get the first and the last inserted node
          first = 0
          last = 0
          DO ii = 1,nrtm
            IF(first==0) THEN
              IF( nbr_insert_ii(ii)/=0 ) first = ii
            ENDIF
            IF(last==0) THEN
              IF( nbr_insert_ii(nrtm+1-ii)/=0 ) last = nrtm+1-ii
            ENDIF
          ENDDO
          !       count the total number of inserted nodes
          total_inserted = 0
          DO ii=1,nrtm
            total_inserted = total_inserted + nbr_insert_ii(ii)
          ENDDO
          !       allocate the buffer array
          ALLOCATE( remnode(nremov(n)+total_inserted) )
 
          j = 0
          i = 0
          offset = 0
          IF( first>0 ) THEN
            !   insertion of the first chunk of node : if ADRESS_II(FIRST) > 1
            !   --> need to copy the old nodes
            IF( adress_ii(first)>1 ) THEN
              remnode(1:adress_ii(first)-1) = intbuf_tab(n)%REMNODE(1:adress_ii(first)-1)
              offset = offset + adress_ii(first)-1
              i = i + adress_ii(first)-1
            ENDIF
 
            DO ii=first,last
              !       insertion of the nodes
              IF( nbr_insert_ii(ii)>0 ) THEN
                DO jj = 1,nbr_insert_ii(ii)
                  j = j + 1
                  remnode(offset+nbr_insert_ii(ii)+1-jj) = inserted_node(j)
                ENDDO
                offset = offset + nbr_insert_ii(ii)
              ENDIF
              IF(ii<last.AND.nremov(n)>0) THEN
                ! copy of the old nodes
                nbr_intra = adress_ii(ii+1) - adress_ii(ii)-nbr_insert_ii(ii)
                IF( nbr_intra>0 )THEN
                  DO jj = 1,nbr_intra
                    i = i + 1
                    remnode(jj+offset) = intbuf_tab(n)%REMNODE(i)
                  ENDDO
                  offset = offset + nbr_intra
                ENDIF
              ENDIF
            ENDDO
          ENDIF
          !       copy of the old nodes for the LAST chunk
 
          IF( i<nremov(n) ) THEN
            nbr_extra = nremov(n) - i
            remnode(offset+1:offset+nbr_extra) = intbuf_tab(n)%REMNODE(i+1:nremov(n))
          ENDIF
          id=nom_opt(1,n)
          CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,n),ltitr)
          ! -----------------
          ! only print the message for the 2nd sorting
          IF(iddlevel>0) THEN
            CALL ancmsg(msgid=3014,
     .              msgtype=msginfo,
     .              anmode=aninfo_blind_1,
     .              i1=id,
     .              c1=titr,
     .              i2=nnrem)
          ENDIF
          ! -----------------
          !       update of NNREM and deallocation / allocation of the new array
 
          nnrem = nnrem + nremov(n)
C----         no need, done in UPGRADE_REMNODE2 IPARI(63,N) = 2
          CALL upgrade_remnode2(n,nnrem,intbuf_tab(n),nty)
          intbuf_tab(n)%REMNODE(1:nnrem) = remnode(1:nnrem)
          intbuf_tab(n)%KREMNODE(2:nrtm+1) = kremnode_save(1:nrtm)
          intbuf_tab(n)%KREMNODE(1)=0
C----------used for Iedge=1
          nremov(n) = nnrem
        END IF !IF (NNREM>0) THEN
        IF(ALLOCATED(remnode)) DEALLOCATE( remnode )
        IF(ALLOCATED(inserted_node)) DEALLOCATE( inserted_node )
 
C
 
        DEALLOCATE( nbr_insert_ii )
        DEALLOCATE( adress_ii )
        DEALLOCATE( kremnode_save )
      END DO
 
      DEALLOCATE(tagd,tagnod)
C----
      RETURN
      END