r2r_group.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/.
!||====================================================================
!||    r2r_group              ../starter/source/coupling/rad2rad/r2r_group.F
!||--- called by ------------------------------------------------------
!||    lectur                 ../starter/source/starter/lectur.F
!||--- calls      -----------------------------------------------------
!||    ale_check_lag          ../starter/source/ale/ale_check_lag.f
!||    ancmsg                 ../starter/source/output/message/message.F
!||    chk_flg_fsi            ../starter/source/coupling/rad2rad/routines_r2r.F
!||    new_link               ../starter/source/coupling/rad2rad/new_link.F
!||    printcenter            ../starter/source/starter/radioss_title.F
!||    r2r_input              ../starter/source/coupling/rad2rad/r2r_input.F
!||    r2r_prelec             ../starter/source/coupling/rad2rad/r2r_prelec.F
!||    tagnod_r2r             ../starter/source/coupling/rad2rad/tagnod_r2r.F
!||    tagnod_r2r_nl          ../starter/source/coupling/rad2rad/tagnod_r2r_nl.F
!||    tagnod_r2r_s           ../starter/source/coupling/rad2rad/tagnod_r2r.F
!||    tagnods_r2r            ../starter/source/coupling/rad2rad/tagnod_r2r.F
!||--- uses       -----------------------------------------------------
!||    detonators_mod         ../starter/share/modules1/detonators_mod.F
!||    group_mod              ../starter/share/modules1/group_mod.F
!||    inivol_def_mod         ../starter/share/modules1/inivol_mod.F
!||    message_mod            ../starter/share/message_module/message_mod.F
!||    r2r_mod                ../starter/share/modules1/r2r_mod.F
!||    reader_old_mod         ../starter/share/modules1/reader_old_mod.F90
!||    restmod                ../starter/share/modules1/restart_mod.F
!||    submodel_mod           ../starter/share/modules1/submodel_mod.F
!||====================================================================
      SUBROUTINE r2r_group(
     1           NGROU,INNOD,FLAG,IPARTS,
     2           IPARTQ,IPARTC,IPARTT,IPARTP,IPARTR,IPARTG,
     3           IPARTSP,IXS10,IXS20,IXS16,KK,BUF_NOD,IXR_KJ,
     4           INOM_OPT,IPART_L,IAD,NALE_R2R,FLG_R2R_ERR ,
     5           PM_STACK ,IWORKSH  ,IGRBRIC2,IGRQUAD2  ,IGRSH4N2,
     6           IGRSH3N2 ,IGRTRUSS2,IGRBEAM2,IGRSPRING2,IGRNOD2 ,
     7           IGRSURF2 ,IGRSLIN2,LSUBMODEL,ALE_EULER,IGEO_,
     8           NLOC_DMG ,DETONATORS,NSENSOR,SEATBELT_SHELL_TO_SPRING,
     9           NB_SEATBELT_SHELLS,MAT_PARAM)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE my_alloc_mod
        USE restmod
        USE r2r_mod
        USE message_mod
        USE groupdef_mod
        USE group_mod
        USE inoutfile_mod
        USE submodel_mod
        USE inivol_def_mod , ONLY : num_inivol
        USE nlocal_reg_mod
        USE detonators_mod
        USE matparam_def_mod
        USE names_and_titles_mod , ONLY : nchartitle
        USE reader_old_mod , ONLY : kinter, nslash
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   A r g u m e n t s
C-----------------------------------------------
        INTEGER,INTENT(IN) :: IGEO_(NPROPGI,NUMGEO)
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "units_c.inc"
#include      "scr17_c.inc"
#include      "param_c.inc"
#include      "sphcom.inc"
#include      "r2r_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        TYPE(submodel_data) LSUBMODEL(NSUBMOD)
        INTEGER ,INTENT(IN) :: NSENSOR
        INTEGER NGROU,
     .     BUF_NOD(*),INNOD,FLAG,KK,
     .     IPARTS(*),IXS10(6,*),IXS20(12,*),
     .     IXS16(8,*),IPARTQ(*),IPARTSP(*),
     .     IPARTC(*),IPARTT(*),IPARTP(*),IPARTR(*),
     .     IPARTG(*),IXR_KJ(*),INOM_OPT(*),IPART_L(*),IAD,
     .     NALE_R2R(*),FLG_R2R_ERR,IWORKSH(*),ALE_EULER
        INTEGER ,INTENT(IN) :: NB_SEATBELT_SHELLS
        INTEGER ,INTENT(IN) :: SEATBELT_SHELL_TO_SPRING(NUMELC,2)
        my_real :: pm_stack(*)
        TYPE (NLOCAL_STR_) ,INTENT(IN)  :: NLOC_DMG
        TYPE (DETONATORS_STRUCT_),TARGET,INTENT(IN) :: DETONATORS
        TYPE (MATPARAM_STRUCT_) ,DIMENSION(NUMMAT) ,INTENT(IN) :: MAT_PARAM
C-----------------------------------------------
!      TYPE (GROUP_)  , DIMENSION(NGRNOD)  :: IGRNOD2
        TYPE (GROUP_)  , DIMENSION(NGROU)   :: IGRNOD2
        TYPE (GROUP_)  , DIMENSION(NGRBRIC) :: IGRBRIC2
        TYPE (GROUP_)  , DIMENSION(NGRQUAD) :: IGRQUAD2
        TYPE (GROUP_)  , DIMENSION(NGRSHEL) :: IGRSH4N2
        TYPE (GROUP_)  , DIMENSION(NGRSH3N) :: IGRSH3N2
        TYPE (GROUP_)  , DIMENSION(NGRTRUS) :: IGRTRUSS2
        TYPE (GROUP_)  , DIMENSION(NGRBEAM) :: IGRBEAM2
        TYPE (GROUP_)  , DIMENSION(NGRSPRI) :: IGRSPRING2
        TYPE (SURF_)   , DIMENSION(NSURF)   :: IGRSURF2
        TYPE (SURF_)   , DIMENSION(NSLIN)   :: IGRSLIN2
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER STAT,I,J,IGR,IGRS,N,NUM,K,ADD,COMPT,IGS,IPID_L
        INTEGER ID_TEMP(NB_PART_SUB),NSUBDOM_LOC,P,TMP_PART(NPART)
        INTEGER, DIMENSION(:,:), ALLOCATABLE :: IGROUP_TEMP2
        INTEGER N_LNK_C,NI,GRM,GRS,MAIN,IGU,NUL,IAD_TMP,COMPT_T2
        INTEGER MODIF,NINTER_PREC,FAC,IO_ERR,NUM_KJ,NSPCONDN,NSPHION,NN
        INTEGER MEMTR(NUMNOD),FLG_SPH,COUNT,NEW_NSLASH_INT,NEW_HM_NINTER,NEW_NINTSUB,NEW_NINIVOL
        CHARACTER(LEN=NCHARTITLE) :: TITR
        CHARACTER NAME*100
        INTEGER NGRNOD2,NGRBRIC2,NGRQUAD2,NGRSHEL2,NGRSH3N2,NGRTRUS2,NGRBEAM2,NGRSPRI2,LENGRN,ITITLE(LTITR)
        CHARACTER(LEN=NCHARTITLE) :: NEW_TITLE(NGROU+10*NSUBDOM)
        INTEGER, DIMENSION(:), ALLOCATABLE :: IGROUP_TEMP2_BUF,TAG_NLOCAL
        INTEGER :: LEN_TMP_NAME
        CHARACTER(len=4096) :: TMP_NAME
C-----------------------------------------------
        n_lnk_c = 0
        tmp_part(:)= 0
        modif = 1
        innod = 0
C----- Storage of IGRN in IGRN Temp------------------------------C
        lengrn = 9
        IF (flag == 1) THEN
          ALLOCATE(igroup_temp2(10,ngrou+10*nsubdom))
          igroup_temp2 = 0
          count = 0
          DO i=1,ngrou
            count = count + igrnod2(i)%NENTITY
          ENDDO
          IF (count > 0) THEN
            ALLOCATE(igroup_temp2_buf(count))
            igroup_temp2_buf(:) = 0
          ENDIF
          iad_tmp = 1
!
          DO i=1,ngrou
            igroup_temp2(1,i) = igrnod2(i)%ID         ! IGRN(1,*)
            igroup_temp2(2,i) = igrnod2(i)%NENTITY    ! IGRN(2,*)
            igroup_temp2(3,i) = igrnod2(i)%GRTYPE     ! IGRN(4,*)
            igroup_temp2(4,i) = igrnod2(i)%SORTED     ! IGRN(5,*)
            igroup_temp2(5,i) = igrnod2(i)%GRPGRP     ! IGRN(6,*)
            igroup_temp2(6,i) = igrnod2(i)%LEVEL      ! IGRN(7,*)
            new_title(i)      = igrnod2(i)%TITLE      ! IGRN(11,*)
            igroup_temp2(8,i) = igrnod2(i)%R2R_ALL    ! IGRN(8,*)
            igroup_temp2(9,i) = igrnod2(i)%R2R_SHARE  ! IGRN(9,*)
            igroup_temp2(7,i) = iad_tmp
            DO j=1,igrnod2(i)%NENTITY
              igroup_temp2_buf(iad_tmp) = igrnod2(i)%ENTITY(j)
              iad_tmp = iad_tmp + 1
            ENDDO
          ENDDO
        ENDIF
C--------------------------------------------------------------------C
C------Creation of groups of nodes of multidomains interface---------C
C--------------------------------------------------------------------C
!
        ngrnod2  = ngrnod
        ngrbric2 = ngrbric
        ngrquad2 = ngrquad
        ngrshel2 = ngrshel
        ngrsh3n2 = ngrsh3n
        ngrtrus2 = ngrtrus
        ngrbeam2 = ngrbeam
        ngrspri2 = ngrspri
!
        IF (flag == 1) THEN
          num = 1
          igs = ngrou+1
          DO i=1,ngrou
            IF (num<=igrnod2(i)%ID) num=igrnod2(i)%ID+1
          END DO
        ENDIF
C--------------------------------------------------------------------C
        IF (ipid==0) nsubdom = 1
        nsubdom_loc = nsubdom
        DO p=1,nsubdom_loc
C-----2 pass : pass 1 - contact nodes / passe 2 - connection nodes
          n = p
          IF (ipid==0) n = iddom
          compt = 0
C--------------------------------------------------------------------C
C---------------FLAG = 0 --> tag of nodes and counting --------------C
C--------------------------------------------------------------------C
          IF (flag==0) THEN
C---------------Reset of out file + printout of new heading ---------C
            ipid_l = ipid
            IF (flg_swale==1) THEN
              IF (ipid==0) ipid_l = 1
              IF (ipid/=0) ipid_l = 0
            ENDIF
            IF (ipid_l==0) THEN
              CLOSE(unit=iout, status='DELETE',iostat=io_err)
 
              tmp_name=outfile_name(1:outfile_name_len)//r2r_filnam(1:len_trim(r2r_filnam))
              len_tmp_name = outfile_name_len+len_trim(r2r_filnam)
              OPEN(unit=iout,file=tmp_name(1:len_tmp_name),
     .        access='SEQUENTIAL',
     .        form='FORMATTED',status='UNKNOWN')
              name = "SUBDOMAIN "//r2r_filnam(1:(len_trim(r2r_filnam)-9))
              WRITE (iout,'(A)')  ''
              CALL printcenter(" ",0,iout,1)
              CALL printcenter(" ",0,iout,2)
              CALL printcenter(name,len_trim(name),iout,2)
              CALL printcenter(" ",0,iout,2)
              CALL printcenter(" ",0,iout,1)
            ENDIF
C---------------Allocation of arrays for tag of elements--------------C
            ALLOCATE(tag_elc(numelc+npart),tag_els(numels+npart))
            ALLOCATE(tag_elg(numeltg+npart),tag_elsp(numsph+npart))
            ALLOCATE(tag_elr(numelr+npart),tag_elt(numelt+npart))
            ALLOCATE(tag_elp(numelp+npart),tag_elq(numelq+npart))
            tag_els(:)=0
            tag_elc(:)=0
            tag_elg(:)=0
            tag_elt(:)=0
            tag_elp(:)=0
            tag_elr(:)=0
            tag_elq(:)=0
            tag_elsp(:)=0
C---------------Tag of Parts-------------------------------------------C
            DO k=1,npart
              tagno(k)=0
C          ---> TAGNO(K)=-1 => PART K belongs to an already treated subdomain---
              IF(tmp_part(k)==-1) tagno(k)=-1
            ENDDO
            add = isubdom(3,n)
            DO k=1,npart
              DO i=1,isubdom(1,n)
                IF(k == isubdom_part(i+add))THEN
                  tagno(k)=1
                  tmp_part(k)=-1
                ENDIF
              ENDDO
            END DO
C----------------Full domain - inversion of part selection-------------C
            IF (iddom == 0) THEN
              DO k=1,npart
                IF(tagno(k)==1) THEN
                  tagno(k)=0
                ELSEIF(tagno(k)==0) THEN
                  tagno(k)=1
                ENDIF
              ENDDO
            ENDIF
C---------------> TAG OF PARTS : ----------------------------------
C---------------> TAGNO(K) = -1 -> Part of already treated subdmain
C---------------> TAGNO(K) = 0 -> Internal part of subdomain
C---------------> TAGNO(K) = 1 -> External part of subdomain
 
C---------------> TAG OF NODES : ----------------------------------
C---------------> TAGNO(K) = -1 -> external node
C---------------> TAGNO(K) = 0 -> free node (not attached to any domain)
C---------------> TAGNO(K) = 1 -> internal node
C---------------> TAGNO(K) = 2 -> coupled node
C---------------> TAGNO(K) = 3 -> coupled node -> main node of RBODY
C---------------> TAGNO(K) = 4 -> coupled node for contacts
C---------------Detag of already treated nodes----------------------C
            CALL tagnods_r2r(ixs,ixs10,ixs20,ixs16,iparts,tagno,-1,n)
            CALL tagnod_r2r(ixq,nixq,2,5,numelq,ipartq,tagno,npart,-1,n)
            CALL tagnod_r2r(ixc,nixc,2,5,numelc,ipartc,tagno,npart,-1,n)
            CALL tagnod_r2r(ixt,nixt,2,3,numelt,ipartt,tagno,npart,-1,n)
            CALL tagnod_r2r(ixp,nixp,2,4,numelp,ipartp,tagno,npart,-1,n)
            CALL tagnod_r2r(ixr,nixr,2,3,numelr,ipartr,tagno,npart,-1,n)
            CALL tagnod_r2r(ixtg,nixtg,2,4,numeltg,ipartg,tagno,npart,-1,n)
            CALL tagnod_r2r(kxsp,nisp,3,3,numsph,ipartsp,tagno,npart,-1,n)
C---------------Tag of nodes -> pass 1------------------------------C
            CALL tagnods_r2r(ixs,ixs10,ixs20,ixs16,iparts,tagno,0,n)
            CALL tagnod_r2r(ixq,nixq,2,5,numelq,ipartq,tagno,npart,0,n)
            CALL tagnod_r2r(ixc,nixc,2,5,numelc,ipartc,tagno,npart,0,n)
            CALL tagnod_r2r(ixt,nixt,2,3,numelt,ipartt,tagno,npart,0,n)
            CALL tagnod_r2r(ixp,nixp,2,3,numelp,ipartp,tagno,npart,0,n)
            CALL tagnod_r2r(ixr,nixr,2,3,numelr,ipartr,tagno,npart,0,n)
            CALL tagnod_r2r(ixtg,nixtg,2,4,numeltg,ipartg,tagno,npart,0,n)
            CALL tagnod_r2r(kxsp,nisp,3,3,numsph,ipartsp,tagno,npart,0,n)
C---------------Tag of nodes -> pass 2-------------------------------C
            CALL tagnods_r2r(ixs,ixs10,ixs20,ixs16,iparts,tagno,1,n)
            CALL tagnod_r2r(ixq,nixq,2,5,numelq,ipartq,tagno,npart,1,n)
            CALL tagnod_r2r(ixc,nixc,2,5,numelc,ipartc,tagno,npart,1,n)
            CALL tagnod_r2r(ixt,nixt,2,3,numelt,ipartt,tagno,npart,1,n)
            CALL tagnod_r2r(ixp,nixp,2,3,numelp,ipartp,tagno,npart,1,n)
            CALL tagnod_r2r(ixr,nixr,2,3,numelr,ipartr,tagno,npart,1,n)
            CALL tagnod_r2r(ixtg,nixtg,2,4,numeltg,ipartg,tagno,npart,1,n)
            CALL tagnod_r2r(kxsp,nisp,3,3,numsph,ipartsp,tagno,npart,1,n)
C---------------Tag of 3rd nodes of beams/springs -> pass 3----------C
            CALL tagnod_r2r(ixp,nixp,4,4,numelp,ipartp,tagno,npart,3,n)
            CALL tagnod_r2r(ixr,nixr,4,4,numelr,ipartr,tagno,npart,3,n)
C---------------Tag of additional nodes for kjoints-- --------------C
            CALL tagnod_r2r(ixr_kj,5,1,3,numelr,ipartr,tagno,npart,4,n)
C---------------Tag of specific nodes -> Skew,Frames-----------------C
            IF (p==nsubdom_loc) CALL tagnod_r2r_s(tagno)
C---------------Storage of initial tag of nodes----------------------C
            DO i=1,numnod
              tagno(npart+numnod+i) = tagno(npart+i)
            END DO
C--------------------------------------------------------------------C
C////////////////////////////////////////////////////////////////////C
C--------------------------------------------------------------------C
            DO WHILE ((modif>0).AND.(compt<80))
              modif = 0
C---------------Prereading of options for tag of nodes---------------C
              IF (p==nsubdom_loc) THEN
                CALL r2r_prelec(iparts,
     2                 ipartc,ipartg,ipartt,ipartp,ipartr,ipartsp,compt_t2,
     3                 modif,compt,inom_opt,nspcondn,nsphion,ipart_l,memtr,
     4                 pm_stack ,iworksh   ,igrnod  ,igrsurf ,igrslin ,
     5                 igrbric  ,igrquad   ,igrsh4n ,igrsh3n ,igrtruss,
     6                 igrbeam  ,igrspring ,new_nslash_int,lsubmodel,new_hm_ninter,
     7                 new_nintsub,new_ninivol,ixs10,ixs20,ixs16,
     8                 detonators,nsensor,seatbelt_shell_to_spring,nb_seatbelt_shells)
              ENDIF
C---------------Tag of nodes of pretaged elements ( for TYPE2)-------C
              IF (compt_t2>0) THEN
                CALL tagnods_r2r(ixs,ixs10,ixs20,ixs16,tag_els,tagno,2,1)
                CALL tagnod_r2r(ixc,nixc,2,5,numelc,tag_elc,tagno,npart,2,1)
                CALL tagnod_r2r(ixtg,nixtg,2,4,numeltg,tag_elg,tagno,npart,2,1)
                CALL tagnod_r2r(ixt,nixt,2,3,numelt,tag_elt,tagno,npart,2,1)
                CALL tagnod_r2r(ixp,nixp,2,4,numelp,tag_elp,tagno,npart,2,1)
              ENDIF
              compt = compt+1
            END DO ! DO WHILE
C---------------Tag of nodes ALE/lagrange ---------------------------C
            IF (iale>0) THEN
              CALL ale_check_lag(nale_r2r,ixs,ixq,ixc,ixt,ixtg,pm,itab,nale_r2r,0,igeo_)
            ENDIF
C---------------Check of FLG_FSI ------------------------------------C
            IF (iale+ieuler>0) THEN
              CALL chk_flg_fsi(ixs,pm,iparts,ale_euler,igeo_)
            ENDIF
C---------------Error message infinite loop -------------------------C
            IF (compt>=80) THEN
              CALL ancmsg(msgid=972,
     .                    msgtype=msgerror,
     .                    anmode=aninfo)
            END IF
C--------------------------------------------------------------------C
C////////////////////////////////////////////////////////////////////C
C--------------------------------------------------------------------C
C---------------Update of number of remaining options----------------C
            nrbody  = new_nrby
            nrbykin = new_nrbykin
            njoint  = new_njoint
            ninter_prec = ninter
            hm_ninter   = new_hm_ninter
            ninter      = new_hm_ninter + new_ninter - new_nintsub
            nslash(kinter) = new_nslash_int
            nintsub = new_nintsub
            num_inivol = new_ninivol
C
            nlink = new_nlink
            nrbe3 = new_nrbe3
            nrbe2 = new_nrbe2
            ngjoint = new_ngjoint
            nummpc = new_nummpc
            nspcond = nspcondn
            nsphio = nsphion
C---------------Determination of flag for coupled sph particles------C
            flg_sph = 0
            DO j=1,numsph
              IF (tagno(kxsp(nisp*(j-1)+3)+npart)>1) flg_sph = 1
            END DO
C---------------Counting of remaining nodes--------------------------C
            compt = 0
            DO j=1,numnod
              IF (tagno(j+npart)>1) innod = innod+1
            ENDDO
C---------------Warnings for size of interfaces ---------------------C
            IF (innod==0) THEN
              CALL ancmsg(msgid=839,
     .                  msgtype=msgerror,
     .                  anmode=aninfo,
     .                     c1="CONNECTIONS FOUND",
     .                     c2="FOR DOMAIN",
     .                     i1=isubdom(1,p))
            ELSE
C--         For SPH big multidomains interfaces are alloxed -> no error message only a warning
              IF ((flg_sph==1).OR.(flg_fsi==1)) r2r_flag_err_off = 1
C
              fac = (100*innod) / numnod
              IF (((fac>20).AND.(fac<50)).OR.((r2r_flag_err_off==1).AND.(fac>50))) THEN
                CALL ancmsg(msgid=859,
     .                      msgtype=msgwarning,
     .                      anmode=aninfo_blind_1,
     .                      i1=innod,
     .                      i2=fac)
              ELSEIF (fac>50) THEN
                flg_r2r_err = 1
                CALL ancmsg(msgid=1075,
     .                      msgtype=msgerror,
     .                      anmode=aninfo_blind_1,
     .                      i1=innod,
     .                      i2=fac)
              ENDIF
            ENDIF
C---------------Warnings for splitted contact interfaces ------------C
            IF (tagint_warn(1)>0) THEN
              CALL ancmsg(msgid=842,
     .                    msgtype=msgwarning,
     .                    anmode=aninfo_blind_1)
              WRITE(iout,1301)
              WRITE(iout,1302) (tagint_warn(1+j),j=1,tagint_warn(1))
            ENDIF
C--------------------------------------------------------------------C
          ELSE
C--------------------------------------------------------------------C
C---------------FLAG = 1 --> Creation of groups and links------------C
C--------------------------------------------------------------------C
            innod = 0
            nn = 4
C
C---------------Tag of nodes with nlocal dof-------------------------C
            IF (nloc_dmg%IMOD > 0) THEN
              nn = 5
              CALL my_alloc(tag_nlocal,numnod)
              tag_nlocal(1:numnod) = 0
              CALL tagnod_r2r_nl(ixc,ixtg,ixs,ixs10,ixs20,
     .                           ixs16,tag_nlocal,mat_param)
            ENDIF
C
            DO k=1,nn
              compt = 0
              iad_tmp = iad
C-----------Storage inside buffer------------------------------------C
              IF (k < 5) THEN
                DO j=1,numnod
                  IF (tagno(j+npart)==(k+n)) THEN
                    buf_nod(iad)=j
                    iad=iad+1
                    compt = compt+1
                  ENDIF
                ENDDO
              ELSE
C-----------Nodes in link type 4 + nlocal dof -> additional link-----C
C-----------Node coupled only if nl material on both sides ----------C
                DO j=1,numnod
                  IF ((tag_nlocal(j)==1).AND.(tagno(j+npart+numnod) == n+1)) THEN
                    buf_nod(iad)=j
                    iad=iad+1
                    compt = compt+1
                  ENDIF
                ENDDO
              ENDIF
C
              innod = innod + compt
              IF (compt>0) THEN
C---------------Creation of new GRNOD + LINK ------------------------C
                IF (k == 1) THEN
                  titr="MULTIDOMAINS INTERFACE TYPE CONNECTION "
                ELSEIF (k == 2) THEN
                  titr="MULTIDOMAINS INTERFACE TYPE RBODY CONNECTION "
                ELSEIF (k == 4) THEN
                  titr="MULTIDOMAINS INTERFACE TYPE KINEMATIC CONDITION"
                ELSEIF (k == 5) THEN
                  titr="MULTIDOMAINS INTERFACE TYPE NON LOCAL"
                ELSE
                  titr="MULTIDOMAINS INTERFACE TYPE CONTACT "
                ENDIF
!---
                igroup_temp2(1,igs)= num
                igroup_temp2(2,igs)= compt
                igroup_temp2(3,igs)= iad_tmp
                igroup_temp2(10,igs)= -1  ! temporary tag new group
                new_title(igs) = titr
!---
C---------------Creation of new LINK---------------------------------C
                CALL new_link(num,n,k)
C---------------Incrementation of Variables for future GRNOD---------C
                num = num+1
                igs = igs+1
                IF (compt>0) n_lnk_c = n_lnk_c+1
              ENDIF
            END DO
            IF (innod==0) THEN
              IF (ipid/=0) THEN
              ENDIF
              CALL ancmsg(msgid=839,
     .                    msgtype=msgerror,
     .                    anmode=aninfo,
     .                    c1="CONNECTIONS FOUND",
     .                    c2="FOR DOMAIN",
     .                    i1=isubdom(1,p))
            ENDIF
c
            IF (nloc_dmg%IMOD > 0) THEN
              DEALLOCATE(tag_nlocal)
            ENDIF
          ENDIF
        END DO
C--------------------------------------------------------------------C
C----- Recopy of other groups in IGROUP_TEMP-------------------------C
C--------------------------------------------------------------------C
C----- Transfer of Igroup_temp in IGRN-------------------------------C
C--------------------------------------------------------------------C
        IF (flag == 1) THEN
          DO i=1,ngrnod
            DEALLOCATE(igrnod(i)%ENTITY)
          ENDDO
          DEALLOCATE(igrnod)
          ALLOCATE(igrnod(ngrnod+n_lnk_c))
          ngrnod = ngrnod+n_lnk_c
!
          DO i=1,ngrnod
            ALLOCATE(igrnod(i)%ENTITY(igroup_temp2(2,i)))
            igrnod(i)%ENTITY(1:igroup_temp2(2,i)) = 0
!
            igrnod(i)%ID        = igroup_temp2(1,i)    ! IGRN(1,*)
            igrnod(i)%NENTITY   = igroup_temp2(2,i)    ! IGRN(2,*)
            igrnod(i)%GRTYPE    = igroup_temp2(3,i)    ! IGRN(4,*)
            igrnod(i)%SORTED    = igroup_temp2(4,i)    ! IGRN(5,*)
            igrnod(i)%GRPGRP    = igroup_temp2(5,i)    ! IGRN(6,*)
            igrnod(i)%LEVEL     = igroup_temp2(6,i)    ! IGRN(7,*)
            igrnod(i)%TITLE     = new_title(i)         ! IGRN(11,*)
            igrnod(i)%R2R_ALL   = igroup_temp2(8,i)    ! IGRN(8,*)
            igrnod(i)%R2R_SHARE = igroup_temp2(9,i)    ! IGRN(9,*)
!
            IF (igroup_temp2(10,i) == -1) THEN
              iad_tmp = igroup_temp2(3,i)
              DO j=1,igroup_temp2(2,i)
!   "BUF_NOD" --> temporary array for shared boundary
                igrnod(i)%ENTITY(j) = buf_nod(iad_tmp+j-1)
              ENDDO
            ELSE
              iad_tmp = igroup_temp2(7,i)
              DO j=1,igroup_temp2(2,i)
                igrnod(i)%ENTITY(j) = igroup_temp2_buf(iad_tmp+j-1)
              ENDDO
            ENDIF
!
          END DO ! DO I=1,NGRNOD
        ENDIF ! IF (FLAG == 1)
C--------------------------------------------------------------------C
C----- Creation of file "_0000.r2r"----------------------------------C
C--------------------------------------------------------------------C
        IF (flag == 1) THEN
          IF (ipid/=0) THEN
            WRITE(istdo,'(A)')' .. MULTIDOMAINS INPUT FILE GENERATION'
            CALL r2r_input(iexlnk)
          ENDIF
        ENDIF
C--------------------------------------------------------------------C
C--------------------------------------------------------------------C
C--------------------------------------------------------------------C
        IF (flag == 1) DEALLOCATE(igroup_temp2)
        IF (flag == 1) THEN
          IF (ALLOCATED(igroup_temp2_buf))DEALLOCATE(igroup_temp2_buf)
        ENDIF
        RETURN
C--------------------------------------------------------------------C
1301    FORMAT( 1x,'LIST OF SPLITTED CONTACT INTERFACES : ')
1302    FORMAT( 1x,10i9)
 
      END SUBROUTINE r2r_group