OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
t3grhead.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!|| t3grhead ../starter/source/elements/solid_2d/tria/t3grhead.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.f
29!|| fretitl2 ../starter/source/starter/freform.F
30!||--- uses -----------------------------------------------------
31!|| drape_mod ../starter/share/modules1/drape_mod.f
32!|| message_mod ../starter/share/message_module/message_mod.F
33!|| reorder_mod ../starter/share/modules1/reorder_mod.F
34!|| stack_mod ../starter/share/modules1/stack_mod.F
35!||====================================================================
36 SUBROUTINE t3grhead(
37 1 IXTG ,PM ,GEO ,INUM ,ISEL ,
38 2 ITR1 ,EADD ,INDEX ,ITRI ,XNUM ,
39 3 IPARTTG ,ND ,THK ,IGRSURF ,IGRSH3N ,
40 4 CEP ,XEP ,IXTG1 ,ICNOD ,
41 5 IGEO ,IPM ,IPART ,SH3TREE ,NOD2ELTG,
42 6 ITRIOFF ,SH3TRIM ,TAGPRT_SMS,MAT_PARAM,
43 7 IWORKSH , STACK ,DRAPE ,RNOISE,
44 8 MULTI_FVM ,SH3ANG,DRAPEG , PTSH3N )
45C-----------------------------------------------
46C M o d u l e s
47C-----------------------------------------------
48 USE my_alloc_mod
49 USE message_mod
50 USE stack_mod
51 USE multi_fvm_mod
52 USE reorder_mod
53 USE groupdef_mod
54 USE drape_mod
55 USE matparam_def_mod
56 USE names_and_titles_mod , ONLY : nchartitle
57C-----------------------------------------------
58C A R G U M E N T S
59C-----------------------------------------------
60C IXTG(NIXTG,NUMELTG)TABLEAU CONECS+PID+MID+NOS TRIANGLES E
61C PM(NPROPM,NUMMAT) TABLEAU DES CARACS DES MATERIAUX E
62C GEO(NPROPG,NUMGEO) TABLEAU DES CARACS DES PID E
63C INUM(9,NUMELTG) TABLEAU DE TRAVAIL E/S
64C ISEL(NSELTG) TABLEAU DES TRI CHOISIES POUR TH E/S
65C ITR1(NSELTG) TABLEAU DE TRAVAIL E/S
66C EADD(NUMELTG) TABLEAU DES ADRESSES DANS IDAM CHGT DAMIER S
67C INDEX(NUMELTG) TABLEAU DE TRAVAIL E/S
68C ITRI(7,NUMELTG) TABLEAU DE TRAVAIL E/S
69C CEP(NUMELTG) TABLEAU PROC E/S
70C XEP(NUMELTG) TABLEAU PROC E/S
71C NOD2ELTG(3*NUMELT ) E/S
72C ITRIOFF(NUMELTG) FLAG ELEM RBY ON/OFF E/S
73C-----------------------------------------------
74C I M P L I C I T T Y P E S
75C-----------------------------------------------
76#include "implicit_f.inc"
77C-----------------------------------------------
78C C O M M O N B L O C K S
79C-----------------------------------------------
80#include "com04_c.inc"
81#include "com01_c.inc"
82#include "com_xfem1.inc"
83#include "param_c.inc"
84#include "vect01_c.inc"
85#include "remesh_c.inc"
86#include "sms_c.inc"
87#include "scr17_c.inc"
88#include "drape_c.inc"
89C-----------------------------------------------
90C D U M M Y A R G U M E N T S
91C-----------------------------------------------
92 integer
93 . ixtg(nixtg,*),isel(*),inum(10,*),nd,icnod(*),ixtg1(4,*),
94 . eadd(*), itr1(*), index(*), itri(7,*),iparttg(*),
95 . cep(*), xep(*),
96 . itrioff(*),
97 . igeo(npropgi,*),ipm(npropmi,*), ipart(lipart1,*),
98 . sh3tree(ksh3tree,*), nod2eltg(*), sh3trim(*),
99 . tagprt_sms(*),iworksh(3,*)
100 INTEGER , DIMENSION(NUMELTG) , INTENT(INOUT):: PTSH3N
101C REAL OU REAL*8
102 my_real
103 . PM(NPROPM,*), GEO(NPROPG,*), XNUM(*), THK(*), RNOISE(NPERTURB,*),
104 . SH3ANG(*)
105C-----------------------------------------------
106 TYPE (STACK_PLY) :: STACK
107 TYPE(MULTI_FVM_STRUCT) :: MULTI_FVM
108 TYPE (DRAPE_) , TARGET :: DRAPE(NUMELC_DRAPE + NUMELTG_DRAPE)
109 TYPE (DRAPEG_) :: DRAPEG
110 TYPE (drape_) ,DIMENSION(:) ,ALLOCATABLE :: xnum_drape
111 TYPE (DRAPEG_) ,ALLOCATABLE :: XNUM_DRAPEG
112 TYPE (DRAPE_PLY_) ,POINTER :: DRAPE_PLY
113 TYPE(MATPARAM_STRUCT_) ,DIMENSION(NUMMAT),INTENT(IN) :: MAT_PARAM
114C-----------------------------------------------
115 TYPE (GROUP_) , DIMENSION(NGRSH3N) :: IGRSH3N
116 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
117C-----------------------------------------------
118C L O C A L V A R I A B L E S
119C-----------------------------------------------
120 INTEGER, DIMENSION(:,:), ALLOCATABLE :: ISTOR,INUM_DRAPE
121 INTEGER WORK(70000)
122 INTEGER I, K, MLN, NG, ISSN, NPN, IFIO,NN,ICO,ID,
123 . mln0, issn0, ic, n, mid, mid0, pid, pid0, istr0,
124 . ihbe, ihbe0, j, midn, nsg, nel, ne1, ithk,
125 . ithk0, ipla, ipla0, ii1, jj1, ii2, jj2, ii, jj,
126 . l, igtyp, ii3, jj3,ngrou,neltg3,
127 . mskmln, msknpn, mskihb, mskisn, mode,icsen,ifail,nfail,
128 . mskist, mskipl, mskith, mskmid,mskpid,mskirp,msktyp,irep,
129 . ii0,jj0,ilev,prt,iadm,dir,mskirb,irb, ii4, jj4,
130 . irup,ixfem,iwarnhb,ipt,imatly,ipid,ish3n,
131 . inum_workc(3,numeltg),ii5,jj5,isubstack,iigeo,iadi,ippid,
132 . nb_law58,ipmat,ipert,stat,ialel, mt,ip,nslice,kk,npt_drp,
133 . iel, iel0
134 my_real
135 . angle(numeltg)
136 CHARACTER(LEN=NCHARTITLE)::TITR
137C
138 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX2, INUM_PTSH3N
139
140 EXTERNAL MY_SHIFTL,MY_SHIFTR,MY_AND
141 INTEGER MY_SHIFTL,MY_SHIFTR,MY_AND
142 my_real, DIMENSION(:,:), ALLOCATABLE :: xnum_rnoise
143C
144Clef 1---------------------------------
145 DATA mskmln /o'00777000000'/
146 DATA msktyp /o'00000777000'/
147 DATA mskisn /o'00000000700'/
148 DATA mskist /o'00000000070'/
149 DATA mskipl /o'00000000007'/
150Clef 2---------------------------------
151 DATA mskith /o'10000000000'/
152 DATA mskirp /o'07000000000'/
153 DATA msknpn /o'00777000000'/
154 DATA mskirb /o'00000000007'/
155Clef 3---------------------------------
156 DATA mskmid /o'07777777777'/
157Clef 4---------------------------------
158 DATA mskpid /o'07777777777'/
159C-----------------------------------------------
160C-----------------------------------------------
161
162C
163C---+----1----+----2----+----3----+----4----+----5----+----6----+----7--
164 iwarnhb=0
165 IF(nadmesh/=0)THEN
166 ALLOCATE( istor(ksh3tree+1,numeltg) )
167 ELSE
168 ALLOCATE( istor(0,0) )
169 ENDIF
170 IF (ndrape > 0 .AND. numeltg_drape > 0) THEN
171 ALLOCATE(xnum_drape(numeltg))
172 ALLOCATE(xnum_drapeg%INDX(numeltg))
173 xnum_drapeg%INDX = 0
174 DO i =1, numeltg
175 iel = drapeg%INDX(numelc + i)
176 IF(iel == 0) cycle
177 npt_drp = drape(iel)%NPLY_DRAPE
178 npt = drape(iel)%NPLY
179 ALLOCATE(xnum_drape(i)%INDX_PLY(npt))
180 ALLOCATE(xnum_drape(i)%DRAPE_PLY(npt_drp))
181 xnum_drape(i)%INDX_PLY= 0
182 DO j = 1,npt_drp
183 nslice = drape(iel)%DRAPE_PLY(j)%NSLICE
184 ALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%RDRAPE(nslice,2))
185 ALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%IDRAPE(nslice,2))
186 xnum_drape(i)%DRAPE_PLY(j)%RDRAPE = 0
187 xnum_drape(i)%DRAPE_PLY(j)%IDRAPE = 0
188 ENDDO
189 ENDDO
190 ELSE
191 ALLOCATE( xnum_drape(0) )
192 ENDIF
193 IF(abs(isigi) == 3 .OR. abs(isigi) == 4 .OR. abs(isigi) == 5) THEN
194 ALLOCATE(inum_ptsh3n(numeltg))
195 inum_ptsh3n = 0
196 ELSE
197 ALLOCATE(inum_ptsh3n(0))
198 ENDIF
199C
200C----------------------------------------------------------
201C TRI GLOBAL SUR TOUS LES CRITERES POUR TOUS LES ELEMENTS
202C----------------------------------------------------------
203C
204 IF (nperturb > 0) THEN
205 ALLOCATE(xnum_rnoise(nperturb,numeltg),stat=stat)
206 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
207 . msgtype=msgerror,
208 . c1='XNUM_RNOISE')
209 ENDIF
210C
211 CALL my_alloc(index2,numeltg)
212
213 IF(ndrape > 0 .AND. numeltg_drape > 0) THEN
214 DO i=1,numeltg
215 index2(i)= permutation%TRIANGLE(i)
216 eadd(i)=1
217 itri(7,i)=i
218 index(i)=i
219 inum(1,i)=iparttg(i)
220 inum(2,i)=itrioff(i)
221 xnum(i) = thk(i)
222 inum(3,i)=ixtg(1,i)
223 inum(4,i)=ixtg(2,i)
224 inum(5,i)=ixtg(3,i)
225 inum(6,i)=ixtg(4,i)
226 inum(7,i)=ixtg(5,i)
227 inum(8,i)=ixtg(6,i)
228 inum(9,i)=icnod(i)
229 inum(10,i)=ixtg(1,i)
230 inum_workc(1,i) = iworksh(1,numelc + i)
231 inum_workc(2,i) = iworksh(2,numelc + i)
232 inum_workc(3,i) = iworksh(3,numelc + i)
233 IF (nperturb > 0) THEN
234 DO ipert = 1, nperturb
235 xnum_rnoise(ipert,i) = rnoise(ipert,i)
236 ENDDO
237 ENDIF
238 angle(i)=sh3ang(i)
239 !drape structure
240 iel = drapeg%INDX(numelc + i)
241 xnum_drapeg%INDX(i) = iel
242 IF(iel == 0) cycle
243 npt = drape(iel)%NPLY
244 xnum_drape(i)%NPLY = npt
245 xnum_drape(i)%INDX_PLY(1:npt) = drape(iel)%INDX_PLY(1:npt)
246 npt = drape(iel)%NPLY_DRAPE
247 xnum_drape(i)%NPLY_DRAPE = npt
248 xnum_drape(i)%THICK = drape(iel)%THICK
249 DO jj = 1, npt
250 drape_ply => drape(iel)%DRAPE_PLY(jj)
251 nslice = drape_ply%NSLICE
252 xnum_drape(i)%DRAPE_PLY(jj)%NSLICE = nslice
253 xnum_drape(i)%DRAPE_PLY(jj)%IPID = drape_ply%IPID
254 DO kk = 1,nslice
255 xnum_drape(i)%DRAPE_PLY(jj)%IDRAPE(kk,1)=drape_ply%IDRAPE(kk,1)
256 xnum_drape(i)%DRAPE_PLY(jj)%IDRAPE(kk,2)=drape_ply%IDRAPE(kk,2)
257 xnum_drape(i)%DRAPE_PLY(jj)%RDRAPE(kk,1)=drape_ply%RDRAPE(kk,1)
258 xnum_drape(i)%DRAPE_PLY(jj)%RDRAPE(kk,2)=drape_ply%RDRAPE(kk,2)
259 ENDDO
260 DEALLOCATE(drape_ply%IDRAPE, drape_ply%RDRAPE)
261 ENDDO
262 DEALLOCATE(drape(iel)%DRAPE_PLY)
263 DEALLOCATE(drape(iel)%INDX_PLY)
264 ENDDO
265 ELSE
266 DO i=1,numeltg
267 index2(i)= permutation%TRIANGLE(i)
268 eadd(i)=1
269 itri(7,i)=i
270 index(i)=i
271 inum(1,i)=iparttg(i)
272 inum(2,i)=itrioff(i)
273 xnum(i) = thk(i)
274 inum(3,i)=ixtg(1,i)
275 inum(4,i)=ixtg(2,i)
276 inum(5,i)=ixtg(3,i)
277 inum(6,i)=ixtg(4,i)
278 inum(7,i)=ixtg(5,i)
279 inum(8,i)=ixtg(6,i)
280 inum(9,i)=icnod(i)
281 inum(10,i)=ixtg(1,i)
282 inum_workc(1,i) = iworksh(1,numelc + i)
283 inum_workc(2,i) = iworksh(2,numelc + i)
284 inum_workc(3,i) = iworksh(3,numelc + i)
285 IF (nperturb > 0) THEN
286 DO ipert = 1, nperturb
287 xnum_rnoise(ipert,i) = rnoise(ipert,i)
288 ENDDO
289 ENDIF
290 angle(i)=sh3ang(i)
291 ENDDO
292 ENDIF
293C
294 IF(abs(isigi)==3.OR.abs(isigi)== 4.OR.abs(isigi)==5)THEN
295 inum_ptsh3n(1:numeltg) = ptsh3n(1:numeltg)
296 ENDIF
297 IF(nadmesh/=0)THEN
298 DO k=1,ksh3tree
299 DO i=1,numeltg
300 istor(k,i)=sh3tree(k,i)
301 ENDDO
302 ENDDO
303 IF(lsh3trim/=0)THEN
304 DO i=1,numeltg
305 istor(ksh3tree+1,i)=sh3trim(i)
306 ENDDO
307 END IF
308 END IF
309C
310 DO i=1,numeltg
311 xep(i)=cep(i)
312 ENDDO
313C
314 DO 100 i = 1, numeltg
315 ii = i
316C
317 IF(nadmesh==0)THEN
318 itri(1,i)=0
319 ELSE
320C
321C ILEV doit etre de poids fort sur 1ere clef
322 prt = iparttg(ii)
323 iadm= ipart(10,prt)
324 IF(iadm==0)THEN
325C not the same group as if adaptivity.
326 itri(1,i)=0
327 ELSE
328 ilev=sh3tree(3,i)
329 IF(ilev<0)ilev=-ilev-1
330 itri(1,i)=ilev+1
331 END IF
332 END IF
333C
334 mid= ixtg(1,ii)
335 pid= ixtg(5,ii)
336 mln = nint(pm(19,mid))
337C
338 jthe = nint(pm(71,mid))
339 igtyp = igeo(11,pid)
340 npn = igeo(4,pid)
341 ish3n = igeo(18,pid)
342 ixfem = 0
343 nfail = mat_param(mid)%NFAIL
344 ifail = 0
345C
346 IF (igtyp == 11) THEN
347 DO ipt = 1, npn
348 imatly = igeo(100+ipt,pid)
349 nfail = max(nfail, mat_param(imatly)%NFAIL)
350 ENDDO
351 IF (icrack3d > 0) ixfem = mat_param(mid)%IXFEM
352 ELSEIF (igtyp == 17) THEN
353 npn = iworksh(1,numelc + ii)
354 isubstack =iworksh(3,numelc + ii)
355 ippid = 2
356 DO ipt = 1, npn
357 ipid = stack%IGEO(ippid+ipt,isubstack)
358 imatly = igeo(101, ipid)
359 nfail = max(nfail, mat_param(imatly)%NFAIL)
360 ENDDO
361 ELSEIF (igtyp == 51 ) THEN
362C---
363C new shell property (multiple NPT through each layer)
364C---
365 nb_law58 = 0
366 npn = iworksh(1,numelc + ii)
367 isubstack =iworksh(3,numelc + ii)
368 ippid = 2
369 DO ipt = 1, npn
370 ipid = stack%IGEO(ippid+ipt,isubstack)
371 imatly = igeo(101, ipid)
372 nfail = max(nfail, mat_param(imatly)%NFAIL)
373C --- PID 51 combined with LAW58 ---
374 IF (nint(pm(19,imatly)) == 58) nb_law58 = nb_law58 + 1
375 ENDDO
376C --- set IREP for tri criteria:
377 IF (nb_law58 == npn) THEN
378 irep = 2
379 ELSEIF (nb_law58 > 0) THEN
380 irep = irep + 3
381 ENDIF
382 ELSEIF ( igtyp == 52 ) THEN
383C---
384C new shell property (multiple NPT through each layer)
385C---
386 nb_law58 = 0
387 npn = iworksh(1,numelc + ii)
388 isubstack =iworksh(3,numelc + ii)
389 ippid = 2
390 ipmat = ippid + npn
391 DO ipt = 1, npn
392 ipid = stack%IGEO(ippid + ipt,isubstack)
393 imatly = stack%IGEO(ipmat + ipt,isubstack)
394 nfail = max(nfail, mat_param(imatly)%NFAIL)
395C --- PID 51 combined with LAW58 ---
396 IF (nint(pm(19,imatly)) == 58) nb_law58 = nb_law58 + 1
397 ENDDO
398C --- set IREP for tri criteria:
399 IF (nb_law58 == npn) THEN
400 irep = 2
401 ELSEIF (nb_law58 > 0) THEN
402 irep = irep + 3
403 ENDIF
404C
405 ELSE ! IGTYP == 1
406 IF(icrack3d > 0)THEN
407C - new monolayer -
408 ixfem = mat_param(mid)%IXFEM
409 IF (ixfem == 1) THEN
410 ixfem = 2
411 icrack3d = ixfem
412 ENDIF
413 END IF
414 ENDIF
415 IF (nfail > 0) ifail = 1
416c
417C thermal material expansion
418 iexpan = ipm(218, mid)
419 ico = icnod(ii)
420 IF(ish3n>3.AND.ish3n<=29)THEN
421 id = igeo(1,pid)
422 CALL fretitl2(titr,igeo(npropgi-ltitr+1,pid),ltitr)
423 CALL ancmsg(msgid=435,
424 . msgtype=msgwarning,
425 . anmode=aninfo_blind_2,
426 . i1=id,
427 . c1=titr,
428 . i2=ish3n,
429 . i3=ixtg(nixtg,ii))
430 iwarnhb=iwarnhb+1
431 ish3n=2
432 ENDIF
433 ithk = nint(geo(35,pid))
434 ipla = nint(geo(39,pid))
435 irep = igeo(6,pid)
436 icsen= igeo(3,pid)
437 IF (icsen > 0) icsen=1
438C
439 IF(npn==0.AND.(mln==36.OR.mln==86))THEN
440 IF(ipla==0) ipla=1
441 IF(ipla==2) ipla=0
442 ELSEIF(npn==0.AND.mln==2)THEN
443 IF(ipla==2) ipla=0
444 ELSE
445 IF(ipla==2) ipla=0
446 IF(ipla==3) ipla=2
447 ENDIF
448 IF(ithk==2)THEN
449 ithk = 0
450 ELSEIF(mln==32)THEN
451 ithk = 1
452 ENDIF
453 istrain = nint(geo(11,pid))
454 IF(mln==19.OR.mln>=25.OR.mln==15)istrain = 1
455 issn = nint(geo(3,pid))
456C tri sur elem delete des rigidbody
457C IRB = 0 : elem actif
458C IRB = 1 : elem inactif et optimise pour en SPMD
459C IRB = 2 : elem inactif mais optimise pour etre actif en SPMD
460 irb = itrioff(i)
461C
462C--- Clef2
463 jsms = 0
464 IF(isms/=0)THEN
465 IF(idtgrs/=0)THEN
466 IF(tagprt_sms(iparttg(ii))/=0)jsms=1
467 ELSE
468 jsms=1
469 END IF
470 END IF
471C JSMS=MY_SHIFTL(JSMS,0)
472 itri(2,i) = jsms
473C NEXT=MY_SHIFTL(NEXT,1)
474C
475C--- Clef3
476C
477C IPLA = MY_SHIFTL(IPLA,0)
478 istrain= my_shiftl(istrain,3)
479 issn = my_shiftl(issn,6)
480C
481 igtyp = my_shiftl(igtyp,9)
482 mln = my_shiftl(mln,18)
483C attention cle pleine ;
484C ICO doit rester en poids le plus fort dans cette cle.
485 ico = my_shiftl(ico,29)
486 itri(3,i)=ipla+istrain+issn+igtyp+mln+ico
487C
488C---clef4
489C
490C IRB = MY_SHIFTL(IRB,0)
491 ifail = my_shiftl(ifail,4)
492 iexpan = my_shiftl(iexpan,5)
493 jthe = my_shiftl(jthe,6)
494 ish3n = my_shiftl(ish3n,11)
495 icsen = my_shiftl(icsen,16)
496 npn = my_shiftl(npn,17)
497 irep = my_shiftl(irep,26)
498 ithk = my_shiftl(ithk,30)
499 IF(ixfem > 0)ixfem = my_shiftl(ixfem,9)
500C
501 itri(4,i)=ithk+irep+npn+icsen+ish3n+jthe+irb+ifail+ixfem
502C--- Clef3
503C MID=MY_SHIFTL(MID,0)
504 itri(5,i)=mid
505C--- Clef4
506C PID=MY_SHIFTL(PID,0)
507 itri(6,i)=pid
508C --- clef7 used for type17 iworkc=0 with/out type17 PID
509 itri(7,i) = iworksh(2,numelc + i)
510 100 CONTINUE
511C
512 mode=0
513 CALL my_orders( mode, work, itri, index, numeltg , 7)
514C
515 DO i=1,numeltg
516 iparttg(i)=inum(1,index(i))
517 thk(i) =xnum(index(i))
518 itrioff(i)=inum(2,index(i))
519 icnod(i) = inum(9,index(i))
520 ENDDO
521
522 DO i=1,numeltg
523 cep(i)=xep(index(i))
524 permutation%TRIANGLE(i)=index2(index(i))
525 ENDDO
526
527 DO k=1,nixtg
528 DO i=1,numeltg
529 ixtg(k,i)=inum(k+2,index(i))
530 ENDDO
531 ENDDO
532C
533C
534 IF(ndrape > 0 .AND. numeltg_drape > 0) THEN
535 iel = drapeg%NUMSH4
536 DO i=1,numeltg
537 iworksh(1,numelc + i)= inum_workc(1,index(i))
538 iworksh(2,numelc + i)= inum_workc(2,index(i))
539 iworksh(3,numelc + i)= inum_workc(3,index(i))
540 IF (nperturb > 0) THEN
541 DO ipert = 1, nperturb
542 rnoise(ipert,i) = xnum_rnoise(ipert,index(i))
543 ENDDO
544 ENDIF
545 sh3ang(i)=angle(index(i))
546 !
547 iel0 = xnum_drapeg%INDX(index(i))
548 drapeg%INDX(numelc + i)= 0
549 IF(iel0 == 0) cycle
550 iel = iel + 1
551 npt = xnum_drape(index(i))%NPLY
552 drape(iel)%NPLY = npt
553 drapeg%INDX(numelc + i)= iel
554 ALLOCATE(drape(iel)%INDX_PLY(npt))
555 drape(iel)%INDX_PLY(1:npt) = xnum_drape(index(i))%INDX_PLY(1:npt)
556 npt = xnum_drape(index(i))%NPLY_DRAPE ! NPT_DRP
557 drape(iel)%NPLY_DRAPE= npt
558 drape(iel)%THICK = xnum_drape(index(i))%THICK
559 ALLOCATE(drape(iel)%DRAPE_PLY(npt))
560 DO jj = 1, npt
561 drape_ply => drape(iel)%DRAPE_PLY(jj)
562 nslice = xnum_drape(index(i))%DRAPE_PLY(jj)%NSLICE
563 drape_ply%NSLICE = nslice
564 drape_ply%IPID = xnum_drape(index(i))%DRAPE_PLY(jj)%IPID
565 ALLOCATE(drape_ply%IDRAPE(nslice,2), drape_ply%RDRAPE(nslice,2))
566 drape_ply%IDRAPE = 0
567 drape_ply%RDRAPE = zero
568 DO kk = 1,nslice
569 drape_ply%IDRAPE(kk,1) = xnum_drape(index(i))%DRAPE_PLY(jj)%IDRAPE(kk,1)
570 drape_ply%IDRAPE(kk,2) = xnum_drape(index(i))%DRAPE_PLY(jj)%IDRAPE(kk,2)
571 drape_ply%RDRAPE(kk,1) = xnum_drape(index(i))%DRAPE_PLY(jj)%RDRAPE(kk,1)
572 drape_ply%RDRAPE(kk,2) = xnum_drape(index(i))%DRAPE_PLY(jj)%RDRAPE(kk,2)
573 ENDDO
574 ENDDO
575 ENDDO
576 ELSE ! ndrape = 0
577 DO i=1,numeltg
578 iworksh(1,numelc + i)= inum_workc(1,index(i))
579 iworksh(2,numelc + i)= inum_workc(2,index(i))
580 iworksh(3,numelc + i)= inum_workc(3,index(i))
581 IF (nperturb > 0) THEN
582 DO ipert = 1, nperturb
583 rnoise(ipert,i) = xnum_rnoise(ipert,index(i))
584 ENDDO
585 ENDIF
586 sh3ang(i)=angle(index(i))
587 ENDDO
588 ENDIF ! ndrape
589 IF(abs(isigi)==3.OR.abs(isigi)== 4.OR.abs(isigi)==5)THEN
590 DO i=1,numeltg
591 ptsh3n(i) = inum_ptsh3n(index(i))
592 ENDDO
593 ENDIF
594 IF(nadmesh/=0)THEN
595 DO k=1,ksh3tree
596 DO i=1,numeltg
597 sh3tree(k,i)=istor(k,index(i))
598 ENDDO
599 ENDDO
600 IF(lsh3trim/=0)THEN
601 DO i=1,numeltg
602 sh3trim(i)=istor(ksh3tree+1,index(i))
603 ENDDO
604 END IF
605 END IF
606
607C
608C INVERSION DE INDEX (DANS ITR1)
609C
610 DO i=1,numeltg
611 itr1(index(i))=i
612 ENDDO
613
614C RENUMEROTATION DE L'ARBRE
615 IF(nadmesh/=0)THEN
616 DO i=1,numeltg
617 IF(sh3tree(1,i)/=0)
618 . sh3tree(1,i)=itr1(sh3tree(1,i))
619 IF(sh3tree(2,i)/=0)
620 . sh3tree(2,i)=itr1(sh3tree(2,i))
621 ENDDO
622 END IF
623C
624C RENUMEROTATION POUR SURFACES
625C
626 DO i=1,nsurf
627 nn=igrsurf(i)%NSEG
628 DO j=1,nn
629 IF(igrsurf(i)%ELTYP(j) == 7)
630 . igrsurf(i)%ELEM(j) = itr1(igrsurf(i)%ELEM(j))
631 ENDDO
632 ENDDO
633C
634C RENUMEROTATION POUR GROUPES DE SHELL3N
635C
636 DO i=1,ngrsh3n
637 nn=igrsh3n(i)%NENTITY
638 DO j=1,nn
639 igrsh3n(i)%ENTITY(j) = itr1(igrsh3n(i)%ENTITY(j))
640 ENDDO
641 ENDDO
642C
643C renumerotation CONNECTIVITE INVERSE
644C
645 DO i=1,3*numeltg
646 IF(nod2eltg(i) /= 0)nod2eltg(i)=itr1(nod2eltg(i))
647 END DO
648C--------------------------------------------------------------
649C DETERMINATION DES SUPER_GROUPES
650C--------------------------------------------------------------
651 nd=1
652 DO i=2,numeltg
653 ii0=itri(1,index(i))
654 jj0=itri(1,index(i-1))
655 ii =itri(2,index(i))
656 jj =itri(2,index(i-1))
657 ii1=itri(3,index(i))
658 jj1=itri(3,index(i-1))
659 ii2=itri(4,index(i))
660 jj2=itri(4,index(i-1))
661 ii3=itri(5,index(i))
662 jj3=itri(5,index(i-1))
663 ii4=itri(6,index(i))
664 jj4=itri(6,index(i-1))
665C for stack/ply pid
666 ii5=itri(7,index(i))
667 jj5=itri(7,index(i-1))
668 IF (ii0/=jj0.OR.
669 . ii/=jj.OR.
670 . ii1/=jj1.OR.
671 . ii2/=jj2.OR.
672 . ii3/=jj3.OR.
673 . ii4/=jj4.OR.
674 . ii5 /= jj5) THEN
675 nd=nd+1
676 eadd(nd)=i
677 ENDIF
678 ENDDO
679 eadd(nd+1) = numeltg+1
680 DO i=1,numeltg
681 IF(iwarnhb/=0)THEN
682 pid = ixtg(nixtg-1,i)
683 id=igeo(1,pid)
684 CALL fretitl2(titr,igeo(npropgi-ltitr+1,pid),ltitr)
685 CALL ancmsg(msgid=436,
686 . msgtype=msgwarning,
687 . anmode=aninfo,
688 . i1=id,
689 . c1=titr)
690 iwarn=iwarn-1
691 ENDIF
692 ENDDO
693c
694 IF (nperturb > 0) THEN
695 IF (ALLOCATED(xnum_rnoise)) DEALLOCATE(xnum_rnoise)
696 ENDIF
697 IF(ndrape > 0 .AND. numeltg_drape > 0) THEN
698 DO i =1, numeltg
699 iel0 = xnum_drapeg%INDX(i)
700 IF(iel0 == 0) cycle
701 npt_drp = xnum_drape(i)%NPLY_DRAPE
702 DO j = 1,npt_drp
703 DEALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%RDRAPE)
704 DEALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%IDRAPE)
705 ENDDO
706 DEALLOCATE(xnum_drape(i)%DRAPE_PLY,xnum_drape(i)%INDX_PLY)
707 ENDDO
708 DEALLOCATE(xnum_drape,xnum_drapeg%INDX)
709 ELSE
710 DEALLOCATE( xnum_drape)
711 ENDIF
712C
713 DEALLOCATE(index2)
714 DEALLOCATE( istor )
715 IF(ALLOCATED(inum_ptsh3n))DEALLOCATE(inum_ptsh3n)
716 RETURN
717 END
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
drape_mod
Definition drape_mod.F:54
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::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
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
starter
program starter
Definition starter.F:39
drape_mod::drape_
Definition drape_mod.F:71
t3grhead
subroutine t3grhead(ixtg, pm, geo, inum, isel, itr1, eadd, index, itri, xnum, iparttg, nd, thk, igrsurf, igrsh3n, cep, xep, ixtg1, icnod, igeo, ipm, ipart, sh3tree, nod2eltg, itrioff, sh3trim, tagprt_sms, mat_param, iworksh, stack, drape, rnoise, multi_fvm, sh3ang, drapeg, ptsh3n)
Definition t3grhead.F:45