merge_node.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/.
!||====================================================================
!||    merge_node            ../starter/source/elements/nodes/merge_node.F
!||--- called by ------------------------------------------------------
!||    lectur                ../starter/source/starter/lectur.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                ../starter/source/output/message/message.F
!||    merge_bucket_search   ../starter/source/elements/nodes/merge_bucket_search.f
!||    usrtos                ../starter/source/system/sysfus.F
!||    usrtosc               ../starter/source/model/submodel/merge.F
!||--- uses       -----------------------------------------------------
!||    message_mod           ../starter/share/message_module/message_mod.F
!||    nod2el_mod            ../starter/share/modules1/nod2el_mod.F
!||====================================================================
      SUBROUTINE merge_node(X,ITAB,ITABM1 ,IMERGE,IMERGE2,
     .                      IADMERGE2,NMERGE_TOT,MERGE_NODE_TAB,MERGE_NODE_TOL,
     .                      NMERGE_NODE_CAND,NMERGE_NODE_DEST,IXS,IXS10,IXS20,
     .                      IXS16,IXQ,IXC,IXT,IXP,
     .                      IXR,IXTG,EANI,IGRNOD)   
      USE message_mod
      USE nod2el_mod
      USE groupdef_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
#include      "units_c.inc"
#include      "com04_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER ITAB(NUMNOD), ITABM1(2*NUMNOD),IMERGE(*),
     .        IMERGE2(NUMNOD+1),IADMERGE2(NUMNOD+1),MERGE_NODE_TAB(4,*),
     .        NMERGE_NODE_CAND,NMERGE_NODE_DEST,NMERGE_TOT
      INTEGER IXS(NIXS,*),IXS10(6,*),IXS16(8,*),IXS20(12,*),IXQ(NIXQ,*),
     .        ixc(nixc,*),ixt(nixt,*),ixp(nixp,*),ixr(nixr,*),
     .        ixtg(nixtg,*),eani(*)
      TARGET  itab
      my_real
     .        x(3,numnod),merge_node_tol(*)
      TYPE (GROUP_)  ,TARGET, DIMENSION(NGRNOD)  :: IGRNOD
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,K,M,N,NUMNOD1,NM,FLAG,N_DEST,N_DEST_DEST,NN1,NN2,CUR_ID,GR_IDS,ALL_VS_ALL,
     .        NM_L,ISS
C
      INTEGER, DIMENSION(:),ALLOCATABLE :: IMERGE0,IADMERGE2TMP,LIST1,LIST2,LIST1_INV,LIST2_INV
      INTEGER, DIMENSION(:),ALLOCATABLE :: LIST1_IDMERGE,LIST2_IDMERGE,LIST1_NBMERGE,LIST2_NBMERGE
      INTEGER, DIMENSION(:),ALLOCATABLE :: TAGNOD_TEMP
      my_real, DIMENSION(:),ALLOCATABLE :: DIST
C 
      my_real
     .        dbuc
C-----------------------------------------------
       INTEGER 
     .         usrtos,usrtosc
      EXTERNAL usrtos,usrtosc
C
C=======================================================================
C - MERGING ROUTINE for /MERGE/NODE 
C======================================================================= 
C     
C-------    dbuc------------------------------
C-- Cnodes not taken into account
C
      numnod1 = numnod0-numcnod
      dbuc = zero 
      all_vs_all = 0
      DO i=1,nb_merge_node 
        dbuc = max(dbuc,merge_node_tol(i))
        gr_ids = merge_node_tab(2,i)
        IF (gr_ids == 0) all_vs_all = 1
      ENDDO   
C
C----------------------------------------------------------------------------------- 
C     BUCKET SEARCH - search of node to merge for each candidate - stored in IMERGE0                           
C-----------------------------------------------------------------------------------
C
      nn1 = nmerge_node_cand
      nn2 = nmerge_node_dest
C
      ALLOCATE(imerge0(nn1),dist(nn1),list1(nmerge_node_cand),list2(nmerge_node_dest))
      ALLOCATE(list1_inv(numnod),list2_inv(numnod),iadmerge2tmp(numnod+1))
      ALLOCATE(list1_idmerge(nmerge_node_cand),list2_idmerge(nmerge_node_dest))
      ALLOCATE(list1_nbmerge(nmerge_node_cand),list2_nbmerge(nmerge_node_dest))
      ALLOCATE(tagnod_temp(numnod))
C
      imerge0 = 0
      dist = zero
      list1 = 0
      list1_idmerge = 0
      list1_nbmerge = 0
      list1_inv = 0
      list2 = 0
      list2_idmerge = 0
      list2_nbmerge = 0
      list2_inv = 0
      tagnod_temp = 0
      iadmerge2tmp = 0
C
      flag = 2
C
C---- bluid list of candidates
      IF (all_vs_all == 1) THEN
C--     all nodes are candidates - only one merge
        DO i=1,numnod
          list1(i) = i
          list1_inv(i) = i
          list1_nbmerge(i) = 1
          list1_idmerge(i) = 1
        ENDDO
      ELSE
C--     list filled merge by merge
        nm = 0
        DO i=1,nb_merge_node 
          gr_ids = merge_node_tab(2,i)
          DO j=1,igrnod(gr_ids)%NENTITY
            IF (list1_inv(igrnod(gr_ids)%ENTITY(j)) == 0) THEN
C--           new point in list
              nm = nm + 1
              list1(nm) = igrnod(gr_ids)%ENTITY(j)
              list1_inv(igrnod(gr_ids)%ENTITY(j)) = nm
              list1_nbmerge(nm) = 1
              list1_idmerge(nm) = i
            ELSE
C--           point already in list
              nm_l = list1_inv(igrnod(gr_ids)%ENTITY(j))
C--           coding of idmerge in case of several merge
              list1_nbmerge(nm_l) = list1_nbmerge(nm_l) + 1
              list1_idmerge(nm_l) = list1_idmerge(nm_l) + i*((2*nb_merge_node)**(list1_nbmerge(nm_l)-1))   
            ENDIF            
          ENDDO
        ENDDO   
      ENDIF
C
C---- bluid list of destination - filled merge by merge
      IF (all_vs_all == 1) THEN
C--   all nodes are destination 
        DO i=1,numnod
          list2(i) = i
          list2_inv(i) = i
          list2_nbmerge(i) = 1
          list2_idmerge(i) = 1
        ENDDO
      ELSE
C--     list filled merge by merge
        nm = 0
        DO i=1,nb_merge_node 
          gr_ids = merge_node_tab(2,i)
          IF (merge_node_tab(1,i) == 1) THEN
C--         Merge_type = 1 - destination is defined by the grnod
            DO j=1,igrnod(gr_ids)%NENTITY
              IF (list2_inv(igrnod(gr_ids)%ENTITY(j)) == 0) THEN
C--             new point in list
                nm = nm + 1
                list2(nm) = igrnod(gr_ids)%ENTITY(j)
                list2_inv(igrnod(gr_ids)%ENTITY(j)) = nm
                list2_nbmerge(nm) = 1
                list2_idmerge(nm) = i
              ELSE
C--             point already in list
                nm_l = list2_inv(igrnod(gr_ids)%ENTITY(j))
C--             coding of idmerge in case of several merge
                list2_nbmerge(nm_l) = list2_nbmerge(nm_l) + 1
                list2_idmerge(nm_l) = list2_idmerge(nm_l) + i*((2*nb_merge_node)**(list2_nbmerge(nm_l)-1))        
              ENDIF      
            ENDDO
          ELSE
C--         Merge_type = 2 - destination is all nodes outside of the grnod
            iss = i+nb_merge_node
            tagnod_temp(1:numnod) = 0
            DO j=1,igrnod(gr_ids)%NENTITY
              tagnod_temp(igrnod(gr_ids)%ENTITY(j)) = 1
            ENDDO  
            DO j=1,numnod
              IF (tagnod_temp(j)==0) THEN
                IF (list2_inv(j) == 0) THEN
C--               new point in list
                  nm = nm + 1
                  list2(nm) = j
                  list2_inv(j) = nm
                  list2_nbmerge(nm) = 1 
                  list2_idmerge(nm) = iss
                ELSE
C--               point already in list
                  nm_l = list2_inv(j)
C--               coding of idmerge in case of several merge
                  list2_nbmerge(nm_l) = list2_nbmerge(nm_l) + 1
                  list2_idmerge(nm_l) = list2_idmerge(nm_l) + iss*((2*nb_merge_node)**(list2_nbmerge(nm_l)-1))      
                ENDIF 
              ENDIF         
            ENDDO     
          ENDIF
        ENDDO   
      ENDIF
C
      CALL merge_bucket_search(x,itab,itabm1,imerge0,merge_node_tol,
     .                         dbuc,nn1,nn2,list1,list2,
     .                         dist,flag,list1_idmerge,list1_nbmerge,list2_idmerge,
     .                         list2_nbmerge)
C
C-------------------------------------------------------------------------- 
C     Remove merge of nodes of one element                        
C--------------------------------------------------------------------------
C
      DO i= 1,nn1 
        IF (imerge0(i) > 0) THEN
          n = list1(i)
          n_dest = usrtos(imerge0(i),itabm1)
C
C---      Check of elements
            flag = 0 
C------------------------>   cas des coques  <-----------------------C        
          DO j = knod2elc(n)+1,knod2elc(n+1)
            DO k=2,5             
              IF (ixc(k,nod2elc(j)) == n_dest) flag = 1        
            ENDDO
          ENDDO
C------------------------>   cas des coques triagnles <--------------C        
          DO j = knod2eltg(n)+1,knod2eltg(n+1)
            DO k=2,4            
              IF (ixtg(k,nod2eltg(j)) == n_dest) flag = 1        
            ENDDO
          ENDDO
C------------------------>   cas des solides <-----------------------C
          DO j = knod2els(n)+1,knod2els(n+1)     
            cur_id = nod2els(j)
            DO k=2,9
                IF(ixs(k,nod2els(j)) == n_dest) flag = 1
            ENDDO
              IF (eani(cur_id)==10) THEN
              DO k=1,6
                  IF(ixs10(k,cur_id-numels8) == n_dest) flag = 1
              ENDDO
            ELSEIF (eani(cur_id)==20) THEN              
              DO k=1,12
                  IF(ixs20(k,cur_id-numels8-numels10) == n_dest) flag = 1
              ENDDO
              ELSEIF (eani(cur_id)==16) THEN      
              DO k=1,8
                  IF(ixs16(k,cur_id-numels8-numels10-numels20) == n) flag = 1
              ENDDO                     
              ENDIF                            
            END DO
C------------------------>   cas des elements 1D <-------------------C
          DO j = knod2el1d(n)+1,knod2el1d(n+1)
            cur_id = nod2el1d(j)
              IF (cur_id <= numelt) THEN
              DO k=2,3
                IF (ixt(k,nod2el1d(j)) == n_dest) flag = 1        
              ENDDO
            ELSEIF (cur_id <= numelt + numelp) THEN
              DO k=2,4
                IF (ixp(k,cur_id-numelt) == n_dest) flag = 1        
              ENDDO
            ELSE
              DO k=2,4
                IF (ixr(k,cur_id-numelt-numelp) == n_dest) flag = 1        
              ENDDO
            ENDIF
          ENDDO
C------------------------>   cas des elements 1D inverse (pour 3e noeud )<---C
          DO j = knod2el1d(n_dest)+1,knod2el1d(n_dest+1)
            cur_id = nod2el1d(j)
              IF (cur_id <= numelt) THEN
              DO k=2,3
                IF (ixt(k,nod2el1d(j)) == n) flag = 1        
              ENDDO
            ELSEIF (cur_id <= numelt + numelp) THEN
              DO k=2,4
                IF (ixp(k,cur_id-numelt) == n) flag = 1        
              ENDDO
            ELSE
              DO k=2,4
                IF (ixr(k,cur_id-numelt-numelp) == n) flag = 1        
              ENDDO
            ENDIF
          ENDDO
C------------------------>   cas des quad  <-----------------------C        
          DO j = knod2elq(n)+1,knod2elq(n+1)
            DO k=2,5             
              IF (ixq(k,nod2elq(j)) == n_dest) flag = 1        
            ENDDO
          ENDDO
C
          IF (flag == 1) THEN
C--         connection removed
            imerge0(i) = 0
            CALL ancmsg(msgid=2039,
     .                  msgtype=msgwarning,
     .                  anmode=aninfo_blind_1,
     .                  i1=itab(n),i2=itab(n_dest),
     .                  r1=dist(i),
     .                  prmod=msg_cumu)
          ENDIF 
C
        ENDIF                                 
      ENDDO
C
      CALL ancmsg(msgid=2039,
     .                msgtype=msgwarning,
     .                anmode=aninfo_blind_1,
     .                prmod=msg_print )
C
C-------------------------------------------------------------------------- 
C     Ignore merge in case of hierarchy                         
C--------------------------------------------------------------------------
      DO i= 1,nn1 
        IF (imerge0(i) > 0) THEN
          n = list1(i)
          n_dest = usrtos(imerge0(i),itabm1)
          IF (list1_inv(n_dest) > 0) THEN
           IF (imerge0(list1_inv(n_dest)) > 0) THEN
            n_dest_dest = usrtos(imerge0(list1_inv(n_dest)),itabm1)
C--         hierarchy detected - the longest merge is removed
            IF (dist(list1_inv(n_dest)) > dist(i)) THEN
              imerge0(list1_inv(n_dest)) = 0
              CALL ancmsg(msgid=2038,
     .                msgtype=msgwarning,
     .                anmode=aninfo_blind_1,
     .                i1=itab(n_dest),i2=itab(n_dest_dest),
     .                r1=dist(list1_inv(n_dest)),
     .                prmod=msg_cumu)
C
            ELSE
              imerge0(i) = 0
              CALL ancmsg(msgid=2038,
     .                msgtype=msgwarning,
     .                anmode=aninfo_blind_1,
     .                i1=itab(n),i2=itab(n_dest),
     .                r1=dist(i),
     .                prmod=msg_cumu)
            ENDIF
           ENDIF
          ENDIF
        ENDIF                                 
      ENDDO
C
      CALL ancmsg(msgid=2038,
     .                msgtype=msgwarning,
     .                anmode=aninfo_blind_1,
     .                prmod=msg_print )
C
C-------------------------------------------------------------------------- 
C     COMPACT IMERGE -> No systeme                           
C-------------------------------------------------------------------------- 
      nm = 0                                  
      DO i= 1,nn1 
        IF (imerge0(i) > 0) THEN
          n = list1(i)
          nm = nm+1                          
          imerge(nmerge_tot+numcnod+nm) = usrtos(imerge0(i),itabm1)
          imerge(numcnod+nm) = n
        ENDIF                                 
      ENDDO                                   
      nmerged = nmerged + nm
                           
C--------------------------------------------------
C     TAB ID_NODE systeme  -> ID_CNODE  systeme (done from scratch even with cnodes)              
C--------------------------------------------------
      IF (nmerged > 0) THEN
        tagnod_temp(1:numnod) = 0
        DO i = 1,nmerge_tot
          IF (imerge(nmerge_tot+i) > 0) THEN
            n = imerge(nmerge_tot+i)
            tagnod_temp(n) = tagnod_temp(n) + 1
          ENDIF
        ENDDO
        iadmerge2(1) = 1
        iadmerge2tmp(1) = 1
        DO i = 2,numnod+1
          iadmerge2(i) = iadmerge2(i-1) + tagnod_temp(i-1)
          iadmerge2tmp(i) = iadmerge2tmp(i-1) + tagnod_temp(i-1)
        ENDDO
        DO i = 1,nmerge_tot
          IF (imerge(nmerge_tot+i) > 0) THEN
            n = imerge(nmerge_tot+i)
            imerge2(iadmerge2tmp(n)) = imerge(i)
            iadmerge2tmp(n)=iadmerge2tmp(n)+1
          ENDIF  
        ENDDO
      ENDIF
 
C--------------------------------------------------
      IF (numcnod == 0) WRITE(iout,1000)
      WRITE(iout,1001)
C    
      j=0                                                            
      DO  n=1,nmerged,50                                             
        j=j+50                                                       
        j=min(j,nmerged)
        DO  i=n,j
          WRITE(iout,'(5X,I10,8X,I10)') 
     .          itab(imerge(numcnod+i)),itab(imerge(numcnod+nmerge_tot+i))
        ENDDO                                                       
      ENDDO
C--------
      DEALLOCATE(imerge0,dist,list1,list2)
      DEALLOCATE(list1_inv,list2_inv,iadmerge2tmp)
      DEALLOCATE(list1_idmerge,list2_idmerge)
      DEALLOCATE(list1_nbmerge,list2_nbmerge)
      DEALLOCATE(tagnod_temp)
C--------
      RETURN
C
1000  FORMAT(/
     . '               MERGE NODES '/
     . '   --------------------------------------')
1001  FORMAT(/
     . '          NODE     MERGED TO     NODE '/)
C
      END