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
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 "vect01_c.inc"
83#include "com04_c.inc"
84#include "com_xfem1.inc"
85#include "param_c.inc"
86#include "remesh_c.inc"
87#include "sms_c.inc"
88#include "scr17_c.inc"
89#include "r2r_c.inc"
90#include "drape_c.inc"
91#include "com01_c.inc"
92C-----------------------------------------------
93C D U M M Y A R G U M E N T S
94C-----------------------------------------------
95 INTEGER IXC(NIXC,*),ISEL(*),INUM(9,*),IPARTC(*), ISHEOFF(*),
96 . EADD(*),ITR1(*),INDEX(*),ITRI(8,*),
97 . ND, CEP(*), XEP(*),
98 . IGEO(NPROPGI,*),IPM(NPROPMI,*),IPART(LIPART1,*),
99 . SH4TREE(KSH4TREE,*), NOD2ELC(*), SH4TRIM(*),
100 . TAGPRT_SMS(*) ,LGAUGE(3,*),
101 . IWORKSH(3,*)
102 INTEGER , DIMENSION(NUMELC) , INTENT(INOUT):: PTSHEL
103 INTEGER , INTENT(IN) :: DAMP_RANGE_PART(NPART) !< flag to compute the damping range
104C REAL OR REAL*8
105 my_real
106 . pm(npropm,*), geo(npropg,*),xnum(*),thk(*), rnoise(nperturb,*),
107 . sh4ang(*)
108C-----------------------------------------------
109 TYPE (STACK_PLY) :: STACK
110 TYPE (DRAPE_) , TARGET :: DRAPE (NUMELC_DRAPE + NUMELTG_DRAPE)
111 TYPE (DRAPEG_) :: DRAPEG
112 TYPE (DRAPE_) , DIMENSION(:), ALLOCATABLE :: XNUM_DRAPE
113 TYPE (DRAPEG_) :: XNUM_DRAPEG
114 TYPE (MATPARAM_STRUCT_) ,DIMENSION(NUMMAT),INTENT(IN) :: MAT_PARAM
115C-----------------------------------------------
116 TYPE (GROUP_) , DIMENSION(NGRSHEL) :: IGRSH4N
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,INUM_DRAPE
122 INTEGER WORK(70000)
123 INTEGER I, K, MLN, NG, ISSN, NPN, IFIO, NN,L,IGTYP,
124 . MLN0, ISSN0, IC, N, MID, MID0, PID, PID0, ISTR0,
125 . IHBE, IHBE0, II, J, MIDN, PIDN, NSG, NEL, NE1,
126 . ITHK, ITHK0, IPLA, IPLA0,II1,JJ1,II2,JJ2,JJ,II3,JJ3,NGROU,
127 . MSKMLN,MSKNPN,MSKIHB,MSKISN,MSKIRB,MODE,ICSEN,IRB,
128 . MSKIST,MSKIPL,MSKITH,MSKMID,MSKPID,MSKIRP,MSKTYP,IREP,
129 . IPT,IMATLY,II0,JJ0,ILEV,PRT,IADM,DIR,II4,JJ4,N1,
130 . NFAIL,IFAIL,IXFEM,INUM_R2R(1+R2R_SIU*NUMELC),
131 . II5,JJ5,II6,JJ6,
132 . ISUBSTACK,IIGEO,IADI ,IPPID,NB_LAW58,IPMAT,
133 . IPERT,STAT,IP,NSLICE,KK,NPT_DRP,IE,IE0
134 INTEGER, DIMENSION(:,:), ALLOCATABLE :: INUM_WORKC !(3,NUMELC)
135 my_real, DIMENSION(:), ALLOCATABLE :: angle !(NUMELC)
136 EXTERNAL my_shiftl,my_shiftr,my_and
137 INTEGER MY_SHIFTL,MY_SHIFTR,MY_AND,IPIDL
138 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX2, INUM_PTSHEL
139C REAL OR REAL*8
140 my_real, DIMENSION(:,:), ALLOCATABLE :: xnum_rnoise
141C
142 TYPE (DRAPE_PLY_) , POINTER :: DRAPE_PLY
143C---+----1----+----2----+----3----+----4----+----5----+----6----+----7--
144C1---------------------------------
145 DATA mskmln /o'07770000000'/
146 DATA msktyp /o'00007770000'/
147 DATA mskihb /o'00000007000'/
148 DATA mskisn /o'00000000700'/
149 DATA mskist /o'00000000070'/
150 DATA mskipl /o'00000000007'/
151C2---------------------------------
152 DATA mskith /o'10000000000'/
153 DATA mskirp /o'07000000000'/
154 DATA msknpn /o'00777000000'/
155 DATA mskirb /o'00000000007'/
156C3---------------------------------
157 DATA mskmid /o'07777777777'/
158C4---------------------------------
159 DATA mskpid /o'07777777777'/
160C======================================================================|
161C GLOBAL SORTING ON ALL CRITERIA FOR ALL ELEMENTS
162C----------------------------------------------------------
163 ALLOCATE(angle(numelc))
164 ALLOCATE(inum_workc(3,numelc))
165 IF(nadmesh /= 0)THEN
166 ALLOCATE( istor(ksh4tree+1,numelc) )
167 ELSE
168 ALLOCATE( istor(0,0) )
169 ENDIF
170 IF (ndrape > 0 .AND. numelc_drape > 0) THEN
171 ALLOCATE(xnum_drape(numelc))
172 ALLOCATE(xnum_drapeg%INDX(numelc))
173 xnum_drapeg%INDX = 0
174 DO i =1, numelc
175 ie = drapeg%INDX(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 xnum_drape(i)%INDX_PLY = 0
183 DO j = 1,npt_drp
184 nslice = drape(ie)%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_ptshel(numelc))
196 inum_ptshel = 0
197 ELSE
198 ALLOCATE(inum_ptshel(0))
199 ENDIF
200C
201 IF (nperturb > 0) THEN
202 ALLOCATE(xnum_rnoise(nperturb,numelc),stat=stat)
203 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
204 . msgtype=msgerror,
205 . c1='XNUM_RNOISE')
206 ENDIF
207C
208 CALL my_alloc(index2,numelc)
209
210 IF(ndrape > 0 .AND. numelc_drape > 0) THEN
211 DO i=1,numelc
212 index2(i)=permutation%SHELL(i)
213 eadd(i)=1
214 itri(7,i)=i
215 index(i)=i
216 inum(1,i)=ipartc(i)
217 inum(2,i)=isheoff(i)
218 inum(3,i)=ixc(1,i)
219 inum(4,i)=ixc(2,i)
220 inum(5,i)=ixc(3,i)
221 inum(6,i)=ixc(4,i)
222 inum(7,i)=ixc(5,i)
223 inum(8,i)=ixc(6,i)
224 inum(9,i)=ixc(7,i)
225 xnum(i)=thk(i)
226 IF (nsubdom>0) inum_r2r(i) = tag_elcf(i)
227 inum_workc(1,i) = iworksh(1,i)
228 inum_workc(2,i) = iworksh(2,i)
229 inum_workc(3,i) = iworksh(3,i)
230 IF (nperturb > 0) THEN
231 DO ipert = 1, nperturb
232 xnum_rnoise(ipert,i) = rnoise(ipert,i)
233 ENDDO
234 ENDIF
235 angle(i)=sh4ang(i)
236 !drape structure
237 ie = drapeg%INDX(i)
238 xnum_drapeg%INDX(i) = drapeg%INDX(i)
239 IF(ie == 0) cycle
240 npt = drape(ie)%NPLY
241 xnum_drape(i)% NPLY = npt
242 xnum_drape(i)%INDX_PLY(1:npt) = drape(ie)%INDX_PLY(1:npt)
243 npt = drape(ie)%NPLY_DRAPE
244 xnum_drape(i)%NPLY_DRAPE = npt
245 xnum_drape(i)%THICK = drape(ie)%THICK
246 DO jj = 1, npt
247 drape_ply => drape(ie)%DRAPE_PLY(jj)
248 nslice = drape_ply%NSLICE
249 xnum_drape(i)%DRAPE_PLY(jj)%NSLICE = nslice
250 xnum_drape(i)%DRAPE_PLY(jj)%IPID = drape_ply%IPID
251 DO kk = 1,nslice
252 xnum_drape(i)%DRAPE_PLY(jj)%IDRAPE(kk,1)=drape_ply%IDRAPE(kk,1)
253 xnum_drape(i)%DRAPE_PLY(jj)%IDRAPE(kk,2)=drape_ply%IDRAPE(kk,2)
254 xnum_drape(i)%DRAPE_PLY(jj)%RDRAPE(kk,1)=drape_ply%RDRAPE(kk,1)
255 xnum_drape(i)%DRAPE_PLY(jj)%RDRAPE(kk,2)=drape_ply%RDRAPE(kk,2)
256 ENDDO
257 DEALLOCATE(drape_ply%IDRAPE, drape_ply%RDRAPE)
258 ENDDO
259 DEALLOCATE(drape(ie)%DRAPE_PLY)
260 DEALLOCATE(drape(ie)%INDX_PLY)
261 ENDDO
262 ELSE
263 DO i=1,numelc
264 index2(i)=permutation%SHELL(i)
265 eadd(i)=1
266 itri(7,i)=i
267 index(i)=i
268 inum(1,i)=ipartc(i)
269 inum(2,i)=isheoff(i)
270 inum(3,i)=ixc(1,i)
271 inum(4,i)=ixc(2,i)
272 inum(5,i)=ixc(3,i)
273 inum(6,i)=ixc(4,i)
274 inum(7,i)=ixc(5,i)
275 inum(8,i)=ixc(6,i)
276 inum(9,i)=ixc(7,i)
277 xnum(i)=thk(i)
278 IF (nsubdom>0) inum_r2r(i) = tag_elcf(i)
279 inum_workc(1,i) = iworksh(1,i)
280 inum_workc(2,i) = iworksh(2,i)
281 inum_workc(3,i) = iworksh(3,i)
282 IF (nperturb > 0) THEN
283 DO ipert = 1, nperturb
284 xnum_rnoise(ipert,i) = rnoise(ipert,i)
285 ENDDO
286 ENDIF
287 angle(i)=sh4ang(i)
288 ENDDO
289 ENDIF
290 IF(abs(isigi)==3.OR.abs(isigi)== 4.OR.abs(isigi)==5)THEN
291 inum_ptshel(1:numelc) = ptshel(1:numelc)
292 ENDIF
293C
294 IF(nadmesh /= 0)THEN
295 DO k=1,ksh4tree
296 DO i=1,numelc
297 istor(k,i)=sh4tree(k,i)
298 ENDDO
299 ENDDO
300 IF(lsh4trim/=0)THEN
301 DO i=1,numelc
302 istor(ksh4tree+1,i)=sh4trim(i)
303 ENDDO
304 END IF
305 END IF
306C
307 DO i=1,numelc
308 xep(i)=cep(i)
309 ENDDO
310C
311 DO i = 1, numelc
312 ii = i
313C
314 IF(nadmesh == 0)THEN
315 itri(1,i)=0
316 ELSE
317C
318C ILEV must have strong weight on 1st key
319 prt = ipartc(ii)
320 iadm= ipart(10,prt)
321 IF(iadm==0)THEN
322C not the same group as if adaptivity.
323 itri(1,i)=0
324 ELSE
325 ilev= sh4tree(3,i)
326 IF(ilev<0)ilev=-ilev-1
327 itri(1,i)=ilev+1
328 END IF
329 END IF
330C
331 mid= ixc(1,ii)
332 pid= ixc(6,ii)
333 mln = nint(pm(19,mid))
334 igtyp= igeo(11,pid)
335 jthe = nint(pm(71,mid))
336 npn = igeo(4,pid)
337 ihbe = nint(geo(171,pid))
338 ithk = nint(geo(35,pid))
339 ipla = nint(geo(39,pid))
340 irep = igeo(6,pid)
341 ishxfem_ply = igeo(19,pid)
342 nfail = 0
343 ifail = 0
344 ixfem = 0
345 IF (igtyp == 11) THEN
346 DO ipt = 1, npn
347 imatly = igeo(100+ipt,pid)
348 nfail = max(nfail,mat_param(imatly)%NFAIL)
349 ENDDO
350 IF(icrack3d > 0)THEN
351C- new multilayer -
352 ixfem = mat_param(mid)%IXFEM
353 ENDIF
354 ELSEIF(igtyp == 17) THEN
355 npn = iworksh(1,ii)
356 isubstack =iworksh(3, ii)
357!! IIGEO = 40 + 5*(ISUBSTACK - 1)
358!! IADI = IGEO(IIGEO + 3,PID)
359!! IPPID = IADI
360 ippid = 2
361 DO ipt = 1, npn
362!! IPIDL = IGEO(IPPID+IPT,PID)
363 ipidl = stack%IGEO(ippid + ipt ,isubstack)
364 imatly = igeo(101,ipidl)
365 nfail = max(nfail,mat_param(imatly)%NFAIL)
366 ENDDO
367 ELSEIF(igtyp == 51 ) THEN
368C---
369C new shell property (variable NPT through each layer)
370C---
371 nb_law58 = 0
372 npn = iworksh(1,ii)
373 isubstack = iworksh(3, ii)
374 ippid = 2
375 DO ipt = 1,npn ! nb of plys
376 ipidl = stack%IGEO(ippid + ipt,isubstack)
377 imatly = igeo(101,ipidl)
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 sorting 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 (PCOMPP + STACK + PLY )
391C---
392 nb_law58 = 0
393 npn = iworksh(1,ii)
394 isubstack = iworksh(3, ii)
395 ippid = 2
396 ipmat = ippid + npn
397 DO ipt = 1,npn ! nb of plys
398 ipidl = 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 sorting 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 nfail = mat_param(mid)%NFAIL
413 IF(icrack3d > 0)THEN
414C - new monolayer -
415 ixfem = mat_param(mid)%IXFEM
416 IF (ixfem == 1) THEN
417 ixfem = 2
418 icrack3d = ixfem
419 ENDIF
420 END IF
421 ENDIF
422 IF (nfail > 0) ifail = 1
423c
424C thermal material expansion
425 iexpan = ipm(218, mid)
426 icsen= igeo(3,pid)
427 IF (icsen > 0) icsen=1
428 IF(npn == 0.AND.(mln == 36.OR.mln == 86))THEN
429 IF(ipla == 0) ipla=1
430 IF(ipla == 2) ipla=0
431C IF(IPLA == 3) IPLA=2
432 ELSEIF(npn == 0.AND.mln == 2)THEN
433 IF(ipla == 2) ipla=0
434 ELSE
435 IF(ipla == 2) ipla=0
436 IF(ipla == 3) ipla=2
437 ENDIF
438 IF(ithk == 2)THEN
439 ithk = 0
440 ELSEIF(mln == 32)THEN
441 ithk = 1
442 ENDIF
443 ipla = iabs(ipla)
444 ithk = iabs(ithk)
445 istrain = nint(geo(11,pid))
446 IF(mln == 19.OR.mln>=25.OR.mln == 15)istrain = 1
447 issn = iabs(nint(geo(3,pid)))
448C sorting on elem delete for rigidbody
449C IRB = 0 : active elem
450C IRB = 1 : inactive elem and optimized for SPMD
451C IRB = 2 : inactive elem but optimized to be active in SPMD
452 irb = isheoff(i)
453C
454C--- Key2
455 jsms = 0
456 IF(isms/=0)THEN
457 IF(idtgrs/=0)THEN
458 IF(tagprt_sms(ipartc(ii))/=0)jsms=1
459 ELSE
460 jsms=1
461 END IF
462 END IF
463C JSMS=MY_SHIFTL(JSMS,0)
464 itri(2,i) = jsms
465C NEXT=MY_SHIFTL(NEXT,1)
466C
467C--- Key3
468C IPLA = MY_SHIFTL(IPLA,0)
469 istrain= my_shiftl(istrain,3)
470 issn = my_shiftl(issn,6)
471 ihbe = my_shiftl(ihbe,9)
472 igtyp = my_shiftl(igtyp,12)
473 mln = my_shiftl(mln,21)
474 itri(3,i)=ipla+istrain+issn+ihbe+igtyp+mln
475C
476C--- Key4
477C
478C IRB = MY_SHIFTL(IRB,0)
479C
480 ishxfem_ply = my_shiftl(ishxfem_ply,10)
481 ifail = my_shiftl(ifail,11)
482 iexpan = my_shiftl(iexpan,14)
483 jthe = my_shiftl(jthe,15)
484 icsen= my_shiftl(icsen,16)
485 npn = my_shiftl(npn,17)
486 irep = my_shiftl(irep,26)
487 ithk = my_shiftl(ithk,30)
488 IF(ixfem > 0) ixfem = my_shiftl(ixfem,9)
489C
490 itri(4,i)=ithk+irep+npn+icsen+jthe+iexpan+irb+ifail+ishxfem_ply
491 . +ixfem
492
493C--- Key5
494C MID=MY_SHIFTL(MID,0)
495 itri(5,i)=mid
496C--- Key6
497C PID=MY_SHIFTL(PID,0)
498 itri(6,i)=pid
499C --- key7 used for type17 iworkc=0 with/out type17 (or type51) PID
500 itri(7,i) = iworksh(2,i)
501C --- key 8---------------------------------
502 itri(8,i )= damp_range_part(ipartc(ii))
503 ENDDO
504C
505 mode=0
506 CALL my_orders( mode, work, itri, index, numelc , 8)
507C
508 DO i=1,numelc
509 ipartc(i) =inum(1,index(i))
510 isheoff(i)=inum(2,index(i))
511 IF (nsubdom>0) tag_elcf(i)=inum_r2r(index(i))
512 thk(i) =xnum(index(i))
513 ENDDO
514
515 DO i=1,numelc
516 cep(i)=xep(index(i))
517 permutation%SHELL(i)=index2(index(i))
518 ENDDO
519
520 DO k=1,7
521 DO i=1,numelc
522 ixc(k,i)=inum(k+2,index(i))
523 ENDDO
524 ENDDO
525 IF(ndrape > 0 .AND. numelc_drape > 0 ) THEN
526 ie = 0
527 DO i=1,numelc
528 iworksh(1,i)= inum_workc(1,index(i))
529 iworksh(2,i)= inum_workc(2,index(i))
530 iworksh(3,i)= inum_workc(3,index(i))
531 IF (nperturb > 0) THEN
532 DO ipert = 1, nperturb
533 rnoise(ipert,i) = xnum_rnoise(ipert,index(i))
534 ENDDO
535 ENDIF
536 sh4ang(i)=angle(index(i))
537 !
538 ie0 = xnum_drapeg%INDX(index(i))
539 drapeg%INDX(i)= 0
540 IF(ie0 == 0) cycle
541 ie = ie + 1
542 npt = xnum_drape(index(i))% NPLY ! number of layer shell
543 drape(ie)%NPLY = npt
544 drapeg%INDX(i)= ie
545 ALLOCATE(drape(ie)%INDX_PLY(npt))
546 drape(ie)%INDX_PLY(1:npt) = xnum_drape(index(i))%INDX_PLY(1:npt)
547 npt = xnum_drape(index(i))%NPLY_DRAPE ! NPT_DRP
548 ALLOCATE(drape(ie)%DRAPE_PLY(npt))
549 drape(ie)%NPLY_DRAPE= npt
550 drape(ie)%THICK = xnum_drape(index(i))%THICK
551 DO jj = 1, npt
552 drape_ply => drape(ie)%DRAPE_PLY(jj)
553 nslice = xnum_drape(index(i))%DRAPE_PLY(jj)%NSLICE
554 drape_ply%NSLICE = nslice
555 drape_ply%IPID = xnum_drape(index(i))%DRAPE_PLY(jj)%IPID
556 ALLOCATE(drape_ply%IDRAPE(nslice,2), drape_ply%RDRAPE(nslice,2))
557 DO kk = 1,nslice
558 drape_ply%IDRAPE(kk,1) = xnum_drape(index(i))%DRAPE_PLY(jj)%IDRAPE(kk,1)
559 drape_ply%IDRAPE(kk,2) = xnum_drape(index(i))%DRAPE_PLY(jj)%IDRAPE(kk,2)
560 drape_ply%RDRAPE(kk,1) = xnum_drape(index(i))%DRAPE_PLY(jj)%RDRAPE(kk,1)
561 drape_ply%RDRAPE(kk,2) = xnum_drape(index(i))%DRAPE_PLY(jj)%RDRAPE(kk,2)
562 ENDDO
563 ENDDO
564 ENDDO
565 ELSE
566 DO i=1,numelc
567 iworksh(1,i)= inum_workc(1,index(i))
568 iworksh(2,i)= inum_workc(2,index(i))
569 iworksh(3,i)= inum_workc(3,index(i))
570 IF (nperturb > 0) THEN
571 DO ipert = 1, nperturb
572 rnoise(ipert,i) = xnum_rnoise(ipert,index(i))
573 ENDDO
574 ENDIF
575 sh4ang(i)=angle(index(i))
576 ENDDO
577 ENDIF
578 IF(abs(isigi)==3.OR.abs(isigi)== 4.OR.abs(isigi)==5)THEN
579 DO i=1,numelc
580 ptshel(i) = inum_ptshel(index(i))
581 ENDDO
582 ENDIF
583C
584 IF(nadmesh /= 0)THEN
585 DO k=1,ksh4tree
586 DO i=1,numelc
587 sh4tree(k,i)=istor(k,index(i))
588 ENDDO
589 ENDDO
590 IF(lsh4trim/=0)THEN
591 DO i=1,numelc
592 sh4trim(i)=istor(ksh4tree+1,index(i))
593 ENDDO
594 END IF
595 END IF
596C
597C INVERSION OF INDEX (IN ITR1)
598C
599 DO i=1,numelc
600 itr1(index(i))=i
601 ENDDO
602C
603C RENUMBERING OF THE TREE
604 IF(nadmesh /= 0)THEN
605 DO i=1,numelc
606 IF(sh4tree(1,i) /= 0)
607 . sh4tree(1,i)=itr1(sh4tree(1,i))
608 IF(sh4tree(2,i) /= 0)
609 . sh4tree(2,i)=itr1(sh4tree(2,i))
610 ENDDO
611 END IF
612C
613C RENUMBERING FOR SURFACES
614C
615 DO i=1,nsurf
616 nn=igrsurf(i)%NSEG
617 DO j=1,nn
618 IF(igrsurf(i)%ELTYP(j) == 3)
619 . igrsurf(i)%ELEM(j) = itr1(igrsurf(i)%ELEM(j))
620 ENDDO
621 ENDDO
622C RENUMBERING FOR shell in Accel (gauge)
623C
624 DO i=1,nbgauge
625 n1 = lgauge(1,i)
626 IF(n1 <= 0) THEN
627 n1=-lgauge(3,i)
628 IF(n1 > 0) lgauge(3,i)=-itr1(n1)
629 ENDIF
630 ENDDO
631C
632C RENUMBERING FOR SHELL GROUPS
633C
634 DO i=1,ngrshel
635 nn=igrsh4n(i)%NENTITY
636 DO j=1,nn
637 igrsh4n(i)%ENTITY(j) = itr1(igrsh4n(i)%ENTITY(j))
638 ENDDO
639 ENDDO
640C
641C renumbering INVERSE CONNECTIVITY
642C
643 DO i=1,4*numelc
644 IF (nod2elc(i) /= 0) nod2elc(i)=itr1(nod2elc(i))
645 END DO
646C
647C--------------------------------------------------------------
648C DETERMINATION OF SUPER_GROUPS
649C--------------------------------------------------------------
650 nd=1
651 DO i=2,numelc
652 ii0=itri(1,index(i))
653 jj0=itri(1,index(i-1))
654 ii =itri(2,index(i))
655 jj =itri(2,index(i-1))
656 ii1=itri(3,index(i))
657 jj1=itri(3,index(i-1))
658 ii2=itri(4,index(i))
659 jj2=itri(4,index(i-1))
660 ii3=itri(5,index(i))
661 jj3=itri(5,index(i-1))
662 ii4=itri(6,index(i))
663 jj4=itri(6,index(i-1))
664C for stack/ply pid
665 ii5=itri(7,index(i))
666 jj5=itri(7,index(i-1))
667C damp freq range
668 ii6=itri(8,index(i))
669 jj6=itri(8,index(i-1))
670 IF (ii0/=jj0 .or.
671 * ii/=jj .or.
672 * ii1/=jj1 .or.
673 * ii2/=jj2.OR.ii3 /= jj3.OR.ii4 /= jj4.OR.ii5 /= jj5 .or.
674 * ii6 /= jj6) THEN
675 nd=nd+1
676 eadd(nd)=i
677 ENDIF
678 ENDDO
679 eadd(nd+1) = numelc+1
680C-----------
681c
682 IF (nperturb > 0) THEN
683 IF (ALLOCATED(xnum_rnoise)) DEALLOCATE(xnum_rnoise)
684 ENDIF
685c
686 DEALLOCATE(index2)
687 DEALLOCATE( istor )
688 IF(ndrape > 0 .AND. numelc_drape > 0) THEN
689 DO i =1, numelc
690 ie = xnum_drapeg%INDX(i)
691 IF(ie == 0) cycle
692 npt_drp = xnum_drape(i)%NPLY_DRAPE
693 DO j = 1,npt_drp
694 DEALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%RDRAPE)
695 DEALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%IDRAPE)
696 ENDDO
697 DEALLOCATE(xnum_drape(i)%DRAPE_PLY,xnum_drape(i)%INDX_PLY)
698 ENDDO
699 DEALLOCATE( xnum_drape ,xnum_drapeg%INDX)
700 ELSE
701 DEALLOCATE( xnum_drape )
702 ENDIF
703 IF(ALLOCATED(inum_ptshel))DEALLOCATE(inum_ptshel)
704
705 DEALLOCATE(angle,inum_workc)
706 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:662
message_mod
Definition message_mod.F:1249
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:72
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:889