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