OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
c3grhead.F File Reference
#include "implicit_f.inc"
#include "com04_c.inc"
#include "com01_c.inc"
#include "com_xfem1.inc"
#include "param_c.inc"
#include "vect01_c.inc"
#include "remesh_c.inc"
#include "sms_c.inc"
#include "scr17_c.inc"
#include "drape_c.inc"

Go to the source code of this file.

Functions/Subroutines

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)

Function/Subroutine Documentation

◆ c3grhead()

subroutine c3grhead ( integer, dimension(nixtg,*) ixtg,
pm,
geo,
integer, dimension(10,*) inum,
integer, dimension(*) isel,
integer, dimension(*) itr1,
integer, dimension(*) eadd,
integer, dimension(*) index,
integer, dimension(8,*) itri,
xnum,
integer, dimension(*) iparttg,
integer nd,
thk,
type (surf_), dimension(nsurf) igrsurf,
type (group_), dimension(ngrsh3n) igrsh3n,
integer, dimension(*) cep,
integer, dimension(*) xep,
integer, dimension(4,*) ixtg1,
integer, dimension(*) icnod,
integer, dimension(npropgi,*) igeo,
integer, dimension(npropmi,*) ipm,
integer, dimension(lipart1,*) ipart,
integer, dimension(ksh3tree,*) sh3tree,
integer, dimension(*) nod2eltg,
integer, dimension(*) itrioff,
integer, dimension(*) sh3trim,
integer, dimension(*) tagprt_sms,
integer, dimension(3,*) iworksh,
type (stack_ply) stack,
type (drape_), dimension(numelc_drape + numeltg_drape), target drape,
rnoise,
type(multi_fvm_struct) multi_fvm,
sh3ang,
type (drapeg_) drapeg,
integer, dimension(numeltg), intent(inout) ptsh3n,
type(matparam_struct_), dimension(nummat), intent(in) mat_param,
integer, dimension(npart), intent(in) damp_range_part )
Parameters
[in]damp_range_partflag to compute the damping range

Definition at line 36 of file c3grhead.F.

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
58 use element_mod , only : nixtg
59C-----------------------------------------------
60C A R G U M E N T S
61C-----------------------------------------------
62C IXTG(NIXTG,NUMELTG)TABLEAU CONECS+PID+MID+NOS TRIANGLES E
63C PM(NPROPM,NUMMAT) ARRAY OF MATERIAL CHARACTERISTICS E
64C GEO(NPROPG,NUMGEO) ARRAY OF PID CHARACTERISTICS E
65C INUM(9,NUMELTG) TABLEAU DE TRAVAIL E/S
66C ISEL(NSELTG) TABLEAU DES TRI CHOISIES POUR TH E/S
67C ITR1(NSELTG) TABLEAU DE TRAVAIL E/S
68C EADD(NUMELTG) TABLEAU DES ADRESSES DANS IDAM CHGT DAMIER S
69C INDEX(NUMELTG) TABLEAU DE TRAVAIL E/S
70C ITRI(7,NUMELTG) TABLEAU DE TRAVAIL E/S
71C CEP(NUMELTG) TABLEAU PROC E/S
72C XEP(NUMELTG) TABLEAU PROC E/S
73C NOD2ELTG(3*NUMELTG+3*NUMELTG6) E/S
74C ITRIOFF(NUMELTG) FLAG ELEM RBY ON/OFF E/S
75C-----------------------------------------------
76C I M P L I C I T T Y P E S
77C-----------------------------------------------
78#include "implicit_f.inc"
79C-----------------------------------------------
80C C O M M O N B L O C K S
81C-----------------------------------------------
82#include "com04_c.inc"
83#include "com01_c.inc"
84#include "com_xfem1.inc"
85#include "param_c.inc"
86#include "vect01_c.inc"
87#include "remesh_c.inc"
88#include "sms_c.inc"
89#include "scr17_c.inc"
90#include "drape_c.inc"
91C-----------------------------------------------
92C D U M M Y A R G U M E N T S
93C-----------------------------------------------
94 integer
95 . ixtg(nixtg,*),isel(*),inum(10,*),nd,icnod(*),ixtg1(4,*),
96 . eadd(*), itr1(*), index(*), itri(8,*),iparttg(*),
97 . cep(*), xep(*),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
102 INTEGER , INTENT(IN) :: DAMP_RANGE_PART(NPART) !< flag to compute the damping range
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,XNUM_DRAPEG
111 TYPE (DRAPE_) , DIMENSION(:), ALLOCATABLE :: XNUM_DRAPE
112 TYPE (DRAPE_PLY_) , POINTER :: DRAPE_PLY
113C-----------------------------------------------
114 TYPE (GROUP_) , DIMENSION(NGRSH3N) :: IGRSH3N
115 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
116 TYPE(MATPARAM_STRUCT_) ,DIMENSION(NUMMAT), INTENT(IN) :: MAT_PARAM
117C-----------------------------------------------
118C L O C A L V A R I A B L E S
119C-----------------------------------------------
120 INTEGER, DIMENSION(:,:), ALLOCATABLE :: ISTOR
121 INTEGER WORK(70000)
122 INTEGER I, K, MLN, ISSN, NPN,NN,ICO,ID,
123 . MID, PID,
124 . J, ITHK,
125 . IPLA, II1, JJ1, II2, JJ2, II, JJ,
126 . IGTYP, II3, JJ3,NELTG3,
127 . MSKMLN, MSKNPN, MSKISN, MODE,ICSEN,IFAIL,NFAIL,
128 . MSKIST, MSKIPL, MSKITH, MSKMID,MSKPID,MSKIRP,MSKTYP,IREP,
129 . II0,JJ0,ILEV,PRT,IADM,MSKIRB,IRB, II4, JJ4,
130 . IXFEM,IWARNHB,IPT,IMATLY,IPID,ISH3N,
131 . II5,JJ5,II6,JJ6,ISUBSTACK,IPPID,
132 . NB_LAW58,IPMAT,IPERT,STAT,NSLICE,KK,NPT_DRP,IE,
133 . IE0
134C REAL OR REAL*8
135 CHARACTER(LEN=NCHARTITLE) :: TITR
136C
137 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX2, INUM_PTSH3N
138 INTEGER, DIMENSION(:,:), ALLOCATABLE :: INUM_WORKSH ! 3,NUMELTG
139
140 EXTERNAL my_shiftl,my_shiftr,my_and
141 INTEGER MY_SHIFTL,MY_SHIFTR,MY_AND
142 my_real, DIMENSION(:,:), ALLOCATABLE :: xnum_rnoise
143 my_real, DIMENSION(:), ALLOCATABLE :: angle ! NUMELTG
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 ALLOCATE(angle(numeltg))
162 ALLOCATE(inum_worksh(3,numeltg))
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 ie = drapeg%INDX(numelc + i)
176 IF(ie == 0) cycle
177 npt_drp = drape(ie)%NPLY_DRAPE
178 npt = drape(ie)%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(ie)%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 GLOBAL SORTING ON ALL CRITERIA FOR ALL 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 IF(ndrape > 0 .AND. numeltg_drape > 0) THEN
213 DO i=1,numeltg
214 index2(i)= permutation%TRIANGLE(i)
215 eadd(i)=1
216 itri(7,i)=i
217 index(i)=i
218 inum(1,i)=iparttg(i)
219 inum(2,i)=itrioff(i)
220 xnum(i) = thk(i)
221 inum(3,i)=ixtg(1,i)
222 inum(4,i)=ixtg(2,i)
223 inum(5,i)=ixtg(3,i)
224 inum(6,i)=ixtg(4,i)
225 inum(7,i)=ixtg(5,i)
226 inum(8,i)=ixtg(6,i)
227 inum(9,i)=icnod(i)
228 inum(10,i)=ixtg(1,i)
229 inum_worksh(1,i) = iworksh(1,numelc + i)
230 inum_worksh(2,i) = iworksh(2,numelc + i)
231 inum_worksh(3,i) = iworksh(3,numelc + i)
232 IF (nperturb > 0) THEN
233 DO ipert = 1, nperturb
234 xnum_rnoise(ipert,i) = rnoise(ipert,i)
235 ENDDO
236 ENDIF
237 angle(i)=sh3ang(i)
238 !drape structure
239 ie = drapeg%INDX(numelc + i)
240 xnum_drapeg%INDX(i) = ie
241 IF(ie == 0) cycle
242 npt = drape(ie)%NPLY
243 xnum_drape(i)%NPLY = npt
244 xnum_drape(i)%INDX_PLY(1:npt) = drape(ie)%INDX_PLY(1:npt)
245 npt = drape(ie)%NPLY_DRAPE
246 xnum_drape(i)%NPLY_DRAPE = npt
247 xnum_drape(i)%THICK = drape(ie)%THICK
248 DO jj = 1, npt
249 drape_ply => drape(ie)%DRAPE_PLY(jj)
250 nslice = drape_ply%NSLICE
251 xnum_drape(i)%DRAPE_PLY(jj)%NSLICE = nslice
252 xnum_drape(i)%DRAPE_PLY(jj)%IPID = drape_ply%IPID
253 DO kk = 1,nslice
254 xnum_drape(i)%DRAPE_PLY(jj)%IDRAPE(kk,1)=drape_ply%IDRAPE(kk,1)
255 xnum_drape(i)%DRAPE_PLY(jj)%IDRAPE(kk,2)=drape_ply%IDRAPE(kk,2)
256 xnum_drape(i)%DRAPE_PLY(jj)%RDRAPE(kk,1)=drape_ply%RDRAPE(kk,1)
257 xnum_drape(i)%DRAPE_PLY(jj)%RDRAPE(kk,2)=drape_ply%RDRAPE(kk,2)
258 ENDDO
259 DEALLOCATE(drape_ply%IDRAPE, drape_ply%RDRAPE)
260 ENDDO
261 DEALLOCATE(drape(ie)%DRAPE_PLY)
262 DEALLOCATE(drape(ie)%INDX_PLY)
263 ENDDO
264 ELSE
265 DO i=1,numeltg
266 index2(i)= permutation%TRIANGLE(i)
267 eadd(i)=1
268 itri(7,i)=i
269 index(i)=i
270 inum(1,i)=iparttg(i)
271 inum(2,i)=itrioff(i)
272 xnum(i) = thk(i)
273 inum(3,i)=ixtg(1,i)
274 inum(4,i)=ixtg(2,i)
275 inum(5,i)=ixtg(3,i)
276 inum(6,i)=ixtg(4,i)
277 inum(7,i)=ixtg(5,i)
278 inum(8,i)=ixtg(6,i)
279 inum(9,i)=icnod(i)
280 inum(10,i)=ixtg(1,i)
281 inum_worksh(1,i) = iworksh(1,numelc + i)
282 inum_worksh(2,i) = iworksh(2,numelc + i)
283 inum_worksh(3,i) = iworksh(3,numelc + i)
284 IF (nperturb > 0) THEN
285 DO ipert = 1, nperturb
286 xnum_rnoise(ipert,i) = rnoise(ipert,i)
287 ENDDO
288 ENDIF
289 angle(i)=sh3ang(i)
290 ENDDO
291 ENDIF
292 IF(abs(isigi)==3.OR.abs(isigi)== 4.OR.abs(isigi)==5)THEN
293 inum_ptsh3n(1:numeltg) = ptsh3n(1:numeltg)
294 ENDIF
295C
296 IF(nadmesh/=0)THEN
297 DO k=1,ksh3tree
298 DO i=1,numeltg
299 istor(k,i)=sh3tree(k,i)
300 ENDDO
301 ENDDO
302 IF(lsh3trim/=0)THEN
303 DO i=1,numeltg
304 istor(ksh3tree+1,i)=sh3trim(i)
305 ENDDO
306 END IF
307 END IF
308C
309 DO i=1,numeltg
310 xep(i)=cep(i)
311 ENDDO
312C
313 DO 100 i = 1, numeltg
314 ii = i
315C
316 IF(nadmesh==0)THEN
317 itri(1,i)=0
318 ELSE
319C
320C ILEV must have a strong weight on the first key
321 prt = iparttg(ii)
322 iadm= ipart(10,prt)
323 IF(iadm==0)THEN
324C not the same group as if adaptivity.
325 itri(1,i)=0
326 ELSE
327 ilev=sh3tree(3,i)
328 IF(ilev<0)ilev=-ilev-1
329 itri(1,i)=ilev+1
330 END IF
331 END IF
332C
333 mid= ixtg(1,ii)
334 pid= ixtg(5,ii)
335 mln = nint(pm(19,mid))
336 IF(mln == 51)trimat=4
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)THEN
352C - new multilayer -
353 ixfem = mat_param(mid)%IXFEM
354 ENDIF
355 ELSEIF (igtyp == 17) THEN
356 npn = iworksh(1,numelc + ii)
357 isubstack =iworksh(3,numelc + ii)
358!! IIGEO = 40 + 5*(ISUBSTACK - 1)
359!! IADI = IGEO(IIGEO + 3,PID)
360!! IPPID = IADI
361 ippid = 2
362 DO ipt = 1, npn
363 ipid = stack%IGEO(ippid+ipt,isubstack)
364 imatly = igeo(101, ipid)
365 nfail = max(nfail, mat_param(imatly)%NFAIL)
366 ENDDO
367 ELSEIF (igtyp == 51 ) THEN
368C---
369C new shell property (multiple NPT through each layer)
370C---
371 nb_law58 = 0
372 npn = iworksh(1,numelc + ii)
373 isubstack =iworksh(3,numelc + ii)
374 ippid = 2
375 DO ipt = 1, npn
376 ipid = stack%IGEO(ippid+ipt,isubstack)
377 imatly = igeo(101, ipid)
378 nfail = max(nfail, mat_param(imatly)%NFAIL)
379C --- PID 51 combined with LAW58 ---
380 IF (nint(pm(19,imatly)) == 58) nb_law58 = nb_law58 + 1
381 ENDDO
382C --- set IREP for tri criteria:
383 IF (nb_law58 == npn) THEN
384 irep = 2
385 ELSEIF (nb_law58 > 0) THEN
386 irep = irep + 3
387 ENDIF
388 ELSEIF ( igtyp == 52 ) THEN
389C---
390C new shell property (multiple NPT through each layer)
391C---
392 nb_law58 = 0
393 npn = iworksh(1,numelc + ii)
394 isubstack =iworksh(3,numelc + ii)
395 ippid = 2
396 ipmat = ippid + npn
397 DO ipt = 1, npn
398 ipid = stack%IGEO(ippid + ipt,isubstack)
399 imatly = stack%IGEO(ipmat + ipt,isubstack)
400 nfail = max(nfail, mat_param(imatly)%NFAIL)
401C --- PID 51 combined with LAW58 ---
402 IF (nint(pm(19,imatly)) == 58) nb_law58 = nb_law58 + 1
403 ENDDO
404C --- set IREP for tri criteria:
405 IF (nb_law58 == npn) THEN
406 irep = 2
407 ELSEIF (nb_law58 > 0) THEN
408 irep = irep + 3
409 ENDIF
410C
411 ELSE ! IGTYP == 1
412 IF(icrack3d > 0)THEN
413C - new monolayer -
414 ixfem = mat_param(mid)%IXFEM
415 IF (ixfem == 1) THEN
416 ixfem = 2
417 icrack3d = ixfem
418 ENDIF
419 END IF
420 ENDIF
421 IF (nfail > 0) ifail = 1
422c
423C thermal material expansion
424 iexpan = ipm(218, mid)
425 ico = icnod(ii)
426 IF(ish3n>3.AND.ish3n<=29)THEN
427 id = igeo(1,pid)
428 CALL fretitl2(titr,igeo(npropgi-ltitr+1,pid),ltitr)
429 CALL ancmsg(msgid=435,
430 . msgtype=msgwarning,
431 . anmode=aninfo_blind_2,
432 . i1=id,
433 . c1=titr,
434 . i2=ish3n,
435 . i3=ixtg(nixtg,ii))
436 iwarnhb=iwarnhb+1
437 ish3n=2
438 ENDIF
439 ithk = nint(geo(35,pid))
440 ipla = nint(geo(39,pid))
441 irep = igeo(6,pid)
442 icsen= igeo(3,pid)
443 IF (icsen > 0) icsen=1
444C
445 IF(npn==0.AND.(mln==36.OR.mln==86))THEN
446 IF(ipla==0) ipla=1
447 IF(ipla==2) ipla=0
448 ELSEIF(npn==0.AND.mln==2)THEN
449 IF(ipla==2) ipla=0
450 ELSE
451 IF(ipla==2) ipla=0
452 IF(ipla==3) ipla=2
453 ENDIF
454 IF(ithk==2)THEN
455 ithk = 0
456 ELSEIF(mln==32)THEN
457 ithk = 1
458 ENDIF
459 ipla = iabs(ipla)
460 ithk = iabs(ithk)
461 istrain = nint(geo(11,pid))
462 IF(mln==19.OR.mln>=25.OR.mln==15)istrain = 1
463 issn = iabs(nint(geo(3,pid)))
464C sorting on elem deletes rigidbody
465C IRB = 0 : elem actif
466C IRB = 1 : inactive elem and optimized for SPMD
467C IRB = 2: Elem inactive but optimized to be active in SPMD
468 irb = itrioff(i)
469C
470C--- Clef2
471 jsms = 0
472 IF(isms/=0)THEN
473 IF(idtgrs/=0)THEN
474 IF(tagprt_sms(iparttg(ii))/=0)jsms=1
475 ELSE
476 jsms=1
477 END IF
478 END IF
479C JSMS=MY_SHIFTL(JSMS,0)
480 itri(2,i) = jsms
481C NEXT=MY_SHIFTL(NEXT,1)
482C
483C--- Clef3
484C
485C IPLA = MY_SHIFTL(IPLA,0)
486 istrain= my_shiftl(istrain,3)
487 issn = my_shiftl(issn,6)
488C
489 igtyp = my_shiftl(igtyp,9)
490 mln = my_shiftl(mln,18)
491C Beware full;
492C ICO must remain the heaviest weight in this key.
493 ico = my_shiftl(ico,29)
494 itri(3,i)=ipla+istrain+issn+igtyp+mln+ico
495C
496C---clef4
497C
498C IRB = MY_SHIFTL(IRB,0)
499 ifail = my_shiftl(ifail,4)
500 iexpan = my_shiftl(iexpan,5)
501 jthe = my_shiftl(jthe,6)
502 ish3n = my_shiftl(ish3n,11)
503 icsen = my_shiftl(icsen,16)
504 npn = my_shiftl(npn,17)
505 irep = my_shiftl(irep,26)
506 ithk = my_shiftl(ithk,30)
507 IF(ixfem > 0)ixfem = my_shiftl(ixfem,9)
508C
509 itri(4,i)=ithk+irep+npn+icsen+ish3n+jthe+irb+ifail+ixfem
510C--- Clef3
511C MID=MY_SHIFTL(MID,0)
512 itri(5,i)=mid
513C--- Clef4
514C PID=MY_SHIFTL(PID,0)
515 itri(6,i)=pid
516C --- clef7 used for type17 iworkc=0 with/out type17 PID
517 itri(7,i) = iworksh(2,numelc + i)
518C --- clef 8---------------------------------
519 itri(8,i )= damp_range_part(iparttg(ii))
520 100 CONTINUE
521C
522 mode=0
523 CALL my_orders( mode, work, itri, index, numeltg , 8)
524C
525 DO i=1,numeltg
526 iparttg(i)=inum(1,index(i))
527 thk(i) =xnum(index(i))
528 itrioff(i)=inum(2,index(i))
529 icnod(i) = inum(9,index(i))
530 ENDDO
531
532 DO i=1,numeltg
533 cep(i)=xep(index(i))
534 permutation%TRIANGLE(i)=index2(index(i))
535 ENDDO
536
537 DO k=1,nixtg
538 DO i=1,numeltg
539 ixtg(k,i)=inum(k+2,index(i))
540 ENDDO
541 ENDDO
542C
543 IF (numeltg6>0) THEN
544 neltg3 = numeltg-numeltg6
545 DO i = 1, numeltg6
546 ii = i + neltg3
547 inum(1,ii)=ixtg1(1,i)
548 inum(2,ii)=ixtg1(2,i)
549 inum(3,ii)=ixtg1(3,i)
550 ENDDO
551 DO i = 1, numeltg6
552 ii = i + neltg3
553 ixtg1(1,i)=inum(1,index(ii))
554 ixtg1(2,i)=inum(2,index(ii))
555 ixtg1(3,i)=inum(3,index(ii))
556 ENDDO
557 ENDIF
558C
559 IF(ndrape > 0 .AND. numeltg_drape > 0) THEN
560 ie = drapeg%NUMSH4
561 DO i=1,numeltg
562 iworksh(1,numelc + i)= inum_worksh(1,index(i))
563 iworksh(2,numelc + i)= inum_worksh(2,index(i))
564 iworksh(3,numelc + i)= inum_worksh(3,index(i))
565 IF (nperturb > 0) THEN
566 DO ipert = 1, nperturb
567 rnoise(ipert,i) = xnum_rnoise(ipert,index(i))
568 ENDDO
569 ENDIF
570 sh3ang(i)=angle(index(i))
571 !
572 ie0 = xnum_drapeg%INDX(index(i))
573 drapeg%INDX(numelc + i) = 0
574 IF(ie0 == 0) cycle
575 ie = ie + 1
576 npt = xnum_drape(index(i))%NPLY ! number of layer shell
577 drape(ie)%NPLY = npt
578 drapeg%INDX(numelc + i)= ie
579 ALLOCATE(drape(ie)%INDX_PLY(npt))
580 drape(ie)%INDX_PLY(1:npt) = xnum_drape(index(i))%INDX_PLY(1:npt)
581 npt = xnum_drape(index(i))%NPLY_DRAPE
582 ALLOCATE(drape(ie)%DRAPE_PLY(npt))
583 drape(ie)%NPLY_DRAPE= npt
584 drape(ie)%THICK = xnum_drape(index(i))%THICK
585 DO jj = 1, npt
586 drape_ply => drape(ie)%DRAPE_PLY(jj)
587 nslice = xnum_drape(index(i))%DRAPE_PLY(jj)%NSLICE
588 drape_ply%NSLICE = nslice
589 drape_ply%IPID = xnum_drape(index(i))%DRAPE_PLY(jj)%IPID
590 ALLOCATE(drape_ply%IDRAPE(nslice,2), drape_ply%RDRAPE(nslice,2))
591 drape_ply%IDRAPE = 0
592 drape_ply%RDRAPE = zero
593 DO kk = 1,nslice
594 drape_ply%IDRAPE(kk,1) = xnum_drape(index(i))%DRAPE_PLY(jj)%IDRAPE(kk,1)
595 drape_ply%IDRAPE(kk,2) = xnum_drape(index(i))%DRAPE_PLY(jj)%IDRAPE(kk,2)
596 drape_ply%RDRAPE(kk,1) = xnum_drape(index(i))%DRAPE_PLY(jj)%RDRAPE(kk,1)
597 drape_ply%RDRAPE(kk,2) = xnum_drape(index(i))%DRAPE_PLY(jj)%RDRAPE(kk,2)
598 ENDDO
599 ENDDO
600 ENDDO
601 ELSE
602 DO i=1,numeltg
603 iworksh(1,numelc + i)= inum_worksh(1,index(i))
604 iworksh(2,numelc + i)= inum_worksh(2,index(i))
605 iworksh(3,numelc + i)= inum_worksh(3,index(i))
606 IF (nperturb > 0) THEN
607 DO ipert = 1, nperturb
608 rnoise(ipert,i) = xnum_rnoise(ipert,index(i))
609 ENDDO
610 ENDIF
611 sh3ang(i)=angle(index(i))
612 ENDDO
613 ENDIF
614 !
615 IF(abs(isigi)==3.OR.abs(isigi)== 4.OR.abs(isigi)==5)THEN
616 DO i=1,numeltg
617 ptsh3n(i) = inum_ptsh3n(index(i))
618 ENDDO
619 ENDIF
620 IF(nadmesh/=0)THEN
621 DO k=1,ksh3tree
622 DO i=1,numeltg
623 sh3tree(k,i)=istor(k,index(i))
624 ENDDO
625 ENDDO
626 IF(lsh3trim/=0)THEN
627 DO i=1,numeltg
628 sh3trim(i)=istor(ksh3tree+1,index(i))
629 ENDDO
630 END IF
631 END IF
632C
633C INDEX INVERSION (IN ITR1)
634C
635 DO i=1,numeltg
636 itr1(index(i))=i
637 ENDDO
638C RENAMING OF THE TREE
639 IF(nadmesh/=0)THEN
640 DO i=1,numeltg
641 IF(sh3tree(1,i)/=0)
642 . sh3tree(1,i)=itr1(sh3tree(1,i))
643 IF(sh3tree(2,i)/=0)
644 . sh3tree(2,i)=itr1(sh3tree(2,i))
645 ENDDO
646 END IF
647C
648C RENAMING FOR SURFACES
649C
650 DO i=1,nsurf
651 nn=igrsurf(i)%NSEG
652 DO j=1,nn
653 IF(igrsurf(i)%ELTYP(j) == 7)
654 . igrsurf(i)%ELEM(j) = itr1(igrsurf(i)%ELEM(j))
655 ENDDO
656 ENDDO
657C
658C RENAMING FOR SHELL3N GROUPS
659C
660 DO i=1,ngrsh3n
661 nn=igrsh3n(i)%NENTITY
662 DO j=1,nn
663 igrsh3n(i)%ENTITY(j) = itr1(igrsh3n(i)%ENTITY(j))
664 ENDDO
665 ENDDO
666C
667C renumerotation CONNECTIVITE INVERSE
668C
669 DO i=1,3*numeltg+3*numeltg6
670 IF(nod2eltg(i) /= 0)nod2eltg(i)=itr1(nod2eltg(i))
671 END DO
672C--------------------------------------------------------------
673C DETERMINATION OF SUPER_GROUPS
674C--------------------------------------------------------------
675 nd=1
676 DO i=2,numeltg
677 ii0=itri(1,index(i))
678 jj0=itri(1,index(i-1))
679 ii =itri(2,index(i))
680 jj =itri(2,index(i-1))
681 ii1=itri(3,index(i))
682 jj1=itri(3,index(i-1))
683 ii2=itri(4,index(i))
684 jj2=itri(4,index(i-1))
685 ii3=itri(5,index(i))
686 jj3=itri(5,index(i-1))
687 ii4=itri(6,index(i))
688 jj4=itri(6,index(i-1))
689C for stack/ply pid
690 ii5=itri(7,index(i))
691 jj5=itri(7,index(i-1))
692C damp freq range
693 ii6=itri(8,index(i))
694 jj6=itri(8,index(i-1))
695 IF (ii0/=jj0.OR.
696 . ii/=jj.OR.
697 . ii1/=jj1.OR.
698 . ii2/=jj2.OR.
699 . ii3/=jj3.OR.
700 . ii4/=jj4.OR.
701 . ii5/=jj5.OR.
702 . ii6/=jj6) THEN
703 nd=nd+1
704 eadd(nd)=i
705 ENDIF
706 ENDDO
707 eadd(nd+1) = numeltg+1
708 DO i=1,numeltg
709 IF(iwarnhb/=0)THEN
710 pid = ixtg(nixtg-1,i)
711 id=igeo(1,pid)
712 CALL fretitl2(titr,igeo(npropgi-ltitr+1,pid),ltitr)
713 CALL ancmsg(msgid=436,
714 . msgtype=msgwarning,
715 . anmode=aninfo,
716 . i1=id,
717 . c1=titr)
718 iwarn=iwarn-1
719 ENDIF
720 ENDDO
721c
722 IF (nperturb > 0) THEN
723 IF (ALLOCATED(xnum_rnoise)) DEALLOCATE(xnum_rnoise)
724 ENDIF
725C
726 DEALLOCATE(index2)
727 DEALLOCATE( istor )
728 IF(ndrape > 0 .AND. numeltg_drape > 0) THEN
729 DO i =1, numeltg
730 ie = xnum_drapeg%INDX(i)
731 IF(ie == 0) cycle
732 npt_drp = xnum_drape(i)%NPLY_DRAPE
733 DO j = 1,npt_drp
734 DEALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%RDRAPE)
735 DEALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%IDRAPE)
736 ENDDO
737 DEALLOCATE(xnum_drape(i)%DRAPE_PLY,xnum_drape(i)%INDX_PLY)
738 ENDDO
739 DEALLOCATE( xnum_drape ,xnum_drapeg%INDX)
740 ELSE
741 DEALLOCATE( xnum_drape )
742 ENDIF
743 IF(ALLOCATED(inum_ptsh3n))DEALLOCATE(inum_ptsh3n)
744
745
746 DEALLOCATE(inum_worksh, angle)
747 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
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
drape_mod::numeltg_drape
integer numeltg_drape
Definition drape_mod.F:92
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
my_shiftr
int my_shiftr(int *a, int *n)
Definition precision.c:45
my_shiftl
int my_shiftl(int *a, int *n)
Definition precision.c:36
my_and
int my_and(int *a, int *b)
Definition precision.c:54
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