OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
t3grtails.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!|| t3grtails ../starter/source/elements/solid_2d/tria/t3grtails.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| arret ../starter/source/system/arret.F
30!|| fretitl2 ../starter/source/starter/freform.F
31!|| zeroin ../starter/source/system/zeroin.F
32!||--- uses -----------------------------------------------------
33!|| drape_mod ../starter/share/modules1/drape_mod.F
34!|| inivol_def_mod ../starter/share/modules1/inivol_mod.F
35!|| message_mod ../starter/share/message_module/message_mod.F
36!|| r2r_mod ../starter/share/modules1/r2r_mod.F
37!|| reorder_mod ../starter/share/modules1/reorder_mod.F
38!|| stack_mod ../starter/share/modules1/stack_mod.F
39!||====================================================================
40 SUBROUTINE t3grtails(
41 1 IXTG ,PM ,IPARG ,GEO ,
42 2 EADD ,ND ,IPARTTG ,DD_IAD ,
43 3 IDX ,INUM ,INDEX ,CEP ,
44 4 THK ,XNUM ,ITR1 ,IGRSURF ,IGRSH3N ,
45 5 ICNOD ,IGEO ,IPM ,IXTG1 ,
46 6 IPART ,SH3TREE ,NOD2ELTG ,ITRIOFF ,
47 7 SH3TRIM ,TAGPRT_SMS ,IWORKSH ,STACK ,
48 8 DRAPE ,RNOISE ,INIVOL ,MAT_PARAM ,
49 9 SH3ANG ,DRAPEG ,PRINT_FLAG ,PTSH3N )
50C-----------------------------------------------
51C M o d u l e s
52C-----------------------------------------------
53 USE my_alloc_mod
54 USE message_mod
55 USE r2r_mod
56 USE stack_mod
57 USE reorder_mod
58 USE groupdef_mod
59 USE drape_mod
60 USE inivol_def_mod , ONLY : inivol_struct_, num_inivol
61 USE matparam_def_mod
62 USE names_and_titles_mod , ONLY : nchartitle
63 USE ale_mod , ONLY : ale
64C-----------------------------------------------
65C A R G U M E N T S
66C-----------------------------------------------
67C IXTG(NIXTG,NUMELTG) ARRAY : CONECS+PID+MID+NOS TRIANGLES I
68C PM(NPROPM,NUMMAT) ARRAY : MATERIALS I
69C IPARG(NPARG,NGROUP) ARRAY : GROUPS I/O
70C GEO(NPROPG,NUMGEO) ARRAY : PROPERTIES I
71C EADD(NUMELTG) ARRAY : IDAM INDEX (CHECKBOARD CHANGE) I
72C IPARTTG(NUMELTG) I/O
73C INUM(8,NUMELTG) WOKING ARRAY I/O
74C ITR1(NSELTG) WOKING ARRAY I/O
75C INDEX(NUMELTG) WOKING ARRAY I/O
76C CEP(NUMELTG) WOKING ARRAY I/O
77C THK(NUMELTG) WOKING ARRAY I/O
78C ITRIOFF(NUMELTG) FLAG ELEM RBY ON/OFF I/O
79C-----------------------------------------------
80C I M P L I C I T T Y P E S
81C-----------------------------------------------
82#include "implicit_f.inc"
83C-----------------------------------------------
84C C O M M O N B L O C K S
85C-----------------------------------------------
86#include "com01_c.inc"
87#include "com04_c.inc"
88#include "com_xfem1.inc"
89#include "units_c.inc"
90#include "param_c.inc"
91#include "vect01_c.inc"
92#include "scr17_c.inc"
93#include "remesh_c.inc"
94#include "sms_c.inc"
95#include "r2r_c.inc"
96#include "drape_c.inc"
97
98C-----------------------------------------------
99C D U M M Y A R G U M E N T S
100C-----------------------------------------------
101 INTEGER ND, IDX,
102 . IXTG(NIXTG,*), IPARG(NPARG,*), EADD(*), IXTG1(4,*),
103 . DD_IAD(NSPMD+1,*),IPARTTG(*),
104 . INUM(10,*),ITR1(*),INDEX(*),CEP(*),ICNOD(*),IPM(NPROPMI,NUMMAT),
105 . ITRIOFF(*), SH3TRIM(*),IGEO(NPROPGI,NUMGEO),
106 . IPART(LIPART1,*), SH3TREE(KSH3TREE,*), NOD2ELTG(*) ,
107 . TAGPRT_SMS(*),IWORKSH(3,*)
108 INTEGER, INTENT(IN) :: PRINT_FLAG !< flag to print the element group data
109 INTEGER , DIMENSION(NUMELTG) , INTENT(INOUT):: PTSH3N
110 TYPE (INIVOL_STRUCT_),DIMENSION(NUM_INIVOL) :: INIVOL
111 MY_REAL :: PM(NPROPM,NUMMAT), GEO(NPROPG,NUMGEO),THK(*),XNUM(*),RNOISE(NPERTURB,*),SH3ANG(*)
112C-----------------------------------------------
113 TYPE (STACK_PLY) :: STACK
114 TYPE (DRAPE_), TARGET :: DRAPE(NUMELC_DRAPE + NUMELTG_DRAPE)
115 TYPE (DRAPEG_) :: DRAPEG
116 TYPE (DRAPE_), DIMENSION(:), ALLOCATABLE :: XNUM_DRAPE
117 TYPE (DRAPEG_), ALLOCATABLE :: XNUM_DRAPEG
118 TYPE (DRAPE_PLY_), POINTER :: DRAPE_PLY
119 TYPE(matparam_struct_) ,DIMENSION(NUMMAT),INTENT(IN) :: MAT_PARAM
120C-----------------------------------------------
121 TYPE (GROUP_), DIMENSION(NGRSH3N) :: IGRSH3N
122 TYPE (SURF_), DIMENSION(NSURF) :: IGRSURF
123C-----------------------------------------------
124C L O C A L V A R I A B L E S
125C-----------------------------------------------
126 INTEGER I, K, NGR1, MLN, ISMST,NN,ICSEN,NLEVXF,
127 . npn, n, mid, pid,ii, j, midn, nsg, nel, ne1, ithk,
128 . ipla, igtyp, p, nel_prec, nb,mode,kcnod,prt,neltg3,ipt,
129 . ilev, ie, mpt, nuvar, nuvarr, iadm, my_nvsiz,
130 . imatly,ixfem,iptun,irep,
131 . isubstack,ippid,ipmat,ish3n, npg,idrot1,nb_law58,ipert,
132 . stat, mft,iloc,jj,
133 . jale_from_mat,jale_from_prop,nslice,kk,npt_drp,idrape,iel,iel0
134 my_real :: angle(numeltg)
135 INTEGER WORK(70000),NGP(NSPMD+1)
136 INTEGER, DIMENSION(:,:), ALLOCATABLE :: ISTOR
137 INTEGER ID,IPARTR2R
138 CHARACTER(LEN=NCHARTITLE)::TITR,TITR1
139 my_real, DIMENSION(:,:), ALLOCATABLE :: XNUM_RNOISE
140 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX2, INUM_PTSH3N
141 INTEGER, DIMENSION(:,:), ALLOCATABLE :: INUM_WORKSH
142 LOGICAL lFOUND
143C-----------------------------------------------
144 CALL my_alloc(index2,numeltg)
145 index2(1:numeltg)=permutation%TRIANGLE(1:numeltg)
146
147 IF(nadmesh/=0)THEN
148 ALLOCATE( istor(ksh3tree+1,numeltg) )
149 ELSE
150 ALLOCATE( istor(0,0) )
151 ENDIF
152C
153 IF (nperturb > 0) THEN
154 ALLOCATE(xnum_rnoise(nperturb,numeltg),stat=stat)
155 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,msgtype=msgerror,c1='XNUM_RNOISE')
156 ELSE
157 ALLOCATE(xnum_rnoise(0,0))
158 ENDIF
159C
160 iptun = 1
161C--------------------------------------------------------------
162C BORNAGE DES GROUPES DE MVSIZ
163C--------------------------------------------------------------
164 ngr1 = ngroup + 1
165C
166C submat 1 : domain decompostition
167C
168 idx=idx+nd*(nspmd+1)
169 CALL zeroin(1,nd*(nspmd+1),dd_iad(1,nspgroup+1))
170 nft = 0
171
172 ! init. dd_iad
173 DO n=1,nd
174 DO p=1,nspmd+1
175 dd_iad(p,nspgroup+n) = 0
176 END DO
177 ENDDO
178
179 neltg3 = numeltg
180 iel = 0
181 IF(ndrape > 0 ) iel = drapeg%NUMSH4
182 DO n=1,nd
183 nel = eadd(n+1)-eadd(n)
184 IF (ndrape > 0 .AND. numeltg_drape > 0) THEN
185 ALLOCATE(xnum_drape(nel))
186 ALLOCATE(xnum_drapeg%INDX(nel))
187 xnum_drapeg%INDX = 0
188 DO i =1, nel
189 iel0 = drapeg%INDX(numelc + i + nft)
190 IF(iel0 == 0) cycle
191 npt = drape(iel0)%NPLY
192 npt_drp = drape(iel0)%NPLY_DRAPE
193 ALLOCATE(xnum_drape(i)%INDX_PLY(npt_drp))
194 ALLOCATE(xnum_drape(i)%DRAPE_PLY(npt_drp))
195 xnum_drape(i)%INDX_PLY= 0
196 DO j = 1,npt_drp
197 nslice = drape(iel0)%DRAPE_PLY(j)%NSLICE
198 ALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%RDRAPE(nslice,2))
199 ALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%IDRAPE(nslice,2))
200 xnum_drape(i)%DRAPE_PLY(j)%RDRAPE = 0
201 xnum_drape(i)%DRAPE_PLY(j)%IDRAPE = 0
202 ENDDO
203 ENDDO
204 ELSE
205 ALLOCATE( xnum_drape(0) )
206 ENDIF
207 ALLOCATE(inum_worksh(3,nel))
208
209 IF(ndrape > 0 .AND. numeltg_drape > 0 ) THEN
210 DO i = 1, nel
211 index(i) = i
212 inum(1,i)=iparttg(nft+i)
213 inum(2,i)=itrioff(nft+i)
214 inum(3,i)=ixtg(1,nft+i)
215 inum(4,i)=ixtg(2,nft+i)
216 inum(5,i)=ixtg(3,nft+i)
217 inum(6,i)=ixtg(4,nft+i)
218 inum(7,i)=ixtg(5,nft+i)
219 inum(8,i)=ixtg(6,nft+i)
220 inum(10,i)=ixtg(1,nft+i)
221 xnum(i)=thk(nft+i)
222 inum_worksh(1,i) = iworksh(1,numelc + nft + i)
223 inum_worksh(2,i) = iworksh(2,numelc + nft + i)
224 inum_worksh(3,i) = iworksh(3,numelc + nft + i)
225 IF (nperturb > 0) THEN
226 DO ipert = 1, nperturb
227 xnum_rnoise(ipert,i) = rnoise(ipert,nft+i)
228 ENDDO
229 ENDIF
230 angle(i) = sh3ang(nft + i)
231 !drape structure
232 iel0 = drapeg%INDX(numelc + nft + i)
233 xnum_drapeg%INDX(i) = iel0
234 IF(iel0 == 0) cycle
235 npt = drape(iel0)%NPLY
236 xnum_drape(i)%NPLY = npt
237 xnum_drape(i)%INDX_PLY(1:npt) = drape(iel0)%INDX_PLY(1:npt)
238 npt = drape(iel)%NPLY_DRAPE
239 xnum_drape(i)%NPLY_DRAPE = npt
240 xnum_drape(i)%THICK = drape(iel0)%THICK
241 DO jj = 1, npt
242 drape_ply => drape(iel0)%DRAPE_PLY(jj)
243 nslice = drape_ply%NSLICE
244 xnum_drape(i)%DRAPE_PLY(jj)%NSLICE = nslice
245 xnum_drape(i)%DRAPE_PLY(jj)%IPID = drape_ply%IPID
246 DO kk = 1,nslice
247 xnum_drape(i)%DRAPE_PLY(jj)%IDRAPE(kk,1)=drape_ply%IDRAPE(kk,1)
248 xnum_drape(i)%DRAPE_PLY(jj)%IDRAPE(kk,2)=drape_ply%IDRAPE(kk,2)
249 xnum_drape(i)%DRAPE_PLY(jj)%RDRAPE(kk,1)=drape_ply%RDRAPE(kk,1)
250 xnum_drape(i)%DRAPE_PLY(jj)%RDRAPE(kk,2)=drape_ply%RDRAPE(kk,2)
251 ENDDO
252 DEALLOCATE(drape_ply%IDRAPE, drape_ply%RDRAPE)
253 ENDDO
254 DEALLOCATE(drape(iel0)%DRAPE_PLY)
255 DEALLOCATE(drape(iel0)%INDX_PLY)
256 ENDDO
257 ELSE
258 DO i = 1, nel
259 index(i) = i
260 inum(1,i)=iparttg(nft+i)
261 inum(2,i)=itrioff(nft+i)
262 inum(3,i)=ixtg(1,nft+i)
263 inum(4,i)=ixtg(2,nft+i)
264 inum(5,i)=ixtg(3,nft+i)
265 inum(6,i)=ixtg(4,nft+i)
266 inum(7,i)=ixtg(5,nft+i)
267 inum(8,i)=ixtg(6,nft+i)
268 inum(10,i)=ixtg(1,nft+i)
269 xnum(i)=thk(nft+i)
270 inum_worksh(1,i) = iworksh(1,numelc + nft + i)
271 inum_worksh(2,i) = iworksh(2,numelc + nft + i)
272 inum_worksh(3,i) = iworksh(3,numelc + nft + i)
273 IF (nperturb > 0) THEN
274 DO ipert = 1, nperturb
275 xnum_rnoise(ipert,i) = rnoise(ipert,nft+i)
276 ENDDO
277 ENDIF
278 angle(i)=sh3ang(nft+i)
279 ENDDO
280 ENDIF
281
282 IF(abs(isigi) == 3 .OR. abs(isigi) == 4 .OR. abs(isigi) == 5) THEN
283 ALLOCATE(inum_ptsh3n(nel))
284 DO i = 1, nel
285 inum_ptsh3n(i)=ptsh3n(nft+i)
286 ENDDO
287 ENDIF
288 IF(nadmesh/=0)THEN
289 DO k=1,ksh3tree
290 DO i=1,nel
291 istor(k,i)=sh3tree(k,nft+i)
292 ENDDO
293 ENDDO
294 IF(lsh3trim/=0)THEN
295 DO i=1,nel
296 istor(ksh3tree+1,i)=sh3trim(nft+i)
297 ENDDO
298 END IF
299 END IF
300
301 mode=0
302 CALL my_orders( mode, work, cep(nft+1), index, nel , 1)
303 IF(ndrape > 0 .AND. numeltg_drape > 0) THEN
304 DO i = 1, nel
305 permutation%TRIANGLE(i+nft) = index2(index(i)+nft)
306 iparttg(i+nft)=inum(1,index(i))
307 itrioff(i+nft)=inum(2,index(i))
308 thk(i+nft) =xnum(index(i))
309 ixtg(1,i+nft)=inum(3,index(i))
310 ixtg(2,i+nft)=inum(4,index(i))
311 ixtg(3,i+nft)=inum(5,index(i))
312 ixtg(4,i+nft)=inum(6,index(i))
313 ixtg(5,i+nft)=inum(7,index(i))
314 ixtg(6,i+nft)=inum(8,index(i))
315 itr1(nft+index(i)) = nft+i
316 iworksh(1,numelc + nft + i)=inum_worksh(1,index(i))
317 iworksh(2,numelc + nft + i)=inum_worksh(2,index(i))
318 iworksh(3,numelc + nft + i)=inum_worksh(3,index(i))
319 IF (nperturb > 0) THEN
320 DO ipert = 1, nperturb
321 rnoise(ipert,i+nft) = xnum_rnoise(ipert,index(i))
322 ENDDO
323 ENDIF
324 sh3ang(nft+i) = angle(index(i))
325 IF(xnum_drapeg%INDX(index(i)) == 0) cycle
326 iel = iel + 1
327 npt = xnum_drape(index(i))%NPLY ! number of ply
328 drape(iel)%NPLY = npt
329 drapeg%INDX(numelc + nft + i)= iel
330 ALLOCATE(drape(iel)%INDX_PLY(npt))
331 drape(iel)%INDX_PLY(1:npt) = xnum_drape(index(i))%INDX_PLY(1:npt)
332 npt = xnum_drape(index(i))%NPLY_DRAPE ! NPT_DRP
333 drape(iel)%NPLY_DRAPE = npt
334 drape(iel)%THICK = xnum_drape(index(i))%THICK
335 ALLOCATE(drape(iel)%INDX_PLY(npt))
336 DO jj = 1, npt
337 drape_ply => drape(iel)%DRAPE_PLY(jj)
338 nslice = xnum_drape(index(i))%DRAPE_PLY(jj)%NSLICE
339 drape_ply%NSLICE = nslice
340 drape_ply%IPID = xnum_drape(index(i))%DRAPE_PLY(jj)%IPID
341 ALLOCATE(drape_ply%IDRAPE(nslice,2), drape_ply%RDRAPE(nslice,2))
342 drape_ply%IDRAPE = 0
343 drape_ply%RDRAPE = zero
344 DO kk = 1,nslice
345 drape_ply%IDRAPE(kk,1) = xnum_drape(index(i))%DRAPE_PLY(jj)%IDRAPE(kk,1)
346 drape_ply%IDRAPE(kk,2) = xnum_drape(index(i))%DRAPE_PLY(jj)%IDRAPE(kk,2)
347 drape_ply%RDRAPE(kk,1) = xnum_drape(index(i))%DRAPE_PLY(jj)%RDRAPE(kk,1)
348 drape_ply%RDRAPE(kk,2) = xnum_drape(index(i))%DRAPE_PLY(jj)%RDRAPE(kk,2)
349 ENDDO
350 ENDDO
351 ENDDO
352 ELSE
353 DO i = 1, nel
354 permutation%TRIANGLE(i+nft) = index2(index(i)+nft)
355 iparttg(i+nft)=inum(1,index(i))
356 itrioff(i+nft)=inum(2,index(i))
357 thk(i+nft) =xnum(index(i))
358 ixtg(1,i+nft)=inum(3,index(i))
359 ixtg(2,i+nft)=inum(4,index(i))
360 ixtg(3,i+nft)=inum(5,index(i))
361 ixtg(4,i+nft)=inum(6,index(i))
362 ixtg(5,i+nft)=inum(7,index(i))
363 ixtg(6,i+nft)=inum(8,index(i))
364 itr1(nft+index(i)) = nft+i
365 iworksh(1,numelc + nft + i)=inum_worksh(1,index(i))
366 iworksh(2,numelc + nft + i)=inum_worksh(2,index(i))
367 iworksh(3,numelc + nft + i)=inum_worksh(3,index(i))
368 IF (nperturb > 0) THEN
369 DO ipert = 1, nperturb
370 rnoise(ipert,i+nft) = xnum_rnoise(ipert,index(i))
371 ENDDO
372 ENDIF
373 sh3ang(nft+i) = angle(index(i))
374 ENDDO
375 ENDIF
376 IF(abs(isigi)==3.OR.abs(isigi)== 4.OR.abs(isigi)==5)THEN
377 DO i=1,nel
378 ptsh3n(nft+i) = inum_ptsh3n(index(i))
379 ENDDO
380 DEALLOCATE(inum_ptsh3n)
381 ENDIF
382 IF(nadmesh/=0)THEN
383 DO k=1,ksh3tree
384 DO i=1,nel
385 sh3tree(k,i+nft)=istor(k,index(i))
386 ENDDO
387 ENDDO
388 IF(lsh3trim/=0)THEN
389 DO i=1,nel
390 sh3trim(i+nft)=istor(ksh3tree+1,index(i))
391 ENDDO
392 END IF
393 END IF
394C
395 IF(nft>=neltg3)THEN
396 DO i = 1, nel
397 ii = i+nft-neltg3
398 inum(1,i)=ixtg1(1,ii)
399 inum(2,i)=ixtg1(2,ii)
400 inum(3,i)=ixtg1(3,ii)
401C INUM(4,I)=IXTG1(4,II)
402 END DO
403 DO i = 1, nel
404 ii = i+nft-neltg3
405 ixtg1(1,ii)=inum(1,index(i))
406 ixtg1(2,ii)=inum(2,index(i))
407 ixtg1(3,ii)=inum(3,index(i))
408C IXTG1(4,II)=INUM(4,INDEX(I))
409 END DO
410 END IF
411C
412
413
414 p = cep(nft+index(1))
415 nb = 1
416 DO i = 2, nel
417 IF (cep(nft+index(i))/=p) THEN
418 dd_iad(p+1,nspgroup+n) = nb
419 nb = 1
420 p = cep(nft+index(i))
421 ELSE
422 nb = nb + 1
423 ENDIF
424 ENDDO
425 dd_iad(p+1,nspgroup+n) = nb
426 DO p = 2, nspmd
427 dd_iad(p,nspgroup+n) = dd_iad(p,nspgroup+n)
428 . + dd_iad(p-1,nspgroup+n)
429 ENDDO
430 DO p = nspmd+1,2,-1
431 dd_iad(p,nspgroup+n) = dd_iad(p-1,nspgroup+n)+1
432 ENDDO
433 dd_iad(1,nspgroup+n) = 1
434C
435C maj CEP
436C
437 DO i = 1, nel
438 index(i) = cep(nft+index(i))
439 ENDDO
440 DO i = 1, nel
441 cep(nft+i) = index(i)
442 ENDDO
443 nft = nft + nel
444 !!
445 IF(ndrape > 0 .AND. numeltg_drape > 0) THEN
446 DO i =1, nel
447 iel0 = xnum_drapeg%INDX(i)
448 IF(iel0 == 0 ) cycle
449 npt_drp = xnum_drape(i)%NPLY_DRAPE
450 DO j = 1,npt_drp
451 DEALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%RDRAPE)
452 DEALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%IDRAPE)
453 ENDDO
454 DEALLOCATE(xnum_drape(i)%DRAPE_PLY,xnum_drape(i)%INDX_PLY)
455 ENDDO
456 DEALLOCATE( xnum_drape, xnum_drapeg%INDX )
457 ELSE
458 DEALLOCATE( xnum_drape )
459 ENDIF
460 DEALLOCATE(inum_worksh)
461 ENDDO
462
463
464C
465C RENUMEROTATION DE L'ARBRE
466C
467 IF(nadmesh/=0)THEN
468 DO i=1,numeltg
469 IF(sh3tree(1,i)/=0)
470 . sh3tree(1,i)=itr1(sh3tree(1,i))
471 IF(sh3tree(2,i)/=0)
472 . sh3tree(2,i)=itr1(sh3tree(2,i))
473 ENDDO
474 END IF
475C
476C RENUMEROTATION POUR SURFACES
477C
478 DO i=1,nsurf
479 nn=igrsurf(i)%NSEG
480 DO j=1,nn
481 IF(igrsurf(i)%ELTYP(j) == 7)
482 . igrsurf(i)%ELEM(j) = itr1(igrsurf(i)%ELEM(j))
483 ENDDO
484 ENDDO
485C
486C RENUMEROTATION POUR GROUPES DE SHELL
487C
488 DO i=1,ngrsh3n
489 nn=igrsh3n(i)%NENTITY
490 DO j=1,nn
491 igrsh3n(i)%ENTITY(j) = itr1(igrsh3n(i)%ENTITY(j))
492 ENDDO
493 ENDDO
494C
495C renumerotation CONNECTIVITE INVERSE
496C
497 DO i=1,3*numeltg
498 IF(nod2eltg(i) /= 0)nod2eltg(i)=itr1(nod2eltg(i))
499 END DO
500C
501C phase 2 : bornage en groupe de mvsiz
502C ngroup est global, iparg est global mais organise en fonction de dd
503C
504 DO 300 n=1,nd
505 nft = 0
506 DO p = 1, nspmd
507 ngp(p)=0
508 nel = dd_iad(p+1,nspgroup+n)-dd_iad(p,nspgroup+n)
509 IF (nel>0) THEN
510 nel_prec = dd_iad(p,nspgroup+n)-dd_iad(1,nspgroup+n)
511 ngp(p)=ngroup
512 DO WHILE (nft < nel_prec+nel)
513 ngroup=ngroup+1
514 ii = eadd(n)+nft
515 prt = iparttg(ii)
516 mid = ixtg(1,ii)
517 mln = nint(pm(19,mid))
518 pid = ixtg(5,ii)
519 ipartr2r = 0
520 IF (nsubdom>0) ipartr2r = tag_mat(mid)
521 npn = igeo(4,pid)
522 ismst = igeo(5,pid)
523 igtyp=igeo(11,pid)
524 kcnod=icnod(ii)
525 idrot1= igeo(20,pid)
526 irep = igeo(6,pid)
527 ish3n = igeo(18,pid)
528 IF (ish3n > 3 .AND. ish3n < 30) ish3n=2
529 nlevxf = 0
530 ixfem = 0
531 isubstack = 0
532 idrape = 0
533 IF (igtyp == 17 .OR. igtyp == 51 .OR. igtyp == 52) THEN
534 npn = iworksh(1,numelc + ii)
535 isubstack =iworksh(3,numelc + ii)
536 IF(npn == 0) THEN
537 id = igeo(1,pid)
538 CALL fretitl2(titr,igeo(npropgi-ltitr+1,pid),ltitr)
539 CALL ancmsg(msgid=1241,
540 . msgtype=msgerror,
541 . anmode=aninfo,
542!! . ANMODE=ANSTOP,
543 . i1=id,
544 . c1=titr,
545 . i2=ixtg(nixtg,ii))
546 CALL arret(2)
547 ENDIF
548 ENDIF
549 IF(ndrape > 0 .AND. (igtyp == 17 .OR. igtyp == 51 .OR. igtyp ==52) ) THEN
550 IF( drapeg%INDX(ii) /= 0 ) idrape = 1
551 ENDIF
552c-------- xfem
553 IF (icrack3d > 0) THEN
554 IF (igtyp == 11) THEN
555 DO ipt = 1, npn
556 imatly = igeo(100+ipt,pid)
557 IF (mat_param(imatly)%NFAIL > 0) ixfem = mat_param(imatly)%IXFEM
558 ENDDO
559 IF (ixfem > 0) ixfem = 1
560 IF (ixfem == 1) nlevxf = nxel*npn
561 ELSEIF (igtyp == 51 .OR. igtyp == 52) THEN
562 ippid = 2
563 ipmat = ippid + npn
564 DO ipt = 1, npn
565 imatly = stack%IGEO(ipmat + ipt ,isubstack)
566 IF (mat_param(imatly)%NFAIL > 0) ixfem = mat_param(imatly)%IXFEM
567 IF (ixfem > 0) ixfem = 1
568 IF (ixfem == 1) nlevxf = nxel*npn
569 ENDDO
570 ELSEIF (igtyp == 1) THEN
571 ixfem = mat_param(mid)%IXFEM
572 IF (ixfem == 1) THEN
573 ixfem = 2
574 nlevxf = nxel
575 ENDIF
576 ENDIF
577 ENDIF
578 IF (ish3n >= 30 .and. ixfem > 0) THEN ! not compatible with Batoz shells
579 ixfem = 0
580 nlevxf = 0
581 CALL ancmsg(msgid=1601,
582 . msgtype=msgwarning,
583 . anmode=aninfo_blind_1,
584 . i1=igeo(1,pid),
585 . c1=titr,
586 . prmod=msg_cumu)
587 ENDIF
588 nlevmax = max(nlevmax, nlevxf)
589C---------
590C
591 id=igeo(1,pid)
592 CALL fretitl2(titr,igeo(npropgi-ltitr+1,pid),ltitr)
593 IF(nadmesh == 0)THEN
594 ilev=0
595 my_nvsiz=nvsiz
596 ELSE
597 prt = iparttg(ii)
598 iadm= ipart(10,prt)
599 IF(iadm==0)THEN
600 ilev = 0
601 my_nvsiz=nvsiz
602 ELSE
603 ilev=sh3tree(3,ii)
604 IF(ilev<0)ilev=-ilev-1
605 my_nvsiz=max(4,min(4**ilev,nvsiz))
606 END IF
607 END IF
608C
609 IF (igtyp == 0) mln=0 ! VOID Property => Void material
610C
611 IF (igtyp == 16 .and. mln == 58 .and.
612 . ismst /= 11 .and. ismst /= 4) THEN
613 ismst = 4
614 CALL ancmsg(msgid=772,
615 . msgtype=msgwarning,
616 . anmode=aninfo_blind_2,
617 . i1=id,
618 . c1=titr)
619 ENDIF
620
621c------
622c global integration
623 IF (npn /= 1 .and. mln == 1) npn = 0
624 IF (npn == 0 .and. mln > 2 .and. mln /= 22 .and.
625 . mln /= 36 .and. mln /= 43 .and. mln /= 60 .and.
626 . mln /= 86 .and. mln /= 13 .and. mln /= 151) THEN
627 CALL fretitl2(titr1,
628 . ipm(npropmi-ltitr+1,mid),
629 . ltitr)
630 CALL ancmsg(msgid=23,
631 . anmode=aninfo,
632 . msgtype=msgerror,
633 . i1=id,
634 . c1=titr,
635 . i2=ipm(1,mid),
636 . c2=titr1,
637 . i3=mln)
638 ENDIF
639C
640C---------Drilling dof--using NB4 -> no supper place needed---------
641 IF (idrot1>0.AND.ish3n>29) THEN
642 CALL ancmsg(msgid=854,
643 . msgtype=msgwarning,
644 . anmode=aninfo_blind_2,
645 . i1=id,
646 . c1=titr)
647 idrot1 = 0
648 END IF
649 ithk = nint(geo(35,pid))
650 ipla = nint(geo(39,pid))
651 icsen= igeo(3,pid)
652 IF(npn == 0.AND.(mln == 36.OR.mln == 86))THEN
653 IF(ipla == 0) ipla=1
654 IF(ipla == 2) ipla=0
655 ELSEIF(npn == 0.AND.mln == 3)THEN
656 IF(ipla == 2) ipla=0
657 ELSE
658 IF(ipla == 2) ipla=0
659 IF(ipla == 3) ipla=2
660 ENDIF
661 IF(ithk == 2)THEN
662 ithk = 0
663 ELSEIF(mln == 32)THEN
664 ithk = 1
665 ENDIF
666 istrain = nint(geo(11,pid))
667C IF(MLN == 19.OR.MLN>=25)ISTRAIN = 1
668 IF(mln == 19.OR.mln>=25.OR.mln == 15)istrain = 1
669c
670 CALL zeroin(1,nparg,iparg(1,ngroup))
671 iparg(1,ngroup) = mln
672 ne1 = min( my_nvsiz, nel + nel_prec - nft)
673 iparg(2,ngroup) = ne1
674 iparg(3,ngroup)= eadd(n)-1 + nft
675 iparg(4,ngroup) = lbufel+1 ! kept in place for compatibility with
676c other groups using old buffer
677 iparg(43,ngroup) = 0
678C
679C-------------
680 IF (igtyp == 11)THEN
681 DO ipt = 1, npn
682 imatly = igeo(100+ipt,pid)
683 IF(mat_param(imatly)%NFAIL > 0)THEN
684 iparg(43,ngroup) = 1
685 ENDIF
686 ENDDO
687c--------
688 ELSEIF(igtyp == 17) THEN
689!! IIGEO = 40 + 5*(ISUBSTACK - 1)
690!! IADI = IGEO(IIGEO + 3,PID)
691!! IPPID = IADI
692 ippid = 2
693 ipmat = ippid + npn
694 DO ipt = 1, npn
695!! IPID = IGEO(100+IPT,PID)
696!! IMATLY = IGEO(101,IPID)
697 imatly = stack%IGEO(ipmat + ipt ,isubstack)
698 IF(mat_param(imatly)%NFAIL > 0)THEN
699 iparg(43,ngroup) = 1
700 ENDIF
701 ENDDO
702c--------
703 ELSEIF (igtyp == 51 .OR. igtyp == 52 ) THEN
704C---
705C new shell property (multiple NPT through each layer)
706C---
707 nb_law58 = 0
708 ippid = 2
709 ipmat = ippid + npn
710 DO ipt = 1, npn
711 imatly = stack%IGEO(ipmat + ipt ,isubstack)
712 IF(mat_param(imatly)%NFAIL > 0)THEN
713 iparg(43,ngroup) = 1
714 ENDIF
715C --- PID 51 combined with LAW58 ---
716 IF (nint(pm(19,imatly)) == 58) nb_law58 = nb_law58 + 1
717 ENDDO
718C --- set new IREP for groups:
719 IF (nb_law58 == npn) THEN
720 irep = 2
721 ELSEIF (nb_law58 > 0) THEN
722 irep = irep + 3
723 ENDIF
724c--------
725 ELSE ! IGTYP == 1
726 IF(mat_param(mid)%NFAIL > 0.AND.mln /= 0 .AND. mln /= 13)THEN
727 iparg(43,ngroup) = 1
728 ENDIF
729 ENDIF ! IGTYP
730C-------------
731 IF(mln == 13) irigid_mat = 1
732
733 jthe = nint(pm(71,mid))
734
735C thermal material expansion
736 iparg(49,ngroup) = 0
737 IF(ipm(218,mid) > 0 .AND. mln /=0 .AND. mln /= 13) THEN
738 iparg(49,ngroup) = 1
739 ENDIF
740C
741 nuvar = 0
742 DO j = 1,ne1
743 ie=j+eadd(n)+nft-1
744 nuvar = max(nuvar,ipm(8,ixtg(1,ie)))
745 END DO
746 iparg(46,ngroup)=nuvar
747C---------
748C
749C - initial volume franction -
750C
751 iparg(53,ngroup) = 0
752 lfound=.false.
753 IF(num_inivol > 0)THEN
754 ! Warning : In same group you can have different PArts, A loop over elem in groups has to be introduced to check if INIVOL PART is there.
755 mft = iparg(3,ngroup)
756 DO iloc = 1 ,iparg(2,ngroup)
757 DO jj=1,num_inivol
758 IF(inivol(jj)%PART_ID == iparttg(iloc+mft)) THEN
759 iparg(53,ngroup) = 1
760 lfound=.true.
761 EXIT
762 ENDIF
763 ENDDO
764 IF(lfound)EXIT
765 END DO
766 END IF
767C---------
768 iparg(54,ngroup) = ixfem
769 iparg(62,ngroup) = pid
770 iparg(65,ngroup) = nlevxf
771C flag for group of duplicated elements in multidomains
772 IF (nsubdom>0) iparg(77,ngroup)= ipartr2r
773 iparg(5,ngroup) = 7
774 iparg(6,ngroup) = npn
775 iparg(9,ngroup) = ismst
776 iparg(11,ngroup)= kcnod
777 iparg(13,ngroup)= jthe !tria : 0:no temp 1: centroid temp -1:nodal temp
778 IF(jale+jeul>0)iparg(13,ngroup)=-jthe
779 iparg(44,ngroup)= istrain
780 iparg(23,ngroup)= ish3n
781 iparg(28,ngroup)= ithk
782 iparg(29,ngroup)= ipla
783 iparg(35,ngroup)= irep
784 iparg(38,ngroup)= igtyp
785 iparg(39,ngroup)= icsen
786 iparg(41,ngroup)= idrot1
787C Multifluid law, setting NLAY
788 IF (mln == 151) THEN
789 iparg(20, ngroup) = ipm(20, mid)
790 jale_from_mat = nint(pm(72,mid))
791 jale_from_prop = igeo(62,pid)
792 jale = max(jale_from_mat, jale_from_prop) !if inconsistent, error message was displayed in PART reader
793 jlag=0
794 jeul=0
795 IF(jale == 2)THEN
796 jale=0
797 jeul=1
798 ENDIF
799 iparg(7, ngroup) = jale
800 iparg(11, ngroup) = jeul
801 iparg(13,ngroup) = +abs(jthe) ! -1 nodal temperature +1 centroid temperature
802 ENDIF
803
804 !ALE REZONING/REMAPING : number of MAT/EOS variables to treat (used by staggered scheme only : arezon.F)
805 ! With ALE framework, since the Mesh is arbitrary, the variable must be updated to map thei expected location and not follow the arbitrary mesh displacement
806 ! this numbering here will be used in arezon.F to loop over variables to rezon/remap
807 IF(jale == 1)THEN
808 ale%REZON%NUM_NUVAR_MAT = ale%REZON%NUM_NUVAR_MAT + mat_param(mid)%REZON%NUM_NUVAR_MAT
809 ale%REZON%NUM_NUVAR_EOS = ale%REZON%NUM_NUVAR_EOS + mat_param(mid)%REZON%NUM_NUVAR_EOS
810 ENDIF
811
812 !ALE UVAR REZONING (81:MAT, 82:EOS)
813 IF(jale == 1)THEN
814 iparg(81,ngroup) = mat_param(mid)%REZON%NUM_NUVAR_MAT
815 iparg(82,ngroup) = mat_param(mid)%REZON%NUM_NUVAR_EOS
816 ENDIF
817
818 iparg(45,ngroup)= ilev
819 IF(ilev/=0 .AND. ish3n > 2)THEN
820 id=igeo(1,pid)
821 CALL fretitl2(titr,igeo(npropgi-ltitr+1,pid),ltitr)
822 CALL ancmsg(msgid=653,
823 . msgtype=msgerror,
824 . anmode=aninfo_blind_1,
825 . i1=id,
826 . c1=titr,
827 . i2=ish3n,
828 . i3=ipart(4,prt))
829 END IF
830 IF(nadmesh/=0)THEN
831 iparg(8,ngroup)=1
832 DO j=1,ne1
833 sh3tree(4,j+eadd(n)+nft-1)=ngroup
834 ilev=sh3tree(3,j+eadd(n)+nft-1)
835 IF(ilev >= 0)iparg(8,ngroup)=0
836 END DO
837 END IF
838
839 nsg = 1
840 DO 210 j = 2,ne1
841 midn = ixtg(1,j+eadd(n)+nft-1)
842 IF(mid/=midn)THEN
843 mid = midn
844 nsg = nsg + 1
845 ENDIF
846 210 CONTINUE
847C
848 iparg(10,ngroup)= nsg
849 iparg(32,ngroup)= p-1
850
851 nuvarr = 0
852 IF (igtyp == 11) THEN
853 mpt = iabs(npn)
854 DO ipt= 1,mpt
855 DO j=1,ne1
856 ie=j+eadd(n)+nft-1
857 imatly = igeo(100+ipt,ixtg(5,ie))
858 nuvarr = max(nuvarr,ipm(221,ixtg(1,ie)))
859 ENDDO
860 ENDDO
861 ELSE
862 DO j=1,ne1
863 ie=j+eadd(n)+nft-1
864 nuvarr = max(nuvarr,ipm(221,ixtg(1,ie)))
865 ENDDO
866 END IF
867 iparg(47,ngroup)=nuvarr
868
869 IF(ish3n == 30)THEN
870 npg=3
871 ELSE
872 npg=1
873 END IF
874 iparg(48,ngroup)=npg
875
876 jsms=0
877 IF(isms/=0)THEN
878 IF(idtgrs/=0)THEN
879 IF(tagprt_sms(iparttg(ii))/=0)jsms=1
880 ELSE
881 jsms=1
882 END IF
883 END IF
884 iparg(52,ngroup)=jsms
885C for stack
886 iparg(71,ngroup) = isubstack
887 iparg(92,ngroup) = idrape !
888C
889 nft = nft + ne1
890c 220 CONTINUE
891 ENDDO
892 ngp(p)=ngroup-ngp(p)
893 ENDIF
894 ENDDO
895C DD_IAD => nb groupes par sous domaine
896 ngp(nspmd+1)=0
897 DO p = 1, nspmd
898 ngp(nspmd+1)=ngp(nspmd+1)+ngp(p)
899 dd_iad(p,nspgroup+n)=ngp(p)
900 END DO
901 dd_iad(nspmd+1,nspgroup+n)=ngp(nspmd+1)
902C
903 300 CONTINUE
904C
905 nspgroup = nspgroup + nd
906C-----------
907 CALL ancmsg(msgid=1601,
908 . msgtype=msgwarning,
909 . anmode=aninfo_blind_1,
910 . i1=pid,
911 . c1=titr ,
912 . prmod=msg_print)
913C-----------
914 IF(print_flag>6) THEN
915 WRITE(iout,1000)
916 DO n=ngr1,ngroup
917 mln = iparg(1,n)
918 WRITE(iout,1001)n,mln,iparg(2,n),iparg(3,n)+1,
919 + iparg(5,n),iabs(iparg(6,n)),
920 + iparg(9,n),iparg(10,n),iparg(44,n),iparg(43,n)
921 ENDDO
922 ENDIF
923C-----------
924 1000 FORMAT(
925 + /10x,' 2D - TRIANGULAR SOLID ELEMENT GROUPS'/
926 + 10x,' ------------------------------------'/
927 +' GROUP MATERIAL ELEMENT FIRST',
928 +' ELEMENT',
929 +' INTEG SMALL SUB STRAIN FAILURE'/
930 +' LAW NUMBER ELEMENT',
931 +' TYPE',
932 +' PTS STRAIN GROUPS OUTPUT FLAG'/)
933 1001 FORMAT(11(1x,i10))
934C
935 IF (ALLOCATED(xnum_rnoise)) DEALLOCATE(xnum_rnoise)
936
937 DEALLOCATE(index2)
938 DEALLOCATE( istor )
939C-----------
940 RETURN
941 END
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
ale_mod
Definition ale_mod.F:149
ale_mod::ale
type(ale_) ale
Definition ale_mod.F:249
drape_mod
Definition drape_mod.F:54
groupdef_mod
Definition groupdef_mod.F:662
inivol_def_mod
Definition inivol_mod.F:45
inivol_def_mod::num_inivol
integer num_inivol
Definition inivol_mod.F:85
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_mat
integer, dimension(:), allocatable tag_mat
Definition r2r_mod.F:136
reorder_mod
Definition reorder_mod.F:45
reorder_mod::permutation
type(reorder_struct_) permutation
Definition reorder_mod.F:54
stack_mod
Definition stack_mod.F:72
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
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804
arret
subroutine arret(nn)
Definition arret.F:87
inivol_def_mod::inivol_struct_
Definition inivol_mod.F:70
t3grtails
subroutine t3grtails(ixtg, pm, iparg, geo, eadd, nd, iparttg, dd_iad, idx, inum, index, cep, thk, xnum, itr1, igrsurf, igrsh3n, icnod, igeo, ipm, ixtg1, ipart, sh3tree, nod2eltg, itrioff, sh3trim, tagprt_sms, iworksh, stack, drape, rnoise, inivol, mat_param, sh3ang, drapeg, print_flag, ptsh3n)
Definition t3grtails.F:50
zeroin
subroutine zeroin(n1, n2, ma)
Definition zeroin.F:47