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