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

Go to the source code of this file.

Functions/Subroutines

subroutine cgrhead (ixc, pm, geo, inum, isel, itr1, eadd, index, itri, xnum, ipartc, nd, thk, igrsurf, igrsh4n, cep, xep, igeo, ipm, ipart, sh4tree, nod2elc, isheoff, sh4trim, tagprt_sms, lgauge, iworksh, mat_param, stack, drape, rnoise, sh4ang, drapeg, ptshel, damp_range_part)

Function/Subroutine Documentation

◆ cgrhead()

subroutine cgrhead ( integer, dimension(nixc,*) ixc,
pm,
geo,
integer, dimension(9,*) inum,
integer, dimension(*) isel,
integer, dimension(*) itr1,
integer, dimension(*) eadd,
integer, dimension(*) index,
integer, dimension(8,*) itri,
xnum,
integer, dimension(*) ipartc,
integer nd,
thk,
type (surf_), dimension(nsurf) igrsurf,
type (group_), dimension(ngrshel) igrsh4n,
integer, dimension(*) cep,
integer, dimension(*) xep,
integer, dimension(npropgi,*) igeo,
integer, dimension(npropmi,*) ipm,
integer, dimension(lipart1,*) ipart,
integer, dimension(ksh4tree,*) sh4tree,
integer, dimension(*) nod2elc,
integer, dimension(*) isheoff,
integer, dimension(*) sh4trim,
integer, dimension(*) tagprt_sms,
integer, dimension(3,*) lgauge,
integer, dimension(3,*) iworksh,
type (matparam_struct_), dimension(nummat), intent(in) mat_param,
type (stack_ply) stack,
type (drape_), dimension (numelc_drape + numeltg_drape), target drape,
rnoise,
sh4ang,
type (drapeg_) drapeg,
integer, dimension(numelc), intent(inout) ptshel,
integer, dimension(npart), intent(in) damp_range_part )
Parameters
[in]damp_range_partflag to compute the damping range

Definition at line 36 of file cgrhead.F.

45C-----------------------------------------------
46C A R G U M E N T S
47C-----------------------------------------------
48C IXC(NIXC,NUMELC) ARRAY MID(1)+CONECS(2-5)+PID(6)+ E
49C N GLOBAL(7) E
50C PM(NPROPM,NUMMAT) ARRAY MATERIAL CHARACTERISTICS E
51C GEO(NPROPG,NUMGEO)ARRAY PID CHARACTERISTICS E
52C INUM(9,NUMELC) WORKING ARRAY E/S
53C ISEL(NSELC) ARRAY SELECTED SHELLS FOR TH E/S
54C ITR1(NSELC) WORKING ARRAY E/S
55C EADD(NUMELC) ARRAY ADDRESSES IN IDAM CHECKBOARD S
56C INDEX(NUMELC) WORKING ARRAY E/S
57C ITRI(7,NUMELC) WORKING ARRAY E/S
58C IPARTC(NUMELC) PART ARRAY E/S
59C CEP(NUMELC) PROC ARRAY E/S
60C XEP(NUMELC) PROC ARRAY E/S
61C NOD2ELC(4*NUMELC) E/S
62C ISHEOFF(NUMELC) FLAG ELEM RBY ON/OFF E/S
63C-----------------------------------------------
64C M o d u l e s
65C-----------------------------------------------
66 USE my_alloc_mod
67 USE message_mod
68 USE r2r_mod
69 USE stack_mod
70 USE message_mod
71 USE reorder_mod
72 USE groupdef_mod
73 USE drape_mod
74 USE matparam_def_mod
75 use element_mod , only : nixc
76C-----------------------------------------------
77C I M P L I C I T T Y P E S
78C-----------------------------------------------
79#include "implicit_f.inc"
80C-----------------------------------------------
81C C O M M O N B L O C K S
82C-----------------------------------------------
83#include "vect01_c.inc"
84#include "com04_c.inc"
85#include "com_xfem1.inc"
86#include "param_c.inc"
87#include "remesh_c.inc"
88#include "sms_c.inc"
89#include "scr17_c.inc"
90#include "r2r_c.inc"
91#include "drape_c.inc"
92#include "com01_c.inc"
93C-----------------------------------------------
94C D U M M Y A R G U M E N T S
95C-----------------------------------------------
96 INTEGER IXC(NIXC,*),ISEL(*),INUM(9,*),IPARTC(*), ISHEOFF(*),
97 . EADD(*),ITR1(*),INDEX(*),ITRI(8,*),
98 . ND, CEP(*), XEP(*),
99 . IGEO(NPROPGI,*),IPM(NPROPMI,*),IPART(LIPART1,*),
100 . SH4TREE(KSH4TREE,*), NOD2ELC(*), SH4TRIM(*),
101 . TAGPRT_SMS(*) ,LGAUGE(3,*),
102 . IWORKSH(3,*)
103 INTEGER , DIMENSION(NUMELC) , INTENT(INOUT):: PTSHEL
104 INTEGER , INTENT(IN) :: DAMP_RANGE_PART(NPART) !< flag to compute the damping range
105C REAL OR REAL*8
106 my_real
107 . pm(npropm,*), geo(npropg,*),xnum(*),thk(*), rnoise(nperturb,*),
108 . sh4ang(*)
109C-----------------------------------------------
110 TYPE (STACK_PLY) :: STACK
111 TYPE (DRAPE_) , TARGET :: DRAPE (NUMELC_DRAPE + NUMELTG_DRAPE)
112 TYPE (DRAPEG_) :: DRAPEG
113 TYPE (DRAPE_) , DIMENSION(:), ALLOCATABLE :: XNUM_DRAPE
114 TYPE (DRAPEG_) :: XNUM_DRAPEG
115 TYPE (MATPARAM_STRUCT_) ,DIMENSION(NUMMAT),INTENT(IN) :: MAT_PARAM
116C-----------------------------------------------
117 TYPE (GROUP_) , DIMENSION(NGRSHEL) :: IGRSH4N
118 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
119C-----------------------------------------------
120C L O C A L V A R I A B L E S
121C-----------------------------------------------
122 INTEGER, DIMENSION(:,:), ALLOCATABLE :: ISTOR
123 INTEGER WORK(70000)
124 INTEGER I, K, MLN, ISSN, NPN, NN,IGTYP,
125 . MID, PID,
126 . IHBE, II, J,
127 . ITHK, IPLA,II1,JJ1,II2,JJ2,JJ,II3,JJ3,
128 . MSKMLN,MSKNPN,MSKIHB,MSKISN,MSKIRB,MODE,ICSEN,IRB,
129 . MSKIST,MSKIPL,MSKITH,MSKMID,MSKPID,MSKIRP,MSKTYP,IREP,
130 . IPT,IMATLY,II0,JJ0,ILEV,PRT,IADM,II4,JJ4,N1,
131 . NFAIL,IFAIL,IXFEM,INUM_R2R(1+R2R_SIU*NUMELC),
132 . II5,JJ5,II6,JJ6,
133 . ISUBSTACK ,IPPID,NB_LAW58,IPMAT,
134 . IPERT,STAT,NSLICE,KK,NPT_DRP,IE,IE0
135 INTEGER, DIMENSION(:,:), ALLOCATABLE :: INUM_WORKC !(3,NUMELC)
136 my_real, DIMENSION(:), ALLOCATABLE :: angle !(NUMELC)
137 EXTERNAL my_shiftl,my_shiftr,my_and
138 INTEGER MY_SHIFTL,MY_SHIFTR,MY_AND,IPIDL
139 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX2, INUM_PTSHEL
140C REAL OR REAL*8
141 my_real, DIMENSION(:,:), ALLOCATABLE :: xnum_rnoise
142C
143 TYPE (DRAPE_PLY_) , POINTER :: DRAPE_PLY
144C---+----1----+----2----+----3----+----4----+----5----+----6----+----7--
145C1---------------------------------
146 DATA mskmln /o'07770000000'/
147 DATA msktyp /o'00007770000'/
148 DATA mskihb /o'00000007000'/
149 DATA mskisn /o'00000000700'/
150 DATA mskist /o'00000000070'/
151 DATA mskipl /o'00000000007'/
152C2---------------------------------
153 DATA mskith /o'10000000000'/
154 DATA mskirp /o'07000000000'/
155 DATA msknpn /o'00777000000'/
156 DATA mskirb /o'00000000007'/
157C3---------------------------------
158 DATA mskmid /o'07777777777'/
159C4---------------------------------
160 DATA mskpid /o'07777777777'/
161C======================================================================|
162C GLOBAL SORTING ON ALL CRITERIA FOR ALL ELEMENTS
163C----------------------------------------------------------
164 ALLOCATE(angle(numelc))
165 ALLOCATE(inum_workc(3,numelc))
166 IF(nadmesh /= 0)THEN
167 ALLOCATE( istor(ksh4tree+1,numelc) )
168 ELSE
169 ALLOCATE( istor(0,0) )
170 ENDIF
171 IF (ndrape > 0 .AND. numelc_drape > 0) THEN
172 ALLOCATE(xnum_drape(numelc))
173 ALLOCATE(xnum_drapeg%INDX(numelc))
174 xnum_drapeg%INDX = 0
175 DO i =1, numelc
176 ie = drapeg%INDX(i)
177 IF(ie == 0) cycle
178 npt_drp = drape(ie)%NPLY_DRAPE
179 npt = drape(ie)%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 xnum_drape(i)%INDX_PLY = 0
184 DO j = 1,npt_drp
185 nslice = drape(ie)%DRAPE_PLY(j)%NSLICE
186 ALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%RDRAPE(nslice,2))
187 ALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%IDRAPE(nslice,2))
188 xnum_drape(i)%DRAPE_PLY(j)%RDRAPE = 0
189 xnum_drape(i)%DRAPE_PLY(j)%IDRAPE = 0
190 ENDDO
191 ENDDO
192 ELSE
193 ALLOCATE( xnum_drape(0) )
194 ENDIF
195 IF(abs(isigi) == 3 .OR. abs(isigi) == 4 .OR. abs(isigi) == 5) THEN
196 ALLOCATE(inum_ptshel(numelc))
197 inum_ptshel = 0
198 ELSE
199 ALLOCATE(inum_ptshel(0))
200 ENDIF
201C
202 IF (nperturb > 0) THEN
203 ALLOCATE(xnum_rnoise(nperturb,numelc),stat=stat)
204 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
205 . msgtype=msgerror,
206 . c1='XNUM_RNOISE')
207 ENDIF
208C
209 CALL my_alloc(index2,numelc)
210
211 IF(ndrape > 0 .AND. numelc_drape > 0) THEN
212 DO i=1,numelc
213 index2(i)=permutation%SHELL(i)
214 eadd(i)=1
215 itri(7,i)=i
216 index(i)=i
217 inum(1,i)=ipartc(i)
218 inum(2,i)=isheoff(i)
219 inum(3,i)=ixc(1,i)
220 inum(4,i)=ixc(2,i)
221 inum(5,i)=ixc(3,i)
222 inum(6,i)=ixc(4,i)
223 inum(7,i)=ixc(5,i)
224 inum(8,i)=ixc(6,i)
225 inum(9,i)=ixc(7,i)
226 xnum(i)=thk(i)
227 IF (nsubdom>0) inum_r2r(i) = tag_elcf(i)
228 inum_workc(1,i) = iworksh(1,i)
229 inum_workc(2,i) = iworksh(2,i)
230 inum_workc(3,i) = iworksh(3,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)=sh4ang(i)
237 !drape structure
238 ie = drapeg%INDX(i)
239 xnum_drapeg%INDX(i) = drapeg%INDX(i)
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,numelc
265 index2(i)=permutation%SHELL(i)
266 eadd(i)=1
267 itri(7,i)=i
268 index(i)=i
269 inum(1,i)=ipartc(i)
270 inum(2,i)=isheoff(i)
271 inum(3,i)=ixc(1,i)
272 inum(4,i)=ixc(2,i)
273 inum(5,i)=ixc(3,i)
274 inum(6,i)=ixc(4,i)
275 inum(7,i)=ixc(5,i)
276 inum(8,i)=ixc(6,i)
277 inum(9,i)=ixc(7,i)
278 xnum(i)=thk(i)
279 IF (nsubdom>0) inum_r2r(i) = tag_elcf(i)
280 inum_workc(1,i) = iworksh(1,i)
281 inum_workc(2,i) = iworksh(2,i)
282 inum_workc(3,i) = iworksh(3,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)=sh4ang(i)
289 ENDDO
290 ENDIF
291 IF(abs(isigi)==3.OR.abs(isigi)== 4.OR.abs(isigi)==5)THEN
292 inum_ptshel(1:numelc) = ptshel(1:numelc)
293 ENDIF
294C
295 IF(nadmesh /= 0)THEN
296 DO k=1,ksh4tree
297 DO i=1,numelc
298 istor(k,i)=sh4tree(k,i)
299 ENDDO
300 ENDDO
301 IF(lsh4trim/=0)THEN
302 DO i=1,numelc
303 istor(ksh4tree+1,i)=sh4trim(i)
304 ENDDO
305 END IF
306 END IF
307C
308 DO i=1,numelc
309 xep(i)=cep(i)
310 ENDDO
311C
312 DO i = 1, numelc
313 ii = i
314C
315 IF(nadmesh == 0)THEN
316 itri(1,i)=0
317 ELSE
318C
319C ILEV must have strong weight on 1st key
320 prt = ipartc(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= sh4tree(3,i)
327 IF(ilev<0)ilev=-ilev-1
328 itri(1,i)=ilev+1
329 END IF
330 END IF
331C
332 mid= ixc(1,ii)
333 pid= ixc(6,ii)
334 mln = nint(pm(19,mid))
335 igtyp= igeo(11,pid)
336 jthe = nint(pm(71,mid))
337 npn = igeo(4,pid)
338 ihbe = nint(geo(171,pid))
339 ithk = nint(geo(35,pid))
340 ipla = nint(geo(39,pid))
341 irep = igeo(6,pid)
342 ishxfem_ply = igeo(19,pid)
343 nfail = 0
344 ifail = 0
345 ixfem = 0
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,ii)
357 isubstack =iworksh(3, 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!! IPIDL = IGEO(IPPID+IPT,PID)
364 ipidl = stack%IGEO(ippid + ipt ,isubstack)
365 imatly = igeo(101,ipidl)
366 nfail = max(nfail,mat_param(imatly)%NFAIL)
367 ENDDO
368 ELSEIF(igtyp == 51 ) THEN
369C---
370C new shell property (variable NPT through each layer)
371C---
372 nb_law58 = 0
373 npn = iworksh(1,ii)
374 isubstack = iworksh(3, ii)
375 ippid = 2
376 DO ipt = 1,npn ! nb of plys
377 ipidl = stack%IGEO(ippid + ipt,isubstack)
378 imatly = igeo(101,ipidl)
379 nfail = max(nfail,mat_param(imatly)%NFAIL)
380C --- PID 51 combined with LAW58 ---
381 IF (nint(pm(19,imatly)) == 58) nb_law58 = nb_law58 + 1
382 ENDDO
383C --- set IREP for sorting criteria:
384 IF (nb_law58 == npn) THEN
385 irep = 2
386 ELSEIF (nb_law58 > 0) THEN
387 irep = irep + 3
388 ENDIF
389 ELSEIF(igtyp == 52) THEN
390C---
391C new shell property (PCOMPP + STACK + PLY )
392C---
393 nb_law58 = 0
394 npn = iworksh(1,ii)
395 isubstack = iworksh(3, ii)
396 ippid = 2
397 ipmat = ippid + npn
398 DO ipt = 1,npn ! nb of plys
399 ipidl = stack%IGEO(ippid + ipt,isubstack)
400 imatly = stack%IGEO(ipmat + ipt,isubstack)
401 nfail = max(nfail,mat_param(imatly)%NFAIL)
402C --- PID 51 combined with LAW58 ---
403 IF (nint(pm(19,imatly)) == 58) nb_law58 = nb_law58 + 1
404 ENDDO
405C --- set IREP for sorting criteria:
406 IF (nb_law58 == npn) THEN
407 irep = 2
408 ELSEIF (nb_law58 > 0) THEN
409 irep = irep + 3
410 ENDIF
411C
412 ELSE ! IGTYP == 1
413 nfail = mat_param(mid)%NFAIL
414 IF(icrack3d > 0)THEN
415C - new monolayer -
416 ixfem = mat_param(mid)%IXFEM
417 IF (ixfem == 1) THEN
418 ixfem = 2
419 icrack3d = ixfem
420 ENDIF
421 END IF
422 ENDIF
423 IF (nfail > 0) ifail = 1
424c
425C thermal material expansion
426 iexpan = ipm(218, mid)
427 icsen= igeo(3,pid)
428 IF (icsen > 0) icsen=1
429 IF(npn == 0.AND.(mln == 36.OR.mln == 86))THEN
430 IF(ipla == 0) ipla=1
431 IF(ipla == 2) ipla=0
432C IF(IPLA == 3) IPLA=2
433 ELSEIF(npn == 0.AND.mln == 2)THEN
434 IF(ipla == 2) ipla=0
435 ELSE
436 IF(ipla == 2) ipla=0
437 IF(ipla == 3) ipla=2
438 ENDIF
439 IF(ithk == 2)THEN
440 ithk = 0
441 ELSEIF(mln == 32)THEN
442 ithk = 1
443 ENDIF
444 ipla = iabs(ipla)
445 ithk = iabs(ithk)
446 istrain = nint(geo(11,pid))
447 IF(mln == 19.OR.mln>=25.OR.mln == 15)istrain = 1
448 issn = iabs(nint(geo(3,pid)))
449C sorting on elem delete for rigidbody
450C IRB = 0 : active elem
451C IRB = 1 : inactive elem and optimized for SPMD
452C IRB = 2 : inactive elem but optimized to be active in SPMD
453 irb = isheoff(i)
454C
455C--- Key2
456 jsms = 0
457 IF(isms/=0)THEN
458 IF(idtgrs/=0)THEN
459 IF(tagprt_sms(ipartc(ii))/=0)jsms=1
460 ELSE
461 jsms=1
462 END IF
463 END IF
464C JSMS=MY_SHIFTL(JSMS,0)
465 itri(2,i) = jsms
466C NEXT=MY_SHIFTL(NEXT,1)
467C
468C--- Key3
469C IPLA = MY_SHIFTL(IPLA,0)
470 istrain= my_shiftl(istrain,3)
471 issn = my_shiftl(issn,6)
472 ihbe = my_shiftl(ihbe,9)
473 igtyp = my_shiftl(igtyp,12)
474 mln = my_shiftl(mln,21)
475 itri(3,i)=ipla+istrain+issn+ihbe+igtyp+mln
476C
477C--- Key4
478C
479C IRB = MY_SHIFTL(IRB,0)
480C
481 ishxfem_ply = my_shiftl(ishxfem_ply,10)
482 ifail = my_shiftl(ifail,11)
483 iexpan = my_shiftl(iexpan,14)
484 jthe = my_shiftl(jthe,15)
485 icsen= my_shiftl(icsen,16)
486 npn = my_shiftl(npn,17)
487 irep = my_shiftl(irep,26)
488 ithk = my_shiftl(ithk,30)
489 IF(ixfem > 0) ixfem = my_shiftl(ixfem,9)
490C
491 itri(4,i)=ithk+irep+npn+icsen+jthe+iexpan+irb+ifail+ishxfem_ply
492 . +ixfem
493
494C--- Key5
495C MID=MY_SHIFTL(MID,0)
496 itri(5,i)=mid
497C--- Key6
498C PID=MY_SHIFTL(PID,0)
499 itri(6,i)=pid
500C --- key7 used for type17 iworkc=0 with/out type17 (or type51) PID
501 itri(7,i) = iworksh(2,i)
502C --- key 8---------------------------------
503 itri(8,i )= damp_range_part(ipartc(ii))
504 ENDDO
505C
506 mode=0
507 CALL my_orders( mode, work, itri, index, numelc , 8)
508C
509 DO i=1,numelc
510 ipartc(i) =inum(1,index(i))
511 isheoff(i)=inum(2,index(i))
512 IF (nsubdom>0) tag_elcf(i)=inum_r2r(index(i))
513 thk(i) =xnum(index(i))
514 ENDDO
515
516 DO i=1,numelc
517 cep(i)=xep(index(i))
518 permutation%SHELL(i)=index2(index(i))
519 ENDDO
520
521 DO k=1,7
522 DO i=1,numelc
523 ixc(k,i)=inum(k+2,index(i))
524 ENDDO
525 ENDDO
526 IF(ndrape > 0 .AND. numelc_drape > 0 ) THEN
527 ie = 0
528 DO i=1,numelc
529 iworksh(1,i)= inum_workc(1,index(i))
530 iworksh(2,i)= inum_workc(2,index(i))
531 iworksh(3,i)= inum_workc(3,index(i))
532 IF (nperturb > 0) THEN
533 DO ipert = 1, nperturb
534 rnoise(ipert,i) = xnum_rnoise(ipert,index(i))
535 ENDDO
536 ENDIF
537 sh4ang(i)=angle(index(i))
538 !
539 ie0 = xnum_drapeg%INDX(index(i))
540 drapeg%INDX(i)= 0
541 IF(ie0 == 0) cycle
542 ie = ie + 1
543 npt = xnum_drape(index(i))% NPLY ! number of layer shell
544 drape(ie)%NPLY = npt
545 drapeg%INDX(i)= ie
546 ALLOCATE(drape(ie)%INDX_PLY(npt))
547 drape(ie)%INDX_PLY(1:npt) = xnum_drape(index(i))%INDX_PLY(1:npt)
548 npt = xnum_drape(index(i))%NPLY_DRAPE ! NPT_DRP
549 ALLOCATE(drape(ie)%DRAPE_PLY(npt))
550 drape(ie)%NPLY_DRAPE= npt
551 drape(ie)%THICK = xnum_drape(index(i))%THICK
552 DO jj = 1, npt
553 drape_ply => drape(ie)%DRAPE_PLY(jj)
554 nslice = xnum_drape(index(i))%DRAPE_PLY(jj)%NSLICE
555 drape_ply%NSLICE = nslice
556 drape_ply%IPID = xnum_drape(index(i))%DRAPE_PLY(jj)%IPID
557 ALLOCATE(drape_ply%IDRAPE(nslice,2), drape_ply%RDRAPE(nslice,2))
558 DO kk = 1,nslice
559 drape_ply%IDRAPE(kk,1) = xnum_drape(index(i))%DRAPE_PLY(jj)%IDRAPE(kk,1)
560 drape_ply%IDRAPE(kk,2) = xnum_drape(index(i))%DRAPE_PLY(jj)%IDRAPE(kk,2)
561 drape_ply%RDRAPE(kk,1) = xnum_drape(index(i))%DRAPE_PLY(jj)%RDRAPE(kk,1)
562 drape_ply%RDRAPE(kk,2) = xnum_drape(index(i))%DRAPE_PLY(jj)%RDRAPE(kk,2)
563 ENDDO
564 ENDDO
565 ENDDO
566 ELSE
567 DO i=1,numelc
568 iworksh(1,i)= inum_workc(1,index(i))
569 iworksh(2,i)= inum_workc(2,index(i))
570 iworksh(3,i)= inum_workc(3,index(i))
571 IF (nperturb > 0) THEN
572 DO ipert = 1, nperturb
573 rnoise(ipert,i) = xnum_rnoise(ipert,index(i))
574 ENDDO
575 ENDIF
576 sh4ang(i)=angle(index(i))
577 ENDDO
578 ENDIF
579 IF(abs(isigi)==3.OR.abs(isigi)== 4.OR.abs(isigi)==5)THEN
580 DO i=1,numelc
581 ptshel(i) = inum_ptshel(index(i))
582 ENDDO
583 ENDIF
584C
585 IF(nadmesh /= 0)THEN
586 DO k=1,ksh4tree
587 DO i=1,numelc
588 sh4tree(k,i)=istor(k,index(i))
589 ENDDO
590 ENDDO
591 IF(lsh4trim/=0)THEN
592 DO i=1,numelc
593 sh4trim(i)=istor(ksh4tree+1,index(i))
594 ENDDO
595 END IF
596 END IF
597C
598C INVERSION OF INDEX (IN ITR1)
599C
600 DO i=1,numelc
601 itr1(index(i))=i
602 ENDDO
603C
604C RENUMBERING OF THE TREE
605 IF(nadmesh /= 0)THEN
606 DO i=1,numelc
607 IF(sh4tree(1,i) /= 0)
608 . sh4tree(1,i)=itr1(sh4tree(1,i))
609 IF(sh4tree(2,i) /= 0)
610 . sh4tree(2,i)=itr1(sh4tree(2,i))
611 ENDDO
612 END IF
613C
614C RENUMBERING FOR SURFACES
615C
616 DO i=1,nsurf
617 nn=igrsurf(i)%NSEG
618 DO j=1,nn
619 IF(igrsurf(i)%ELTYP(j) == 3)
620 . igrsurf(i)%ELEM(j) = itr1(igrsurf(i)%ELEM(j))
621 ENDDO
622 ENDDO
623C RENUMBERING FOR shell in Accel (gauge)
624C
625 DO i=1,nbgauge
626 n1 = lgauge(1,i)
627 IF(n1 <= 0) THEN
628 n1=-lgauge(3,i)
629 IF(n1 > 0) lgauge(3,i)=-itr1(n1)
630 ENDIF
631 ENDDO
632C
633C RENUMBERING FOR SHELL GROUPS
634C
635 DO i=1,ngrshel
636 nn=igrsh4n(i)%NENTITY
637 DO j=1,nn
638 igrsh4n(i)%ENTITY(j) = itr1(igrsh4n(i)%ENTITY(j))
639 ENDDO
640 ENDDO
641C
642C renumbering INVERSE CONNECTIVITY
643C
644 DO i=1,4*numelc
645 IF (nod2elc(i) /= 0) nod2elc(i)=itr1(nod2elc(i))
646 END DO
647C
648C--------------------------------------------------------------
649C DETERMINATION OF SUPER_GROUPS
650C--------------------------------------------------------------
651 nd=1
652 DO i=2,numelc
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))
668C damp freq range
669 ii6=itri(8,index(i))
670 jj6=itri(8,index(i-1))
671 IF (ii0/=jj0 .or.
672 * ii/=jj .or.
673 * ii1/=jj1 .or.
674 * ii2/=jj2.OR.ii3 /= jj3.OR.ii4 /= jj4.OR.ii5 /= jj5 .or.
675 * ii6 /= jj6) THEN
676 nd=nd+1
677 eadd(nd)=i
678 ENDIF
679 ENDDO
680 eadd(nd+1) = numelc+1
681C-----------
682c
683 IF (nperturb > 0) THEN
684 IF (ALLOCATED(xnum_rnoise)) DEALLOCATE(xnum_rnoise)
685 ENDIF
686c
687 DEALLOCATE(index2)
688 DEALLOCATE( istor )
689 IF(ndrape > 0 .AND. numelc_drape > 0) THEN
690 DO i =1, numelc
691 ie = xnum_drapeg%INDX(i)
692 IF(ie == 0) cycle
693 npt_drp = xnum_drape(i)%NPLY_DRAPE
694 DO j = 1,npt_drp
695 DEALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%RDRAPE)
696 DEALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%IDRAPE)
697 ENDDO
698 DEALLOCATE(xnum_drape(i)%DRAPE_PLY,xnum_drape(i)%INDX_PLY)
699 ENDDO
700 DEALLOCATE( xnum_drape ,xnum_drapeg%INDX)
701 ELSE
702 DEALLOCATE( xnum_drape )
703 ENDIF
704 IF(ALLOCATED(inum_ptshel))DEALLOCATE(inum_ptshel)
705
706 DEALLOCATE(angle,inum_workc)
707 RETURN
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
drape_mod::numelc_drape
integer numelc_drape
Definition drape_mod.F:92
groupdef_mod
Definition groupdef_mod.F:668
message_mod
Definition message_mod.F:1257
r2r_mod
Definition r2r_mod.F:125
r2r_mod::tag_elcf
integer, dimension(:), allocatable tag_elcf
Definition r2r_mod.F:141
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