OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
r2r_group.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| r2r_group ../starter/source/coupling/rad2rad/r2r_group.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| ale_check_lag ../starter/source/ale/ale_check_lag.F
29!|| ancmsg ../starter/source/output/message/message.f
30!|| chk_flg_fsi ../starter/source/coupling/rad2rad/routines_r2r.F
31!|| new_link ../starter/source/coupling/rad2rad/new_link.F
32!|| printcenter ../starter/source/starter/radioss_title.F
33!|| r2r_input ../starter/source/coupling/rad2rad/r2r_input.F
34!|| r2r_prelec ../starter/source/coupling/rad2rad/r2r_prelec.F
35!|| tagnod_r2r ../starter/source/coupling/rad2rad/tagnod_r2r.F
36!|| tagnod_r2r_nl ../starter/source/coupling/rad2rad/tagnod_r2r_nl.F
37!|| tagnod_r2r_s ../starter/source/coupling/rad2rad/tagnod_r2r.F
38!|| tagnods_r2r ../starter/source/coupling/rad2rad/tagnod_r2r.F
39!||--- uses -----------------------------------------------------
40!|| detonators_mod ../starter/share/modules1/detonators_mod.F
41!|| group_mod ../starter/share/modules1/group_mod.F
42!|| inivol_def_mod ../starter/share/modules1/inivol_mod.F
43!|| message_mod ../starter/share/message_module/message_mod.F
44!|| r2r_mod ../starter/share/modules1/r2r_mod.F
45!|| reader_old_mod ../starter/share/modules1/reader_old_mod.F90
46!|| restmod ../starter/share/modules1/restart_mod.F
47!|| submodel_mod ../starter/share/modules1/submodel_mod.F
48!||====================================================================
49 SUBROUTINE r2r_group(
50 1 NGROU,INNOD,FLAG,IPARTS,
51 2 IPARTQ,IPARTC,IPARTT,IPARTP,IPARTR,IPARTG,
52 3 IPARTSP,IXS10,IXS20,IXS16,KK,BUF_NOD,IXR_KJ,
53 4 INOM_OPT,IPART_L,IAD,NALE_R2R,FLG_R2R_ERR ,
54 5 PM_STACK ,IWORKSH ,IGRBRIC2,IGRQUAD2 ,IGRSH4N2,
55 6 IGRSH3N2 ,IGRTRUSS2,IGRBEAM2,IGRSPRING2,IGRNOD2 ,
56 7 IGRSURF2 ,IGRSLIN2,LSUBMODEL,ALE_EULER,IGEO_,
57 8 NLOC_DMG ,DETONATORS,SEATBELT_SHELL_TO_SPRING,
58 9 NB_SEATBELT_SHELLS,MAT_PARAM,NEBCS)
59C-----------------------------------------------
60C M o d u l e s
61C-----------------------------------------------
62 USE my_alloc_mod
63 USE restmod
64 USE r2r_mod
65 USE message_mod
66 USE groupdef_mod
67 USE group_mod
68 USE inoutfile_mod
69 USE submodel_mod
70 USE inivol_def_mod , ONLY : num_inivol
71 USE nlocal_reg_mod
72 USE detonators_mod
73 USE matparam_def_mod
74 USE names_and_titles_mod , ONLY : nchartitle
75 USE reader_old_mod , ONLY : kinter, nslash
76 use element_mod , only : nixs,nixq,nixc,nixt,nixp,nixr,nixtg
77C-----------------------------------------------
78C I m p l i c i t T y p e s
79C-----------------------------------------------
80#include "implicit_f.inc"
81C-----------------------------------------------
82C A r g u m e n t s
83C-----------------------------------------------
84 INTEGER,INTENT(IN) :: IGEO_(NPROPGI,NUMGEO)
85C-----------------------------------------------
86C C o m m o n B l o c k s
87C-----------------------------------------------
88#include "com01_c.inc"
89#include "com04_c.inc"
90#include "units_c.inc"
91#include "scr17_c.inc"
92#include "param_c.inc"
93#include "sphcom.inc"
94#include "r2r_c.inc"
95C-----------------------------------------------
96C D u m m y A r g u m e n t s
97C-----------------------------------------------
98 TYPE(submodel_data) LSUBMODEL(NSUBMOD)
99 INTEGER NGROU,
100 . BUF_NOD(*),INNOD,FLAG,KK,
101 . IPARTS(*),IXS10(6,*),IXS20(12,*),
102 . IXS16(8,*),IPARTQ(*),IPARTSP(*),
103 . IPARTC(*),IPARTT(*),IPARTP(*),IPARTR(*),
104 . IPARTG(*),IXR_KJ(*),INOM_OPT(*),IPART_L(*),IAD,
105 . NALE_R2R(*),FLG_R2R_ERR,IWORKSH(*),ALE_EULER
106 INTEGER ,INTENT(IN) :: NB_SEATBELT_SHELLS
107 INTEGER ,INTENT(IN) :: SEATBELT_SHELL_TO_SPRING(NUMELC,2)
108 INTEGER ,INTENT(INOUT) :: NEBCS
109 my_real :: PM_STACK(*)
110 TYPE (NLOCAL_STR_) ,INTENT(IN) :: NLOC_DMG
111 TYPE (DETONATORS_STRUCT_),TARGET,INTENT(IN) :: DETONATORS
112 TYPE (MATPARAM_STRUCT_) ,DIMENSION(NUMMAT) ,INTENT(IN) :: MAT_PARAM
113C-----------------------------------------------
114! TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD2
115 TYPE (GROUP_) , DIMENSION(NGROU) :: IGRNOD2
116 TYPE (GROUP_) , DIMENSION(NGRBRIC) :: IGRBRIC2
117 TYPE (GROUP_) , DIMENSION(NGRQUAD) :: IGRQUAD2
118 TYPE (GROUP_) , DIMENSION(NGRSHEL) :: IGRSH4N2
119 TYPE (GROUP_) , DIMENSION(NGRSH3N) :: IGRSH3N2
120 TYPE (GROUP_) , DIMENSION(NGRTRUS) :: IGRTRUSS2
121 TYPE (GROUP_) , DIMENSION(NGRBEAM) :: IGRBEAM2
122 TYPE (GROUP_) , DIMENSION(NGRSPRI) :: IGRSPRING2
123 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF2
124 TYPE (SURF_) , DIMENSION(NSLIN) :: IGRSLIN2
125C-----------------------------------------------
126C L o c a l V a r i a b l e s
127C-----------------------------------------------
128 INTEGER STAT,I,J,IGR,IGRS,N,NUM,K,ADD,COMPT,IGS,IPID_L
129 INTEGER ID_TEMP(NB_PART_SUB),NSUBDOM_LOC,P,TMP_PART(NPART)
130 INTEGER, DIMENSION(:,:), ALLOCATABLE :: IGROUP_TEMP2
131 INTEGER N_LNK_C,NI,GRM,GRS,MAIN,IGU,NUL,IAD_TMP,COMPT_T2
132 INTEGER MODIF,NINTER_PREC,FAC,IO_ERR,NUM_KJ,NSPCONDN,NSPHION,NN
133 INTEGER MEMTR(NUMNOD),FLG_SPH,COUNT,NEW_NSLASH_INT,NEW_HM_NINTER,NEW_NINTSUB,NEW_NINIVOL
134 INTEGER NEW_NEBCS
135 CHARACTER(LEN=NCHARTITLE) :: TITR
136 CHARACTER NAME*100
137 INTEGER NGRNOD2,NGRBRIC2,NGRQUAD2,NGRSHEL2,NGRSH3N2,NGRTRUS2,NGRBEAM2,NGRSPRI2,LENGRN,ITITLE(LTITR)
138 CHARACTER(LEN=NCHARTITLE) :: NEW_TITLE(NGROU+10*NSUBDOM)
139 INTEGER, DIMENSION(:), ALLOCATABLE :: IGROUP_TEMP2_BUF,TAG_NLOCAL
140 INTEGER :: LEN_TMP_NAME
141 CHARACTER(len=4096) :: TMP_NAME
142C-----------------------------------------------
143 n_lnk_c = 0
144 tmp_part(:)= 0
145 modif = 1
146 innod = 0
147C----- Storage of IGRN in IGRN Temp------------------------------C
148 lengrn = 9
149 IF (flag == 1) THEN
150 ALLOCATE(igroup_temp2(10,ngrou+10*nsubdom))
151 igroup_temp2 = 0
152 count = 0
153 DO i=1,ngrou
154 count = count + igrnod2(i)%NENTITY
155 ENDDO
156 IF (count > 0) THEN
157 ALLOCATE(igroup_temp2_buf(count))
158 igroup_temp2_buf(:) = 0
159 ENDIF
160 iad_tmp = 1
161!
162 DO i=1,ngrou
163 igroup_temp2(1,i) = igrnod2(i)%ID ! IGRN(1,*)
164 igroup_temp2(2,i) = igrnod2(i)%NENTITY ! IGRN(2,*)
165 igroup_temp2(3,i) = igrnod2(i)%GRTYPE ! IGRN(4,*)
166 igroup_temp2(4,i) = igrnod2(i)%SORTED ! IGRN(5,*)
167 igroup_temp2(5,i) = igrnod2(i)%GRPGRP ! IGRN(6,*)
168 igroup_temp2(6,i) = igrnod2(i)%LEVEL ! IGRN(7,*)
169 new_title(i) = igrnod2(i)%TITLE ! IGRN(11,*)
170 igroup_temp2(8,i) = igrnod2(i)%R2R_ALL ! IGRN(8,*)
171 igroup_temp2(9,i) = igrnod2(i)%R2R_SHARE ! IGRN(9,*)
172 igroup_temp2(7,i) = iad_tmp
173 DO j=1,igrnod2(i)%NENTITY
174 igroup_temp2_buf(iad_tmp) = igrnod2(i)%ENTITY(j)
175 iad_tmp = iad_tmp + 1
176 ENDDO
177 ENDDO
178 ENDIF
179C--------------------------------------------------------------------C
180C------Creation of groups of nodes of multidomains interface---------C
181C--------------------------------------------------------------------C
182!
183 ngrnod2 = ngrnod
184 ngrbric2 = ngrbric
185 ngrquad2 = ngrquad
186 ngrshel2 = ngrshel
187 ngrsh3n2 = ngrsh3n
188 ngrtrus2 = ngrtrus
189 ngrbeam2 = ngrbeam
190 ngrspri2 = ngrspri
191!
192 IF (flag == 1) THEN
193 num = 1
194 igs = ngrou+1
195 DO i=1,ngrou
196 IF (num<=igrnod2(i)%ID) num=igrnod2(i)%ID+1
197 END DO
198 ENDIF
199C--------------------------------------------------------------------C
200 IF (ipid==0) nsubdom = 1
201 nsubdom_loc = nsubdom
202 DO p=1,nsubdom_loc
203C----- 2 Pass: Pass 1-Nodes / Pass 2-Nodes Connection
204 n = p
205 IF (ipid==0) n = iddom
206 compt = 0
207C--------------------------------------------------------------------C
208C---------------FLAG = 0 --> tag of nodes and counting --------------C
209C--------------------------------------------------------------------C
210 IF (flag==0) THEN
211C---------------Reset of out file + printout of new heading ---------C
212 ipid_l = ipid
213 IF (flg_swale==1) THEN
214 IF (ipid==0) ipid_l = 1
215 IF (ipid/=0) ipid_l = 0
216 ENDIF
217 IF (ipid_l==0) THEN
218 CLOSE(unit=iout, status='delete',IOSTAT=IO_ERR)
219
220 TMP_NAME=OUTFILE_NAME(1:OUTFILE_NAME_LEN)//R2R_FILNAM(1:LEN_TRIM(R2R_FILNAM))
221 LEN_TMP_NAME = OUTFILE_NAME_LEN+LEN_TRIM(R2R_FILNAM)
222 OPEN(UNIT=IOUT,FILE=TMP_NAME(1:LEN_TMP_NAME),
223 . ACCESS='sequential',
224 . FORM='formatted',STATUS='unknown')
225 NAME = "SUBDOMAIN "//R2R_FILNAM(1:(LEN_TRIM(R2R_FILNAM)-9))
226 WRITE (IOUT,'(a)') ''
227 CALL PRINTCENTER(" ",0,IOUT,1)
228 CALL PRINTCENTER(" ",0,IOUT,2)
229 CALL PRINTCENTER(NAME,LEN_TRIM(NAME),IOUT,2)
230 CALL PRINTCENTER(" ",0,IOUT,2)
231 CALL PRINTCENTER(" ",0,IOUT,1)
232 ENDIF
233C---------------Allocation of arrays for tag of elements--------------C
234 ALLOCATE(TAG_ELC(NUMELC+NPART),TAG_ELS(NUMELS+NPART))
235 ALLOCATE(TAG_ELG(NUMELTG+NPART),TAG_ELSP(NUMSPH+NPART))
236 ALLOCATE(TAG_ELR(NUMELR+NPART),TAG_ELT(NUMELT+NPART))
237 ALLOCATE(TAG_ELP(NUMELP+NPART),TAG_ELQ(NUMELQ+NPART))
238 TAG_ELS(:)=0
239 TAG_ELC(:)=0
240 TAG_ELG(:)=0
241 TAG_ELT(:)=0
242 TAG_ELP(:)=0
243 TAG_ELR(:)=0
244 TAG_ELQ(:)=0
245 TAG_ELSP(:)=0
246C---------------Tag of Parts-------------------------------------------C
247 DO K=1,NPART
248 TAGNO(K)=0
249C ---> TAGNO(K)=-1 => PART K belongs to an already treated subdomain---
250 IF(TMP_PART(K)==-1) TAGNO(K)=-1
251 ENDDO
252 ADD = ISUBDOM(3,N)
253 DO K=1,NPART
254 DO I=1,ISUBDOM(1,N)
255 IF(K == ISUBDOM_PART(I+ADD))THEN
256 TAGNO(K)=1
257 TMP_PART(K)=-1
258 ENDIF
259 ENDDO
260 END DO
261C----------------Full domain - inversion of part selection-------------C
262 IF (IDDOM == 0) THEN
263 DO K=1,NPART
264 IF(TAGNO(K)==1) THEN
265 TAGNO(K)=0
266 ELSEIF(TAGNO(K)==0) THEN
267 TAGNO(K)=1
268 ENDIF
269 ENDDO
270 ENDIF
271C---------------> TAG OF PARTS : ----------------------------------
272C---------------> TAGNO(K) = -1 -> Part of already treated subdmain
273C---------------> TAGNO(K) = 0 -> Internal part of subdomain
274C---------------> TAGNO(K) = 1 -> External part of subdomain
275
276C---------------> TAG OF NODES : ----------------------------------
277C---------------> TAGNO(K) = -1 -> external node
278C---------------> TAGNO(K) = 0 -> free node (not attached to any domain)
279C---------------> TAGNO(K) = 1 -> internal node
280C---------------> TAGNO(K) = 2 -> coupled node
281C---------------> TAGNO(K) = 3 -> coupled node -> main node of RBODY
282C---------------> TAGNO(K) = 4 -> coupled node for contacts
283C---------------Detag of already treated nodes----------------------C
284 CALL TAGNODS_R2R(IXS,IXS10,IXS20,IXS16,IPARTS,TAGNO,-1,N)
285 CALL TAGNOD_R2R(IXQ,NIXQ,2,5,NUMELQ,IPARTQ,TAGNO,NPART,-1,N)
286 CALL TAGNOD_R2R(IXC,NIXC,2,5,NUMELC,IPARTC,TAGNO,NPART,-1,N)
287 CALL TAGNOD_R2R(IXT,NIXT,2,3,NUMELT,IPARTT,TAGNO,NPART,-1,N)
288 CALL TAGNOD_R2R(IXP,NIXP,2,4,NUMELP,IPARTP,TAGNO,NPART,-1,N)
289 CALL TAGNOD_R2R(IXR,NIXR,2,3,NUMELR,IPARTR,TAGNO,NPART,-1,N)
290 CALL TAGNOD_R2R(IXTG,NIXTG,2,4,NUMELTG,IPARTG,TAGNO,NPART,-1,N)
291 CALL TAGNOD_R2R(KXSP,NISP,3,3,NUMSPH,IPARTSP,TAGNO,NPART,-1,N)
292C---------------Tag of nodes -> pass 1------------------------------C
293 CALL TAGNODS_R2R(IXS,IXS10,IXS20,IXS16,IPARTS,TAGNO,0,N)
294 CALL TAGNOD_R2R(IXQ,NIXQ,2,5,NUMELQ,IPARTQ,TAGNO,NPART,0,N)
295 CALL TAGNOD_R2R(IXC,NIXC,2,5,NUMELC,IPARTC,TAGNO,NPART,0,N)
296 CALL TAGNOD_R2R(IXT,NIXT,2,3,NUMELT,IPARTT,TAGNO,NPART,0,N)
297 CALL TAGNOD_R2R(IXP,NIXP,2,3,NUMELP,IPARTP,TAGNO,NPART,0,N)
298 CALL TAGNOD_R2R(IXR,NIXR,2,3,NUMELR,IPARTR,TAGNO,NPART,0,N)
299 CALL TAGNOD_R2R(IXTG,NIXTG,2,4,NUMELTG,IPARTG,TAGNO,NPART,0,N)
300 CALL TAGNOD_R2R(KXSP,NISP,3,3,NUMSPH,IPARTSP,TAGNO,NPART,0,N)
301C---------------Tag of nodes -> pass 2-------------------------------C
302 CALL TAGNODS_R2R(IXS,IXS10,IXS20,IXS16,IPARTS,TAGNO,1,N)
303 CALL TAGNOD_R2R(IXQ,NIXQ,2,5,NUMELQ,IPARTQ,TAGNO,NPART,1,N)
304 CALL TAGNOD_R2R(IXC,NIXC,2,5,NUMELC,IPARTC,TAGNO,NPART,1,N)
305 CALL TAGNOD_R2R(IXT,NIXT,2,3,NUMELT,IPARTT,TAGNO,NPART,1,N)
306 CALL TAGNOD_R2R(IXP,NIXP,2,3,NUMELP,IPARTP,TAGNO,NPART,1,N)
307 CALL TAGNOD_R2R(IXR,NIXR,2,3,NUMELR,IPARTR,TAGNO,NPART,1,N)
308 CALL TAGNOD_R2R(IXTG,NIXTG,2,4,NUMELTG,IPARTG,TAGNO,NPART,1,N)
309 CALL TAGNOD_R2R(KXSP,NISP,3,3,NUMSPH,IPARTSP,TAGNO,NPART,1,N)
310C---------------Tag of 3rd nodes of beams/springs -> pass 3----------C
311 CALL TAGNOD_R2R(IXP,NIXP,4,4,NUMELP,IPARTP,TAGNO,NPART,3,N)
312 CALL TAGNOD_R2R(IXR,NIXR,4,4,NUMELR,IPARTR,TAGNO,NPART,3,N)
313C---------------Tag of additional nodes for kjoints-- --------------C
314 CALL TAGNOD_R2R(IXR_KJ,5,1,3,NUMELR,IPARTR,TAGNO,NPART,4,N)
315C---------------Tag of specific nodes -> Skew,Frames-----------------C
316 IF (P==NSUBDOM_LOC) CALL TAGNOD_R2R_S(TAGNO)
317C---------------Storage of initial tag of nodes----------------------C
318 DO I=1,NUMNOD
319 TAGNO(NPART+NUMNOD+I) = TAGNO(NPART+I)
320 END DO
321C--------------------------------------------------------------------C
322C////////////////////////////////////////////////////////////////////C
323C--------------------------------------------------------------------C
324.AND. DO WHILE ((MODIF>0)(COMPT<80))
325 MODIF = 0
326C---------------Prereading of options for tag of nodes---------------C
327 IF (P==NSUBDOM_LOC) THEN
328 CALL R2R_PRELEC(IPARTS,
329 2 IPARTC,IPARTG,IPARTT,IPARTP,IPARTR,IPARTSP,COMPT_T2,
330 3 MODIF,COMPT,INOM_OPT,NSPCONDN,NSPHION,IPART_L,MEMTR,
331 4 PM_STACK ,IWORKSH ,IGRNOD ,IGRSURF ,IGRSLIN ,
332 5 IGRBRIC ,IGRQUAD ,IGRSH4N ,IGRSH3N ,IGRTRUSS,
333 6 IGRBEAM ,IGRSPRING ,NEW_NSLASH_INT,LSUBMODEL,NEW_HM_NINTER,
334 7 NEW_NINTSUB,NEW_NINIVOL,IXS10,IXS20,IXS16,
335 8 DETONATORS,SEATBELT_SHELL_TO_SPRING,NB_SEATBELT_SHELLS,
336 9 NEBCS,NEW_NEBCS)
337 ENDIF
338C---------------Tag of nodes of pretaged elements ( for TYPE2)-------C
339 IF (COMPT_T2>0) THEN
340 CALL TAGNODS_R2R(IXS,IXS10,IXS20,IXS16,TAG_ELS,TAGNO,2,1)
341 CALL TAGNOD_R2R(IXC,NIXC,2,5,NUMELC,TAG_ELC,TAGNO,NPART,2,1)
342 CALL TAGNOD_R2R(IXTG,NIXTG,2,4,NUMELTG,TAG_ELG,TAGNO,NPART,2,1)
343 CALL TAGNOD_R2R(IXT,NIXT,2,3,NUMELT,TAG_ELT,TAGNO,NPART,2,1)
344 CALL TAGNOD_R2R(IXP,NIXP,2,4,NUMELP,TAG_ELP,TAGNO,NPART,2,1)
345 ENDIF
346 COMPT = COMPT+1
347 END DO ! DO WHILE
348C---------------Tag of nodes ALE/lagrange ---------------------------C
349 IF (IALE>0) THEN
350 CALL ALE_CHECK_LAG(NALE_R2R,IXS,IXQ,IXC,IXT,IXTG,PM,ITAB,NALE_R2R,0,IGEO_)
351 ENDIF
352C---------------Check of FLG_FSI ------------------------------------C
353 IF (IALE+IEULER>0) THEN
354 CALL CHK_FLG_FSI(IXS,PM,IPARTS,ALE_EULER,IGEO_)
355 ENDIF
356C---------------Error message infinite loop -------------------------C
357 IF (COMPT>=80) THEN
358 CALL ANCMSG(MSGID=972,
359 . MSGTYPE=MSGERROR,
360 . ANMODE=ANINFO)
361 END IF
362C--------------------------------------------------------------------C
363C////////////////////////////////////////////////////////////////////C
364C--------------------------------------------------------------------C
365C---------------Update of number of remaining options----------------C
366 NRBODY = NEW_NRBY
367 NRBYKIN = NEW_NRBYKIN
368 NJOINT = NEW_NJOINT
369 NINTER_PREC = NINTER
370 HM_NINTER = NEW_HM_NINTER
371 NINTER = NEW_HM_NINTER + NEW_NINTER - NEW_NINTSUB
372 NSLASH(KINTER) = NEW_NSLASH_INT
373 NINTSUB = NEW_NINTSUB
374 NUM_INIVOL = NEW_NINIVOL
375C
376 NLINK = NEW_NLINK
377 NRBE3 = NEW_NRBE3
378 NRBE2 = NEW_NRBE2
379 NGJOINT = NEW_NGJOINT
380 NUMMPC = NEW_NUMMPC
381 NSPCOND = NSPCONDN
382 NSPHIO = NSPHION
383 NEBCS = NEW_NEBCS
384C---------------Determination of flag for coupled sph particles------C
385 FLG_SPH = 0
386 DO J=1,NUMSPH
387 IF (TAGNO(KXSP(NISP*(J-1)+3)+NPART)>1) FLG_SPH = 1
388 END DO
389C---------------Counting of remaining nodes--------------------------C
390 COMPT = 0
391 DO J=1,NUMNOD
392 IF (TAGNO(J+NPART)>1) INNOD = INNOD+1
393 ENDDO
394C---------------Warnings for size of interfaces ---------------------C
395 IF (INNOD==0) THEN
396 CALL ANCMSG(MSGID=839,
397 . MSGTYPE=MSGERROR,
398 . ANMODE=ANINFO,
399 . C1="CONNECTIONS FOUND",
400 . C2="FOR DOMAIN",
401 . I1=ISUBDOM(1,P))
402 ELSE
403C-- For SPH big multidomains interfaces are alloxed -> no error message only a warning
404.OR. IF ((FLG_SPH==1)(FLG_FSI==1)) R2R_FLAG_ERR_OFF = 1
405C
406 FAC = (100*INNOD) / NUMNOD
407.AND..OR..AND. IF (((FAC>20)(FAC<50))((R2R_FLAG_ERR_OFF==1)(FAC>50))) THEN
408 CALL ANCMSG(MSGID=859,
409 . MSGTYPE=MSGWARNING,
410 . ANMODE=ANINFO_BLIND_1,
411 . I1=INNOD,
412 . I2=FAC)
413 ELSEIF (FAC>50) THEN
414 FLG_R2R_ERR = 1
415 CALL ANCMSG(MSGID=1075,
416 . MSGTYPE=MSGERROR,
417 . ANMODE=ANINFO_BLIND_1,
418 . I1=INNOD,
419 . I2=FAC)
420 ENDIF
421 ENDIF
422C---------------Warnings for splitted contact interfaces ------------C
423 IF (TAGINT_WARN(1)>0) THEN
424 CALL ANCMSG(MSGID=842,
425 . MSGTYPE=MSGWARNING,
426 . ANMODE=ANINFO_BLIND_1)
427 WRITE(IOUT,1301)
428 WRITE(IOUT,1302) (TAGINT_WARN(1+J),J=1,TAGINT_WARN(1))
429 ENDIF
430C--------------------------------------------------------------------C
431 ELSE
432C--------------------------------------------------------------------C
433C---------------FLAG = 1 --> Creation of groups and links------------C
434C--------------------------------------------------------------------C
435 INNOD = 0
436 NN = 4
437C
438C---------------Tag of nodes with nlocal dof-------------------------C
439 IF (NLOC_DMG%IMOD > 0) THEN
440 NN = 5
441 CALL MY_ALLOC(TAG_NLOCAL,NUMNOD)
442 TAG_NLOCAL(1:NUMNOD) = 0
443 CALL TAGNOD_R2R_NL(IXC,IXTG,IXS,IXS10,IXS20,
444 . IXS16,TAG_NLOCAL,MAT_PARAM)
445 ENDIF
446C
447 DO K=1,NN
448 COMPT = 0
449 IAD_TMP = IAD
450C-----------Storage inside buffer------------------------------------C
451 IF (K < 5) THEN
452 DO J=1,NUMNOD
453 IF (TAGNO(J+NPART)==(K+N)) THEN
454 BUF_NOD(IAD)=J
455 IAD=IAD+1
456 COMPT = COMPT+1
457 ENDIF
458 ENDDO
459 ELSE
460C-----------Nodes in link type 4 + nlocal dof -> additional link-----C
461C-----------Node coupled only if nl material on both sides ----------C
462 DO J=1,NUMNOD
463.AND. IF ((TAG_NLOCAL(J)==1)(TAGNO(J+NPART+NUMNOD) == N+1)) THEN
464 BUF_NOD(IAD)=J
465 IAD=IAD+1
466 COMPT = COMPT+1
467 ENDIF
468 ENDDO
469 ENDIF
470C
471 INNOD = INNOD + COMPT
472 IF (COMPT>0) THEN
473C---------------Creation of new GRNOD + LINK ------------------------C
474 IF (K == 1) THEN
475 TITR="MULTIDOMAINS INTERFACE TYPE CONNECTION "
476 ELSEIF (K == 2) THEN
477 TITR="MULTIDOMAINS INTERFACE TYPE RBODY CONNECTION "
478 ELSEIF (K == 4) THEN
479 TITR="MULTIDOMAINS INTERFACE TYPE KINEMATIC CONDITION"
480 ELSEIF (K == 5) THEN
481 TITR="MULTIDOMAINS INTERFACE TYPE NON LOCAL"
482 ELSE
483 TITR="MULTIDOMAINS INTERFACE TYPE CONTACT "
484 ENDIF
485!---
486 IGROUP_TEMP2(1,IGS)= NUM
487 IGROUP_TEMP2(2,IGS)= COMPT
488 IGROUP_TEMP2(3,IGS)= IAD_TMP
489 IGROUP_TEMP2(10,IGS)= -1 ! temporary tag new group
490 NEW_TITLE(IGS) = TITR
491!---
492C---------------Creation of new LINK---------------------------------C
493 CALL NEW_LINK(NUM,N,K)
494C---------------Incrementation of Variables for future GRNOD---------C
495 NUM = NUM+1
496 IGS = IGS+1
497 IF (COMPT>0) N_LNK_C = N_LNK_C+1
498 ENDIF
499 END DO
500 IF (INNOD==0) THEN
501 IF (IPID/=0) THEN
502 ENDIF
503 CALL ANCMSG(MSGID=839,
504 . MSGTYPE=MSGERROR,
505 . ANMODE=ANINFO,
506 . C1="CONNECTIONS FOUND",
507 . C2="FOR DOMAIN",
508 . I1=ISUBDOM(1,P))
509 ENDIF
510c
511 IF (NLOC_DMG%IMOD > 0) THEN
512 DEALLOCATE(TAG_NLOCAL)
513 ENDIF
514 ENDIF
515 END DO
516C--------------------------------------------------------------------C
517C----- Recopy of other groups in IGROUP_TEMP-------------------------C
518C--------------------------------------------------------------------C
519C----- Transfer of Igroup_temp in IGRN-------------------------------C
520C--------------------------------------------------------------------C
521 IF (FLAG == 1) THEN
522 DO I=1,NGRNOD
523 DEALLOCATE(IGRNOD(I)%ENTITY)
524 ENDDO
525 DEALLOCATE(IGRNOD)
526 ALLOCATE(IGRNOD(NGRNOD+N_LNK_C))
527 NGRNOD = NGRNOD+N_LNK_C
528!
529 DO I=1,NGRNOD
530 ALLOCATE(IGRNOD(I)%ENTITY(IGROUP_TEMP2(2,I)))
531 IGRNOD(I)%ENTITY(1:IGROUP_TEMP2(2,I)) = 0
532!
533 IGRNOD(I)%ID = IGROUP_TEMP2(1,I) ! IGRN(1,*)
534 IGRNOD(I)%NENTITY = IGROUP_TEMP2(2,I) ! IGRN(2,*)
535 IGRNOD(I)%GRTYPE = IGROUP_TEMP2(3,I) ! IGRN(4,*)
536 IGRNOD(I)%SORTED = IGROUP_TEMP2(4,I) ! IGRN(5,*)
537 IGRNOD(I)%GRPGRP = IGROUP_TEMP2(5,I) ! IGRN(6,*)
538 IGRNOD(I)%LEVEL = IGROUP_TEMP2(6,I) ! IGRN(7,*)
539 IGRNOD(I)%TITLE = NEW_TITLE(I) ! IGRN(11,*)
540 IGRNOD(I)%R2R_ALL = IGROUP_TEMP2(8,I) ! IGRN(8,*)
541 IGRNOD(I)%R2R_SHARE = IGROUP_TEMP2(9,I) ! IGRN(9,*)
542!
543 IF (IGROUP_TEMP2(10,I) == -1) THEN
544 IAD_TMP = IGROUP_TEMP2(3,I)
545 DO J=1,IGROUP_TEMP2(2,I)
546! "BUF_NOD" --> temporary array for shared boundary
547 IGRNOD(I)%ENTITY(J) = BUF_NOD(IAD_TMP+J-1)
548 ENDDO
549 ELSE
550 IAD_TMP = IGROUP_TEMP2(7,I)
551 DO J=1,IGROUP_TEMP2(2,I)
552 IGRNOD(I)%ENTITY(J) = IGROUP_TEMP2_BUF(IAD_TMP+J-1)
553 ENDDO
554 ENDIF
555!
556 END DO ! DO I=1,NGRNOD
557 ENDIF ! IF (FLAG == 1)
558C--------------------------------------------------------------------C
559C----- Creation of file "_0000.r2r"----------------------------------C
560C--------------------------------------------------------------------C
561 IF (FLAG == 1) THEN
562 IF (IPID/=0) THEN
563 WRITE(ISTDO,'(a)')' .. multidomains input file generation'
564 CALL R2R_INPUT(IEXLNK)
565 ENDIF
566 ENDIF
567C--------------------------------------------------------------------C
568C--------------------------------------------------------------------C
569C--------------------------------------------------------------------C
570 IF (FLAG == 1) DEALLOCATE(IGROUP_TEMP2)
571 IF (FLAG == 1) THEN
572 IF (ALLOCATED(IGROUP_TEMP2_BUF))DEALLOCATE(IGROUP_TEMP2_BUF)
573 ENDIF
574 RETURN
575C--------------------------------------------------------------------C
5761301 FORMAT( 1X,'list of splitted contact interfaces : ')
5771302 FORMAT( 1X,10I9)
578
579 END SUBROUTINE R2R_GROUP
detonators_mod
Definition detonators_mod.F:80
group_mod
Definition group_mod.F:31
groupdef_mod
Definition groupdef_mod.F:668
inivol_def_mod
Definition inivol_mod.F:45
inivol_def_mod::num_inivol
integer num_inivol
Definition inivol_mod.F:85
inoutfile_mod
Definition inoutfile_mod.F:96
message_mod
Definition message_mod.F:1257
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1008
nlocal_reg_mod
Definition nlocal_reg_mod.F:119
r2r_mod
Definition r2r_mod.F:125
submodel_mod
Definition submodel_mod.F:717
r2r_group
subroutine r2r_group(ngrou, innod, flag, iparts, ipartq, ipartc, ipartt, ipartp, ipartr, ipartg, ipartsp, ixs10, ixs20, ixs16, kk, buf_nod, ixr_kj, inom_opt, ipart_l, iad, nale_r2r, flg_r2r_err, pm_stack, iworksh, igrbric2, igrquad2, igrsh4n2, igrsh3n2, igrtruss2, igrbeam2, igrspring2, igrnod2, igrsurf2, igrslin2, lsubmodel, ale_euler, igeo_, nloc_dmg, detonators, seatbelt_shell_to_spring, nb_seatbelt_shells, mat_param, nebcs)
Definition r2r_group.F:59
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:895
starter
program starter
Definition starter.F:39
submodel_mod::submodel_data
Definition submodel_mod.F:728