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