OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
r2r_void.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "units_c.inc"
#include "scr17_c.inc"
#include "param_c.inc"
#include "r2r_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine r2r_void (ipartl)
subroutine r2r_void_1d (id_part, ipartl)

Function/Subroutine Documentation

◆ r2r_void()

subroutine r2r_void ( integer, dimension(lipart1,npart), intent(inout) ipartl)

Definition at line 38 of file r2r_void.F.

39C-----------------------------------------------
40C M o d u l e s
41C-----------------------------------------------
42 USE my_alloc_mod
43 USE restmod
44 USE r2r_mod
45 USE message_mod
46 USE ddweights_mod
47 USE stack_var_mod
48 USE names_and_titles_mod , ONLY : nchartitle
49C-----------------------------------------------
50C I m p l i c i t T y p e s
51C-----------------------------------------------
52#include "implicit_f.inc"
53C-----------------------------------------------
54C C o m m o n B l o c k s
55C-----------------------------------------------
56#include "com01_c.inc"
57#include "com04_c.inc"
58#include "units_c.inc"
59#include "scr17_c.inc"
60#include "param_c.inc"
61#include "r2r_c.inc"
62C-----------------------------------------------
63C D u m m y A r g u m e n t s
64C-----------------------------------------------
65 INTEGER, INTENT(INOUT) :: IPARTL(LIPART1,NPART)
66C-----------------------------------------------
67C L o c a l V a r i a b l e s
68C-----------------------------------------------
69 INTEGER :: STAT,I,J,LEN1,LEN2,NUM,P,N
70 INTEGER :: K,ADD,COMPT,NB_PART,F2,IGTYP,L,PID,COMPT_STACK_TOT,COMPT_STACK
71 INTEGER :: COMPT_STACK_REMOV,COMPT_PCOMP_TOT,COMPT_PCOMP,COMPT_PCOMP_REMOV
72 INTEGER, DIMENSION(:), ALLOCATABLE :: NUMGEOSTACK1_TEMP,NUMGEOSTACK2_TEMP
73 INTEGER, DIMENSION(:,:), ALLOCATABLE :: IPM_TEMP,IGEO_TEMP
74 CHARACTER(LEN=NCHARTITLE) TITR
75 my_real :: alphai
76 my_real, DIMENSION(:,:), ALLOCATABLE :: pm_temp,geo_temp
77 my_real, DIMENSION(:,:,:), ALLOCATABLE :: ddw_temp
78C-----------------------------------------------
79
80 nummat0 = nummat
81 numgeo0 = numgeo
82
83C---------filling of array PM_R2R--------------------------------C
84 ALLOCATE (pm_r2r(nummat+npart+1),stat=stat)
85 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,msgtype=msgerror,c1='PM_R2R')
86 DO i=1,nummat
87 pm_r2r(i) = pm(npropm*(i-1)+20)
88 END DO
89
90 IF (ipid==0) nsubdom = 1
91
92C---------tag of external parts-----------------------------------C
93
94 DO p=1,nsubdom
95 n = p
96 IF (ipid==0) n = iddom
97 add = isubdom(3,n)
98 DO k=1,npart
99 DO i=1,isubdom(1,n)
100 IF(k == isubdom_part(i+add)) THEN
101 tag_part(k)=1
102 ENDIF
103 ENDDO
104 END DO
105 END DO
106
107 IF (ipid==0) THEN
108 DO p=1,npart
109 IF (tag_part(p)==1) THEN
110 tag_part(p)=0
111 ELSE
112 tag_part(p)=1
113 ENDIF
114 END DO
115 ENDIF
116
117C--------------------------------------------------------------C
118 compt = 0
119 compt_pcomp_tot = 0
120 compt_pcomp_remov = 0
121 compt_stack_tot = 0
122 compt_stack_remov = 0
123 ipart_pcompp = 0
124 ipart_stack = 0
125C
126 DO k=1,npart
127 ipart_r2r(1,k) = ipartl(1,k) !mat_id
128 ipart_r2r(2,k) = ipartl(5,k) !user_mat_id
129 ipart_r2r(3,k) = 0
130 igtyp = igeo(npropgi*(ipartl(2,k)-1)+11)
131 IF (igtyp==51) compt_stack_tot = compt_stack_tot + 1
132 IF (igtyp==52) compt_pcomp_tot = compt_pcomp_tot + 1
133 ipart_r2r(4,k) = ipartl(2,k) !prop_id
134 IF (tag_part(k)==1) THEN
135 compt=compt+1
136 IF ((igtyp==11).OR.(igtyp==16)) THEN
137C-- Multilayer shells to be changed to void
138 tag_part(k) = 2
139 ELSEIF (igtyp.EQ.52) THEN
140C-- /PROP/PCOMP shells to be changed to void
141 tag_part(k) = 3
142 compt_pcomp_remov = compt_pcomp_remov + 1
143 ELSEIF (igtyp.EQ.51) THEN
144C-- /PROP/TYPE51 shells to be changed to void
145 tag_part(k) = 4
146 compt_stack_remov = compt_stack_remov + 1
147 ENDIF
148 ENDIF
149 END DO
150
151 compt_pcomp = compt_pcomp_tot - compt_pcomp_remov
152 IF (compt_pcomp > 0) ipart_pcompp = 1
153 compt_stack = compt_stack_tot - compt_stack_remov
154 IF (compt_stack > 0) ipart_stack = 1
155
156 IF (compt==0) GOTO 150
157
158 WRITE(iout,1200)
159
160C---------Allocation of temporary arrays ----------------------C
161
162 nb_part = compt
163
164 ALLOCATE (ipm_temp(npropmi,nummat+nb_part),stat=stat)
165 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,msgtype=msgerror,c1='IPM_TEMP')
166 ALLOCATE (pm_temp(npropm,nummat+nb_part),stat=stat)
167 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,msgtype=msgerror,c1='PM_TEMP')
168 ALLOCATE (ddw_temp(2,2,nummat+nb_part+1),stat=stat)
169 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,msgtype=msgerror,c1='DDW_TEMP')
170
171 ipm_temp(:,:)=0
172 pm_temp(:,:)=0
173 ddw_temp(:,:,:)=0
174
175C---------Copy of arrays in temporary arrays -----------------C
176
177 DO i=1,nummat
178 DO j=1,npropmi
179 ipm_temp(j,i)=ipm(npropmi*(i-1)+j)
180 END DO
181 END DO
182
183 DO i=1,nummat
184 DO j=1,npropm
185 pm_temp(j,i)=pm(npropm*(i-1)+j)
186 END DO
187 END DO
188
189 DO i=1,nummat
190 DO j=1,2
191 DO l=1,2
192 ddw_temp(j,l,i)=ddweights(j,l,i)
193 ENDDO
194 END DO
195 END DO
196C
197 DO j=1,2
198 DO l=1,2
199 ddw_temp(j,l,nummat+nb_part+1)=ddweights(j,l,nummat+1)
200 ENDDO
201 END DO
202
203C--------------- offset of id for generated void materials--------C
204 num = 0
205 DO i=1,nummat
206 IF (num<=ipm_temp(1,i)) num=ipm_temp(1,i)
207 END DO
208
209C---------------Creation of new void materials -------------------C
210
211 DO k=1,npart
212 IF (tag_part(k)>=1) THEN
213
214 num = num+1
215 nummat = nummat+1
216C
217 IF ((tag_part(k)==1).OR.(tag_part(k)==3).OR.(tag_part(k) == 4)) THEN
218C--> standard elements
219 f2 = ipartl(1,k)
220 pm_temp(1,nummat)= 1e-20
221 pm_temp(19,nummat) =zero
222 pm_temp(20,nummat) = pm_temp(20,f2)
223 pm_r2r(nummat)= pm_temp(20,f2)
224 pm_temp(21,nummat) = pm_temp(21,f2)
225 pm_temp(32,nummat) = pm_temp(32,f2)
226 pm_temp(70,nummat) =zero
227 pm_temp(71,nummat) =zero
228 pm_temp(72,nummat) =zero
229 pm_temp(75,nummat) = pm_temp(75,f2)
230 pm_temp(76,nummat) = pm_temp(76,f2)
231 pm_temp(89,nummat) = pm_temp(1,nummat)
232 pm_temp(100,nummat) = pm_temp(100,f2)
233C
234 ELSE
235C--> Multilayer shells
236 pm_temp(1,nummat)= 1e-20
237 pm_temp(19,nummat) =zero
238 pm_temp(70,nummat) =zero
239 pm_temp(71,nummat) =zero
240 pm_temp(72,nummat) =zero
241 pm_temp(89,nummat) = pm_temp(1,nummat)
242
243 DO i=1,igeo(npropgi*(ipartl(2,k)-1)+4)
244 f2 = igeo(npropgi*(ipartl(2,k)-1)+100+i)
245 alphai = geo(npropg*(ipartl(2,k)-1)+300+i)
246 pm_temp(20,nummat) = pm_temp(20,nummat) + alphai*pm_temp(20,f2)
247 pm_r2r(nummat)= pm_r2r(nummat) + alphai*pm_temp(20,f2)
248 pm_temp(21,nummat) = pm_temp(21,nummat) + alphai*pm_temp(21,f2)
249 pm_temp(32,nummat) = pm_temp(32,nummat) + alphai*pm_temp(32,f2)
250 pm_temp(75,nummat) = pm_temp(75,nummat) + alphai*pm_temp(75,f2)
251 pm_temp(76,nummat) = pm_temp(76,nummat) + alphai*pm_temp(76,f2)
252 pm_temp(100,nummat) = pm_temp(100,nummat) + alphai*pm_temp(100,f2)
253 END DO
254C
255 ENDIF
256C
257 ipm_temp(1,nummat)= num
258 ipm_temp(2,nummat)= 0
259 titr = "Multidomains void material"
260 CALL fretitl(titr,ipm_temp(npropmi-ltitr,nummat),ltitr)
261
262 WRITE(iout,1300) num,pm_temp(1,nummat)
263 . ,pm_temp(20,nummat),pm_temp(21,nummat),ipartl(4,k)
264C
265 ipartl(5,k)= num
266 ipartl(1,k)= nummat
267C
268 ENDIF
269C
270 END DO
271
272C----------------Reallocation and filling of IPM and PM-----------C
273
274 len1 = npropmi*nummat
275 len2 = npropm*nummat
276
277 DEALLOCATE(ipm,pm,ddweights)
278 ALLOCATE (ipm(len1),stat=stat)
279 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo, msgtype=msgerror, c1='IPM')
280 ALLOCATE (pm(len2),stat=stat)
281 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo, msgtype=msgerror, c1='PM')
282 CALL init_mat_weight(nummat)
283
284 DO i=1,nummat
285 DO j=1,npropmi
286 ipm(npropmi*(i-1)+j)=ipm_temp(j,i)
287 END DO
288 END DO
289
290 DO i=1,nummat
291 DO j=1,npropm
292 pm(npropm*(i-1)+j)=pm_temp(j,i)
293 END DO
294 END DO
295
296 DO i=1,nummat+1
297 DO j=1,2
298 DO l=1,2
299 ddweights(j,l,i)=ddw_temp(j,l,i)
300 ENDDO
301 END DO
302 END DO
303
304 DEALLOCATE(ipm_temp,pm_temp,ddw_temp)
305
306C--------------------------------------------------------------C
307
308 DO k=1,npart
309 IF (tag_part(k) >= 2) THEN
310C
311 pid = igeo(npropgi*(ipartl(2,k)-1)+1)
312C
313C---------Allocation of temporary arrays ----------------------C
314
315 nb_part = 1
316C
317 CALL my_alloc (igeo_temp,npropgi,numgeo+nb_part)
318 CALL my_alloc (geo_temp,npropg,numgeo+nb_part)
319 CALL my_alloc (numgeostack1_temp,numgeo+nb_part)
320 CALL my_alloc (numgeostack2_temp,numstack)
321C
322 igeo_temp(:,:)=0
323 geo_temp(:,:)=0
324 numgeostack1_temp(:)=0
325 numgeostack2_temp(:)=0
326C
327C---------Copy of property arrays in temporary arrays ---------C
328
329 DO i=1,numgeo
330 DO j=1,npropgi
331 igeo_temp(j,i)=igeo(npropgi*(i-1)+j)
332 END DO
333 END DO
334
335 DO i=1,numgeo
336 DO j=1,npropg
337 geo_temp(j,i)=geo(npropg*(i-1)+j)
338 END DO
339 END DO
340
341 DO i=1,numgeo
342 numgeostack1_temp(i)=numgeostack(i)
343 END DO
344
345 DO i=1,numstack
346 numgeostack2_temp(i)=numgeostack(numgeo+i)
347 END DO
348
349C------------offset of id for generated shell properties-------C
350 num = 0
351 DO i=1,numgeo
352 IF (num.LE.igeo_temp(1,i)) num=igeo_temp(1,i)+1
353 END DO
354
355C-----------Creation of new void properties for shells---------C
356
357 f2 = ipartl(2,k)
358 numgeo = numgeo+1
359
360 igeo_temp(1,numgeo)=num
361 geo_temp(1,numgeo)=geo_temp(1,f2)
362 numgeostack1_temp(numgeo)=0
363C
364 titr = "Multidomains void property"
365 CALL fretitl(titr,igeo_temp(npropgi-ltitr,numgeo),ltitr)
366
367 WRITE(iout,1400) num,geo_temp(1,numgeo),ipartl(4,k)
368
369C---------------Affectation of new shell property--------------C
370 ipartl(6,k)= num
371 ipartl(2,k)= numgeo
372
373C---------------Reallocation and filling of IGEO and GEO------C
374
375 len1 = npropgi*numgeo
376 len2 = npropg*numgeo
377C
378 DEALLOCATE(igeo,geo,numgeostack)
379 CALL my_alloc (igeo,len1)
380 CALL my_alloc (geo,len2)
381 CALL my_alloc (numgeostack,numgeo+numstack)
382C
383 DO i=1,numgeo
384 DO j=1,npropgi
385 igeo(npropgi*(i-1)+j)=igeo_temp(j,i)
386 END DO
387 END DO
388
389 DO i=1,numgeo
390 DO j=1,npropg
391 geo(npropg*(i-1)+j)=geo_temp(j,i)
392 END DO
393 END DO
394
395 DO i=1,numgeo
396 numgeostack(i)=numgeostack1_temp(i)
397 END DO
398
399 DO i=1,numstack
400 numgeostack(numgeo+i)=numgeostack2_temp(i)
401 END DO
402
403 DEALLOCATE(igeo_temp,geo_temp,numgeostack1_temp,numgeostack2_temp)
404
405 ENDIF
406C
407 END DO
408
409C--------------------------------------------------------------C
410 tag_part(:)= 0
411C--------------------------------------------------------------C
412
413150 CONTINUE
414
415 RETURN
416 1200 FORMAT(
417 . //' MULTIDOMAINS SPECIAL TREATMENTS '/
418 . ' --------------------------------- '/)
419 1300 FORMAT(
420 & 5x,40hvoid material created ,/,
421 & 5x,40h ----------- ,/,
422 & 5x,40hmaterial id . . . . . . . . . . . . .=,i10/,
423 & 5x,40hdensity . . . . . . . . . . . . . . .=,e12.4/,
424 & 5x,40hyoung'S MODULUS . . . . . . . . . . . .=,E12.4/,
425 & 5X,40HPOISSON's ratio . . . . . . . . . . . .=,e12.4/,
426 & 5x,40happlied on part . . . . . . . . . . . =,i10//)
427 1400 FORMAT(
428 & 5x,40hvoid property created ,/,
429 & 5x,40h ----------- ,/,
430 & 5x,40hproperty id . . . . . . . . . . . . .=,i10/,
431 & 5x,40hthickness. . . . . . . . . . . . . . .=,e12.4/,
432 & 5x,40happlied on part . . . . . . . . . . . =,i10//)
433C-----------
434 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
id
initmumps id
Definition multiplerhs_example.m:4
ddweights_mod
Definition ddweights_mod.F:40
message_mod
Definition message_mod.F:1249
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
r2r_mod
Definition r2r_mod.F:125
r2r_mod::tag_part
integer, dimension(:), allocatable tag_part
Definition r2r_mod.F:134
r2r_mod::isubdom_part
integer, dimension(:), allocatable isubdom_part
Definition r2r_mod.F:131
r2r_mod::ipart_r2r
integer, dimension(:,:), allocatable ipart_r2r
Definition r2r_mod.F:144
r2r_mod::isubdom
integer, dimension(:,:), allocatable isubdom
Definition r2r_mod.F:144
restmod::ipm
integer, dimension(:), allocatable ipm
Definition restart_mod.F:83
restmod::igeo
integer, dimension(:), allocatable igeo
Definition restart_mod.F:83
stack_var_mod
Definition stack_var_mod.F:33
stack_var_mod::numgeostack
integer, dimension(:), allocatable numgeostack
Definition stack_var_mod.F:42
init_mat_weight
subroutine init_mat_weight(nummat)
Definition set_dd_mat_weight.F:65
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:889
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:620

◆ r2r_void_1d()

subroutine r2r_void_1d ( integer id_part,
integer, dimension(lipart1,*) ipartl )

Definition at line 445 of file r2r_void.F.

446C-----------------------------------------------
447C M o d u l e s
448C-----------------------------------------------
449 USE my_alloc_mod
450 USE restmod
451 USE r2r_mod
452C-----------------------------------------------
453C I m p l i c i t T y p e s
454C-----------------------------------------------
455#include "implicit_f.inc"
456C-----------------------------------------------
457C C o m m o n B l o c k s
458C-----------------------------------------------
459#include "scr17_c.inc"
460#include "param_c.inc"
461C-----------------------------------------------
462C D u m m y A r g u m e n t s
463C-----------------------------------------------
464 INTEGER ID_PART,IPARTL(LIPART1,*)
465C-----------------------------------------------
466C L o c a l V a r i a b l e s
467C-----------------------------------------------
468 INTEGER IMAT,IMAT0,J
469C-----------------------------------------------
470
471 imat = ipartl(1,id_part)
472
473C-----If part already treated or non void material part is skiped---C
474 IF (ipart_r2r(3,id_part)==1) GOTO 150
475 IF (ipm(npropmi*(imat-1)+2)/=0) GOTO 150
476
477C-----Id of original material --------------------------------------C
478 imat0 = ipart_r2r(1,id_part)
479
480C-----Void material is replaced by dummy material-------------------C
481 DO j=1,npropm
482 pm(npropm*(imat-1)+j)=pm(npropm*(imat0-1)+j)
483 END DO
484 DO j=1,npropmi
485 ipm(npropmi*(imat-1)+j)=ipm(npropmi*(imat0-1)+j)
486 END DO
487
488 pm(npropm*(imat-1)+1)= 1e-20
489 pm(npropm*(imat-1)+19)= pm(npropm*(imat0-1)+19)
490 pm(npropm*(imat-1)+20)= 1e-20
491 pm(npropm*(imat-1)+70)= zero
492 pm(npropm*(imat-1)+71)= zero
493 pm(npropm*(imat-1)+72)= zero
494 pm(npropm*(imat-1)+89)= 1e-20
495 pm_r2r(imat)= pm(npropm*(imat0-1)+20)
496 ipart_r2r(3,id_part) = 1
497
498150 CONTINUE
499
500C-----------
501 RETURN