OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
pres_stackgroup.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| pre_stackgroup ../starter/source/stack/pres_stackgroup.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!||--- uses -----------------------------------------------------
30!|| drape_mod ../starter/share/modules1/drape_mod.f
31!|| message_mod ../starter/share/message_module/message_mod.F
32!|| stack_mod ../starter/share/modules1/stack_mod.F
33!|| submodel_mod ../starter/share/modules1/submodel_mod.F
34!||====================================================================
35 SUBROUTINE pre_stackgroup(
36 . IGRSH3N ,IGRSH4N ,IXC ,IXTG ,
37 . IGEO ,GEO ,IGEO_STACK ,IWORKSH ,
38 . IWORK_T)
39C-----------------------------------------------
40C M o d u l e s
41C-----------------------------------------------
42 USE submodel_mod
43 USE stack_mod
44 USE message_mod
45 USE groupdef_mod
46 USE drape_mod
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 "scr03_c.inc"
58#include "com04_c.inc"
59#include "units_c.inc"
60#include "warn_c.inc"
61#include "param_c.inc"
62#include "remesh_c.inc"
63#include "sphcom.inc"
64#include "drape_c.inc"
65C-----------------------------------------------
66C D u m m y A r g u m e n t s
67C-----------------------------------------------
68 INTEGER IXC(NIXC,NUMELC),
69 . IXTG(NIXTG,NUMELTG),IGEO(NPROPGI,NUMGEO),IWORKSH(3,NUMELC+NUMELTG),
70 . IGEO_STACK(NPROPGI,NUMSTACK + NUMPLY)
72 . geo(npropg,numgeo)
73C-----------------------------------------------
74 TYPE (GROUP_) , DIMENSION(NGRSH3N) :: IGRSH3N
75 TYPE (GROUP_) , DIMENSION(NGRSHEL) :: IGRSH4N
76 TYPE(DRAPE_WORK_) , DIMENSION(NUMELC + NUMELTG) , TARGET :: IWORK_T
77C-----------------------------------------------
78C L o c a l V a r i a b l e s
79C-----------------------------------------------
80 INTEGER I,J,II,NSTACK,NPLY,IGTYP,ID,JD,IDPLY,NEL,
81 . IAD,ITY,IDSHEL,PID,IS,IDS,NSH,MODE,NS,JJ,NGEO_STACK,
82 . IGRTYP,N1,IIGEO,NSS,IPPOS,NPT,IIS,NP,
83 . jjpid,jstack,jpid,itg,ipmat_iply,ish3n,j4n,j3n,ipos,
84 . mat_ly,nlay,nptt,ipidl,it,ilay,ipthk_nptt,ippos_nptt,
85 . iint,ipid_ly,ipdir ,ns_stack0 ,npt_stack0,is0,js,pids,ip,
86 . ii1,ii2,jj1,jj2
87
88 INTEGER , DIMENSION(NUMGEO+NUMPLY) :: IPIDPLY,IDGR4N,IDGR3N
89
90 INTEGER NGL, IPID_1, NSHQ4, NSHT3
91
92 INTEGER, DIMENSION(:,:), ALLOCATABLE :: ITRI
93 INTEGER, DIMENSION (:) ,ALLOCATABLE ::ICSH,INDX
94 CHARACTER(LEN=NCHARTITLE) :: TITR,TITR1
95C----------------------------f-------------------
96C=======================================================================
97C For Shell
98C-----------------------------------------------
99 IF(ipart_stack > 0) THEN
100 nply = 0
101 nstack = 0
102C
103 ipidply = 0
104 idgr4n = 0
105 idgr3n = 0
106 DO i = 1, numgeo
107!! ISUBSTACK(I)= 0
108 igtyp=igeo(11,i)
109 nstack = igeo(42,i) ! number of stack where ply is attached
110 IF (igtyp == 19 .AND. nstack > 0) THEN
111 nply = nply+1
112 ipidply(nply) = i
113 idgr4n(nply) = igeo(40,i) ! groupe shell 4N id
114 idgr3n(nply) = igeo(41,i) ! groupe shell 3N id
115 ENDIF
116 ENDDO
117C transformation d'id groupe
118 DO 10 i=1,nply
119C shell 4N id group
120 id = idgr4n(i)
121 IF(id > 0) THEN
122 DO j=1,ngrshel
123 jd = igrsh4n(j)%ID
124 IF(jd == id)THEN
125 idgr4n(i) = j
126 GOTO 20
127 ENDIF
128 ENDDO
129 ENDIF ! ID > 0
130C !GR T3
131 20 CONTINUE
132 id = idgr3n(i)
133 IF(id > 0) THEN
134 DO j=1,ngrsh3n
135 jd = igrsh3n(j)%ID
136 IF(jd == id)THEN
137 idgr3n(i) = j
138 GOTO 10
139 ENDIF
140 ENDDO
141 ENDIF ! ID > 0
14210 CONTINUE
143C tag o f ply element
144 nshq4 = 0
145 DO i=1,numelc
146 pid = ixc(6,i)
147 igtyp = igeo(11,pid)
148 IF(igtyp == 17 .OR. igtyp == 51)THEN
149 nshq4 = nshq4 + 1
150 ENDIF
151 ENDDO
152C
153 nsht3 = 0
154 DO i=1,numeltg
155 pid = ixtg(5,i)
156 igtyp = igeo(11,pid)
157 IF(igtyp == 17 .OR. igtyp == 51)THEN
158 nsht3 = nsht3 + 1
159 ENDIF
160 ENDDO
161C number of ply belong to the element
162 DO i=1,nply
163 j = idgr4n(i)
164 j4n = j
165 idply = ipidply(i)
166 nstack = igeo(42, idply)
167 IF(j > 0 .AND. nstack > 0 ) THEN
168 nel = igrsh4n(j)%NENTITY
169C eleme nt type Q4 or T3
170 ity = igrsh4n(j)%GRTYPE
171 DO 100 ii = 1,nel
172 idshel = igrsh4n(j)%ENTITY(ii)
173 pid = ixc(6,idshel)
174 igtyp = igeo(11,pid)
175 IF(igtyp == 17 .OR. igtyp == 51) THEN
176 DO is = 1,nstack
177 ids = igeo(200 + is, idply)
178 IF (ids == pid) THEN
179 iworksh(1,idshel) = iworksh(1,idshel) + 1
180 GOTO 100
181 ENDIF
182 ENDDO
183 ENDIF
184 100 CONTINUE
185 ENDIF
186 j = idgr3n(i)
187 j3n = j
188 IF(j > 0 .AND. nstack > 0 ) THEN
189 nel = igrsh3n(j)%NENTITY
190C eleme nt type T3
191 ity = igrsh3n(j)%GRTYPE
192 DO 200 ii = 1,nel
193 ish3n = igrsh3n(j)%ENTITY(ii)
194 pid = ixtg(5,ish3n)
195 igtyp = igeo(11,pid)
196 IF(igtyp == 17 .OR. igtyp == 51) THEN
197 DO is = 1,nstack
198 ids = igeo(200 + is,idply)
199 IF (ids == pid) THEN
200 idshel = ish3n + numelc
201 iworksh(1,idshel) = iworksh(1,idshel ) + 1
202 GOTO 200
203 ENDIF
204 ENDDO
205 ENDIF
206 200 CONTINUE
207 ENDIF
208 IF(j4n == 0 .AND. j3n == 0 .AND. nstack > 0 ) THEN
209C
210 DO 300 ii = 1,numelc
211 pid = ixc(6,ii)
212 igtyp = igeo(11,pid)
213 IF(igtyp == 17 .OR. igtyp == 51) THEN
214 DO is = 1,nstack
215 ids = igeo(200 + is,idply)
216 IF (ids == pid) THEN
217 iworksh(1,ii) = iworksh(1,ii) + 1
218 GOTO 300
219 ENDIF
220 ENDDO
221 ENDIF
222 300 CONTINUE
223 DO 400 ii = 1,numeltg
224 pid = ixtg(5,ii)
225 igtyp = igeo(11,pid)
226 itg = numelc + ii
227 IF(igtyp == 17 .OR. igtyp == 51) THEN
228 DO is = 1,nstack
229 ids = igeo(200 + is,idply)
230 IF (ids == pid) THEN
231 iworksh(1,itg) = iworksh(1,itg) + 1
232 GOTO 400
233 ENDIF
234 ENDDO
235 ENDIF
236 400 CONTINUE
237 ENDIF
238C
239 ENDDO ! iply
240C #####################################################"
241 ! SH4N element
242 DO i=1,numelc
243 pid = ixc(6,i)
244 igtyp = igeo(11,pid)
245 npt = iworksh(1,i)
246 IF(igtyp == 17 .OR. igtyp == 51 .AND. npt > 0) THEN
247 ALLOCATE(iwork_t(i)%PLYID(npt))
248 ALLOCATE(iwork_t(i)%PLYNUM(npt))
249 iwork_t(i)%PLYID = 0
250 iworksh(1,i) = 0
251 iwork_t(i)%PLYNUM = 0
252 ENDIF
253 ENDDO
254 ! sh3n element
255 DO i=1, numeltg
256 pid = ixtg(5,i)
257 igtyp = igeo(11,pid)
258 ii = numelc + i
259 npt = iworksh(1,ii)
260 IF((igtyp == 17 .OR. igtyp == 51) .AND. npt > 0) THEN
261 ALLOCATE(iwork_t(ii)%PLYID(npt))
262 ALLOCATE(iwork_t(ii)%PLYNUM(npt))
263 iwork_t(ii)%PLYID = 0
264 iworksh(1,ii) = 0
265 iwork_t(ii)%PLYNUM = 0
266 ENDIF
267 ENDDO
268! ply to element
269!!
270 DO i=1,nply
271 j = idgr4n(i)
272 j4n = j
273 idply = ipidply(i)
274 nstack = igeo(42, idply)
275 IF(j > 0 .AND. nstack > 0 ) THEN
276 nel = igrsh4n(j)%NENTITY
277C eleme nt type Q4 or T3
278 ity = igrsh4n(j)%GRTYPE
279 DO 101 ii = 1,nel
280 idshel = igrsh4n(j)%ENTITY(ii)
281 pid = ixc(6,idshel)
282 igtyp = igeo(11,pid)
283 IF(igtyp == 17 .OR. igtyp == 51) THEN
284 DO is = 1,nstack
285 ids = igeo(200 + is, idply)
286 IF (ids == pid) THEN
287 iworksh(1,idshel) = iworksh(1,idshel) + 1
288 npt = iworksh(1,idshel)
289 iwork_t(idshel)%PLYID(npt) = idply
290 iwork_t(idshel)%PLYNUM(npt) = i
291 GOTO 101
292 ENDIF
293 ENDDO
294 ENDIF
295 101 CONTINUE
296 ENDIF
297 j = idgr3n(i)
298 j3n = j
299 IF(j > 0 .AND. nstack > 0 ) THEN
300 nel = igrsh3n(j)%NENTITY
301C eleme nt type T3
302 ity = igrsh3n(j)%GRTYPE
303 DO 202 ii = 1,nel
304 ish3n = igrsh3n(j)%ENTITY(ii)
305 pid = ixtg(5,ish3n)
306 igtyp = igeo(11,pid)
307 IF(igtyp == 17 .OR. igtyp == 51) THEN
308 DO is = 1,nstack
309 ids = igeo(200 + is,idply)
310 IF (ids == pid) THEN
311 idshel = ish3n + numelc
312 iworksh(1,idshel) = iworksh(1,idshel ) + 1
313 npt = iworksh(1,idshel)
314 iwork_t(idshel)%PLYID(npt) = idply
315 iwork_t(idshel)%PLYNUM(npt) = i
316 GOTO 202
317 ENDIF
318 ENDDO
319 ENDIF
320 202 CONTINUE
321 ENDIF
322 IF(j4n == 0 .AND. j3n == 0 .AND. nstack > 0 ) THEN
323C
324 DO 333 ii = 1,numelc
325 pid = ixc(6,ii)
326 igtyp = igeo(11,pid)
327 IF(igtyp == 17 .OR. igtyp == 51) THEN
328 DO is = 1,nstack
329 ids = igeo(200 + is,idply)
330 IF (ids == pid) THEN
331 iworksh(1,ii) = iworksh(1,ii) + 1
332 npt = iworksh(1,ii)
333 iwork_t(ii)%PLYID(npt) = idply
334 iwork_t(ii)%PLYNUM(npt) = i
335 GOTO 333
336 ENDIF
337 ENDDO
338 ENDIF
339 333 CONTINUE
340 DO 404 ii = 1,numeltg
341 pid = ixtg(5,ii)
342 igtyp = igeo(11,pid)
343 itg = numelc + ii
344 IF(igtyp == 17 .OR. igtyp == 51) THEN
345 DO is = 1,nstack
346 ids = igeo(200 + is,idply)
347 IF (ids == pid) THEN
348 iworksh(1,itg) = iworksh(1,itg) + 1
349 npt = iworksh(1,itg)
350 iwork_t(itg)%PLYID(npt) = idply
351 iwork_t(itg)%PLYNUM(npt) = i
352 GOTO 404
353 ENDIF
354 ENDDO
355 ENDIF
356 404 CONTINUE
357 ENDIF
358C
359 ENDDO ! iply
360 ENDIF
361C
362C pccommp part
363C
364 IF(ipart_pcompp > 0) THEN
365 nply = 0
366 nstack = 0
367 DO i = 1, numply
368!! Only one stack by ply
369 ids = igeo_stack(42,numstack + i)
370 IF (ids > 0) THEN
371 nply = nply+1
372 ipidply(nply) = numstack + i
373 idgr4n(nply) = igeo_stack(40,numstack + i) ! groupe shell 4N id
374 idgr3n(nply) = igeo_stack(41,numstack + i) ! groupe shell 3N id
375 ENDIF
376 ENDDO
377!
378 DO 11 i=1,nply
379C shell 4N id group
380 id = idgr4n(i)
381 IF(id > 0) THEN
382 DO j=1,ngrshel
383 jd = igrsh4n(j)%ID
384 IF(jd == id)THEN
385 idgr4n(i) = j
386 GOTO 22
387 ENDIF
388 ENDDO
389 ENDIF ! ID > 0
390C !GR T3
391 22 CONTINUE
392 id = idgr3n(i)
393 IF(id > 0) THEN
394 DO j=1,ngrsh3n
395 jd = igrsh3n(j)%ID
396 IF(jd == id)THEN
397 idgr3n(i) = j
398 GOTO 11
399 ENDIF
400 ENDDO
401 ENDIF ! ID > 0
40211 CONTINUE
403C counter by element
404 iwork_t(1:numelc + numeltg)%IDSTACK = 0
405 DO i= 1,nply
406 j = idgr4n(i)
407 j4n = j
408 idply = ipidply(i)
409 ids = igeo_stack(42, idply)
410 IF(j > 0 .AND. ids > 0 ) THEN
411 nel = igrsh4n(j)%NENTITY
412C element type Q4
413!! ITY = IGRN(4,J)
414 ity = igrsh4n(j)%GRTYPE
415 DO 111 ii = 1,nel
416 idshel = igrsh4n(j)%ENTITY(ii)
417 pid = ixc(6,idshel)
418 igtyp = igeo(11,pid)
419 IF(igtyp == 52) THEN
420 IF(iwork_t(idshel)%IDSTACK == 0) THEN
421 iworksh(1,idshel) = iworksh(1,idshel) + 1
422 iwork_t(idshel)%IDSTACK = ids
423 ELSEIF(iwork_t(idshel)%IDSTACK == ids) THEN
424 iworksh(1,idshel) = iworksh(1,idshel) + 1
425 ELSE
426C error message
427 ipid_1=igeo_stack(1,iwork_t(idshel)%IDSTACK)
428 ngl =ixc(nixc,idshel)
429 CALL ancmsg(msgid=1152,
430 . msgtype=msgerror,
431 . anmode=aninfo_blind_1,
432 . i1=ngl,
433!! . C2='SHELL',
434 . i2= igeo_stack(1,ids),
435 . i3= igeo_stack(1,ipid_1) )
436 ENDIF
437 ENDIF
438 111 CONTINUE
439 ENDIF
440 j = idgr3n(i)
441 j3n = j
442 IF(j > 0 .AND. ids > 0 ) THEN
443 nel = igrsh3n(j)%NENTITY
444C element type T3
445 ity = igrsh3n(j)%GRTYPE
446 DO 222 ii = 1,nel
447!
448 ish3n = igrsh3n(j)%ENTITY(ii)
449 pid = ixtg(5,ish3n)
450 igtyp = igeo(11,pid)
451 IF(igtyp == 52) THEN
452 idshel = ish3n + numelc
453 IF(iwork_t(idshel)%IDSTACK == 0) THEN
454 iworksh(1,idshel) = iworksh(1,idshel ) + 1
455 iwork_t(idshel)%IDSTACK= ids
456 ELSEIF(iwork_t(idshel)%IDSTACK == ids) THEN
457 iworksh(1,idshel) = iworksh(1,idshel ) + 1
458 ELSE
459C error message
460 ipid_1=igeo_stack(1,iwork_t(idshel)%IDSTACK)
461 ngl =ixtg(nixtg,idshel)
462 CALL ancmsg(msgid=1152,
463 . msgtype=msgerror,
464 . anmode=aninfo_blind_1,
465 . i1=ngl,
466!! . C2='SHE3N',
467 . i2= igeo_stack(1,ids),
468 . i3= igeo_stack(1,ipid_1) )
469 ENDIF
470 ENDIF
471 222 CONTINUE
472 ENDIF
473 ENDDO ! I ply groupe
474C
475!!!------------------------------------------------
476 DO i=1,numelc
477 pid = ixc(6,i)
478 igtyp = igeo(11,pid)
479 npt = iworksh(1,i)
480 IF(igtyp == 52 .AND. npt > 0) THEN
481 ALLOCATE(iwork_t(i)%PLYID(npt))
482 ALLOCATE(iwork_t(i)%PLYNUM(npt))
483 iwork_t(i)%PLYID = 0
484 iwork_t(i)%IDSTACK = 0
485 iworksh(1,i) = 0
486 iwork_t(i)%PLYNUM = 0
487 ENDIF
488 ENDDO
489 DO i=1, numeltg
490 pid = ixtg(5,i)
491 igtyp = igeo(11,pid)
492 ii = numelc + i
493 npt = iworksh(1,ii)
494 IF(igtyp == 52 .AND. npt > 0) THEN
495 ALLOCATE(iwork_t(ii)%PLYID(npt) )
496 ALLOCATE(iwork_t(ii)%PLYNUM(npt))
497 iwork_t(ii)%PLYID = 0
498 iwork_t(ii)%IDSTACK = 0
499 iworksh(1,ii) = 0
500 iwork_t(ii)%PLYNUM = 0
501 ENDIF
502 ENDDO
503C
504 DO i= 1,nply
505 j = idgr4n(i)
506 j4n = j
507 idply = ipidply(i)
508 ids = igeo_stack(42, idply)
509 IF(j > 0 .AND. ids > 0 ) THEN
510 nel = igrsh4n(j)%NENTITY
511C element type Q4
512!! ITY = IGRN(4,J)
513 ity = igrsh4n(j)%GRTYPE
514 DO ii = 1,nel
515 idshel = igrsh4n(j)%ENTITY(ii)
516 pid = ixc(6,idshel)
517 igtyp = igeo(11,pid)
518 IF(igtyp == 52) THEN
519 IF(iwork_t(idshel)%IDSTACK == 0) THEN
520 iworksh(1,idshel) = iworksh(1,idshel) + 1
521 npt = iworksh(1,idshel)
522 iwork_t(idshel)%PLYID(npt) = idply
523 iwork_t(idshel)%IDSTACK = ids
524 iwork_t(idshel)%PLYNUM(npt) = i
525 ELSEIF(iwork_t(idshel)%IDSTACK == ids) THEN
526 iworksh(1,idshel) = iworksh(1,idshel) + 1
527 npt = iworksh(1,idshel)
528 iwork_t(idshel)%PLYID(npt) = idply
529 iwork_t(idshel)%PLYNUM(npt) = i
530 ELSE
531C error message
532 ipid_1=igeo_stack(1,iwork_t(idshel)%IDSTACK)
533 ngl =ixc(nixc,idshel)
534 CALL ancmsg(msgid=1152,
535 . msgtype=msgerror,
536 . anmode=aninfo_blind_1,
537 . i1=ngl,
538!! . C2='SHELL',
539 . i2= igeo_stack(1,ids),
540 . i3= igeo_stack(1,ipid_1) )
541 ENDIF
542 ENDIF
543 ENDDO
544 ENDIF
545 j = idgr3n(i)
546 j3n = j
547 IF(j > 0 .AND. ids > 0 ) THEN
548 nel = igrsh3n(j)%NENTITY
549C element type T3
550 ity = igrsh3n(j)%GRTYPE
551 DO ii = 1,nel
552! c a verifier l'id du triangle
553
554 ish3n = igrsh3n(j)%ENTITY(ii)
555 pid = ixtg(5,ish3n)
556 igtyp = igeo(11,pid)
557 IF(igtyp == 52) THEN
558 idshel = ish3n + numelc
559 IF(iwork_t(idshel)%IDSTACK == 0) THEN
560 iworksh(1,idshel) = iworksh(1,idshel ) + 1
561 npt = iworksh(1,idshel)
562 iwork_t(idshel)%PLYID(npt) = idply
563 iwork_t(idshel)%IDSTACK= ids
564 iwork_t(idshel)%PLYNUM(npt) = i
565 ELSEIF(iwork_t(idshel)%IDSTACK == ids) THEN
566 iworksh(1,idshel) = iworksh(1,idshel ) + 1
567 npt = iworksh(1,idshel)
568 iwork_t(idshel)%PLYID(npt) = idply
569 iwork_t(idshel)%PLYNUM(npt) = i
570 ELSE
571C error message
572 ipid_1=igeo_stack(1,iwork_t(idshel)%IDSTACK)
573 ngl =ixtg(nixtg,idshel)
574 CALL ancmsg(msgid=1152,
575 . msgtype=msgerror,
576 . anmode=aninfo_blind_1,
577 . i1=ngl,
578!! . C2='SHE3N',
579 . i2= igeo_stack(1,ids),
580 . i3= igeo_stack(1,ipid_1) )
581 ENDIF
582 ENDIF
583 ENDDO ! II
584 ENDIF
585 ENDDO ! I ply groupe
586!!!------------------------------------------
587 ENDIF
588C--------
589
590 RETURN
591 END
#define my_real
Definition cppsort.cpp:32
integer, parameter nchartitle
subroutine pre_stackgroup(igrsh3n, igrsh4n, ixc, ixtg, igeo, geo, igeo_stack, iworksh, iwork_t)
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
program starter
Definition starter.F:39