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