OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
r2r_split.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_split ../starter/source/coupling/rad2rad/r2r_split.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| constit ../starter/source/elements/nodes/constit.F
30!|| nlocal ../starter/source/spmd/node/ddtools.F
31!|| prelecsec ../starter/source/tools/sect/prelecsec.F
32!|| r2r_monvol ../starter/source/coupling/rad2rad/r2r_prelec.F
33!|| tagelem_r2r ../starter/source/coupling/rad2rad/tagelem_r2r.F
34!||--- uses -----------------------------------------------------
35!|| front_mod ../starter/share/modules1/front_mod.F
36!|| message_mod ../starter/share/message_module/message_mod.F
37!|| nod2el_mod ../starter/share/modules1/nod2el_mod.F
38!|| r2r_mod ../starter/share/modules1/r2r_mod.F
39!|| restmod ../starter/share/modules1/restart_mod.F
40!|| submodel_mod ../starter/share/modules1/submodel_mod.F
41!||====================================================================
42 SUBROUTINE r2r_split(
43 1 NB_LINE,
44 2 NB_SURF,FLAG,EANI2,BUF_NOD,IXR_KJ,
45 3 INOM_OPT,RESERVEP,NALE_R2R,NSPCOND0,
46 4 SUBSET ,IGRSURF,IGRNOD ,IGRBRIC,IGRQUAD,
47 5 IGRSH4N,IGRSH3N,IGRTRUSS,IGRBEAM,IGRSPRING,
48 6 IGRPART,IGRSLIN,LSUBMODEL,RBY_MSN,IWORKSH,
49 7 SEATBELT_SHELL_TO_SPRING,NB_SEATBELT_SHELLS)
50C-----------------------------------------------
51C M o d u l e s
52C-----------------------------------------------
53 USE my_alloc_mod
54 USE restmod
55 USE r2r_mod
56 USE nod2el_mod
57 USE front_mod
58 USE message_mod
59 USE groupdef_mod
60 USE submodel_mod
61 USE ale_mod
62 USE names_and_titles_mod , ONLY : ncharkey
63C-----------------------------------------------
64C I m p l i c i t T y p e s
65C-----------------------------------------------
66#include "implicit_f.inc"
67C-----------------------------------------------
68C C o m m o n B l o c k s
69C-----------------------------------------------
70#include "com01_c.inc"
71#include "com04_c.inc"
72#include "scr17_c.inc"
73#include "r2r_c.inc"
74#include "tabsiz_c.inc"
75#include "sphcom.inc"
76#include "param_c.inc"
77C-----------------------------------------------
78C D u m m y A r g u m e n t s
79C-----------------------------------------------
80 TYPE(submodel_data) LSUBMODEL(NSUBMOD)
81 INTEGER BUF_NOD(*),
82 . NB_SURF,FLAG,
83 . EANI2(*),NB_LINE,
84 . IXR_KJ(*),INOM_OPT(*),RESERVEP(*),NALE_R2R(ALE%GLOBAL%SNALE),
85 . NSPCOND0,RBY_MSN(2,*)
86 INTEGER, INTENT(INOUT) :: IWORKSH(3,NUMELC+NUMELTG)
87 INTEGER ,INTENT(IN) :: NB_SEATBELT_SHELLS
88 INTEGER ,INTENT(IN) :: SEATBELT_SHELL_TO_SPRING(NUMELC,2)
89 TYPE (SUBSET_) , DIMENSION(NSUBS) :: SUBSET
90 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
91 TYPE (SURF_) , DIMENSION(NSLIN) :: IGRSLIN
92 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
93 TYPE (GROUP_) , DIMENSION(NGRBRIC) :: IGRBRIC
94 TYPE (GROUP_) , DIMENSION(NGRQUAD) :: IGRQUAD
95 TYPE (GROUP_) , DIMENSION(NGRSHEL) :: IGRSH4N
96 TYPE (GROUP_) , DIMENSION(NGRSH3N) :: IGRSH3N
97 TYPE (GROUP_) , DIMENSION(NGRTRUS) :: IGRTRUSS
98 TYPE (GROUP_) , DIMENSION(NGRBEAM) :: IGRBEAM
99 TYPE (GROUP_) , DIMENSION(NGRSPRI) :: IGRSPRING
100 TYPE (GROUP_) , DIMENSION(NGRPART) :: IGRPART
101C-----------------------------------------------
102C E x t e r n a l F u n c t i o n s
103C-----------------------------------------------
104 INTEGER NLOCAL
105 EXTERNAL nlocal
106C-----------------------------------------------
107C L o c a l V a r i a b l e s
108C-----------------------------------------------
109 INTEGER I,K,J,ADD,IAD,CUR_ID,TPP,CCPL,NF1,NF2,TYP2
110 INTEGER COMPT,NSEG,FSKW,IDOM,NUMNOD_OLD
111 INTEGER ISUR,ISURS,NTOT,NB_NOD_SUB,NB_NOD_CPL,NB_NOD
112 INTEGER MAXN,MAXANUS,SIXSN,ID_INTER,NUL,TAG,COMPTB
113 INTEGER COMPT10,COMPT20,COMPT16,COMPT8,J10,J20,J16,JJ
114 INTEGER G1,G2,GRS,GRM,GRS2,LN1,LN2,NI,ID_MON,IAD3,IO_ERR
115 INTEGER LNM,LNS,NEW_ID,SIPART0,SIPARTTH,COMPT_IP,COMPT_IP_TMP,L0
116 INTEGER ID_PROP,COEFF,NUMSPHA,NSPHRESN,FIRST_CELL,NOD_ID,PART_RES,INOD
117 INTEGER JJB,IUN,NRB,NRBODY_OLD
118 CHARACTER TITR*40
119 INTEGER, DIMENSION(:), POINTER :: PART1,PART2
120 INTEGER, DIMENSION(:), ALLOCATABLE :: BUF_TEMP,ITAB_TEMP,IX_TEMP
121 INTEGER, DIMENSION(:), ALLOCATABLE :: CORESN,CORESC,CORESTG,COREST
122 INTEGER, DIMENSION(:), ALLOCATABLE :: CORESPA,CORESR,CORESP,CORESS,CORESSP
123 INTEGER, DIMENSION(:), ALLOCATABLE :: IPART_TEMP,IWA_TEMP
124 INTEGER, DIMENSION(:), ALLOCATABLE :: IPM_TEMP,IGEO_TEMP,CORESMA
125 INTEGER, DIMENSION(:), ALLOCATABLE :: CORESPRO,TAGNO_TEMP
126 INTEGER, DIMENSION(:), ALLOCATABLE :: IX10_TEMP,IX20_TEMP
127 INTEGER, DIMENSION(:), ALLOCATABLE :: IX16_TEMP,CORESQ,ITAB_SUP
128 INTEGER, DIMENSION(:), ALLOCATABLE :: KXSP_TEMP,RES_TEMP,NALE_R2R_TEMP
129 INTEGER, DIMENSION(:,:), ALLOCATABLE :: RBY_MSN_TEMP,IWORKSH_TEMP
130 my_real, DIMENSION(:,:), ALLOCATABLE :: x_temp
131 my_real, DIMENSION(:), ALLOCATABLE :: thk_tmp,pm_temp
132 my_real, DIMENSION(:), ALLOCATABLE :: eani_temp,geo_temp
133 CHARACTER MESS*40
134 CHARACTER(LEN=NCHARKEY) :: OPT,KEY
135 DATA mess/'MULTIDOMAIN INITIALIZATION'/
136 DATA iun/1/
137C===================================================================================
138
139C----------------------------------------------------------------------------------C
140C--------------------------------Initialisation------------------------------------C
141C----------------------------------------------------------------------------------C
142
143 n_part = npart
144
145C----------------------------------------------------------------------------------C
146C-----------------------First pass -> tag and count--------------------------------C
147C----------------------------------------------------------------------------------C
148
149 IF (flag==0) THEN
150
151C----------------------------------------------------------------------------------C
152C---------------------Allocation and initialisation of array tags------------------C
153C----------------------------------------------------------------------------------C
154
155 ALLOCATE(tag_mat(nummat),tag_prop(numgeo),tag_subs(nsubs))
156 ALLOCATE(tag_surf(numelc+numeltg+numels+npart))
157
158 tag_surf(:) = 0
159 tag_subs(:) = 0
160 tag_part(:) = 0
161
162C------------Temporarily all mat and properties are kept --------------------------C
163 tag_mat(:) = 1
164 tag_prop(:) = 1
165
166C------------TAG_EL must be stored-------------------------------------------------C
167 ALLOCATE(tag_elcf2(numelc))
168 ALLOCATE(tag_elsf2(numels))
169 tag_elcf2 = 0
170 tag_elsf2 = 0
171 DO i=1,numels
172 tag_elsf2(i) = tag_els(i+npart)
173 END DO
174 DO i=1,numelc
175 tag_elcf2(i) = tag_elc(i+npart)
176 END DO
177
178C----------------------------------------------------------------------------------C
179C-----------------------------tag of data of the subdomain-------------------------C
180C----------------------------------------------------------------------------------C
181
182 IF (iddom/=0) THEN
183 add = isubdom(3,iddom)
184 DO k=1,npart
185 DO i=1,isubdom(1,iddom)
186 IF(k == isubdom_part(i+add))THEN
187 tag_part(k)=1
188 ENDIF
189 ENDDO
190 END DO
191 ENDIF
192
193C----------------Full domain --> tag of parts of all subdomains--------------------C
194
195 IF (iddom == 0) THEN
196
197 DO idom=1,nsubdom
198 add = isubdom(3,idom)
199 DO k=1,npart
200 DO i=1,isubdom(1,idom)
201 IF(k == isubdom_part(i+add))THEN
202 tag_part(k)=1
203 ENDIF
204 ENDDO
205 END DO
206 END DO
207
208C- ----->Full domain --> inversion of tag of parts<---
209 DO k=1,npart
210 IF(tag_part(k) == 1) THEN
211 tag_part(k)=0
212 ELSE
213 tag_part(k)=1
214 ENDIF
215 END DO
216
217 ENDIF
218
219C---------------Tag of subsets-----------------------------------------------------C
220!
221C --- TAG_SUBS ---> ATTENTION not used
222!
223! DO J=1,NSUBS
224! IAD3 = ISUBS(LISUB1*(J-1)+9)
225! DO K=1,ISUBS(LISUB1*(J-1)+8)
226! IF (TAG_PART(BUF_NOD(IAD3))>0) TAG_SUBS(J)=1
227! IAD3 = IAD3+1
228! END DO
229! END DO
230!---
231 DO j=1,nsubs
232 DO k=1,subset(j)%NTPART
233 IF (tag_part(subset(j)%TPART(k))>0) tag_subs(j)=1
234!
235 ENDDO
236 ENDDO
237!---
238
239C---------------Tag of parts for tag of elements-----------------------------------C
240 DO k=1,npart
241 IF(tag_part(k) == 1) THEN
242 tag_els(k)=1
243 tag_elq(k)=1
244 tag_elc(k)=1
245 tag_elt(k)=1
246 tag_elp(k)=1
247 tag_elr(k)=1
248 tag_elg(k)=1
249 tag_elsp(k)=1
250 tag_surf(k)=1
251C---------------Tag of materials and properties------------------------------------C
252 tag_mat(ipart(lipart1*(k-1)+1))=1
253 tag_prop(ipart(lipart1*(k-1)+2))=1
254 ENDIF
255 END DO
256
257C---------------Nodes are already taged in TAGNO-----------------------------------C
258
259C---------------Tag of elements----------------------------------------------------C
260
261 sipart0 = lipart1*npart+lipart1*nthpart
262 sipartth= 2*9*npart+2*9*nthpart
263 l0 =sipartth+sipart0+1
264
265 IF (numels>0) CALL tagelem_r2r(numels,ipart(l0),tag_els,npart)
266 l0 = l0+numels
267
268 IF (numelq>0) CALL tagelem_r2r(numelq,ipart(l0),tag_elq,npart)
269 l0 = l0+numelq
270
271 IF (numelc>0) CALL tagelem_r2r(numelc,ipart(l0),tag_elc,npart)
272 l0 = l0+numelc
273
274 IF (numelt>0) CALL tagelem_r2r(numelt,ipart(l0),tag_elt,npart)
275 l0 = l0+numelt
276
277 IF (numelp>0) CALL tagelem_r2r(numelp,ipart(l0),tag_elp,npart)
278 l0 = l0+numelp
279
280 IF (numelr>0) CALL tagelem_r2r(numelr,ipart(l0),tag_elr,npart)
281 l0 = l0+numelr
282
283 IF (numeltg>0)CALL tagelem_r2r(numeltg,ipart(l0),tag_elg,npart)
284 l0 = l0+numeltg+numelx
285
286 IF (numsph>0) CALL tagelem_r2r(numsph,ipart(l0),tag_elsp,npart)
287
288C---------------Tag of injectors and corresponding material and property-----------C
289 CALL r2r_monvol(tag_mat,tag_prop,igrsurf,lsubmodel)
290
291C----------------------------------------------------------------------------------C
292C--------------------------First pass -> counting----------------------------------C
293C----------------------------------------------------------------------------------C
294
295 compt = 0
296 nnodn = 0
297 nodsupr = 0
298 nsphn = 0
299 nelcn = 0
300 neltgn = 0
301 neltn = 0
302 nelrn = 0
303 nelpn = 0
304 nelqn = 0
305 nelsn = 0
306 nels10n = 0
307 nels20n = 0
308 nels16n = 0
309 ninletn = 0
310 siz_ipm_new = npropmi
311 siz_pm_new = npropm
312 siz_igeo_new = npropgi
313 siz_geo_new = npropg
314
315C ---------> counting of materials -------------------------------------------C
316 DO j=1,nummat
317 IF (tag_mat(j)/=0)THEN
318 siz_ipm_new = siz_ipm_new + npropmi
319 siz_pm_new = siz_pm_new + npropm
320 ENDIF
321 ENDDO
322C ---------> counting of properties -------------------------------------------C
323 DO j=1,numgeo
324 IF (tag_prop(j)/=0)THEN
325 siz_igeo_new = siz_igeo_new + npropgi
326 siz_geo_new = siz_geo_new + npropg
327 ENDIF
328 ENDDO
329C ---------> counting of nodes and deleted nodes-----------------------------------C
330 DO j=1,numnod
331 IF (tagno(j+npart)>=0)THEN
332 nnodn = nnodn+1
333 ELSE
334 nodsupr = nodsupr+1
335 ENDIF
336 ENDDO
337C ---------> counting of parts ---------------------------------------------------C
338 DO j=1,npart
339 IF (tag_part(j)==1) THEN
340 nparn = nparn+1
341 ENDIF
342 ENDDO
343C ---------> DUmmy nodes ---------------------------------------------------C
344 nnodn = nnodn+1
345C ---------> counting of shells ---------------------------------------------------C
346 DO j=1,numelc
347 IF (tag_elc(j+npart)/=0) THEN
348 nelcn = nelcn+1
349 ENDIF
350 ENDDO
351C ---------> counting of sh3n ---------------------------------------------------C
352 DO j=1,numeltg
353 IF (tag_elg(j+npart)/=0) THEN
354 neltgn = neltgn+1
355 ENDIF
356 ENDDO
357C ---------> counting of truss ---------------------------------------------------C
358 DO j=1,numelt
359 IF (tag_elt(j+npart)/=0) THEN
360 neltn = neltn+1
361 ENDIF
362 ENDDO
363C ---------> counting of springs---------------------------------------------------C
364 DO j=1,numelr
365 IF (tag_elr(j+npart)/=0) THEN
366 nelrn = nelrn+1
367 ENDIF
368 ENDDO
369C ---------> comptage des beams----------------------------------------------------C
370 DO j=1,numelp
371 IF (tag_elp(j+npart)/=0) THEN
372 nelpn = nelpn+1
373 ENDIF
374 ENDDO
375C ---------> counting of beams ---------------------------------------------------C
376 DO j=1,numelq
377 IF (tag_elq(j+npart)/=0) THEN
378 nelqn = nelqn+1
379 ENDIF
380 ENDDO
381C ---------> counting of solids ---------------------------------------------------C
382 DO j=1,numels
383 IF (tag_els(j+npart)/=0) THEN
384 nelsn = nelsn+1
385 IF (eani2(j)==10) nels10n = nels10n+1
386 IF (eani2(j)==20) nels20n = nels20n+1
387 IF (eani2(j)==16) nels16n = nels16n+1
388 ENDIF
389 ENDDO
390C ---------> counting of SPH particles---------------------------------------------C
391 DO j=1,numsph
392 IF (tag_elsp(j+npart)/=0) THEN
393 nsphn = nsphn+1
394 ENDIF
395 ENDDO
396C ---------> counting of particles reserve-----------------------------------------C
397 first_cell = first_sphres
398 DO j=1,nbpartinlet
399 IF (tag_elsp(first_cell+npart)/=0) THEN
400 ninletn = ninletn + 1
401 ENDIF
402 first_cell = first_cell + reservep(j)
403 ENDDO
404
405C----------------------------------------------------------------------------------C
406 ENDIF ! IF (FLAG==0) THEN
407
408C----------------------------------------------------------------------------------C
409C-------------------------Second pass -> split of arrays --------------------------C
410C----------------------------------------------------------------------------------C
411
412 IF (flag==1) THEN
413
414C----------------------------------------------------------------------------------C
415C-------------Split of materials --------------------------------------------------C
416C----------------------------------------------------------------------------------C
417
418 ALLOCATE (ipm_temp(npropmi*nummat),pm_temp(npropm*nummat))
419 ALLOCATE(coresma(nummat))
420 DO i=1,nummat
421 DO j=1,npropmi
422 ipm_temp(npropmi*(i-1)+j)=ipm(npropmi*(i-1)+j)
423 END DO
424 END DO
425 DO i=1,nummat
426 DO j=1,npropm
427 pm_temp(npropm*(i-1)+j)=pm(npropm*(i-1)+j)
428 END DO
429 END DO
430 DEALLOCATE(ipm,pm)
431
432C-------------Split----------------------------------------------------------------C
433
434 ALLOCATE(ipm(siz_ipm_new),pm(siz_pm_new))
435 compt = 0
436 DO j=1,nummat
437 IF ((tag_mat(j)/=0).OR.(j==nummat)) THEN
438 compt = compt+1
439 coresma(j)=compt
440 DO k=1,npropmi
441 ipm(npropmi*(compt-1)+k)=ipm_temp(npropmi*(j-1)+k)
442 END DO
443 DO k=1,npropm
444 pm(npropm*(compt-1)+k)=pm_temp(npropm*(j-1)+k)
445 END DO
446 ENDIF
447 ENDDO
448
449 nummat = compt
450 DEALLOCATE(ipm_temp,pm_temp)
451
452C----------------------------------------------------------------------------------C
453C-------------Split of properties -------------------------------------------------C
454C----------------------------------------------------------------------------------C
455
456 ALLOCATE (igeo_temp(npropgi*numgeo),geo_temp(npropg*numgeo))
457 ALLOCATE(corespro(numgeo))
458 DO i=1,numgeo
459 DO j=1,npropgi
460 igeo_temp(npropgi*(i-1)+j)=igeo(npropgi*(i-1)+j)
461 END DO
462 END DO
463 DO i=1,numgeo
464 DO j=1,npropg
465 geo_temp(npropg*(i-1)+j)=geo(npropg*(i-1)+j)
466 END DO
467 END DO
468 DEALLOCATE(igeo,geo)
469
470C-------------Split----------------------------------------------------------------C
471
472 ALLOCATE(igeo(siz_igeo_new),geo(siz_geo_new))
473 compt = 0
474 maxanus = 0
475 DO j=1,numgeo
476 IF (tag_prop(j)/=0) THEN
477 compt = compt+1
478 corespro(j)=compt
479 DO k=1,npropgi
480 maxanus = npropgi*(compt-1)+k
481 igeo(npropgi*(compt-1)+k)=igeo_temp(npropgi*(j-1)+k)
482 END DO
483 DO k=1,npropg
484 geo(npropg*(compt-1)+k)=geo_temp(npropg*(j-1)+k)
485 END DO
486 ENDIF
487 ENDDO
488
489 numgeo = compt
490 DEALLOCATE(igeo_temp,geo_temp)
491
492C----------------------------------------------------------------------------------C
493C-------------Split of PARTS-------------------------------------------------------C
494C----------------------------------------------------------------------------------C
495
496 DO j=1,npart
497 ipart(lipart1*(j-1)+1)=coresma(ipart(lipart1*(j-1)+1))
498 ipart(lipart1*(j-1)+2)=corespro(ipart(lipart1*(j-1)+2))
499 ENDDO
500
501C----------------------------------------------------------------------------------C
502C-------------Split of nodes-------------------------------------------------------C
503C----------------------------------------------------------------------------------C
504
505 ALLOCATE(coresn(numnod),x_temp(3,numnod))
506 ALLOCATE(itab_temp(numnod))
507 DO j=1,numnod
508 itab_temp(j)=itab(j)
509 x_temp(1,j)=x(3*(j-1)+1)
510 x_temp(2,j)=x(3*(j-1)+2)
511 x_temp(3,j)=x(3*(j-1)+3)
512 END DO
513 DEALLOCATE(itab,x)
514
515C-------------Split----------------------------------------------------------------C
516 ALLOCATE(itab(nnodn),x(3*nnodn),itab_sup(nodsupr))
517 ALLOCATE(front_r2r(nnodn))
518 ALLOCATE(flagkin_r2r(nnodn))
519 flagkin_r2r(1:nnodn)=0
520 front_r2r(1:nnodn)=0
521 compt = 0
522 comptb = 0
523 maxn=0
524 DO j=1,numnod
525 IF (tagno(j+npart)>=0)THEN
526 compt = compt+1
527 itab(compt)=itab_temp(j)
528 IF (itab(compt)>maxn) maxn = itab(compt)
529 coresn(j)=compt
530 x(3*(compt-1)+1)=x_temp(1,j)
531 x(3*(compt-1)+2)=x_temp(2,j)
532 x(3*(compt-1)+3)=x_temp(3,j)
533c FRONT_R2R(COMPT)=FRONT(J,1)
534 front_r2r(compt) = nlocal(j,1)
535 IF(flagkin(j)==1)THEN
536 flagkin_r2r(compt)=1
537 ENDIF
538c ELSE
539c FRONT_R2R(COMPT) = 0
540c ENDIF
541 IF (tagno(j+npart)>1) THEN
542 ms(compt)=1e-20
543 IF (iroddl==1) in(compt)=1e-20
544 ENDIF
545 ELSE
546 comptb = comptb+1
547 itab_sup(comptb)=itab_temp(j)
548 ENDIF
549 ENDDO
550
551C -----------update of skews-------------------------------------------------------C
552 DO j=1,numskw
553 DO k=1,3
554 IF (iskwn(liskn*j+k)>0)
555 . iskwn(liskn*j+k)=coresn(iskwn(liskn*j+k))
556 END DO
557 ENDDO
558
559C -----------update of frames------------------------------------------------------C
560 jj = siskwn-siframe
561 IF (nsphn==numsph) THEN
562 DO j=1,numfram
563 DO k=1,3
564 IF (iskwn(jj+liskn*j+k)>0)
565 . iskwn(jj+liskn*j+k)=coresn(iskwn(jj+liskn*j+k))
566 END DO
567 ENDDO
568 ELSE
569C-- advance of fraomes if SPH particles are removed
570 jjb = siskwn-siframe-min(iun,nspcond0)*(numsph-nsphn)*liskn
571 DO j=1,numfram
572 DO k=1,3
573 IF (iskwn(jj+liskn*j+k)>0) THEN
574 iskwn(jjb+liskn*j+k)=coresn(iskwn(jj+liskn*j+k))
575 ENDIF
576 END DO
577 DO k=4,liskn
578 iskwn(jjb+liskn*j+k)=iskwn(jj+liskn*j+k)
579 END DO
580 END DO
581 ENDIF
582
583 numnod_old = numnod
584 numnod = compt
585 numnod0 = compt
586 DEALLOCATE(itab_temp,x_temp)
587
588C-------------Reconstitution of ITABM1---------------------------------------------C
589 part1 => itabm1(1:2*numnod)
590 CALL constit(itab,part1,numnod)
591
592C-------------A second list of removed nodes is generated for error detection
593 IF (nodsupr/=0) THEN
594 part2 => itabm1(2*numnod+1:2*numnod_old)
595 CALL constit(itab_sup,part2,nodsupr)
596 DEALLOCATE(itab_sup)
597 ENDIF
598
599C----------------------------------------------------------------------------------C
600C-------------Split of NALE_R2R----------------------------------------------------C
601C----------------------------------------------------------------------------------C
602
603 IF (ale%GLOBAL%SNALE>0) THEN
604C
605 ALLOCATE(nale_r2r_temp(ale%GLOBAL%SNALE))
606 DO j=1,numnod_old
607 nale_r2r_temp(j)=nale_r2r(j)
608 END DO
609
610C-------------Split----------------------------------------------------------------C
611 nale_r2r(:) = 0
612 compt = 0
613 DO j=1,numnod_old
614 IF (tagno(j+npart)>=0) THEN
615 compt = compt+1
616 nale_r2r(compt) = nale_r2r_temp(j)
617 ENDIF
618 END DO
619 DEALLOCATE(nale_r2r_temp)
620
621 ENDIF
622
623C----------------------------------------------------------------------------------C
624C-------------Split of EANI--------------------------------------------------------C
625C----------------------------------------------------------------------------------C
626
627 ntot = nelsn+nelcn+neltgn+nelqn
628 ALLOCATE(eani_temp(seani))
629 compt = 0
630
631 DO j=1,seani
632 eani_temp(j)=eani2(j)
633 eani2(j)=0
634 END DO
635
636 seani = ntot
637
638 DO j=1,numels
639 IF (tag_els(j+npart)/=0) THEN
640 compt = compt + 1
641 eani2(compt)=eani_temp(j)
642 ENDIF
643 END DO
644
645 compt = nelsn+nelcn+nelqn
646 DO j=1,numeltg
647 IF (tag_elg(j+npart)/=0) THEN
648 compt = compt + 1
649 eani2(compt)=eani_temp(numels+numelq+numelc+j)
650 ENDIF
651 END DO
652
653C----------------------------------------------------------------------------------C
654C-------------INITIALIZATION OF IPART----------------------------------------------C
655C----------------------------------------------------------------------------------C
656
657 sipart0 = lipart1*npart+lipart1*nthpart
658 sipartth= 2*9*npart+2*9*nthpart
659 ALLOCATE(ipart_temp(sipart))
660
661 DO j=1,sipart
662 ipart_temp(j)=ipart(j)
663 END DO
664
665 DEALLOCATE(ipart)
666 sipart = sipart0+sipartth+nelsn+nelqn+nelcn+neltn+nelpn
667 . + nelrn+neltgn+numelx+numsph
668 ALLOCATE(ipart(sipart))
669
670 DO j=1,sipart0+sipartth
671 ipart(j)=ipart_temp(j)
672 END DO
673
674 compt_ip = sipart0+sipartth
675 compt_ip_tmp = sipart0+sipartth
676
677C----------------------------------------------------------------------------------C
678C-------------Split of SOLID elements----------------------------------------------C
679C----------------------------------------------------------------------------------C
680
681 ALLOCATE(ix_temp(sixs),coress(numels))
682
683 DO j=1,numels
684 DO k=1,nixs
685 ix_temp(nixs*(j-1)+k)=ixs(nixs*(j-1)+k)
686 END DO
687 END DO
688
689C-------------Storage of additional terms IXS10,IXS20,IXS16------------------------C
690
691 DO j=numels+1,sixs
692 ix_temp(j)=ixs(j)
693 END DO
694
695 DEALLOCATE(ixs)
696
697C-------------Split----------------------------------------------------------------C
698
699 sixsn = nelsn*nixs+nels10n*6+nels20n*12+nels16n*8
700 ALLOCATE(ixs(sixsn),tag_elsf(nelsn))
701 tag_elsf = 0
702 compt = 0
703 compt8 = 0
704 compt10 = 0
705 compt20 = 0
706 compt16 = 0
707 j10 = 0
708 j20 = 0
709 j16 = 0
710
711 DO j=1,numels
712 compt_ip_tmp=compt_ip_tmp+1
713 IF (eani_temp(j)==10) j10 = j10+1
714 IF (eani_temp(j)==20) j20 = j20+1
715 IF (eani_temp(j)==16) j16 = j16+1
716 IF (tag_els(j+npart)/=0) THEN
717 compt_ip=compt_ip+1
718 compt = compt+1
719 coress(j)=compt
720 ipart(compt_ip)=ipart_temp(compt_ip_tmp)
721 DO k=1,nixs
722 ixs(nixs*(compt-1)+k)=ix_temp(nixs*(j-1)+k)
723 END DO
724 ixs(nixs*(compt-1)+1)=coresma(ix_temp(nixs*(j-1)+1))
725 ixs(nixs*(compt-1)+10)=corespro(ix_temp(nixs*(j-1)+10))
726 DO k=2,9
727 ixs(nixs*(compt-1)+k)=coresn(ix_temp(nixs*(j-1)+k))
728 END DO
729 IF (tag_elsf2(j)>1) tag_elsf(compt) = 1
730 IF (eani_temp(j)==10) THEN
731 compt10 = compt10+1
732 DO k=1,6
733 ixs(nixs*nelsn+6*(compt10-1)+k)=
734 . coresn(ix_temp(nixs*numels+6*(j10-1)+k))
735 END DO
736 ELSEIF (eani_temp(j)==20) THEN
737 compt20 = compt20+1
738 DO k=1,12
739 ixs((nixs*nelsn+6*nels10n)+12*(compt20-1)+k)=
740 . coresn(ix_temp((nixs*numels+6*numels10)+
741 . 12*(j20-1)+k))
742 END DO
743 ELSEIF (eani_temp(j)==16) THEN
744 compt16 = compt16+1
745 DO k=1,8
746 ixs((nixs*nelsn+6*nels10n+12*nels20n)+8*(compt16-1)+k)=
747 . coresn(ix_temp((nixs*numels+6*numels10+
748 . 12*numels20)+8*(j16-1)+k))
749 END DO
750 ELSE
751 compt8 = compt8+1
752 ENDIF
753
754 ENDIF
755 ENDDO
756
757 numels8 = compt8
758 numels10 = compt10
759 numels20 = compt20
760 numels16 = compt16
761 numels = compt
762
763 DEALLOCATE(ix_temp)
764
765
766C----------------------------------------------------------------------------------C
767C-------------Split of QUAD elements-----------------------------------------------C
768C----------------------------------------------------------------------------------C
769
770 ALLOCATE(ix_temp(numelq*nixq),coresq(numelq))
771 DO j=1,numelq
772 DO k=1,nixq
773 ix_temp(nixq*(j-1)+k)=ixq(nixq*(j-1)+k)
774 END DO
775 END DO
776 DEALLOCATE(ixq)
777
778C-------------Split----------------------------------------------------------------C
779
780 ALLOCATE(ixq(nelqn*nixq))
781 compt = 0
782 DO j=1,numelq
783 compt_ip_tmp=compt_ip_tmp+1
784 IF (tag_elq(j+npart)/=0) THEN
785 compt_ip=compt_ip+1
786 compt = compt+1
787 coresq(j)=compt
788 ipart(compt_ip)=ipart_temp(compt_ip_tmp)
789 DO k=1,nixq
790 ixq(nixq*(compt-1)+k)=ix_temp(nixq*(j-1)+k)
791 END DO
792 ixq(nixq*(compt-1)+1)=coresma(ix_temp(nixq*(j-1)+1))
793 ixq(nixq*(compt-1)+6)=corespro(ix_temp(nixq*(j-1)+6))
794 DO k=2,5
795 ixq(nixq*(compt-1)+k)=coresn(ix_temp(nixq*(j-1)+k))
796 END DO
797 ENDIF
798 ENDDO
799
800 numelq = compt
801 DEALLOCATE(ix_temp)
802
803C----------------------------------------------------------------------------------C
804C-------------Split of SHELL elements----------------------------------------------C
805C----------------------------------------------------------------------------------C
806
807 numelc0 = numelc
808 ALLOCATE(ix_temp(numelc*nixc),coresc(numelc))
809 CALL my_alloc (iworksh_temp,3,numelc)
810 DO j=1,numelc
811 DO k=1,nixc
812 ix_temp(nixc*(j-1)+k)=ixc(nixc*(j-1)+k)
813 END DO
814 iworksh_temp(1,j) = iworksh(1,j)
815 iworksh_temp(2,j) = iworksh(2,j)
816 iworksh_temp(3,j) = iworksh(3,j)
817 END DO
818 DEALLOCATE(ixc)
819
820C-------------Split----------------------------------------------------------------C
821 ALLOCATE(ixc(nelcn*nixc),tag_elcf(nelcn))
822 tag_elcf = 0
823 compt = 0
824 DO j=1,numelc
825 compt_ip_tmp=compt_ip_tmp+1
826 IF (tag_elc(j+npart)/=0) THEN
827 compt_ip=compt_ip+1
828 compt = compt+1
829 coresc(j)=compt
830 ipart(compt_ip)=ipart_temp(compt_ip_tmp)
831 DO k=1,nixc
832 ixc(nixc*(compt-1)+k)=ix_temp(nixc*(j-1)+k)
833 END DO
834 ixc(nixc*(compt-1)+1)=coresma(ix_temp(nixc*(j-1)+1))
835 ixc(nixc*(compt-1)+6)=corespro(ix_temp(nixc*(j-1)+6))
836 DO k=2,5
837 ixc(nixc*(compt-1)+k)=coresn(ix_temp(nixc*(j-1)+k))
838 END DO
839 IF (tag_elcf2(j) > 1) tag_elcf(compt) = 1
840 IF (tag_part(ipart(compt_ip)) /= 0) THEN
841 iworksh(1,compt)=iworksh_temp(1,j)
842 iworksh(2,compt)=iworksh_temp(2,j)
843 iworksh(3,compt)=iworksh_temp(3,j)
844 ELSE
845 iworksh(1,compt)=zero
846 iworksh(2,compt)=zero
847 iworksh(3,compt)=zero
848 ENDIF
849 ENDIF
850 ENDDO
851
852 numelc = compt
853 DEALLOCATE(ix_temp,iworksh_temp)
854
855C----------------------------------------------------------------------------------C
856C-------------Split of TRUSS elements----------------------------------------------C
857C----------------------------------------------------------------------------------C
858
859 ALLOCATE(ix_temp(numelt*nixt),corest(numelt))
860 DO j=1,numelt
861 DO k=1,nixt
862 ix_temp(nixt*(j-1)+k)=ixt(nixt*(j-1)+k)
863 END DO
864 END DO
865 DEALLOCATE(ixt)
866
867C-------------Split----------------------------------------------------------------C
868
869 ALLOCATE(ixt(neltn*nixt))
870 compt = 0
871 DO j=1,numelt
872 compt_ip_tmp=compt_ip_tmp+1
873 IF (tag_elt(j+npart)/=0) THEN
874 compt_ip=compt_ip+1
875 compt = compt+1
876 corest(j)=compt
877 ipart(compt_ip)=ipart_temp(compt_ip_tmp)
878 DO k=1,nixt
879 ixt(nixt*(compt-1)+k)=ix_temp(nixt*(j-1)+k)
880 END DO
881 ixt(nixt*(compt-1)+1)=coresma(ix_temp(nixt*(j-1)+1))
882 ixt(nixt*(compt-1)+4)=corespro(ix_temp(nixt*(j-1)+4))
883 DO k=2,3
884 ixt(nixt*(compt-1)+k)=coresn(ix_temp(nixt*(j-1)+k))
885 END DO
886 ENDIF
887 ENDDO
888
889 numelt = compt
890 DEALLOCATE(ix_temp)
891
892
893C----------------------------------------------------------------------------------C
894C-------------Split of BEAM elements-----------------------------------------------C
895C----------------------------------------------------------------------------------C
896
897 ALLOCATE(ix_temp(numelp*nixp),coresp(numelp))
898 DO j=1,numelp
899 DO k=1,nixp
900 ix_temp(nixp*(j-1)+k)=ixp(nixp*(j-1)+k)
901 END DO
902 END DO
903 DEALLOCATE(ixp)
904
905C-------------Split----------------------------------------------------------------C
906
907 ALLOCATE(ixp(nelpn*nixp))
908 compt = 0
909 DO j=1,numelp
910 compt_ip_tmp=compt_ip_tmp+1
911 IF (tag_elp(j+npart)/=0) THEN
912 compt_ip=compt_ip+1
913 compt = compt+1
914 coresp(j)=compt
915 ipart(compt_ip)=ipart_temp(compt_ip_tmp)
916 DO k=1,nixp
917 ixp(nixp*(compt-1)+k)=ix_temp(nixp*(j-1)+k)
918 END DO
919 ixp(nixp*(compt-1)+1)=coresma(ix_temp(nixp*(j-1)+1))
920 ixp(nixp*(compt-1)+5)=corespro(ix_temp(nixp*(j-1)+5))
921 DO k=2,4
922 ixp(nixp*(compt-1)+k)=coresn(ix_temp(nixp*(j-1)+k))
923 END DO
924 ENDIF
925 ENDDO
926
927 numelp = compt
928 DEALLOCATE(ix_temp)
929
930
931C----------------------------------------------------------------------------------C
932C-------------Split of SPRINGS and KJOINTS-----------------------------------------C
933C----------------------------------------------------------------------------------C
934
935 ALLOCATE(ix_temp(numelr*5+1))
936 DO j=1,numelr
937 DO k=1,5
938 ix_temp(5*(j-1)+k)=ixr_kj(5*(j-1)+k)
939 ixr_kj(5*(j-1)+k) = 0
940 END DO
941 END DO
942
943C-------------Split----------------------------------------------------------------C
944
945 compt = 0
946 comptb = 0
947 DO j=1,numelr
948 id_prop = corespro(ixr(nixr*(j-1)+1))
949 IF (igeo(npropgi*(id_prop-1)+11)==45) THEN
950 comptb = comptb + 1
951 IF (tag_elr(j+npart)/=0) THEN
952 compt = compt + 1
953 DO k=1,3
954 ixr_kj(5*(compt-1)+k)=coresn(ix_temp(5*(comptb-1)+k))
955 END DO
956 ixr_kj(5*(compt-1)+4)=ix_temp(5*(comptb-1)+4)
957 ixr_kj(5*(compt-1)+5)=0
958 ENDIF
959 ENDIF
960 ENDDO
961
962 ixr_kj(5*nelrn+1) = compt
963 DEALLOCATE(ix_temp)
964
965C----------------------------------------------------------------------------------C
966C-------------Split of SPRING elements---------------------------------------------C
967C----------------------------------------------------------------------------------C
968
969 ALLOCATE(ix_temp(numelr*nixr),coresr(numelr))
970 DO j=1,numelr
971 DO k=1,nixr
972 ix_temp(nixr*(j-1)+k)=ixr(nixr*(j-1)+k)
973 END DO
974 END DO
975 DEALLOCATE(ixr)
976
977C-------------Split----------------------------------------------------------------C
978
979 ALLOCATE(ixr(nelrn*nixr))
980 compt = 0
981 DO j=1,numelr
982 compt_ip_tmp=compt_ip_tmp+1
983 IF (tag_elr(j+npart)/=0) THEN
984 compt_ip=compt_ip+1
985 compt = compt+1
986 coresr(j)=compt
987 ipart(compt_ip)=ipart_temp(compt_ip_tmp)
988 DO k=1,nixr
989 ixr(nixr*(compt-1)+k)=ix_temp(nixr*(j-1)+k)
990 END DO
991 ixr(nixr*(compt-1)+1)=corespro(ix_temp(nixr*(j-1)+1))
992 DO k=2,3
993 ixr(nixr*(compt-1)+k)=coresn(ix_temp(nixr*(j-1)+k))
994 END DO
995 IF (ixr(nixr*(compt-1)+4)/=0) THEN
996 ixr(nixr*(compt-1)+4)=coresn(ix_temp(nixr*(j-1)+4))
997 ENDIF
998 ENDIF
999 ENDDO
1000
1001 numelr = compt
1002 DEALLOCATE(ix_temp)
1003
1004C----------------------------------------------------------------------------------C
1005C-------------Split of SH3N elements-----------------------------------------------C
1006C----------------------------------------------------------------------------------C
1007
1008 numeltg0 = numeltg
1009 ALLOCATE(ix_temp(numeltg*nixtg),corestg(numeltg))
1010 DO j=1,numeltg
1011 DO k=1,nixtg
1012 ix_temp(nixtg*(j-1)+k)=ixtg(nixtg*(j-1)+k)
1013 END DO
1014 END DO
1015 DEALLOCATE(ixtg)
1016
1017C-------------Split----------------------------------------------------------------C
1018
1019 ALLOCATE(ixtg(neltgn*nixtg))
1020 compt = 0
1021 DO j=1,numeltg
1022 compt_ip_tmp=compt_ip_tmp+1
1023 IF (tag_elg(j+npart)/=0) THEN
1024 compt_ip=compt_ip+1
1025 compt = compt+1
1026 corestg(j)=compt
1027 ipart(compt_ip)=ipart_temp(compt_ip_tmp)
1028 DO k=1,nixtg
1029 ixtg(nixtg*(compt-1)+k)=ix_temp(nixtg*(j-1)+k)
1030 END DO
1031 ixtg(nixtg*(compt-1)+1)=coresma(ix_temp(nixtg*(j-1)+1))
1032 ixtg(nixtg*(compt-1)+5)=corespro(ix_temp(nixtg*(j-1)+5))
1033 DO k=2,4
1034 ixtg(nixtg*(compt-1)+k)=coresn(ix_temp(nixtg*(j-1)+k))
1035 END DO
1036 ENDIF
1037 ENDDO
1038
1039 numeltg = compt
1040 DEALLOCATE(ix_temp)
1041
1042C----------------------------------------------------------------------------------C
1043C-------------Split of /SPH/RESERVE------------------------------------------------C
1044C----------------------------------------------------------------------------------C
1045
1046 ALLOCATE(res_temp(nbpartinlet))
1047 DO j=1,nbpartinlet
1048 res_temp(j) = reservep(j)
1049 END DO
1050
1051C-------------Split----------------------------------------------------------------C
1052 compt = 0
1053 part_res = 0
1054 first_cell = first_sphres
1055 DO j=1,nbpartinlet
1056 IF (tag_elsp(first_cell+npart)/=0) THEN
1057 compt = compt + 1
1058 reservep(compt) = res_temp(j)
1059 ENDIF
1060 DO k=1,res_temp(j)
1061 inod = kxsp(nisp*(first_cell-1)+3)
1062 first_cell = first_cell+1
1063 ENDDO
1064 ENDDO
1065
1066 nbpartinlet = compt
1067 DEALLOCATE(res_temp)
1068
1069C----------------------------------------------------------------------------------C
1070C-------------Split of SPH particles-----------------------------------------------C
1071C----------------------------------------------------------------------------------C
1072
1073 coeff = 0
1074 IF (nsphn>0) coeff = 1
1075 numspha = numsph - nsphres
1076C
1077 ALLOCATE(kxsp_temp(nisp*numsph),coressp(numsph))
1078 DO j=1,numsph
1079 DO k=1,nisp
1080 kxsp_temp(nisp*(j-1)+k)=kxsp(nisp*(j-1)+k)
1081 END DO
1082 END DO
1083 DEALLOCATE(ixsp,kxsp,nod2sp,spbuf)
1084
1085C-------------Split----------------------------------------------------------------C
1086 ALLOCATE(ixsp(kvoisph,nsphn),kxsp(nisp*nsphn),nod2sp(coeff*numnod))
1087 ALLOCATE(spbuf(nspbuf*nsphn))
1088 compt = 0
1089 nsphresn = 0
1090 DO j=1,numsph
1091 compt_ip_tmp=compt_ip_tmp+1
1092 IF (tag_elsp(j+npart)/=0) THEN
1093 compt_ip=compt_ip+1
1094 compt = compt+1
1095 coressp(j)=compt
1096 IF (j>=first_sphres) nsphresn=nsphresn+1
1097 ipart(compt_ip)=ipart_temp(compt_ip_tmp)
1098 DO k=1,nisp
1099 kxsp(nisp*(compt-1)+k)=kxsp_temp(nisp*(j-1)+k)
1100 END DO
1101 kxsp(nisp*(compt-1)+3)=coresn(kxsp_temp(nisp*(j-1)+3))
1102 nod2sp(coresn(kxsp_temp(nisp*(j-1)+3))) = compt
1103 ENDIF
1104 ENDDO
1105 IF ((compt/=0).AND.(compt/=numsph)) THEN
1106 CALL ancmsg(msgid=1061,
1107 . msgtype=msgwarning,
1108 . anmode=aninfo_blind_1)
1109 ENDIF
1110 numsph = compt
1111 numspha = compt - nsphresn
1112 nsphres = nsphresn
1113 first_sphres = numspha + 1
1114 DEALLOCATE(kxsp_temp)
1115
1116C----------------------------------------------------------------------------------C
1117
1118 DEALLOCATE(ipart_temp)
1119
1120C----------------------------------------------------------------------------------C
1121C-------------Split of THKE for shell and sh3n elements----------------------------C
1122C----------------------------------------------------------------------------------C
1123
1124 ALLOCATE(thk_tmp(numeltg0+numelc0))
1125 DO j=1,numeltg0+numelc0
1126 thk_tmp(j)=thke(j)
1127 END DO
1128 DEALLOCATE(thke)
1129
1130C-------------Split----------------------------------------------------------------C
1131
1132 ALLOCATE(thke(numeltg+numelc))
1133 DO j=1,numelc0
1134 IF (tag_elc(j+npart)/=0) THEN
1135 thke(coresc(j))=thk_tmp(j)
1136 ENDIF
1137 ENDDO
1138 DO j=1,numeltg0
1139 IF (tag_elg(j+npart)/=0) THEN
1140 thke(corestg(j)+numelc)=thk_tmp(j+numelc0)
1141 ENDIF
1142 ENDDO
1143
1144 DEALLOCATE(thk_tmp)
1145
1146C----------------------------------------------------------------------------------C
1147C-------------Split of GROUPS------------------------------------------------------C
1148C----------------------------------------------------------------------------------C
1149
1150!! ALLOCATE(BUF_TEMP(SIZE))
1151!! DO I=1,SIZE
1152!! BUF_TEMP(I)=BUF_NOD(I)
1153!! END DO
1154
1155C ---------> groups of elements----------------------------------------------------C
1156C --> solids <--
1157 DO i=1,ngrbric
1158 compt = 0
1159 igrbric(i)%R2R_SHARE = 0
1160 DO j=1,igrbric(i)%NENTITY
1161 cur_id = igrbric(i)%ENTITY(j)
1162 IF (tag_els(cur_id+npart)/=0)THEN
1163 compt = compt+1
1164 igrbric(i)%ENTITY(compt) = coress(cur_id)
1165 IF (tag_els(cur_id+npart)>1)
1166 . igrbric(i)%R2R_SHARE = igrbric(i)%R2R_SHARE + 1
1167 ENDIF
1168 ENDDO
1169 igrbric(i)%R2R_ALL = igrbric(i)%NENTITY
1170 igrbric(i)%NENTITY = compt
1171 ENDDO
1172C --> quads <--
1173 DO i=1,ngrquad
1174 compt = 0
1175 igrquad(i)%R2R_SHARE = 0
1176 DO j=1,igrquad(i)%NENTITY
1177 cur_id = igrquad(i)%ENTITY(j)
1178 IF (tag_elq(cur_id+npart)/=0)THEN
1179 compt = compt+1
1180 igrquad(i)%ENTITY(compt) = coresq(cur_id)
1181 IF (tag_elq(cur_id+npart)>1)
1182 . igrquad(i)%R2R_SHARE = igrquad(i)%R2R_SHARE + 1
1183 ENDIF
1184 ENDDO
1185 igrquad(i)%R2R_ALL = igrquad(i)%NENTITY
1186 igrquad(i)%NENTITY = compt
1187 ENDDO
1188C --> sh4n <--
1189 DO i=1,ngrshel
1190 compt = 0
1191 igrsh4n(i)%R2R_SHARE = 0
1192 DO j=1,igrsh4n(i)%NENTITY
1193 cur_id = igrsh4n(i)%ENTITY(j)
1194 IF (tag_elc(cur_id+npart)/=0)THEN
1195 compt = compt+1
1196 igrsh4n(i)%ENTITY(compt) = coresc(cur_id)
1197 IF (tag_elc(cur_id+npart)>1)
1198 . igrsh4n(i)%R2R_SHARE = igrsh4n(i)%R2R_SHARE + 1
1199 ENDIF
1200 ENDDO
1201 igrsh4n(i)%R2R_ALL = igrsh4n(i)%NENTITY
1202 igrsh4n(i)%NENTITY = compt
1203 ENDDO
1204C --> truss <--
1205 DO i=1,ngrtrus
1206 compt = 0
1207 igrtruss(i)%R2R_SHARE = 0
1208 DO j=1,igrtruss(i)%NENTITY
1209 cur_id = igrtruss(i)%ENTITY(j)
1210 IF (tag_elt(cur_id+npart)/=0)THEN
1211 compt = compt+1
1212 igrtruss(i)%ENTITY(compt) = corest(cur_id)
1213 IF (tag_elt(cur_id+npart)>1)
1214 . igrtruss(i)%R2R_SHARE = igrtruss(i)%R2R_SHARE + 1
1215 ENDIF
1216 ENDDO
1217 igrtruss(i)%R2R_ALL = igrtruss(i)%NENTITY
1218 igrtruss(i)%NENTITY = compt
1219 ENDDO
1220C --> beams <--
1221 DO i=1,ngrbeam
1222 compt = 0
1223 igrbeam(i)%R2R_SHARE = 0
1224 DO j=1,igrbeam(i)%NENTITY
1225 cur_id = igrbeam(i)%ENTITY(j)
1226 IF (tag_elp(cur_id+npart)/=0)THEN
1227 compt = compt+1
1228 igrbeam(i)%ENTITY(compt) = coresp(cur_id)
1229 IF (tag_elp(cur_id+npart)>1)
1230 . igrbeam(i)%R2R_SHARE = igrbeam(i)%R2R_SHARE + 1
1231 ENDIF
1232 ENDDO
1233 igrbeam(i)%R2R_ALL = igrbeam(i)%NENTITY
1234 igrbeam(i)%NENTITY = compt
1235 ENDDO
1236C --> springs <--
1237 DO i=1,ngrspri
1238 compt = 0
1239 igrspring(i)%R2R_SHARE = 0
1240 DO j=1,igrspring(i)%NENTITY
1241 cur_id = igrspring(i)%ENTITY(j)
1242 IF (tag_elr(cur_id+npart)/=0)THEN
1243 compt = compt+1
1244 igrspring(i)%ENTITY(compt) = coresr(cur_id)
1245 IF (tag_elr(cur_id+npart)>1)
1246 . igrspring(i)%R2R_SHARE = igrspring(i)%R2R_SHARE + 1
1247 ENDIF
1248 ENDDO
1249 igrspring(i)%R2R_ALL = igrspring(i)%NENTITY
1250 igrspring(i)%NENTITY = compt
1251 ENDDO
1252C --> sh3n <--
1253 DO i=1,ngrsh3n
1254 compt = 0
1255 igrsh3n(i)%R2R_SHARE = 0
1256 DO j=1,igrsh3n(i)%NENTITY
1257 cur_id = igrsh3n(i)%ENTITY(j)
1258 IF (tag_elg(cur_id+npart)/=0)THEN
1259 compt = compt+1
1260 igrsh3n(i)%ENTITY(compt) = corestg(cur_id)
1261 IF (tag_elg(cur_id+npart)>1)
1262 . igrsh3n(i)%R2R_SHARE = igrsh3n(i)%R2R_SHARE + 1
1263 ENDIF
1264 ENDDO
1265 igrsh3n(i)%R2R_ALL = igrsh3n(i)%NENTITY
1266 igrsh3n(i)%NENTITY = compt
1267 ENDDO
1268
1269C ---------> groups of parts-----------------------------------------------------C
1270
1271 DO i=1,ngrpart
1272 compt = 0
1273 DO j=1,igrpart(i)%NENTITY
1274 cur_id = igrpart(i)%ENTITY(j)
1275 IF (tag_part(cur_id)==1)THEN
1276 compt = compt+1
1277 igrpart(i)%ENTITY(compt) = cur_id
1278 ENDIF
1279 ENDDO
1280 igrpart(i)%R2R_ALL = igrpart(i)%NENTITY
1281 igrpart(i)%NENTITY = compt
1282 ENDDO
1283C----------------------------------------------------------------------------------C
1284C-------------Split of surfaces----------------------------------------------------C
1285C----------------------------------------------------------------------------------C
1286
1287 DO i=1,nb_surf
1288 nseg = 0
1289 ccpl = 0
1290 DO j=1,igrsurf(i)%NSEG
1291 nb_nod_sub=0
1292 nb_nod_cpl=0
1293 tag = 0
1294 cur_id = igrsurf(i)%ELEM(j)
1295 IF (igrsurf(i)%ELTYP(j) == 1) THEN
1296C---------------> case face of solid <--
1297 IF (tag_els(cur_id+npart)/=0) THEN
1298 new_id = coress(cur_id)
1299 tag = 1
1300 ENDIF
1301 ELSEIF (igrsurf(i)%ELTYP(j) == 2) THEN
1302C---------------> case quad <--
1303 IF (tag_elq(cur_id+npart)/=0) THEN
1304 new_id = coresq(cur_id)
1305 tag = 1
1306 ENDIF
1307 ELSEIF (igrsurf(i)%ELTYP(j) == 3) THEN
1308C---------------> case shell <--
1309 IF (tag_elc(cur_id+npart)/=0) THEN
1310 new_id = coresc(cur_id)
1311 tag = 1
1312 ENDIF
1313 ELSEIF (igrsurf(i)%ELTYP(j) == 7) THEN
1314C---------------> case sh3n <--
1315 IF (tag_elg(cur_id+npart)/=0) THEN
1316 new_id = corestg(cur_id)
1317 tag = 1
1318 ENDIF
1319 ELSEIF (igrsurf(i)%ELTYP(j) > 10) THEN
1320C---------------> case of surface defined by segments and associated elements <--
1321 IF (igrsurf(i)%ELTYP(j) == 11) THEN
1322 IF (tag_els(cur_id+npart)/=0) tag=1
1323 ELSEIF (igrsurf(i)%ELTYP(j) == 13) THEN
1324 IF (tag_elc(cur_id+npart)/=0) tag=1
1325 ELSEIF (igrsurf(i)%ELTYP(j) == 17) THEN
1326 IF (tag_elg(cur_id+npart)/=0) tag=1
1327 ENDIF
1328C ---> resef of type of segment <--
1329 igrsurf(i)%ELTYP(j) = 0
1330 new_id = 0
1331 ELSEIF (igrsurf(i)%ELTYP(j) == 0) THEN
1332C---------------> case of surface defined by segments with nodes <--
1333 DO k=1,4
1334 nod_id = igrsurf(i)%NODES(j,k)
1335 IF (tagno(nod_id+npart)/=-1) nb_nod_cpl=nb_nod_cpl+1
1336 END DO
1337 IF (nb_nod_cpl==4) THEN
1338 tag = 1
1339 new_id = 0
1340 ENDIF
1341 ENDIF
1342C---------------> TAG = 1, segment is kept, update of nodes <--
1343 IF (tag == 1) THEN
1344 nseg = nseg + 1
1345 DO k=1,4
1346 cur_id = igrsurf(i)%NODES(j,k)
1347 IF (tagno(cur_id+npart)>1) nb_nod_cpl=nb_nod_cpl+1
1348 igrsurf(i)%NODES(nseg,k) = coresn(cur_id)
1349 END DO
1350 IF (nb_nod_cpl==4) ccpl=ccpl+1
1351 igrsurf(i)%ELTYP(nseg) = igrsurf(i)%ELTYP(j)
1352 igrsurf(i)%ELEM(nseg) = new_id
1353 ENDIF
1354 END DO
1355 isurf_r2r(2,i) = igrsurf(i)%NSEG
1356 igrsurf(i)%NSEG = nseg
1357 isurf_r2r(1,i) = ccpl
1358 END DO
1359
1360C----------------------------------------------------------------------------------C
1361C-------------Split of Lines-------------------------------------------------------C
1362C----------------------------------------------------------------------------------C
1363 DO i=1,nb_line
1364 nseg = 0
1365 DO j=1,igrslin(i)%NSEG
1366 nb_nod_sub=0
1367 tag = 0
1368 cur_id = igrslin(i)%ELEM(j)
1369 IF (igrslin(i)%ELTYP(j)==1) THEN
1370C---------------> case face of solid <--
1371 IF (tag_els(cur_id+npart)/=0) THEN
1372 new_id = coress(cur_id)
1373 tag = 1
1374 ENDIF
1375 ELSEIF (igrslin(i)%ELTYP(j)==2) THEN
1376C---------------> case quad <--
1377 IF (tag_elq(cur_id+npart)/=0) THEN
1378 new_id = coresq(cur_id)
1379 tag = 2
1380 ENDIF
1381 ELSEIF (igrslin(i)%ELTYP(j)==3) THEN
1382C---------------> case shell <--
1383 IF (tag_elc(cur_id+npart)/=0) THEN
1384 new_id = coresc(cur_id)
1385 tag = 3
1386 ENDIF
1387 ELSEIF (igrslin(i)%ELTYP(j)==4) THEN
1388C---------------> case truss <--
1389 IF (tag_elt(cur_id+npart)/=0) THEN
1390 new_id = corest(cur_id)
1391 tag = 4
1392 ENDIF
1393 ELSEIF (igrslin(i)%ELTYP(j)==5) THEN
1394C---------------> case beam <--
1395 IF (tag_elp(cur_id+npart)/=0) THEN
1396 new_id = coresp(cur_id)
1397 tag = 5
1398 ENDIF
1399 ELSEIF (igrslin(i)%ELTYP(j)==6) THEN
1400C---------------> cas spring <--
1401 IF (tag_elr(cur_id+npart)/=0) THEN
1402 new_id = coresr(cur_id)
1403 tag = 6
1404 ENDIF
1405 ELSEIF (igrslin(i)%ELTYP(j)==7) THEN
1406C---------------> cas sh3n <--
1407 IF (tag_elg(cur_id+npart)/=0) THEN
1408 new_id = corestg(cur_id)
1409 tag = 7
1410 ENDIF
1411 ELSEIF (igrslin(i)%ELTYP(j)==0) THEN
1412C---------------> No element, count of taged nodes <--
1413 new_id = 0
1414 DO k=1,2
1415 cur_id = igrslin(i)%NODES(j,k)
1416 IF (tagno(cur_id+npart)>=0) nb_nod_sub=nb_nod_sub+1
1417 END DO
1418 IF (nb_nod_sub==2) tag = 8
1419 ENDIF
1420C---------------> TAG = 1, segment is kept, update of nodes <--
1421 IF (tag > 0) THEN
1422 nseg = nseg + 1
1423 DO k=1,2
1424 cur_id = igrslin(i)%NODES(j,k)
1425 igrslin(i)%NODES(nseg,k) = coresn(cur_id)
1426 END DO
1427 igrslin(i)%ELTYP(nseg) = igrslin(i)%ELTYP(j)
1428 igrslin(i)%ELEM(nseg) = new_id
1429 ENDIF
1430 END DO
1431 igrslin(i)%NSEG_R2R_ALL = igrslin(i)%NSEG
1432 igrslin(i)%NSEG = nseg
1433 END DO
1434
1435C----------------------------------------------------------------------------------C
1436C-------------Split of groups of nodes---------------------------------------------C
1437C----------------------------------------------------------------------------------C
1438
1439 DO i=1,ngrnod
1440! ---------> groups of nodes
1441 compt = 0
1442 ccpl = 0
1443 DO j=1,igrnod(i)%NENTITY
1444 cur_id = igrnod(i)%ENTITY(j)
1445 IF (tagno(cur_id+npart) >= 0) THEN
1446 compt = compt + 1
1447 igrnod(i)%ENTITY(compt) = coresn(cur_id)
1448 ENDIF
1449 IF (tagno(cur_id+npart)>1) ccpl=ccpl+1
1450 ENDDO
1451 igrnod(i)%R2R_ALL = igrnod(i)%NENTITY
1452 igrnod(i)%R2R_SHARE = ccpl
1453 igrnod(i)%NENTITY = compt
1454 ENDDO ! DO I=1,NGRNOD
1455
1456C----------------------------------------------------------------------------------C
1457C--------------Update of TAGNO-----------------------------------------------------C
1458C----------------------------------------------------------------------------------C
1459
1460 ALLOCATE(tagno_temp(2*numnod_old+npart))
1461 DO j=1,npart+2*numnod_old
1462 tagno_temp(j)=tagno(j)
1463 END DO
1464
1465 DEALLOCATE(tagno)
1466 ALLOCATE(tagno(2*numnod+npart))
1467 DO j=1,npart
1468 tagno(j)=tagno_temp(j)
1469 END DO
1470 compt=0
1471 DO j=1,numnod_old
1472 IF (tagno_temp(j+npart)>=0)THEN
1473 compt=compt+1
1474 tagno(compt+npart)=tagno_temp(j+npart)
1475 tagno(compt+npart+numnod)=tagno_temp(j+npart+numnod_old)
1476 ENDIF
1477 ENDDO
1478
1479C----------------------------------------------------------------------------------C
1480C------Prereading and tag of SECTIONS----------------------------------------------C
1481C----------------------------------------------------------------------------------C
1482
1483 CALL prelecsec(
1484 1 nul,nul,itabm1,2,nom_opt(lnopt1*inom_opt(8)+1),
1485 2 igrbric ,igrquad ,igrsh4n ,igrsh3n ,igrtruss,
1486 3 igrbeam ,igrspring ,igrnod, lsubmodel ,seatbelt_shell_to_spring,
1487 4 nb_seatbelt_shells)
1488
1489C----------------------------------------------------------------------------------C
1490C------Split of GAUGES-------------------------------------------------------------C
1491C----------------------------------------------------------------------------------C
1492
1493 compt = 0
1494 DO i=1,nbgauge
1495 IF ((taggau(i)>0).AND.(numels>0)) THEN
1496C---------------> Cas des GAUGES <--
1497 compt = compt + 1
1498 ELSEIF ((taggau(i)<0).AND.(numsph>0)) THEN
1499C---------------> Cas des GAUGE/SPH <--
1500 taggau(i) = abs(taggau(i))
1501 compt = compt + 1
1502 ELSE
1503 taggau(i) = 0
1504 ENDIF
1505 ENDDO
1506
1507 nbgauge = compt
1508
1509C----------------------------------------------------------------------------------C
1510C------Split of RBY_MSN (used for /INIVEL/AXIS) -----------------------------------C
1511C----------------------------------------------------------------------------------C
1512
1513 nrbody_old = SIZE(tagrby)
1514 ALLOCATE(rby_msn_temp(2,nrbody_old))
1515 DO i=1,nrbody_old
1516 rby_msn_temp(1,i) = rby_msn(1,i)
1517 rby_msn_temp(2,i) = rby_msn(2,i)
1518 rby_msn(1,i) = 0
1519 rby_msn(2,i) = 0
1520 ENDDO
1521
1522C-------------Split----------------------------------------------------------------C
1523
1524 nrb =0
1525 DO i=1,nrbody_old
1526 IF(tagrby(i) > 0) THEN
1527 nrb = nrb + 1
1528 rby_msn(1,nrb) = rby_msn_temp(1,i)
1529 rby_msn(2,nrb) = coresn(rby_msn_temp(2,i))
1530 END IF
1531 ENDDO
1532
1533C------------------------------------------------------------------------------------C
1534
1535 flg_split = 1
1536!! DEALLOCATE(BUF_TEMP)
1537 DEALLOCATE(coresc,coresn,corestg,corest)
1538 DEALLOCATE(corespro,coresr,coresp,coress)
1539 DEALLOCATE(coresq,eani_temp,tagno_temp)
1540
1541C------------------------------------------------------------------------------------C
1542
1543 DEALLOCATE(tag_elc,tag_els,tag_elp,tag_elq,tag_elr,tag_elt)
1544 DEALLOCATE(tag_elg,tag_surf,tag_prop,tag_elcf2,tag_elsf2)
1545
1546C----------------------------------------------------------------------------------C
1547C------Rewritinf of TAGMAT and TAGPROP for grouping--------------------------------C
1548C----------------------------------------------------------------------------------C
1549 DO k=1,npart
1550 IF(tag_part(k) == 0) THEN
1551 tag_mat(ipart(lipart1*(k-1)+1))=0
1552 ENDIF
1553 END DO
1554
1555C------------------------------------------------------------------------------------
1556
1557 ENDIF
1558 RETURN
1559
1560 END SUBROUTINE r2r_split
constit
subroutine constit(itab, itabm1, numnod)
Definition constit.F:35
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
ale_mod
Definition ale_mod.F:149
front_mod
Definition front_mod.F:84
front_mod::flagkin
integer, dimension(:), allocatable flagkin
Definition front_mod.F:105
groupdef_mod
Definition groupdef_mod.F:662
message_mod
Definition message_mod.F:1249
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1000
nod2el_mod
Definition nod2el_mod.F:36
r2r_mod
Definition r2r_mod.F:125
r2r_mod::tag_els
integer, dimension(:), allocatable tag_els
Definition r2r_mod.F:133
r2r_mod::tag_elg
integer, dimension(:), allocatable tag_elg
Definition r2r_mod.F:135
r2r_mod::tagno
integer, dimension(:), allocatable tagno
Definition r2r_mod.F:132
r2r_mod::tag_prop
integer, dimension(:), allocatable tag_prop
Definition r2r_mod.F:136
r2r_mod::tag_elq
integer, dimension(:), allocatable tag_elq
Definition r2r_mod.F:135
r2r_mod::tagrby
integer, dimension(:), allocatable tagrby
Definition r2r_mod.F:132
r2r_mod::tag_elcf
integer, dimension(:), allocatable tag_elcf
Definition r2r_mod.F:141
r2r_mod::tag_elc
integer, dimension(:), allocatable tag_elc
Definition r2r_mod.F:133
r2r_mod::tag_part
integer, dimension(:), allocatable tag_part
Definition r2r_mod.F:134
r2r_mod::tag_elr
integer, dimension(:), allocatable tag_elr
Definition r2r_mod.F:134
r2r_mod::tag_mat
integer, dimension(:), allocatable tag_mat
Definition r2r_mod.F:136
r2r_mod::flagkin_r2r
integer, dimension(:), allocatable flagkin_r2r
Definition r2r_mod.F:140
r2r_mod::tag_elt
integer, dimension(:), allocatable tag_elt
Definition r2r_mod.F:134
r2r_mod::front_r2r
integer, dimension(:), allocatable front_r2r
Definition r2r_mod.F:140
r2r_mod::tag_surf
integer, dimension(:), allocatable tag_surf
Definition r2r_mod.F:136
r2r_mod::isubdom_part
integer, dimension(:), allocatable isubdom_part
Definition r2r_mod.F:131
r2r_mod::isurf_r2r
integer, dimension(:,:), allocatable isurf_r2r
Definition r2r_mod.F:143
r2r_mod::tag_subs
integer, dimension(:), allocatable tag_subs
Definition r2r_mod.F:135
r2r_mod::tag_elsf
integer, dimension(:), allocatable tag_elsf
Definition r2r_mod.F:141
r2r_mod::taggau
integer, dimension(:), allocatable taggau
Definition r2r_mod.F:142
r2r_mod::tag_elsf2
integer, dimension(:), allocatable tag_elsf2
Definition r2r_mod.F:141
r2r_mod::tag_elp
integer, dimension(:), allocatable tag_elp
Definition r2r_mod.F:133
r2r_mod::isubdom
integer, dimension(:,:), allocatable isubdom
Definition r2r_mod.F:144
r2r_mod::tag_elsp
integer, dimension(:), allocatable tag_elsp
Definition r2r_mod.F:142
r2r_mod::tag_elcf2
integer, dimension(:), allocatable tag_elcf2
Definition r2r_mod.F:141
restmod::ixs
integer, dimension(:), allocatable, target ixs
Definition restart_mod.F:60
restmod::ipm
integer, dimension(:), allocatable ipm
Definition restart_mod.F:83
restmod::ipart
integer, dimension(:), allocatable, target ipart
Definition restart_mod.F:60
restmod::ixt
integer, dimension(:), allocatable ixt
Definition restart_mod.F:60
restmod::ixr
integer, dimension(:), allocatable ixr
Definition restart_mod.F:60
restmod::ixtg
integer, dimension(:), allocatable, target ixtg
Definition restart_mod.F:60
restmod::kxsp
integer, dimension(:), allocatable kxsp
Definition restart_mod.F:60
restmod::itabm1
integer, dimension(:), allocatable, target itabm1
Definition restart_mod.F:60
restmod::iskwn
integer, dimension(:), allocatable, target iskwn
Definition restart_mod.F:60
restmod::itab
integer, dimension(:), allocatable itab
Definition restart_mod.F:60
restmod::nod2sp
integer, dimension(:), allocatable nod2sp
Definition restart_mod.F:60
restmod::ixp
integer, dimension(:), allocatable ixp
Definition restart_mod.F:60
restmod::nom_opt
integer, dimension(:), allocatable, target nom_opt
Definition restart_mod.F:60
restmod::igeo
integer, dimension(:), allocatable igeo
Definition restart_mod.F:83
restmod::ixsp
integer, dimension(:,:), allocatable ixsp
Definition restart_mod.F:81
restmod::ixq
integer, dimension(:), allocatable ixq
Definition restart_mod.F:60
restmod::ixc
integer, dimension(:), allocatable ixc
Definition restart_mod.F:60
submodel_mod
Definition submodel_mod.F:712
prelecsec
subroutine prelecsec(snstrf, ssecbuf, itabm1, flag_r2r, nom_opt, igrbric, igrquad, igrsh4n, igrsh3n, igrtruss, igrbeam, igrspring, igrnod, lsubmodel, seatbelt_shell_to_spring, nb_seatbelt_shells)
Definition prelecsec.F:52
r2r_monvol
subroutine r2r_monvol(tagpart, tagpro, igrsurf, lsubmodel)
Definition r2r_prelec.F:1376
r2r_split
subroutine r2r_split(nb_line, nb_surf, flag, eani2, buf_nod, ixr_kj, inom_opt, reservep, nale_r2r, nspcond0, subset, igrsurf, igrnod, igrbric, igrquad, igrsh4n, igrsh3n, igrtruss, igrbeam, igrspring, igrpart, igrslin, lsubmodel, rby_msn, iworksh, seatbelt_shell_to_spring, nb_seatbelt_shells)
Definition r2r_split.F:50
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
submodel_mod::submodel_data
Definition submodel_mod.F:723
tagelem_r2r
subroutine tagelem_r2r(numel, ipart, tagbuf, npart)
Definition tagelem_r2r.F:29