OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
stackgroup.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "scr17_c.inc"
#include "com04_c.inc"
#include "units_c.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine stackgroup (igrsh3n, igrsh4n, ixc, ixtg, igeo, geo, iworksh, thk, stack, ipm, igeo_stack, geo_stack, stack_info, numgeo_stack, nprop_stack)

Function/Subroutine Documentation

◆ stackgroup()

subroutine stackgroup ( type (group_), dimension(ngrsh3n) igrsh3n,
type (group_), dimension(ngrshel) igrsh4n,
integer, dimension(nixc,*) ixc,
integer, dimension(nixtg,*) ixtg,
integer, dimension(npropgi,*) igeo,
geo,
integer, dimension(3,*) iworksh,
thk,
type (stack_ply) stack,
integer, dimension(npropmi,*) ipm,
integer, dimension(npropgi,*) igeo_stack,
geo_stack,
type(stack_info_ ), dimension (nprop_stack), intent(inout) stack_info,
integer, dimension(*) numgeo_stack,
integer nprop_stack )

Definition at line 34 of file stackgroup.F.

39C-----------------------------------------------
40C M o d u l e s
41C-----------------------------------------------
42 USE my_alloc_mod
43 USE submodel_mod
44 USE stack_mod
45 USE message_mod
46 USE groupdef_mod
47 USE names_and_titles_mod , ONLY : nchartitle
48C-----------------------------------------------
49C I m p l i c i t T y p e s
50C-----------------------------------------------
51#include "implicit_f.inc"
52C-----------------------------------------------
53C C o m m o n B l o c k s
54C-----------------------------------------------
55#include "com01_c.inc"
56#include "scr17_c.inc"
57#include "com04_c.inc"
58#include "units_c.inc"
59#include "param_c.inc"
60C-----------------------------------------------
61C D u m m y A r g u m e n t s
62C-----------------------------------------------
63 INTEGER IXC(NIXC,*),
64 . IXTG(NIXTG,*),IGEO(NPROPGI,*),IWORKSH(3,*),IPM(NPROPMI,*),
65 . IGEO_STACK(NPROPGI,*),NUMGEO_STACK(*),
66 . NPROP_STACK
67 my_real
68 . geo(npropg,*),thk(*),geo_stack(npropg,*)
69C-----------------------------------------------
70 TYPE (GROUP_) , DIMENSION(NGRSH3N) :: IGRSH3N
71 TYPE (GROUP_) , DIMENSION(NGRSHEL) :: IGRSH4N
72 TYPE(STACK_INFO_ ),INTENT(INOUT), DIMENSION (NPROP_STACK):: STACK_INFO
73C-----------------------------------------------
74C L o c a l V a r i a b l e s
75C-----------------------------------------------
76 INTEGER I,J,II,NSTACK,NPLY,IGTYP,ID,JD,IDPLY,NEL,
77 . IAD,ITY,IDSHEL,PID,IS,IDS,NSH,MODE,NS,JJ,NGEO_STACK,
78 . IGRTYP,N1,IPMAT,IPANG,IPTHK,IIGEO,NSS,IPPOS,NPT,IIS,NP,
79 . JJPID,JSTACK,JPID,ITG,IPMAT_IPLY,ISH3N,J4N,J3N,IPOS,
80 . MAT_LY,NLAY,NPTT,IPIDL,IT,ILAY,IPTHK_NPTT,IPPOS_NPTT,
81 . IINT,IPID_LY,IPDIR ,NS_STACK0 ,NPT_STACK0,IS0,JS,PIDS,IP,
82 . II1,II2,JJ1,JJ2,II3,II4,II5,JJ3,JJ4,JJ5, NKEY,IREST,IBIT,IKEY,
83 . NBIT
84 INTEGER :: IJK
85 INTEGER WORK(70000),
86 . IPTPLY(1000),NBFI,IPPID,ITAG(1000),
87 . NGL,IPID_1,NUMS,IPWEIGHT,IPTHKLY,NSHQ4,NSHT3
88 INTEGER, DIMENSION(:), ALLOCATABLE :: IPIDPLY
89 INTEGER, DIMENSION(:), ALLOCATABLE :: IDGR4N,IDGR3N
90 INTEGER, DIMENSION(:), ALLOCATABLE :: ISUBSTACK
91 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX_SH4,INDEX_T3
92 INTEGER, DIMENSION(:), ALLOCATABLE :: NFIRST,NLAST
93 INTEGER, DIMENSION(:), ALLOCATABLE :: INDX_SH,PID_SH
94 my_real, DIMENSION(:,:), ALLOCATABLE :: geo0
95
96 my_real
97 . thickt,zshift,tmin,tmax,dt,thk_ly,pos_ly,thk_it(100),
98 . pos_it(100),pos_nptt,thk_nptt,pos_0,thinning,pos
99
100 INTEGER, DIMENSION(:,:), ALLOCATABLE :: ITRI
101 INTEGER, DIMENSION (:) ,ALLOCATABLE ::INDX,
102 . ICSH_STACK,IDSTACK
103 INTEGER , DIMENSION(:,:), ALLOCATABLE :: ACTIV_PLY
104 TYPE (STACK_PLY) :: STACK, IWORKS
105
106 CHARACTER(LEN=NCHARTITLE) :: TITR,TITR1
107C-----------------------------------------------
108 my_real
109 . a_gauss(9,9),w_gauss(9,9)
110C-----------------------------------------------
111 DATA a_gauss /
112 1 0. ,0. ,0. ,
113 1 0. ,0. ,0. ,
114 1 0. ,0. ,0. ,
115 2 -.577350269189626,0.577350269189626,0. ,
116 2 0. ,0. ,0. ,
117 2 0. ,0. ,0. ,
118 3 -.774596669241483,0. ,0.774596669241483,
119 3 0. ,0. ,0. ,
120 3 0. ,0. ,0. ,
121 4 -.861136311594053,-.339981043584856,0.339981043584856,
122 4 0.861136311594053,0. ,0. ,
123 4 0. ,0. ,0. ,
124 5 -.906179845938664,-.538469310105683,0. ,
125 5 0.538469310105683,0.906179845938664,0. ,
126 5 0. ,0. ,0. ,
127 6 -.932469514203152,-.661209386466265,-.238619186083197,
128 6 0.238619186083197,0.661209386466265,0.932469514203152,
129 6 0. ,0. ,0. ,
130 7 -.949107912342759,-.741531185599394,-.405845151377397,
131 7 0. ,0.405845151377397,0.741531185599394,
132 7 0.949107912342759,0. ,0. ,
133 8 -.960289856497536,-.796666477413627,-.525532409916329,
134 8 -.183434642495650,0.183434642495650,0.525532409916329,
135 8 0.796666477413627,0.960289856497536,0. ,
136 9 -.968160239507626,-.836031107326636,-.613371432700590,
137 9 -.324253423403809,0. ,0.324253423403809,
138 9 0.613371432700590,0.836031107326636,0.968160239507626/
139 DATA w_gauss /
140 1 2. ,0. ,0. ,
141 1 0. ,0. ,0. ,
142 1 0. ,0. ,0. ,
143 2 1. ,1. ,0. ,
144 2 0. ,0. ,0. ,
145 2 0. ,0. ,0. ,
146 3 0.555555555555556,0.888888888888889,0.555555555555556,
147 3 0. ,0. ,0. ,
148 3 0. ,0. ,0. ,
149 4 0.347854845137454,0.652145154862546,0.652145154862546,
150 4 0.347854845137454,0. ,0. ,
151 4 0. ,0. ,0. ,
152 5 0.236926885056189,0.478628670499366,0.568888888888889,
153 5 0.478628670499366,0.236926885056189,0. ,
154 5 0. ,0. ,0. ,
155 6 0.171324492379170,0.360761573048139,0.467913934572691,
156 6 0.467913934572691,0.360761573048139,0.171324492379170,
157 6 0. ,0. ,0. ,
158 7 0.129484966168870,0.279705391489277,0.381830050505119,
159 7 0.417959183673469,0.381830050505119,0.279705391489277,
160 7 0.129484966168870,0. ,0. ,
161 8 0.101228536290376,0.222381034453374,0.313706645877887,
162 8 0.362683783378362,0.362683783378362,0.313706645877887,
163 8 0.222381034453374,0.101228536290376,0. ,
164 9 0.081274388361574,0.180648160694857,0.260610696402935,
165 9 0.312347077040003,0.330239355001260,0.312347077040003,
166 9 0.260610696402935,0.180648160694857,0.081274388361574/
167C----------------------------f-------------------
168c=======================================================================
169c define temporary work structure
170c=======================================================================
171c
172 TYPE tmp_work
173 integer, DIMENSION(:) , POINTER :: IPT
174 END TYPE tmp_work
175 TYPE(TMP_WORK) , DIMENSION(:), POINTER :: IWORK_T
176C=======================================================================
177C For Shell
178C-----------------------------------------------
179 ns_stack = 0
180 npt_stack = 0
181 CALL my_alloc(geo0,1000,numgeo)
182 ALLOCATE(iwork_t(numelc+numeltg))
183 ALLOCATE(ipidply(numgeo+numply))
184 ALLOCATE(idgr4n(numgeo+numply))
185 ALLOCATE(idgr3n(numgeo+numply))
186 ALLOCATE(isubstack(numgeo+numstack))
187 ALLOCATE(index_sh4(numelc))
188 ALLOCATE(index_t3(numeltg))
189 ALLOCATE(nfirst(numelc+numeltg))
190 ALLOCATE(nlast(numelc+numeltg))
191 ALLOCATE(indx_sh(numelc+numeltg))
192 ALLOCATE(pid_sh(numelc+numeltg))
193C
194 IF(ipart_stack > 0) THEN
195 nply = 0
196 nstack = 0
197C
198 DO i = 1, numgeo
199!! ISUBSTACK(I)= 0
200 igtyp=igeo(11,i)
201 nstack = igeo(42,i) ! number of stack where ply is attached
202 IF (igtyp == 19 .AND. nstack > 0) THEN
203 nply = nply+1
204 ipidply(nply) = i
205 idgr4n(nply) = igeo(40,i) ! groupe shell 4N id
206 idgr3n(nply) = igeo(41,i) ! groupe shell 3N id
207 ENDIF
208 ENDDO
209
210C transformation d'id groupe
211 DO 10 i=1,nply
212C shell 4N id group
213 id = idgr4n(i)
214 IF(id > 0) THEN
215 DO j=1,ngrshel
216 jd = igrsh4n(j)%ID
217 IF(jd == id)THEN
218 idgr4n(i) = j
219 GOTO 20
220 ENDIF
221 ENDDO
222 ENDIF ! ID > 0
223C !GR T3
224 20 CONTINUE
225 id = idgr3n(i)
226 IF(id > 0) THEN
227 DO j=1,ngrsh3n
228 jd = igrsh3n(j)%ID
229 IF(jd == id)THEN
230 idgr3n(i) = j
231 GOTO 10
232 ENDIF
233 ENDDO
234 ENDIF ! ID > 0
23510 CONTINUE
236C
237 nbit = bit_size(nply)
238 irest = mod(nply,nbit)
239 nkey = nply / nbit
240 IF(irest > 0) nkey = nkey + 1
241 !
242 ALLOCATE( activ_ply(numelc+numeltg,nkey))
243 IF(numelc + numeltg > 0)activ_ply = 0
244C tag o f ply element
245 nshq4 = 0
246 DO i=1,numelc
247 pid = ixc(6,i)
248 igtyp = igeo(11,pid)
249 IF(igtyp == 17 .OR. igtyp == 51)THEN
250 nshq4 = nshq4 + 1
251 index_sh4(nshq4) = i
252 ENDIF
253 ENDDO
254C
255 nsht3 = 0
256 DO i=1,numeltg
257 pid = ixtg(5,i)
258 igtyp = igeo(11,pid)
259 IF(igtyp == 17 .OR. igtyp == 51)THEN
260 nsht3 = nsht3 + 1
261 index_t3(nsht3) = i
262 ENDIF
263 ENDDO
264C number of ply belong to the element
265 DO i=1,nply
266 j = idgr4n(i)
267 j4n = j
268 idply = ipidply(i)
269 nstack = igeo(42, idply)
270 IF(j > 0 .AND. nstack > 0 ) THEN
271 nel = igrsh4n(j)%NENTITY
272C eleme nt type Q4 or T3
273 ity = igrsh4n(j)%GRTYPE
274 DO 100 ii = 1,nel
275 idshel = igrsh4n(j)%ENTITY(ii)
276 pid = ixc(6,idshel)
277 igtyp = igeo(11,pid)
278 IF(igtyp == 17 .OR. igtyp == 51) THEN
279 DO is = 1,nstack
280 ids = igeo(200 + is, idply)
281 IF (ids == pid) THEN
282 iworksh(1,idshel) = iworksh(1,idshel) + 1
283 GOTO 100
284 ENDIF
285 ENDDO
286 ENDIF
287 100 CONTINUE
288 ENDIF
289 j = idgr3n(i)
290 j3n = j
291 IF(j > 0 .AND. nstack > 0 ) THEN
292 nel = igrsh3n(j)%NENTITY
293C eleme nt type T3
294 ity = igrsh3n(j)%GRTYPE
295 DO 200 ii = 1,nel
296! c a v erifier l'id du triangle
297 ish3n = igrsh3n(j)%ENTITY(ii)
298 pid = ixtg(5,ish3n)
299 igtyp = igeo(11,pid)
300 IF(igtyp == 17 .OR. igtyp == 51) THEN
301 DO is = 1,nstack
302 ids = igeo(200 + is,idply)
303 IF (ids == pid) THEN
304 idshel = ish3n + numelc
305 iworksh(1,idshel) = iworksh(1,idshel ) + 1
306 GOTO 200
307 ENDIF
308 ENDDO
309 ENDIF
310 200 CONTINUE
311 ENDIF
312 IF(j4n == 0 .AND. j3n == 0 .AND. nstack > 0 ) THEN
313 DO 300 ijk = 1,nshq4
314 ii = index_sh4(ijk)
315 pid = ixc(6,ii)
316 igtyp = igeo(11,pid)
317 IF(igtyp == 17 .OR. igtyp == 51) THEN
318 DO is = 1,nstack
319 ids = igeo(200 + is,idply)
320 IF (ids == pid) THEN
321 iworksh(1,ii) = iworksh(1,ii) + 1
322 GOTO 300
323 ENDIF
324 ENDDO
325 ENDIF
326 300 CONTINUE
327 DO 400 ijk = 1,nsht3
328 ii = index_t3(ijk)
329 pid = ixtg(5,ii)
330 igtyp = igeo(11,pid)
331 itg = numelc + ii
332 IF(igtyp == 17 .OR. igtyp == 51) THEN
333 DO is = 1,nstack
334 ids = igeo(200 + is,idply)
335 IF (ids == pid) THEN
336 iworksh(1,itg) = iworksh(1,itg) + 1
337 GOTO 400
338 ENDIF
339 ENDDO
340 ENDIF
341 400 CONTINUE
342 ENDIF
343 ENDDO ! iply
344C #####################################################"
345 DO i=1,numelc
346 pid = ixc(6,i)
347 igtyp = igeo(11,pid)
348 npt = iworksh(1,i)
349 IF(igtyp == 17 .OR. igtyp == 51 .AND. npt > 0) THEN
350 NULLIFY(iwork_t(i)%IPT)
351 ALLOCATE(iwork_t(i)%IPT(npt))
352 iwork_t(i)%IPT = 0
353 iworksh(1,i) = 0
354 ENDIF
355 ENDDO
356 DO i=1, numeltg
357 pid = ixtg(5,i)
358 igtyp = igeo(11,pid)
359 ii = numelc + i
360 npt = iworksh(1,ii)
361 IF((igtyp == 17 .OR. igtyp == 51) .AND. npt > 0) THEN
362 NULLIFY(iwork_t(ii)%IPT)
363 ALLOCATE(iwork_t(ii)%IPT(npt))
364 iwork_t(ii)%IPT = 0
365 iworksh(1,ii) = 0
366 ENDIF
367 ENDDO
368!!
369! ply to element
370!!
371 DO i=1,nply
372 j = idgr4n(i)
373 j4n = j
374 idply = ipidply(i)
375 nstack = igeo(42, idply)
376 ikey = i / nbit ! 32 or 64 bits
377 IF(mod(i,nbit) > 0 ) ikey = ikey + 1
378 ikey = min(ikey, nkey)
379 ibit = i - (ikey - 1)*nbit ! Bit corresponding to PLy
380 ! First key Ply form 1 to NBIT
381 ! 2dn NBIT - 2*NBIT
382 ! .... etc
383 IF(j > 0 .AND. nstack > 0 ) THEN
384 nel = igrsh4n(j)%NENTITY
385C eleme nt type Q4 or T3
386 ity = igrsh4n(j)%GRTYPE
387 DO 101 ii = 1,nel
388 idshel = igrsh4n(j)%ENTITY(ii)
389 pid = ixc(6,idshel)
390 igtyp = igeo(11,pid)
391 IF(igtyp == 17 .OR. igtyp == 51) THEN
392 DO is = 1,nstack
393 ids = igeo(200 + is, idply)
394 IF (ids == pid) THEN
395 iworksh(1,idshel) = iworksh(1,idshel) + 1
396 npt = iworksh(1,idshel)
397 iwork_t(idshel)%IPT(npt) = idply
398 activ_ply(idshel,ikey) = ibset(activ_ply(idshel,ikey),ibit)
399 GOTO 101
400 ENDIF
401 ENDDO
402 ENDIF
403 101 CONTINUE
404 ENDIF
405 j = idgr3n(i)
406 j3n = j
407 IF(j > 0 .AND. nstack > 0 ) THEN
408 nel = igrsh3n(j)%NENTITY
409C eleme nt type T3
410 ity = igrsh3n(j)%GRTYPE
411 DO 202 ii = 1,nel
412 ish3n = igrsh3n(j)%ENTITY(ii)
413 pid = ixtg(5,ish3n)
414 igtyp = igeo(11,pid)
415 IF(igtyp == 17 .OR. igtyp == 51) THEN
416 DO is = 1,nstack
417 ids = igeo(200 + is,idply)
418 IF (ids == pid) THEN
419 idshel = ish3n + numelc
420 iworksh(1,idshel) = iworksh(1,idshel ) + 1
421 npt = iworksh(1,idshel)
422 iwork_t(idshel)%IPT(npt) = idply
423 activ_ply(idshel,ikey) = ibset(activ_ply(idshel,ikey),ibit)
424 GOTO 202
425 ENDIF
426 ENDDO
427 ENDIF
428 202 CONTINUE
429 ENDIF
430 IF(j4n == 0 .AND. j3n == 0 .AND. nstack > 0 ) THEN
431C
432 DO 333 ijk = 1,nshq4
433 ii = index_sh4(ijk)
434 pid = ixc(6,ii)
435 igtyp = igeo(11,pid)
436 IF(igtyp == 17 .OR. igtyp == 51) THEN
437 DO is = 1,nstack
438 ids = igeo(200 + is,idply)
439 IF (ids == pid) THEN
440 iworksh(1,ii) = iworksh(1,ii) + 1
441 npt = iworksh(1,ii)
442 iwork_t(ii)%IPT(npt) = idply
443 activ_ply(ii,ikey) = ibset(activ_ply(ii,ikey),ibit)
444 GOTO 333
445 ENDIF
446 ENDDO
447 ENDIF
448 333 CONTINUE
449 DO 404 ijk = 1,nsht3
450 ii = index_t3(ijk)
451 pid = ixtg(5,ii)
452 igtyp = igeo(11,pid)
453 itg = numelc + ii
454 IF(igtyp == 17 .OR. igtyp == 51) THEN
455 DO is = 1,nstack
456 ids = igeo(200 + is,idply)
457 IF (ids == pid) THEN
458 iworksh(1,itg) = iworksh(1,itg) + 1
459 npt = iworksh(1,itg)
460 iwork_t(itg)%IPT(npt) = idply
461 activ_ply(itg,ikey) = ibset(activ_ply(itg,ikey),ibit)
462 GOTO 404
463 ENDIF
464 ENDDO
465 ENDIF
466 404 CONTINUE
467 ENDIF
468C
469 ENDDO ! iply
470!!###########################################################"
471C
472C mise en groupe des stack
473C
474 nsh = 0
475 indx_sh = 0
476 pid_sh = 0
477C
478 DO i=1,numelc
479 pid = ixc(6,i)
480 igtyp = igeo(11,pid)
481 IF(igtyp == 17 .OR. igtyp == 51)THEN
482 nsh = nsh + 1
483 indx_sh(nsh) = i
484 pid_sh(nsh) = pid
485 ENDIF
486 ENDDO
487C
488 DO i=1,numeltg
489 pid = ixtg(5,i)
490 igtyp = igeo(11,pid)
491 IF(igtyp == 17 .OR. igtyp == 51)THEN
492 nsh = nsh + 1
493 indx_sh(nsh) = i+numelc
494 pid_sh(nsh) = pid
495 ENDIF
496 ENDDO
497C
498C
499C
500 ALLOCATE(indx(2*nsh),itri(2+nkey,nsh))
501 indx = 0
502 itri = 0
503 !!
504 DO i = 1,nsh
505 indx(i) = i
506 ii = indx_sh(i)
507 itri(1,i) = pid_sh(i)
508 itri(2,i) = iworksh(1,ii)
509 DO j=1,nkey
510 itri(2+j,i) = activ_ply(ii,j)
511 ENDDO
512 ENDDO
513C
514 mode = 0
515C
516 nkey = nkey + 2
517 CALL my_orders(mode, work, itri, indx, nsh , nkey)
518 ns = 1
519 nfirst(1) = 1
520 nlast(1) = 1
521 DO i=2,nsh
522 DO ikey = 1, nkey
523 ii = itri(ikey,indx(i))
524 jj = itri(ikey,indx(i-1))
525 IF(ii /= jj) THEN
526 ns = ns + 1
527 nfirst(ns) = i
528 nlast(ns) = nfirst(ns)
529 EXIT
530 ELSEIF(ikey == nkey) THEN
531 nlast(ns) = nlast(ns) + 1
532 ENDIF
533 ENDDO
534 ENDDO
535C
536C substack
537C
538 npt_stack = 0
539 ns_stack = ns
540C
541 DO is = 1,ns
542 id = nfirst(is)
543 i = indx(id)
544 ii = indx_sh(i)
545 npt = iworksh(1,ii)
546 npt_stack = max(npt_stack,npt)
547 ENDDO
548C allocation
549 ALLOCATE(iworks%IGEO(3*npt_stack+2,ns_stack))
550 ALLOCATE(iworks%GEO(6*npt_stack+1,ns_stack))
551C
552 iworks%IGEO = 0
553 iworks%GEO = zero
554C
555 DO is = 1,ns
556 ngeo_stack = numgeo + is
557 id = nfirst(is)
558C
559 i = indx(id)
560 ii = indx_sh(i)
561 pid = pid_sh(i)
562!! MAIN_PID(1,IS) = PID_SH(II) ! pid
563!! MAIN_PID(2,IS) = IWORKSH(1,II) ! npt
564 npt = iworksh(1,ii)
565!C ISUBSTACK(PID) = ISUBSTACK(PID) + 1
566 iis = ii
567C
568 DO i= nfirst(is) , nlast(is)
569 id = indx(i)
570 ii = indx_sh(id)
571 iworksh(2,ii) = ngeo_stack
572 iworksh(3,ii) = is ! compter for all stack
573!! IWORKSH(3,II) = ISUBSTACK(PID) ! computer by stack ! old conception
574 ENDDO
575C Geo and Igeo organisation
576!! I = NFIRST(IS)
577!! II = INDX_Q4(I)
578!! PID = PID_Q4(II)
579!! NSS = ISUBSTACK(PID) ! number of substack in each Pid
580C geometric property for each sub stack
581!!! IGEO( ,PID) = NGEO_STACK
582 n1 = int(geo(6,pid))
583 np = 0
584 nums = numgeo_stack(pid)
585 DO 700 j = 1,n1
586!! JPID = IGEO(100 + J, PID)
587 jpid = stack_info(nums)%PID(j)
588 IF(np <= npt) THEN
589 DO jj = 1,npt
590 jjpid = iwork_t(iis)%IPT(jj)
591 IF(jjpid == jpid) THEN
592 np = np + 1
593 iptply(np) = j
594 GOTO 700
595 ENDIF
596 ENDDO
597 ENDIF
598 700 CONTINUE
599C geometric property
600 iworks%IGEO(1,is) = npt
601 iworks%IGEO(2,is) = pid
602 ippid = 2
603 ipmat = ippid + npt
604 ipmat_iply = ipmat + npt
605 ipang = 1
606 ipthk = ipang + npt
607 ippos = ipthk + npt
608 ipdir = ippos + npt
609 ipthkly = ipdir + npt
610 ipweight = ipthkly + npt
611 nums= numgeo_stack(pid)
612 DO j=1,npt
613 jstack = iptply(j)
614 iworks%IGEO(ippid + j ,is) = stack_info(nums)%PID(jstack)
615 iworks%IGEO(ipmat + j ,is) = stack_info(nums)%MID(jstack)
616 iworks%IGEO(ipmat_iply + j ,is) = stack_info(nums)%MID_IP(jstack)
617 iworks%GEO(ipang + j ,is) = stack_info(nums)%ANG(jstack)
618 iworks%GEO(ipthk + j ,is) = stack_info(nums)%THK(jstack)
619 iworks%GEO(ippos + j ,is) = stack_info(nums)%POS(jstack)
620 iworks%GEO(ipdir + j ,is) = stack_info(nums)%DIR(jstack)
621 iworks%GEO(ipthkly + j ,is) = stack_info(nums)%THKLY(jstack)
622 iworks%GEO(ipweight + j ,is) = stack_info(nums)%WEIGHT(jstack)
623 ENDDO
624C
625C to be clarified later IPOS > 0
626 ipos = igeo(99,pid)
627 zshift = geo(199,pid)
628 IF(ipos == 1)THEN
629 tmin = ep20
630 tmax = -ep20
631 DO j=1,npt
632 dt = half*iworks%GEO(ipthk + j ,is)
633 tmin = min(tmin,iworks%GEO(ippos + j ,is)-dt)
634 tmax = max(tmax,iworks%GEO(ippos + j ,is)+dt)
635 ENDDO
636 thickt = tmax - tmin
637 DO j=1,npt
638 iworks%GEO(ipthk+j,is)=iworks%GEO(ipthk+j,is)/max(thickt,em20)
639 iworks%GEO(ippos+j,is)=iworks%GEO(ippos+j,is)/max(thickt,em20)
640 ENDDO
641
642 ELSE
643 thickt = zero
644 DO j=1,npt
645 thickt = thickt + iworks%GEO(ipthk+j,is)
646 ENDDO
647 DO j=1,npt
648 iworks%GEO(ipthk+j,is) =
649 . iworks%GEO(ipthk+j,is)/max(thickt,em20)
650 ENDDO
651C
652 IF(ipos == 2 )zshift = zshift /max(thickt,em20)
653C--- calcul automatique de position des couches
654 iworks%GEO(ippos+1,is) = zshift + half*iworks%GEO(ipthk+1,is)
655 DO j=2,npt
656 iworks%GEO(ippos+j,is) = iworks%GEO(ippos+j-1,is)
657 . + half*(iworks%GEO(ipthk+j,is)+iworks%GEO(ipthk+j-1,is))
658 ENDDO
659C
660 ENDIF ! IPOS =0,1,2,3,4
661C calcul du thk by shell
662 iworks%GEO(1,is) = thickt
663C============================================================================
664C---
665C update the shell thickness without drape
666C---
667 DO i= nfirst(is) , nlast(is)
668 id = indx(i)
669 ii = indx_sh(id)
670 IF (thk(ii) == zero) thk(ii) = thickt
671 ENDDO
672C============================================================================
673cc IF (IGTYP == 51) THEN
674cc NLAY = MAX(1,NPT)
675C---
676C - various nb of integration points through each layer
677C---
678C
679C--- TEST de calcul automatique de position des NPTT dans les couches
680C
681cc IPPID = 2
682cc DO ILAY=1,NLAY
683cc!! IPIDL = IGEO(IPPID + ILAY,PID)
684cc THK_LY = IWORKS%GEO(IPTHK + ILAY,IS) ! layer thickness ratio
685cc POS_LY = IWORKS%GEO(IPPOS + ILAY,IS) ! layer position ratio
686cc IPID_LY = IWORKS%IGEO(IPPID + ILAY,IS) ! layer PID (igtyp = 19)
687cc MAT_LY = IWORKS%IGEO(IPMAT + ILAY,IS) ! layer material
688cccc IINT = IGEO(47,IPID_LY)
689cc IINT = IGEO(47,PID)
690cc NPTT = IGEO(4,IPID_LY)
691cc THICKT = IWORKS%GEO(1,IS)
692cc IF (IINT == 1) THEN ! uniform distribution - by default
693cc DO IT=1,NPTT
694cc THK_IT(IT) = THK_LY/NPTT ! equally distribution of NPTT through layer
695cc ENDDO
696cc POS_0 = POS_LY - HALF*THK_LY
697cc IF (NLAY == 1) POS_0 = - HALF !! special case
698cc POS_IT(1) = POS_0 + HALF*THK_IT(1)
699cccc POS_IT(1) = POS_LY - HALF*THK_LY + HALF*THK_IT(1)
700cc DO IT=2,NPTT
701cc POS_IT(IT) = POS_IT(IT-1) + HALF*(THK_IT(IT) + THK_IT(IT-1))
702cc ENDDO
703cc ELSEIF (IINT == 2) THEN ! Gauss distribution
704cc DO IT=1,NPTT
705cc THK_IT(IT) = HALF*THK_LY*W_GAUSS(IT,NPTT)
706cc POS_IT(IT) = POS_LY + HALF*THK_LY*A_GAUSS(IT,NPTT)
707cc ENDDO
708cc ENDIF
709cc ENDDO ! DO ILAY=1,NLAY
710cc ENDIF ! IF (IGTYP == 51) THEN
711C============================================================================
712 ENDDO ! DO IS = 1,NS
713C
714 DEALLOCATE(indx,itri,activ_ply)
715 ENDIF
716C
717C pccommp part
718C
719C---
720 ns_stack0 = ns_stack
721 npt_stack0 = npt_stack
722C
723 IF(ipart_pcompp > 0) THEN
724 nply = 0
725 nstack = 0
726 DO i = 1, numply
727!! Only one stack by ply
728 ids = igeo_stack(42,numstack + i)
729 IF (ids > 0) THEN
730 nply = nply+1
731 ipidply(nply) = numstack + i
732 idgr4n(nply) = igeo_stack(40,numstack + i) ! groupe shell 4N id
733 idgr3n(nply) = igeo_stack(41,numstack + i) ! groupe shell 3N id
734 ENDIF
735 ENDDO
736C
737C transformation d'id groupe
738C
739 DO 11 i=1,nply
740C shell 4N id group
741 id = idgr4n(i)
742 IF(id > 0) THEN
743 DO j=1,ngrshel
744 jd = igrsh4n(j)%ID
745 IF(jd == id)THEN
746 idgr4n(i) = j
747 GOTO 22
748 ENDIF
749 ENDDO
750 ENDIF ! ID > 0
751C !GR T3
752 22 CONTINUE
753 id = idgr3n(i)
754 IF(id > 0) THEN
755 DO j=1,ngrsh3n
756 jd = igrsh3n(j)%ID
757 IF(jd == id)THEN
758 idgr3n(i) = j
759 GOTO 11
760 ENDIF
761 ENDDO
762 ENDIF ! ID > 0
76311 CONTINUE
764
765 ! Size of NPLY '(32 or 64)
766 nbit = bit_size(nply)
767 irest = mod(nply,nbit)
768 nkey = nply / nbit
769 IF(irest > 0) nkey = nkey + 1
770 !
771 ALLOCATE( activ_ply(numelc+numeltg,nkey))
772 IF(numelc + numeltg > 0)activ_ply = 0
773C
774C tag of ply element
775 ALLOCATE(icsh_stack(numelc + numeltg) )
776 IF(numelc + numeltg > 0)icsh_stack = 0
777C compteur by element
778 DO i= 1,nply
779 j = idgr4n(i)
780 j4n = j
781 idply = ipidply(i)
782 ids = igeo_stack(42, idply)
783 IF(j > 0 .AND. ids > 0 ) THEN
784 nel = igrsh4n(j)%NENTITY
785C element type Q4
786!! ITY = IGRN(4,J)
787 ity = igrsh4n(j)%GRTYPE
788 DO 111 ii = 1,nel
789 idshel = igrsh4n(j)%ENTITY(ii)
790 pid = ixc(6,idshel)
791 igtyp = igeo(11,pid)
792 IF(igtyp == 52) THEN
793 IF(icsh_stack(idshel) == 0) THEN
794 iworksh(1,idshel) = iworksh(1,idshel) + 1
795 icsh_stack(idshel) = ids
796 ELSEIF(icsh_stack(idshel) == ids) THEN
797 iworksh(1,idshel) = iworksh(1,idshel) + 1
798 ELSE
799C message d'erreur
800 ipid_1=igeo_stack(1,icsh_stack(idshel))
801 ngl =ixc(nixc,idshel)
802 CALL ancmsg(msgid=1152,
803 . msgtype=msgerror,
804 . anmode=aninfo_blind_1,
805 . i1=ngl,
806!! . C2='SHELL',
807 . i2= igeo_stack(1,ids),
808 . i3= igeo_stack(1,ipid_1) )
809 ENDIF
810 ENDIF
811 111 CONTINUE
812 ENDIF
813 j = idgr3n(i)
814 j3n = j
815 IF(j > 0 .AND. ids > 0 ) THEN
816 nel = igrsh3n(j)%NENTITY
817C element type T3
818 ity = igrsh3n(j)%GRTYPE
819 DO 222 ii = 1,nel
820! c a verifier l'id du triangle
821
822 ish3n = igrsh3n(j)%ENTITY(ii)
823 pid = ixtg(5,ish3n)
824 igtyp = igeo(11,pid)
825 IF(igtyp == 52) THEN
826 idshel = ish3n + numelc
827 IF(icsh_stack(idshel) == 0) THEN
828 iworksh(1,idshel) = iworksh(1,idshel ) + 1
829 icsh_stack(idshel) = ids
830 ELSEIF(icsh_stack(idshel) == ids) THEN
831 iworksh(1,idshel) = iworksh(1,idshel ) + 1
832 ELSE
833C message d'erreur
834 ipid_1=igeo_stack(1,icsh_stack(idshel))
835 ngl =ixtg(nixtg,idshel)
836 CALL ancmsg(msgid=1152,
837 . msgtype=msgerror,
838 . anmode=aninfo_blind_1,
839 . i1=ngl,
840!! . C2='SHE3N',
841 . i2= igeo_stack(1,ids),
842 . i3= igeo_stack(1,ipid_1) )
843 ENDIF
844 ENDIF
845 222 CONTINUE
846 ENDIF
847 ENDDO ! I ply groupe
848C
849!! ENDDO ! iply
850!------------------------------------------------
851 IF(numelc+numeltg > 0) icsh_stack = 0
852 DO i=1,numelc
853 pid = ixc(6,i)
854 igtyp = igeo(11,pid)
855 npt = iworksh(1,i)
856 IF(igtyp == 52 .AND. npt > 0) THEN
857 NULLIFY(iwork_t(i)%IPT)
858 ALLOCATE(iwork_t(i)%IPT(npt))
859 iwork_t(i)%IPT = 0
860 iworksh(1,i) = 0
861 ENDIF
862 ENDDO
863 DO i=1, numeltg
864 pid = ixtg(5,i)
865 igtyp = igeo(11,pid)
866 ii = numelc + i
867 npt = iworksh(1,ii)
868 IF(igtyp == 52 .AND. npt > 0) THEN
869 NULLIFY(iwork_t(ii)%IPT)
870 ALLOCATE(iwork_t(ii)%IPT(npt))
871 iwork_t(ii)%IPT = 0
872 iworksh(1,ii) = 0
873 ENDIF
874 ENDDO
875C
876 DO i= 1,nply
877 j = idgr4n(i)
878 j4n = j
879 idply = ipidply(i)
880 ids = igeo_stack(42, idply)
881 !
882 ikey = i / nbit ! 32 or 64 bits
883 IF(mod(i,nbit) > 0 ) ikey = ikey + 1
884 ikey = min(ikey, nkey)
885 ibit = i - (ikey - 1)*nbit ! Bit corresponding to PLy
886 !
887 IF(j > 0 .AND. ids > 0 ) THEN
888 nel = igrsh4n(j)%NENTITY
889C element type Q4
890!! ITY = IGRN(4,J)
891 ity = igrsh4n(j)%GRTYPE
892 DO ii = 1,nel
893 idshel = igrsh4n(j)%ENTITY(ii)
894 pid = ixc(6,idshel)
895 igtyp = igeo(11,pid)
896 IF(igtyp == 52) THEN
897 IF(icsh_stack(idshel) == 0) THEN
898 iworksh(1,idshel) = iworksh(1,idshel) + 1
899 npt = iworksh(1,idshel)
900 iwork_t(idshel)%IPT(npt) = idply
901 icsh_stack(idshel) = ids
902 activ_ply(idshel,ikey) = ibset(activ_ply(idshel,ikey),ibit)
903 ELSEIF(icsh_stack(idshel) == ids) THEN
904 iworksh(1,idshel) = iworksh(1,idshel) + 1
905 npt = iworksh(1,idshel)
906 iwork_t(idshel)%IPT(npt) = idply
907 activ_ply(idshel,ikey) = ibset(activ_ply(idshel,ikey),ibit)
908C message d'erreur
909 ELSE
910 ipid_1=igeo_stack(1,icsh_stack(idshel))
911 ngl =ixc(nixc,idshel)
912 CALL ancmsg(msgid=1152,
913 . msgtype=msgerror,
914 . anmode=aninfo_blind_1,
915 . i1=ngl,
916!! . C2='SHELL',
917 . i2= igeo_stack(1,ids),
918 . i3= igeo_stack(1,ipid_1) )
919 ENDIF
920 ENDIF
921 ENDDO
922 ENDIF
923 j = idgr3n(i)
924 j3n = j
925 IF(j > 0 .AND. ids > 0 ) THEN
926 nel = igrsh3n(j)%NENTITY
927C element type T3
928 ity = igrsh3n(j)%GRTYPE
929 DO ii = 1,nel
930! c a verifier l'id du triangle
931
932 ish3n = igrsh3n(j)%ENTITY(ii)
933 pid = ixtg(5,ish3n)
934 igtyp = igeo(11,pid)
935 IF(igtyp == 52) THEN
936 idshel = ish3n + numelc
937 IF(icsh_stack(idshel) == 0) THEN
938 iworksh(1,idshel) = iworksh(1,idshel ) + 1
939 npt = iworksh(1,idshel)
940 iwork_t(idshel)%IPT(npt) = idply
941 icsh_stack(idshel) = ids
942 activ_ply(idshel,ikey) = ibset(activ_ply(idshel,ikey),ibit)
943 ELSEIF(icsh_stack(idshel) == ids) THEN
944 iworksh(1,idshel) = iworksh(1,idshel ) + 1
945 npt = iworksh(1,idshel)
946 iwork_t(idshel)%IPT(npt) = idply
947 activ_ply(idshel,ikey) = ibset(activ_ply(idshel,ikey),ibit)
948 ELSE
949C message d'erreur
950 ipid_1=igeo_stack(1,icsh_stack(idshel))
951 ngl =ixtg(nixtg,idshel)
952 CALL ancmsg(msgid=1152,
953 . msgtype=msgerror,
954 . anmode=aninfo_blind_1,
955 . i1=ngl,
956!! . C2='SHE3N',
957 . i2= igeo_stack(1,ids),
958 . i3= igeo_stack(1,ipid_1) )
959 ENDIF
960 ENDIF
961 ENDDO ! II
962 ENDIF
963 ENDDO ! I ply groupe
964!!!------------------------------------------
965C
966C mise en groupe des stack
967C
968 nsh = 0
969 indx_sh = 0
970 pid_sh = 0
971C
972 DO i=1,numelc
973 pid = ixc(6,i)
974 igtyp = igeo(11,pid)
975C
976 is = icsh_stack(i)
977 IF(igtyp == 52 ) THEN
978 nsh = nsh + 1
979 indx_sh(nsh) = i
980 pid_sh(nsh) = pid
981 ENDIF
982 ENDDO
983C
984 DO i=1,numeltg
985 pid = ixtg(5,i)
986 igtyp = igeo(11,pid)
987C
988 is = icsh_stack(numelc + i)
989 IF(igtyp == 52 )THEN
990 nsh = nsh + 1
991 indx_sh(nsh) = i + numelc
992 pid_sh(nsh) = pid
993 ENDIF
994 ENDDO
995C
996C
997C
998 ALLOCATE(indx(2*nsh),itri(2+nkey,nsh))
999 indx = 0
1000 itri = 0
1001 DO i = 1,nsh
1002 indx(i) = i
1003 ii = indx_sh(i)
1004 itri(1,i) = pid_sh(i)
1005 itri(2,i) = iworksh(1,ii)
1006 DO j=1,nkey
1007 itri(2+j,i) = activ_ply(ii,j)
1008 ENDDO
1009 ENDDO
1010C
1011 mode = 0
1012 nkey = nkey + 2
1013!! WORK = 0
1014 CALL my_orders(mode, work, itri, indx, nsh , nkey)
1015C
1016 ns = 1
1017 nfirst(1) = 1
1018 nlast(1) = 1
1019 DO i=2,nsh
1020 DO ikey = 1, nkey
1021 ii = itri(ikey,indx(i))
1022 jj = itri(ikey,indx(i-1))
1023 IF(ii /= jj) THEN
1024 ns = ns + 1
1025 nfirst(ns) = i
1026 nlast(ns) = nfirst(ns)
1027 EXIT
1028 ELSEIF(ikey == nkey) THEN
1029 nlast(ns) = nlast(ns) + 1
1030 ENDIF
1031 ENDDO
1032 ENDDO
1033C
1034C sous stack
1035C
1036 ALLOCATE(idstack(ns))
1037 idstack = 0
1038 ns_stack = ns_stack + ns
1039 DO is = 1,ns
1040 id = nfirst(is)
1041 i = indx(id)
1042 ii = indx_sh(i)
1043 npt = iworksh(1,ii)
1044 npt_stack = max(npt_stack,npt)
1045C
1046 ids = icsh_stack(ii)
1047 idstack(is) = ids
1048 ENDDO
1049C
1050C allocation
1051C
1052 ALLOCATE(stack%IGEO(4*npt_stack+2,ns_stack))
1053 ALLOCATE(stack%GEO(6*npt_stack+1,ns_stack))
1054 ALLOCATE(stack%PM(20,ns_stack))
1055C
1056 stack%IGEO = 0
1057 stack%GEO = zero
1058 stack%PM = zero
1059C
1060 DO is = 1,ns
1061C a changer
1062 ngeo_stack = numgeo + numstack + numply + is !!!!!!! limit id i will change it
1063 id = nfirst(is)
1064C
1065 i = indx(id)
1066 ii = indx_sh(i)
1067 pid = pid_sh(i)
1068!! MAIN_PID(1,IS) = PID_SH(II) ! pid
1069!! MAIN_PID(2,IS) = IWORKSH(1,II) ! npt
1070 npt = iworksh(1,ii)
1071 iis = ii
1072C
1073 DO i= nfirst(is) , nlast(is)
1074 id = indx(i)
1075 ii = indx_sh(id)
1076 iworksh(2,ii) = ngeo_stack
1077 iworksh(3,ii) = ns_stack0 + is ! compter for all stack
1078 ENDDO
1079C Cp igeo_stack and Geo_stack dans IGEO, GEO --ppccomp
1080 igtyp = igeo(11,pid)
1081 DO j=2,npropgi - ltitr
1082 igeo(j,pid) = igeo_stack(j,idstack(is))
1083 ENDDO
1084 igeo(11,pid) = igtyp
1085!
1086 DO j=1,npropg
1087 geo(j,pid) = geo_stack(j,idstack(is))
1088 ENDDO
1089C
1090 n1 = int(geo(6,pid))
1091 np = 0
1092 nums = numgeo_stack(numgeo + idstack(is))
1093 DO 777 j = 1,n1
1094 jpid = stack_info(nums)%PID(j)
1095 IF(np <= npt) THEN
1096 DO jj = 1,npt
1097 jjpid = iwork_t(iis)%IPT(jj)
1098 IF(jjpid == jpid) THEN
1099 np = np + 1
1100 iptply(np) = j
1101 GOTO 777
1102 ENDIF
1103 ENDDO
1104 ENDIF
1105 777 CONTINUE
1106C geometric property
1107C
1108 iis = ns_stack0 + is
1109 stack%IGEO(1,iis) = npt
1110 stack%IGEO(2,iis) = pid
1111 ippid = 2
1112 ipmat = ippid + npt
1113 ipmat_iply = ipmat + npt
1114C
1115 ipang = 1
1116 ipthk = ipang + npt
1117 ippos = ipthk + npt
1118 ipdir = ippos + npt
1119 ipthkly = ipdir + npt
1120 ipweight =ipthkly + npt
1121C stack id
1122!old IPPIDS = 100
1123!old IPMATS = 300
1124!old IPMAT_IPLYS = 500
1125!old IPANGS = 200
1126!old IPTHKS = 400
1127!old IPPOSS = 600
1128!old IPDIRS = 800
1129 pids = idstack(is)
1130 nums = numgeo_stack(numgeo + pids)
1131 DO j=1,npt
1132 js = iptply(j)
1133 stack%IGEO(ippid+j ,iis) = stack_info(nums)%PID(js)
1134 stack%IGEO(ipmat + j ,iis) = stack_info(nums)%MID(js)
1135 stack%IGEO(ipmat_iply+j ,iis) = stack_info(nums)%MID_IP(js)
1136 stack%GEO(ipang + j ,iis) = stack_info(nums)%ANG(js)
1137 stack%GEO(ipthk + j ,iis) = stack_info(nums)%THK(js)
1138 stack%GEO(ippos + j ,iis) = stack_info(nums)%POS(js)
1139 stack%GEO(ipdir + j ,iis) = stack_info(nums)%DIR(js)
1140 stack%GEO(ipthkly + j ,iis) = stack_info(nums)%THKLY(js)
1141 stack%GEO(ipweight + j ,iis) = stack_info(nums)%WEIGHT(js)
1142 ENDDO
1143C
1144C to be clarified later IPOS > 0
1145 ipos = igeo(99,pid)
1146 zshift = geo(199,pid)
1147 IF(ipos == 1)THEN
1148 tmin = ep20
1149 tmax = -ep20
1150 DO j=1,npt
1151 dt = half*stack%GEO(ipthk + j ,iis)
1152 tmin = min(tmin,stack%GEO(ippos + j ,iis)-dt)
1153 tmax = max(tmax,stack%GEO(ippos + j ,iis)+dt)
1154 ENDDO
1155 thickt = tmax - tmin
1156 DO j=1,npt
1157 stack%GEO(ipthk+j,iis)=
1158 . stack%GEO(ipthk+j,iis)/max(thickt,em20)
1159 stack%GEO(ippos+j,iis)=
1160 . stack%GEO(ippos+j,iis)/max(thickt,em20)
1161 ENDDO
1162
1163 ELSE
1164 thickt = zero
1165 DO j=1,npt
1166 thickt = thickt + stack%GEO(ipthk+j,iis)
1167 ENDDO
1168 DO j=1,npt
1169 stack%GEO(ipthk+j,iis) =
1170 . stack%GEO(ipthk+j,iis)/max(thickt,em20)
1171 ENDDO
1172C
1173 IF (ipos == 2 ) zshift = zshift /max(thickt,em20)
1174C--- calcul automatique de position des couches
1175 stack%GEO(ippos+1,iis) = zshift +
1176 . half*stack%GEO(ipthk+1,iis)
1177 DO j=2,npt
1178 stack%GEO(ippos+j,iis) =
1179 . stack%GEO(ippos+j-1,iis) +
1180 . half*(stack%GEO(ipthk+j,iis)+
1181 . stack%GEO(ipthk+j-1,iis))
1182 ENDDO
1183C
1184 ENDIF ! IPOS =0,1,2,3,4
1185C calcul du thk by shell
1186 stack%GEO(1,iis) = thickt
1187C============================================================================
1188C---
1189C update the shell thickness without drape
1190C---
1191 DO i= nfirst(is) , nlast(is)
1192 id = indx(i)
1193 ii = indx_sh(id)
1194 IF (thk(ii) == zero) thk(ii) = thickt
1195 ENDDO
1196C============================================================================
1197cc IF (IGTYP == 52) THEN
1198cc NLAY = MAX(1,NPT)
1199C---
1200C - various nb of integration points through each layer
1201C---
1202C
1203C--- TEST de calcul automatique de position des NPTT dans les couches
1204C
1205cc IPPID = 2
1206cc DO ILAY=1,NLAY
1207cc!! IPIDL = IGEO(IPPID + ILAY,PID)
1208cc THK_LY = STACK%GEO(IPTHK + ILAY,IIS) ! layer thickness ratio
1209cc POS_LY = STACK%GEO(IPPOS + ILAY,IIS) ! layer position ratio
1210cc IPID_LY = STACK%IGEO(IPPID + ILAY,IIS) ! layer PID (igtyp = 19)
1211cc MAT_LY = STACK%IGEO(IPMAT + ILAY,IIS) ! layer material
1212cccc IINT = IGEO(47,IPID_LY)
1213cc IINT = IGEO_STACK(47,PIDS)
1214cc NPTT = IGEO_STACK(4,PIDS)
1215cc THICKT = STACK%GEO(1,IIS)
1216cc IF (IINT == 1) THEN ! uniform distribution - by default
1217cc DO IT=1,NPTT
1218cc THK_IT(IT) = THK_LY/NPTT ! equally distribution of NPTT through layer
1219cc ENDDO
1220cc POS_0 = POS_LY - HALF*THK_LY
1221cc IF (NLAY == 1) POS_0 = - HALF !! special case
1222cc POS_IT(1) = POS_0 + HALF*THK_IT(1)
1223cccc POS_IT(1) = POS_LY - HALF*THK_LY + HALF*THK_IT(1)
1224cc DO IT=2,NPTT
1225cc POS_IT(IT) = POS_IT(IT-1) + HALF*(THK_IT(IT) + THK_IT(IT-1))
1226cc ENDDO
1227cc ELSEIF (IINT == 2) THEN ! Gauss distribution
1228cc DO IT=1,NPTT
1229cc THK_IT(IT) = HALF*THK_LY*W_GAUSS(IT,NPTT)
1230cc POS_IT(IT) = POS_LY + HALF*THK_LY*A_GAUSS(IT,NPTT)
1231cc ENDDO
1232cc ENDIF
1233cc ENDDO ! DO ILAY=1,NLAY
1234cc ENDIF ! IF (IGTYP == 52) THEN
1235C============================================================================
1236C---
1237 ippid = 2
1238 DO ilay=1,npt
1239 pids = stack%IGEO(ippid + ilay ,iis)
1240 nptt = igeo_stack(4,pids)
1241 igeo(4,pid) = max(igeo(4,pid),nptt)
1242 ENDDO
1243 ENDDO ! DO IS = 1,NS
1244C---
1245 DEALLOCATE(indx,itri,idstack, icsh_stack)
1246 DEALLOCATE(activ_ply)
1247 ENDIF
1248 DO i=1,numelc + numeltg
1249 npt = iworksh(1,i)
1250 IF(npt > 0) DEALLOCATE(iwork_t(i)%IPT)
1251 ENDDO
1252 DEALLOCATE(iwork_t)
1253C
1254 IF(ipart_stack > 0) THEN
1255 IF(ipart_pcompp == 0) THEN
1256 ALLOCATE(stack%IGEO(4*npt_stack0+2,ns_stack0))
1257 ALLOCATE(stack%GEO(6*npt_stack0+1,ns_stack0))
1258 ALLOCATE(stack%PM(20,ns_stack0))
1259 stack%IGEO = 0
1260 stack%GEO = zero
1261 stack%PM = zero
1262 ENDIF
1263 DO is = 1, ns_stack0
1264 DO j = 1, 3*npt_stack0 + 2
1265 stack%IGEO(j, is ) = iworks%IGEO(j,is)
1266 ENDDO
1267 DO j = 1, 6*npt_stack0+1
1268 stack%GEO(j, is ) = iworks%GEO(j,is)
1269 ENDDO
1270 ENDDO
1271 DEALLOCATE(iworks%IGEO, iworks%GEO)
1272 ENDIF
1273C --- update of sub-stack
1274 IF(ns_stack > 0) THEN
1275 DO is = 1,ns_stack
1276 npt = stack%IGEO(1,is)
1277 pid = stack%IGEO(2,is)
1278 thickt = stack%GEO(1,is)
1279 id = igeo(1,pid)
1280 igtyp = igeo(11,pid)
1281C
1282 WRITE(iout,1000)id, is
1283 WRITE(iout,1100) thickt,npt
1284!! IPANG = 1
1285!! IPTHK = IPANG + NPT
1286!! IPPOS = IPTHK + NPT
1287 ippos = 1 + 2*npt
1288 ippid = 2
1289 IF(igtyp == 52) THEN
1290 DO j = 1,npt
1291 pid = stack%IGEO(ippid + j ,is)
1292 pos = stack%GEO( ippos + j ,is)
1293 pos = pos*thickt
1294 id = igeo_stack(1,pid)
1295 WRITE(iout,2000)j, id , pos
1296 ENDDO
1297 ELSE
1298 DO j = 1,npt
1299 pid = stack%IGEO(ippid + j ,is)
1300 pos = stack%GEO( ippos + j ,is)
1301 pos = pos*thickt
1302 id = igeo(1,pid)
1303 WRITE(iout,2000)j, id , pos
1304 ENDDO
1305 ENDIF
1306 ENDDO
1307 ENDIF
1308C for restart
1309 IF(ipart_pcompp > 0 .AND. ipart_stack == 0) ipart_stack = 1
1310C--------
1311 DEALLOCATE(ipidply)
1312 DEALLOCATE(idgr4n)
1313 DEALLOCATE(idgr3n)
1314 DEALLOCATE(isubstack)
1315 DEALLOCATE(index_sh4)
1316 DEALLOCATE(index_t3)
1317 DEALLOCATE(nfirst)
1318 DEALLOCATE(nlast)
1319 DEALLOCATE(indx_sh)
1320 DEALLOCATE(pid_sh)
1321 DEALLOCATE(geo0)
1322
1323 RETURN
1324 1000 FORMAT(//,
1325 & 5x,'COMPOSITE STACK SHELL PROPERTY SET ',
1326 & 'WITH VARIABLE THICKNESSES AND MATERIALS'//,
1327 & 7x,'PROPERTY SET NUMBER . . . . . . . . . . ..=',i10/,
1328 & 7x,'sub property set number . . . . . . . . . .=',I10/)
1329 1100 FORMAT(
1330 & 8X,'shell thickness . . . . . . . . . . . .=',1PG20.13/
1331 & 8X,'number of plies. . . . . . . . . . . . =',I10/)
1332 2000 FORMAT(
1333 & 8X,' ply ',I3/,
1334 & 8X,' ply pid number . . . . . . . . .=',I10/
1335 & 8X,' position. . . . . . . . . . . . .=',1PG20.13/)
1336
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
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
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
stack_mod
Definition stack_mod.F:72
submodel_mod
Definition submodel_mod.F:712
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