OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i24sti3.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!|| i24sti3 ../starter/source/interfaces/inter3d1/i24sti3.F
25!||--- called by ------------------------------------------------------
26!|| inint3 ../starter/source/interfaces/inter3d1/inint3.F
27!||--- calls -----------------------------------------------------
28!|| friction_parts_search ../starter/source/interfaces/inter3d1/i7sti3.F
29!|| i24bord ../starter/source/interfaces/inter3d1/i24sti3.F
30!|| i24gapm ../starter/source/interfaces/inter3d1/i24sti3.F
31!|| i24normns ../starter/source/interfaces/inter3d1/i24sti3.F
32!|| insol3et ../starter/source/interfaces/inter3d1/i24sti3.F
33!||--- uses -----------------------------------------------------
34!||====================================================================
35 SUBROUTINE i24sti3(
36 1 X ,IRECT ,STF ,IXS ,PM ,
37 2 GEO ,NRT ,IXC ,NINT ,STFAC ,
38 3 NTY ,GAP ,NOINT ,
39 4 STFN ,NSN ,MS ,NSV ,IXTG ,
40 5 IGAP ,WA ,GAP_S ,GAP_M ,GAPMIN,
41 6 IXT ,IXP ,GAPINF,GAPMAX_S,
42 9 INACTI ,KNOD2ELS ,KNOD2ELC ,KNOD2ELTG ,NOD2ELS ,
43 A NOD2ELC,NOD2ELTG ,IGRSURF ,INTTH,
44 B IELES ,IELEC ,AREAS ,SH4TREE ,SH3TREE ,
45 C IPART ,IPARTC ,IPARTTG ,THK ,THK_PART ,
46 D IXR ,ITAB ,BGAPSMX ,IXS10 ,MSEGTYP ,
47 E NRT_SH ,IXS16 ,IXS20 ,GAP_N ,MVOISN ,
48 F ILEV ,IGRSURF2 ,GAPMAX_M ,ID,TITR ,IGAP0 ,
49 G PEN_OLD,IPARTNS ,IPARTS ,IGEO ,FILLSOL ,
50 H PM_STACK, IWORKSH ,INTFRIC ,TAGPRT_FRIC,IPARTFRICS,
51 G IPARTFRICM,INTBUF_FRIC_TAB ,INTNITSCHE,NRTS,IRECTS,
52 I IELNRTS ,ADRECTS ,FACNRTS ,NMN ,MSR ,
53 J IPARTT ,IPARTP ,IPARTR ,ELEM_LINKED_TO_SEGMENT,
54 K IGSTI ,FLAG_ELEM_INTER25 )
55C-----------------------------------------------
56C M o d u l e s
57C-----------------------------------------------
58 USE my_alloc_mod
59 USE intbuf_fric_mod
60 USE groupdef_mod
61 USE names_and_titles_mod , ONLY : nchartitle
62 use element_mod , only : nixs,nixc,nixtg,nixt,nixp,nixr
63C-----------------------------------------------
64C I m p l i c i t T y p e s
65C-----------------------------------------------
66#include "implicit_f.inc"
67C-----------------------------------------------
68C C o m m o n B l o c k s
69C-----------------------------------------------
70#include "com01_c.inc"
71#include "com04_c.inc"
72#include "param_c.inc"
73#include "remesh_c.inc"
74#include "scr03_c.inc"
75#include "scr17_c.inc"
76#include "units_c.inc"
77C-----------------------------------------------
78C D u m m y A r g u m e n t s
79C-----------------------------------------------
80 INTEGER NRT, NINT, NTY, NOINT,NSN,IGAP,INTFRIC,NMN,IGSTI,
81 . inacti,nrt_sh ,ilev ,igap0,intnitsche,nrts,igeo(npropgi,*)
82 INTEGER IRECT(4,*), IXS(NIXS,*), IXC(NIXC,*),
83 . NSV(*), IXTG(NIXTG,*), IXT(NIXT,*), IXP(NIXP,*),
84 . KNOD2ELS(*), KNOD2ELC(*), KNOD2ELTG(*), NOD2ELS(*), NOD2ELC(*),
85 . NOD2ELTG(*), IELES(*), INTTH, IELEC(*),
86 . SH3TREE(KSH3TREE,*), SH4TREE(KSH4TREE,*),IXR(NIXR,*) ,
87 . IPART(LIPART1,*), IPARTC(*), IPARTTG(*),
88 . ITAB(*), IXS10(6,*),MSEGTYP(*), IXS16(8,*), IXS20(12,*),MVOISN(4,*),
89 . IWORKSH(3,*),TAGPRT_FRIC(*),IPARTFRICS(*),IPARTFRICM(*),
90 . IRECTS(4,*),IELNRTS(*),ADRECTS(4,*),FACNRTS(*),MSR(*)
91C REAL
92 my_real
93 . STFAC, GAP,GAPMIN,GAPINF, GAPMAX_S,BGAPSMX ,GAPMAX_M
94C REAL
95 my_real
96 . X(3,*), STF(*), PM(NPROPM,*), GEO(NPROPG,*), STFN(*),
97 . MS(*),WA(*),GAP_S(*),GAP_M(*),GAP_N(12,*),
98 . AREAS(*),THK(*),THK_PART(*),PEN_OLD(5,NSN), FILLSOL(*),
99 . pm_stack(20,*)
100 INTEGER ID,IPARTNS(*),IPARTS(*)
101 INTEGER, DIMENSION(NUMELT), INTENT(IN) :: IPARTT
102 INTEGER, DIMENSION(NUMELP), INTENT(IN) :: IPARTP
103 INTEGER, DIMENSION(NUMELR), INTENT(IN) :: IPARTR
104 INTEGER, DIMENSION(NUMELS), INTENT(INOUT):: ELEM_LINKED_TO_SEGMENT !< working array, dim=numels
105 CHARACTER(LEN=NCHARTITLE) :: TITR
106 TYPE(INTBUF_FRIC_STRUCT_) INTBUF_FRIC_TAB(*)
107 TYPE (SURF_) :: IGRSURF
108 TYPE (SURF_) :: IGRSURF2
109 INTEGER, INTENT(IN) :: FLAG_ELEM_INTER25(NINTER25,NUMELS)
110C-----------------------------------------------
111C L o c a l V a r i a b l e s
112C-----------------------------------------------
113 INTEGER NDX, I, J, INRT, NELS, MT, JJ, JJJ, NELC,
114 . mg, num, npt, ll, l, nn, neltg,n1,n2,n3,n4,ie,
115 . ip, nlev, mylev, k, p, r, t,nrt1,nrt2,nshif,
116 . ns,igtyp,nrtt,ipl,ipfmax,
117 . ipflmax,nm,nel,fc,perm,nshiff,n,ipg
118
119 INTEGER JPERM(4) ,FACES(4,6),TAB1(4),TAB2(4),FACES10(3,16)
120C REAL
121 my_real
122 . dxm, gapmx, gapmn, area, vol, dx,gaps1,gaps2, gapm, ddx,
123 . gaptmp, gapscale,sx1,sy1,sz1,sx2,sy2,sz2,sx3,sy3,sz3,
124 . slsfac,xl,gaps_mn
125 INTEGER, DIMENSION(:),ALLOCATABLE ::TAGNOD,TAGB
126 DATA jperm/2,3,4,1/
127 DATA faces/1,2,3,4,
128 . 1,2,6,5,
129 . 2,3,7,6,
130 . 3,4,8,7,
131 . 1,5,8,4,
132 . 5,6,7,8/
133 DATA faces10/1,11,14,
134 . 3,11,15,
135 . 5,14,15,
136 . 11,14,15,
137 . 1,13,14,
138 . 6,13,16,
139 . 5,14,16,
140 . 13,14,16,
141 . 3,11,12,
142 . 6,12,13,
143 . 1,11,13,
144 . 11,12,13,
145 . 3,12,15,
146 . 6,12,16,
147 . 5,15,16,
148 . 12,15,16/
149C--------------------------------------------------------------
150C CALCULATION OF THE STIFFNESSES OF THE SEGMENTS
151C V16: IN CASE A SEGMENT BELONGS TO BOTH
152C A BRICK AND A SHELL, THE STIFFNESS OF THE SHELL IS CHOSEN
153C OF THE SHELL UNLESS THE SHELL MATERIAL IS NULL.
154C---------------------------------------------------------------
155C NRT->NRT0
156C--- MVOISN is used temporarily for Pen_ini MVOISN(1,*) -> MTYPE(solid),MVOISN(2,*) -> E_id
157C-----MVOISN(3,*) -> part_id, IPARTNS->part_id(SECONDARY)
158 slsfac = stfac
159 dxm=zero
160 ndx=0
161 nshif=0
162 gapmx=ep30
163 gapmn=ep30
164 gaps1=zero
165 gaps2=zero
166 gaps_mn=ep30
167 gapscale = one
168C-----NRTT:NRTM
169C NRT_SH nb of shells before symetrization, NRT nb of MAIN segments before symetrization (symetrization in i24surfi)
170 nrtt =nrt+nrt_sh
171C------------------------------------
172C GAP NODES SECONDS
173C------------------------------------
174 ALLOCATE(tagb(numnod))
175 DO i=1,numnod
176 wa(i)=zero
177 ENDDO
178 DO i=1,numelc
179 mg=ixc(6,i)
180 ip = ipartc(i)
181 igtyp = igeo(11,mg)
182 IF ( thk_part(ip) /= zero .AND. iintthick == 0) THEN
183 dx=half*thk_part(ip)
184 ELSEIF ( thk(i) /= zero .AND. iintthick == 0) THEN
185 dx=half*thk(i)
186 ELSEIF(igtyp == 17 .OR. igtyp ==51 .OR. igtyp ==52) THEN
187 dx=half*thk(i)
188 ELSE
189 dx=half*geo(1,mg)
190 ENDIF
191 wa(ixc(2,i))=max(wa(ixc(2,i)),dx)
192 wa(ixc(3,i))=max(wa(ixc(3,i)),dx)
193 wa(ixc(4,i))=max(wa(ixc(4,i)),dx)
194 wa(ixc(5,i))=max(wa(ixc(5,i)),dx)
195 ENDDO
196 DO i=1,numeltg
197 mg=ixtg(5,i)
198 ip = iparttg(i)
199 igtyp = igeo(11,mg)
200 IF ( thk_part(ip) /= zero .AND. iintthick == 0) THEN
201 dx=half*thk_part(ip)
202 ELSEIF ( thk(numelc+i) /= zero .AND. iintthick == 0) THEN
203 dx=half*thk(numelc+i)
204 ELSEIF(igtyp == 17 .OR. igtyp ==51 .OR. igtyp ==52) THEN
205 dx=half*thk(numelc+i)
206 ELSE
207 dx=half*geo(1,mg)
208 ENDIF
209 wa(ixtg(2,i))=max(wa(ixtg(2,i)),dx)
210 wa(ixtg(3,i))=max(wa(ixtg(3,i)),dx)
211 wa(ixtg(4,i))=max(wa(ixtg(4,i)),dx)
212 ENDDO
213C-----for case of coating shell--
214 IF (ilev/=3) THEN
215 DO i=1,numnod
216 tagb(i) = 0
217 END DO
218 DO i=1,nrt
219 IF (msegtyp(i) /= 0) THEN
220 DO j =1,4
221 nn= irect(j,i)
222 tagb(nn) = 1
223 END DO
224 END IF
225 END DO
226 DO i=1,numnod
227 IF (tagb(i)==0) wa(i)=0
228 END DO
229 END IF
230C-------
231 DO i=1,numelt
232 mg=ixt(4,i)
233 ip = ipartt(i)
234 IF ( thk_part(ip) > zero ) THEN
235 dx=half*thk_part(ip)
236 ELSE
237 dx=half*sqrt(geo(1,mg))
238 END IF
239 wa(ixt(2,i))=max(wa(ixt(2,i)),dx)
240 wa(ixt(3,i))=max(wa(ixt(3,i)),dx)
241 ENDDO
242 DO i=1,numelp
243 mg=ixp(5,i)
244 ip = ipartp(i)
245 IF ( thk_part(ip) > zero ) THEN
246 dx=half*thk_part(ip)
247 ELSE
248 dx=half*sqrt(geo(1,mg))
249 END IF
250 wa(ixp(2,i))=max(wa(ixp(2,i)),dx)
251 wa(ixp(3,i))=max(wa(ixp(3,i)),dx)
252 ENDDO
253 DO i=1,numelr
254 ip = ipartr(i)
255 IF ( thk_part(ip) > zero ) THEN
256 mg=ixr(1,i)
257 igtyp = igeo(11,mg)
258 dx=half*thk_part(ip)
259 wa(ixr(2,i))=max(wa(ixr(2,i)),dx)
260 wa(ixr(3,i))=max(wa(ixr(3,i)),dx)
261 IF (igtyp==12) wa(ixr(4,i))=max(wa(ixr(4,i)),dx)
262 END IF
263 ENDDO
264 DO i=1,nsn
265 gap_s(i)=gapscale * wa(nsv(i))
266 gap_s(i)=min(gap_s(i),gapmax_s)
267 ENDDO
268C---------put SECONDARY node on the free edge to GAP=0
269 IF(igap0 > 0)THEN
270 DO i=1,numnod
271 tagb(i)=0
272 ENDDO
273C
274 IF(ilev /= 3 )THEN
275 CALL i24bord(igrsurf2%NSEG ,igrsurf2%NODES ,tagb)
276 ENDIF
277 IF(ilev == 2)THEN
278 CALL i24bord(igrsurf%NSEG ,igrsurf%NODES ,tagb)
279 ENDIF
280 DO i=1,nsn
281 ns = nsv(i)
282 IF( tagb(ns) > 0 ) gap_s(i) = em20
283 ENDDO
284 ENDIF
285C
286 DO i=1,nsn
287 gaps1=max(gaps1,gap_s(i))
288 gaps_mn=min(gaps_mn,gap_s(i))
289 ENDDO
290C calculation of the second surface. ---
291 IF(intth > 0 ) THEN
292 IF(nadmesh==0)THEN
293 DO i = 1,nsn
294 areas(i) = zero
295 DO j= knod2elc(nsv(i))+1,knod2elc(nsv(i)+1)
296 ie = nod2elc(j)
297 sx1 = x(1,ixc(4,ie)) - x(1,ixc(2,ie))
298 sy1 = x(2,ixc(4,ie)) - x(2,ixc(2,ie))
299 sz1 = x(3,ixc(4,ie)) - x(3,ixc(2,ie))
300 sx2 = x(1,ixc(5,ie)) - x(1,ixc(3,ie))
301 sy2 = x(2,ixc(5,ie)) - x(2,ixc(3,ie))
302 sz2 = x(3,ixc(5,ie)) - x(3,ixc(3,ie))
303 sx3 = sy1*sz2 - sz1*sy2
304 sy3 = sz1*sx2 - sx1*sz2
305 sz3 = sx1*sy2 - sy1*sx2
306 areas(i) = areas(i)
307 . + one_over_8*sqrt(sx3*sx3+sy3*sy3+sz3*sz3)
308C overwrite
309 ielec(i) = ixc(1,ie)
310 END DO
311C
312 DO j= knod2eltg(nsv(i))+1,knod2eltg(nsv(i)+1)
313 ie = nod2eltg(j)
314 sx1 = x(1,ixtg(3,ie)) - x(1,ixtg(2,ie))
315 sy1 = x(2,ixtg(3,ie)) - x(2,ixtg(2,ie))
316 sz1 = x(3,ixtg(3,ie)) - x(3,ixtg(2,ie))
317 sx2 = x(1,ixtg(4,ie)) - x(1,ixtg(2,ie))
318 sy2 = x(2,ixtg(4,ie)) - x(2,ixtg(2,ie))
319 sz2 = x(3,ixtg(4,ie)) - x(3,ixtg(2,ie))
320 sx3 = sy1*sz2 - sz1*sy2
321 sy3 = sz1*sx2 - sx1*sz2
322 sz3 = sx1*sy2 - sy1*sx2
323 areas(i) = areas(i)
324 . + one_over_6*sqrt(sx3*sx3+sy3*sy3+sz3*sz3)
325C overwrite
326 ielec(i) = ixtg(1,ie)
327 END DO
328 END DO
329 ELSE
330 DO i = 1,nsn
331 areas(i) = zero
332 DO j= knod2elc(nsv(i))+1,knod2elc(nsv(i)+1)
333 ie = nod2elc(j)
334
335 ip = ipartc(ie)
336 nlev =ipart(10,ip)
337 mylev=sh4tree(3,ie)
338 IF(mylev < 0) mylev=-(mylev+1)
339
340 IF(mylev==nlev)THEN
341 sx1 = x(1,ixc(4,ie)) - x(1,ixc(2,ie))
342 sy1 = x(2,ixc(4,ie)) - x(2,ixc(2,ie))
343 sz1 = x(3,ixc(4,ie)) - x(3,ixc(2,ie))
344 sx2 = x(1,ixc(5,ie)) - x(1,ixc(3,ie))
345 sy2 = x(2,ixc(5,ie)) - x(2,ixc(3,ie))
346 sz2 = x(3,ixc(5,ie)) - x(3,ixc(3,ie))
347 sx3 = sy1*sz2 - sz1*sy2
348 sy3 = sz1*sx2 - sx1*sz2
349 sz3 = sx1*sy2 - sy1*sx2
350 areas(i) = areas(i)
351 . + one_over_8*sqrt(sx3*sx3+sy3*sy3+sz3*sz3)
352C overwrite
353 ielec(i) = ixc(1,ie)
354 END IF
355
356 END DO
357C
358 DO j= knod2eltg(nsv(i))+1,knod2eltg(nsv(i)+1)
359 ie = nod2eltg(j)
360
361 ip = iparttg(ie)
362 nlev =ipart(10,ip)
363 mylev=sh3tree(3,ie)
364 IF(mylev < 0) mylev=-(mylev+1)
365
366 IF(mylev==nlev)THEN
367 sx1 = x(1,ixtg(3,ie)) - x(1,ixtg(2,ie))
368 sy1 = x(2,ixtg(3,ie)) - x(2,ixtg(2,ie))
369 sz1 = x(3,ixtg(3,ie)) - x(3,ixtg(2,ie))
370 sx2 = x(1,ixtg(4,ie)) - x(1,ixtg(2,ie))
371 sy2 = x(2,ixtg(4,ie)) - x(2,ixtg(2,ie))
372 sz2 = x(3,ixtg(4,ie)) - x(3,ixtg(2,ie))
373 sx3 = sy1*sz2 - sz1*sy2
374 sy3 = sz1*sx2 - sx1*sz2
375 sz3 = sx1*sy2 - sy1*sx2
376 areas(i) = areas(i)
377 . + one_over_6*sqrt(sx3*sx3+sy3*sy3+sz3*sz3)
378C overwrite
379 ielec(i) = ixtg(1,ie)
380 END IF
381
382 END DO
383 END DO
384 END IF
385 END IF
386
387C ---- FRUCTION Model Secondary Nodes Parts ------
388C-----------if node connects to both shell and solid -> takes shell
389
390 IF(intfric > 0) THEN
391
392 IF(numels/=0)THEN
393 DO i = 1,nsn
394 ipfmax = 0
395 ipflmax = 0
396 DO j= knod2els(nsv(i))+1,knod2els(nsv(i)+1)
397 ie = nod2els(j)
398 ip = iparts(ie)
399 ipg = tagprt_fric(ip)
400 IF(ipg > 0.AND.ip>ipfmax) THEN
401 CALL friction_parts_search (
402 . ipg,intbuf_fric_tab(intfric)%S_TABPARTS_FRIC,
403 . intbuf_fric_tab(intfric)%TABPARTS_FRIC,ipl)
404 IF(ipl /=0) THEN
405 ipfmax = ip
406 ipflmax = ipl
407 ENDIF
408 ENDIF
409 ENDDO
410C
411C
412 IF(ipfmax/=0) THEN
413 ipartfrics(i) = ipflmax
414 ENDIF
415
416 ENDDO
417 ENDIF
418
419 IF(numelc/=0.OR.numeltg/=0) THEN
420 DO i = 1,nsn
421 ipfmax = 0
422 ipflmax = 0
423 DO j= knod2elc(nsv(i))+1,knod2elc(nsv(i)+1)
424 ie = nod2elc(j)
425 ip = ipartc(ie)
426 ipg = tagprt_fric(ip)
427 IF(ipg > 0.AND.ip>ipfmax) THEN
428 CALL friction_parts_search (
429 . ipg,intbuf_fric_tab(intfric)%S_TABPARTS_FRIC,
430 . intbuf_fric_tab(intfric)%TABPARTS_FRIC,ipl)
431 IF(ipl /=0) THEN
432 ipfmax = ip
433 ipflmax = ipl
434 ENDIF
435 ENDIF
436 ENDDO
437
438C
439 DO j= knod2eltg(nsv(i))+1,knod2eltg(nsv(i)+1)
440 ie = nod2eltg(j)
441 ip = iparttg(ie)
442 ipg = tagprt_fric(ip)
443 IF(ipg > 0.AND.ip>ipfmax) THEN
444 CALL friction_parts_search (
445 . ipg,intbuf_fric_tab(intfric)%S_TABPARTS_FRIC,
446 . intbuf_fric_tab(intfric)%TABPARTS_FRIC,ipl)
447
448 IF(ipl /=0) THEN
449 ipfmax = ip
450 ipflmax = ipl
451 ENDIF
452 ENDIF
453 ENDDO
454C
455 IF(ipfmax/=0) THEN
456 ipartfrics(i) = ipflmax
457 ENDIF
458
459 ENDDO
460 ENDIF
461 ENDIF
462
463C----------------------------------
464C -----NITSCHE method for contact : construction of tabs needed to compute equivalent nodal force------
465 IF(intnitsche > 0 ) THEN
466C IRECTS tab : case NRTS=NRTM, similar to irect
467C but irects (seg -> SECONDARY or MAIN node) / irect (seg -> local node)
468
469 ALLOCATE(tagnod(numnod))
470 tagnod(1:numnod)=0
471 DO nm=1,nmn
472 tagnod(msr(nm))=nm
473 END DO
474
475 DO i=1,nrts
476 DO j=1,4
477 nm = tagnod(irect(j,i))
478 irects(j,i) = nm
479 ENDDO
480 ENDDO
481
482 DEALLOCATE(tagnod)
483
484C IELENRTS tab : Element number for each SECONDARY segment
485 IF (ilev==2) THEN
486 nrt1=igrsurf2%NSEG
487 DO i=1,nrt1
488 nel=igrsurf2%ELEM(i)
489 IF(igrsurf2%ELTYP(i)==1 ) THEN
490 ielnrts(i) = nel
491 ENDIF
492 ENDDO
493 nshiff = nrt1
494 nrt2=igrsurf%NSEG
495 DO i=1,nrt2
496 nel=igrsurf%ELEM(i)
497 IF(igrsurf%ELTYP(i) == 1 ) THEN
498 ielnrts(nshiff+i) = nel
499 ENDIF
500 ENDDO
501 ELSE
502 DO i=1,nrt
503 nel=igrsurf%ELEM(i)
504 IF(igrsurf%ELTYP(i) == 1 ) THEN
505 ielnrts(i) = nel
506 ENDIF
507 ENDDO
508 ENDIF
509
510C ADRECTS tab : address of each SECONDARY node in element connectivity for PARITH/ON computation
511 adrects(1:4,1:nrt) = 0
512 DO i=1,nrt
513 ie = ielnrts(i)
514 n1 = irect(1,i)
515 n2 = irect(2,i)
516 n3 = irect(3,i)
517 n4 = irect(4,i)
518
519
520 IF(ie > 0) THEN
521
522 IF (ie <= numels8 ) THEN
523
524 DO k=1,4
525 DO j=1,8
526 IF(adrects(k,i)==0) THEN
527 n=ixs(j+1,ie)
528 IF(n==irect(k,i)) THEN
529 adrects(k,i) = j
530 ENDIF
531 ENDIF
532 ENDDO
533 ENDDO
534
535 IF(n3==n4) THEN
536 DO k=1,4
537 IF(adrects(k,i) == 5) THEN
538 adrects(k,i) = 6
539 ELSEIF(adrects(k,i) == 6) THEN
540 adrects(k,i) = 5
541 ENDIF
542 ENDDO
543 ENDIF
544
545 ELSEIF(ie <= numels8+numels10 ) THEN
546 DO k=1,3
547 DO j=1,6
548 n=ixs10(j,ie-numels8)
549 IF(n==irect(k,i)) THEN
550 adrects(k,i) = 10 +j
551 ENDIF
552 ENDDO
553 DO j=1,8
554 IF(adrects(k,i)==0) THEN
555
556 n=ixs(j+1,ie)
557 IF(n==irect(k,i)) THEN
558 adrects(k,i) = j
559 ENDIF
560 ENDIF
561 ENDDO
562
563 ENDDO
564 ELSEIF(ie <= numels8+numels10+numels20 ) THEN
565 DO k=1,4
566 DO j=1,12
567 n=ixs20(j,ie-numels8-numels10)
568 IF(n==irect(k,i)) THEN
569 adrects(k,i) = 20 +j
570 ENDIF
571 ENDDO
572 DO j=1,8
573 IF(adrects(k,i)==0) THEN
574 n=ixs(j+1,ie)
575 IF(n==irect(k,i)) THEN
576 adrects(k,i) = j
577 ENDIF
578 ENDIF
579 ENDDO
580 ENDDO
581 ELSEIF(ie <= numels8+numels10+numels20+numels16)THEN
582 DO k=1,4
583 DO j=1,8
584 n=ixs20(j,ie-numels8-numels10-numels20)
585 IF(n==irect(k,i)) THEN
586 adrects(k,i) = 40 +j
587 ENDIF
588 ENDDO
589 DO j=1,8
590 IF(adrects(k,i)==0) THEN
591 n=ixs(j+1,ie)
592 IF(n==irect(k,i)) THEN
593 adrects(k,i) = j
594 ENDIF
595 ENDIF
596 ENDDO
597
598 ENDDO
599 ENDIF
600
601 ENDIF ! IE >0
602
603 ENDDO ! NRTS
604
605C FACNRTS tab : Facet number in element connectuvty for each SECONDARY segment for PARITH/ON computation
606 DO i=1,nrt
607 ie = ielnrts(i)
608 n1 = irect(1,i)
609 n2 = irect(2,i)
610 n3 = irect(3,i)
611 n4 = irect(4,i)
612
613 IF(ie > 0) THEN
614
615 IF(ie<= numels8 ) THEN
616 IF(n3 /= n4) THEN
617 tab1(1) = n1
618 tab1(2) = n2
619 tab1(3) = n3
620 tab1(4) = n4
621 DO k=1,4
622 DO j=1,4-k
623 IF(tab1(j+1) < tab1(j)) THEN
624 perm = tab1(j+1)
625 tab1(j+1) = tab1(j)
626 tab1(j) = perm
627 ENDIF
628 ENDDO
629 ENDDO
630
631 DO fc=1,6
632 tab2(1) = ixs(faces(1,fc)+1,ie)
633 tab2(2) = ixs(faces(2,fc)+1,ie)
634 tab2(3) = ixs(faces(3,fc)+1,ie)
635 tab2(4) = ixs(faces(4,fc)+1,ie)
636 DO k=1,4
637 DO j=1,4-k
638 IF(tab2(j+1) < tab2(j)) THEN
639 perm = tab2(j+1)
640 tab2(j+1) = tab2(j)
641 tab2(j) = perm
642 ENDIF
643 ENDDO
644 ENDDO
645 IF(tab1(1)==tab2(1).AND.tab1(2)==tab2(2).AND.tab1(3)==tab2(3)) THEN
646 facnrts(i) = fc
647 EXIT
648 ENDIF
649 ENDDO
650 ELSE
651 tab1(1) = n1
652 tab1(2) = n2
653 tab1(3) = n3
654
655 DO k=1,3
656 DO j=1,3-k
657 IF(tab1(j+1) < tab1(j)) THEN
658 perm = tab1(j+1)
659 tab1(j+1) = tab1(j)
660 tab1(j) = perm
661 ENDIF
662 ENDDO
663 ENDDO
664
665 DO fc=1,6
666 n1 = ixs(faces(1,fc)+1,ie)
667 n2 = ixs(faces(2,fc)+1,ie)
668 n3 = ixs(faces(3,fc)+1,ie)
669 n4 = ixs(faces(4,fc)+1,ie)
670 tab2(1) =n1
671 IF(n1/=n2.AND.n2/=n3) THEN
672 tab2(2) =n2
673 tab2(3) =n3
674 ELSEIF(n1/=n2) THEN
675 tab2(2) =n2
676 tab2(3) =n4
677 ELSEIF(n2/=n3) THEN
678 tab2(2) =n3
679 tab2(3) =n4
680 ELSE
681 EXIT
682 ENDIF
683 DO k=1,3
684 DO j=1,3-k
685 IF(tab2(j+1) < tab2(j)) THEN
686 perm = tab2(j+1)
687 tab2(j+1) = tab2(j)
688 tab2(j) = perm
689 ENDIF
690 ENDDO
691 ENDDO
692 IF(tab1(1)==tab2(1).AND.tab1(2)==tab2(2).AND.tab1(3)==tab2(3)) THEN
693 facnrts(i) = fc
694 EXIT
695 ENDIF
696 ENDDO
697 ENDIF
698
699 ELSEIF(ie<= numels8+numels10 ) THEN
700 tab1(1) = adrects(1,i)
701 tab1(2) = adrects(2,i)
702 tab1(3) = adrects(3,i)
703 DO k=1,3
704 DO j=1,3-k
705 IF(tab1(j+1) < tab1(j)) THEN
706 perm = tab1(j+1)
707 tab1(j+1) = tab1(j)
708 tab1(j) = perm
709 ENDIF
710 ENDDO
711 ENDDO
712 DO fc=1,16
713 IF(tab1(1)==faces10(1,fc).AND.tab1(2)==faces10(2,fc).AND.tab1(3)==faces10(3,fc)) THEN
714 facnrts(i) = fc
715 EXIT
716 ENDIF
717 ENDDO
718
719 ELSEIF(ie <= numels8+numels10+numels20 ) THEN
720! Not Available Yet
721 ENDIF
722
723 ENDIF ! IE >0
724
725 ENDDO ! NRTS
726
727 ENDIF ! NITSHCHE
728
729C
730C------------------------------------
731C GAP STIF FACES MAIN
732C------------------------------------
733 IF (ilev==2) THEN
734C------------ISU1 first
735 nrt1=igrsurf2%NSEG
736 CALL i24gapm(
737 1 x ,irect ,stf ,ixs ,pm ,
738 2 geo ,nrt1 ,ixc ,nint ,stfac ,
739 3 nty ,gap ,noint ,stfn ,nsn ,
740 4 ms ,nsv ,ixtg ,igap ,gap_m ,
741 6 ixt ,ixp ,slsfac,dxm ,ndx ,
742 9 knod2els ,knod2elc ,knod2eltg ,nod2els ,
743 a nod2elc,nod2eltg ,igrsurf2 ,intth,
744 b ieles ,ielec ,areas ,sh4tree ,sh3tree ,
745 c ipart ,ipartc ,iparttg ,thk ,thk_part ,
746 d ixr ,itab ,bgapsmx ,ixs10 ,msegtyp ,
747 e ixs16 ,ixs20 ,gap_n ,gaps1 ,gaps2 ,
748 f gapmx , gapmn ,gapscale ,nshif ,gapmax_m,
749 g id ,titr ,igeo ,fillsol ,nrtt ,
750 h pm_stack, iworksh,intfric ,tagprt_fric,ipartfrics,
751 i ipartfricm,iparts,intbuf_fric_tab ,elem_linked_to_segment,
752 j igsti , flag_elem_inter25)
753 nrt2=igrsurf%NSEG
754 nshif = nrt1
755 CALL i24gapm(
756 1 x ,irect ,stf ,ixs ,pm ,
757 2 geo ,nrt2 ,ixc ,nint ,stfac ,
758 3 nty ,gap ,noint ,stfn ,nsn ,
759 4 ms ,nsv ,ixtg ,igap ,gap_m ,
760 6 ixt ,ixp ,
761 8 slsfac,dxm ,ndx ,
762 9 knod2els ,knod2elc ,knod2eltg ,nod2els ,
763 a nod2elc,nod2eltg ,igrsurf ,intth,
764 b ieles ,ielec ,areas ,sh4tree ,sh3tree ,
765 c ipart ,ipartc ,iparttg ,thk ,thk_part ,
766 d ixr ,itab ,bgapsmx ,ixs10 ,msegtyp ,
767 e ixs16 ,ixs20 ,gap_n ,gaps1 ,gaps2 ,
768 f gapmx , gapmn ,gapscale ,nshif ,gapmax_m,
769 g id ,titr ,igeo ,fillsol ,nrtt ,
770 h pm_stack , iworksh,intfric,tagprt_fric,ipartfrics,
771 i ipartfricm,iparts,intbuf_fric_tab ,elem_linked_to_segment,
772 j igsti , flag_elem_inter25)
773 ELSE
774 CALL i24gapm(
775 1 x ,irect ,stf ,ixs ,pm ,
776 2 geo ,nrt ,ixc ,nint ,stfac ,
777 3 nty ,gap ,noint ,stfn ,nsn ,
778 4 ms ,nsv ,ixtg ,igap ,gap_m ,
779 6 ixt ,ixp ,slsfac,dxm ,ndx ,
780 9 knod2els ,knod2elc ,knod2eltg ,nod2els ,
781 a nod2elc,nod2eltg ,igrsurf ,intth,
782 b ieles ,ielec ,areas ,sh4tree ,sh3tree ,
783 c ipart ,ipartc ,iparttg ,thk ,thk_part ,
784 d ixr ,itab ,bgapsmx ,ixs10 ,msegtyp ,
785 e ixs16 ,ixs20 ,gap_n ,gaps1 ,gaps2 ,
786 f gapmx , gapmn ,gapscale ,nshif ,gapmax_m,
787 g id ,titr ,igeo ,fillsol ,nrtt ,
788 h pm_stack , iworksh,intfric,tagprt_fric,ipartfrics,
789 i ipartfricm,iparts,intbuf_fric_tab ,elem_linked_to_segment,
790 j igsti , flag_elem_inter25)
791 END IF
792
793
794C---------------------------
795C GAP
796C---------------------------
797 gapmx=sqrt(gapmx)
798 gapmx=min(gapmx,gapmax_m)
799C GAP VARIABLE :
800C - GAPMIN CONTIENT ONE GAP MINIMUM UTILISE SI GAP_S(I)+GAP_M(J) < GAPMIN
801C - GAP CONTIENT LE SUP DE (GAP_S(I)+GAP_M(J),GAPMIN)
802 IF(gap<=zero)THEN
803 IF(ndx/=0)THEN
804 gapmin = gapmn
805 gapmin = min(half*gapmx,gapmin)
806 ELSE
807C GAPMIN = EM01 * GAPMX
808 gapmin = zero
809 ENDIF
810C WRITE(IOUT,1300)GAPMIN
811 ELSE
812 gapmin = gap
813 ENDIF
814C------recalculate GAP_MIN,MAX
815 gapmx=zero
816 gapmn=ep30
817 DO i=1,nrt
818 gapmx=max(gapmx,gap_m(i))
819 gapmn=min(gapmn,gap_m(i))
820 END DO
821 IF(ipri>=1) THEN
822 IF(gap<=zero)THEN
823 WRITE(iout,1400)gaps_mn,gaps1
824 WRITE(iout,1500)gapmn,gapmx
825 END IF
826 END if!(IPRI>=1) THEN
827C REMOVAL OF VARIABLE GAPS
828 gap = gaps1+gaps2
829C---------------------------------------------
830C SETTING TO ONE OF THE NODE STIFFNESS MULTIPLIER
831C---------------------------------------------
832 DO 610 l=1,nsn
833 stfn(l) = one
834 610 CONTINUE
835C
836C Calculation of the real gap to use during the retri criterion
837C
838 bgapsmx = zero
839 gapinf=ep30
840 DO i = 1, nsn
841 gapinf = min(gapinf,gap_s(i))
842 bgapsmx = max(bgapsmx,gap_s(i))
843 ENDDO
844 DO i = 1, nrt
845 gapinf = min(gapinf,gap_m(i))
846 ENDDO
847 gapinf=max(gapinf,gapmin)
848C--- MVOISN is used temporarily for Pen_ini MVOISN(1,*) -> MTYPE(solid),MVOISN(2,*) -> E_id
849 DO i=1,nrt
850 CALL insol3et(x ,irect ,ixs ,nint ,mvoisn(2,i),i ,
851 . area ,noint ,knod2els,nod2els,ixs10 ,
852 . ixs16,ixs20 ,mvoisn(1,i))
853C-------supposing only small segments (sub-triangles) for 10 nodes tetras --------------
854 IF (mvoisn(1,i)==10) THEN
855C---Verify this factor 3-------------
856 gap_n(1,i) = three*one_over_8*gap_n(1,i)
857 stf(i) = sixteen*stf(i)
858 ELSEIF (mvoisn(1,i)==16) THEN
859 gap_n(1,i) = gap_n(1,i)/4
860 END IF
861 END DO
862C-----reset MSEGTYP(I)=0 for coating shell, engine uses MSEGTYP only for symmetry
863C------do it at end of init3, used for i24pen3....
864c DO I=1,NRT
865c IF (MSEGTYP(I)==-4.OR.MSEGTYP(I)==-8) MSEGTYP(I) =0
866c END DO
867C------initialize MSEGTYP and asymmetric shell part
868c IAD=ISURF(3)+1
869c CALL I24NIMTYP(NRT ,IBUFSSG(IAD),MSEGTYP,NRT_SH)
870 IF (nrt_sh>0) THEN
871 j=nrt
872 DO i=1,nrt
873 IF (msegtyp(i) > 0 .AND.msegtyp(i)<=nrtt ) THEN
874 j = j + 1
875 stf(j) = stf(i)
876 gap_m(j)=gap_m(i)
877 IF(intth > 0 ) ieles(j) = ieles(i)
878 IF(intfric > 0) ipartfricm(j)=ipartfricm(i)
879 END IF
880 END DO
881 END IF
882c print*,'NOINT',NOINT, BGAPSMX
883C---------------------------------------------
884C CALCULATE NODAL NORMAL FOR SECONDARY NODES
885C---------------------------------------------
886 IF (inacti/=0) THEN
887 CALL i24normns(
888 1 x ,irect ,nrt ,nsn ,nsv ,pen_old, stf)
889C------nodal part_id
890 DO i=1,numnod
891 tagb(i)=0
892 ENDDO
893C-----------if node connects to both shell and solid -> take solid's
894 DO i=1,numelc
895 ip = ipartc(i)
896 DO j=1,4
897 tagb(ixc(1+j,i))=ip
898 ENDDO
899 ENDDO
900 DO i=1,numeltg
901 ip = iparttg(i)
902 DO j=1,3
903 tagb(ixtg(1+j,i))=ip
904 ENDDO
905 ENDDO
906C----factulative for Truss and beam
907c DO I=1,NUMELT
908c IP = IPARTT(I)
909c TAGB(IXT(2,I))=IP
910c TAGB(IXT(3,I))=IP
911c ENDDO
912c DO I=1,NUMELP
913c IP = IPARTP(I)
914c TAGB(IXP(2,I))=IP
915c TAGB(IXP(3,I))=IP
916c ENDDO
917C-------solid elements
918 DO i=1,nrt
919 IF (mvoisn(2,i)>0) THEN
920 ip = iparts(mvoisn(2,i))
921 mvoisn(3,i) =ip
922 DO j=1,4
923 tagb(irect(j,i))=ip
924 ENDDO
925 END IF
926 END DO
927 DO i=1,nsn
928 ns = nsv(i)
929 ipartns(i) = tagb(ns)
930C-------to not have wrong equality IPART_NS=IPART_E with 0
931 IF (ipartns(i)==0) ipartns(i) =-1
932 ENDDO
933C-------shell elements
934 j=nrt
935 DO i=1,nrt
936 IF (msegtyp(i) > 0 .AND.msegtyp(i)<=nrtt) THEN
937 j = j + 1
938 ip = tagb(irect(1,i))
939 mvoisn(3,i) =ip
940 mvoisn(3,j) =ip
941 END IF
942 END DO
943 END IF
944
945 DEALLOCATE(tagb)
946 RETURN
947
948 1400 FORMAT(2x,'MIN,MAX OF SECONDARY GAP: ',2(1pg20.13))
949 1500 FORMAT(2x,'MIN,MAX OF MAIN GAP: ',2(1pg20.13)/)
950 END
951!||====================================================================
952!|| insol3et ../starter/source/interfaces/inter3d1/i24sti3.F
953!||--- called by ------------------------------------------------------
954!|| i24sti3 ../starter/source/interfaces/inter3d1/i24sti3.F
955!|| i25sti3 ../starter/source/interfaces/inter3d1/i25sti3.F
956!|| remn_self24 ../starter/source/interfaces/inter3d1/remn_self24.F
957!||--- uses -----------------------------------------------------
958!||====================================================================
959 SUBROUTINE insol3et(X ,IRECT ,IXS ,NINT ,NEL,I ,
960 . AREA ,NOINT ,KNOD2ELS,NOD2ELS,IXS10 ,
961 . IXS16,IXS20 ,NNOD )
962 use element_mod , only : nixs
963C-----------------------------------------------
964C I m p l i c i t T y p e s
965C-----------------------------------------------
966#include "implicit_f.inc"
967C-----------------------------------------------
968C C o m m o n B l o c k s
969C-----------------------------------------------
970#include "com04_c.inc"
971C-----------------------------------------------
972C D u m m y A r g u m e n t s
973C-----------------------------------------------
974 INTEGER NINT, NEL, I, NOINT,NNOD
975 my_real
976 . AREA
977 INTEGER IRECT(4,*), IXS(NIXS,*), KNOD2ELS(*), NOD2ELS(*),
978 . IXS10(6,*), IXS16(8,*), IXS20(12,*)
979 my_real
980 . x(3,*)
981C-----------------------------------------------
982C L o c a l V a r i a b l e s
983C-----------------------------------------------
984 INTEGER N, JJ, II, K, IC, IAD,
985 . NUSER, NUSERM
986C REAL
987
988
989C-----------------------------------------------
990C E x t e r n a l F u n c t i o n s
991C-----------------------------------------------
992C
993 NEL=0
994 ic=0
995 nnod = 0
996 IF(numels==0) RETURN
997 nuserm = -1
998 DO 230 iad=knod2els(irect(1,i))+1,knod2els(irect(1,i)+1)
999 n = nod2els(iad)
1000 IF(n <= numels8)THEN
1001 DO 210 jj=1,4
1002 ii=irect(jj,i)
1003 DO k=1,8
1004 IF(ixs(k+1,n)==ii) GOTO 210
1005 ENDDO
1006 GOTO 230
1007 210 CONTINUE
1008 ic=ic+1
1009 nuser = ixs(11,n)
1010 IF (nuser>nuserm) THEN
1011 nel = n
1012 nuserm = nuser
1013 ENDIF
1014 nnod = 8
1015 ELSEIF(n <= numels8+numels10)THEN
1016 DO 220 jj=1,4
1017 ii=irect(jj,i)
1018 DO k=1,8
1019 IF(ixs(k+1,n)==ii) GOTO 220
1020 ENDDO
1021 DO k=1,6
1022 IF(ixs10(k,n-numels8)==ii) GOTO 220
1023 ENDDO
1024 GOTO 230
1025 220 CONTINUE
1026 ic=ic+1
1027 nuser = ixs(11,n)
1028 IF (nuser>nuserm) THEN
1029 nel = n
1030 nuserm = nuser
1031 ENDIF
1032 nnod = 10
1033 ELSEIF(n <= numels8+numels10+numels20)THEN
1034 DO 222 jj=1,4
1035 ii=irect(jj,i)
1036 DO k=1,8
1037 IF(ixs(k+1,n)==ii) GOTO 222
1038 ENDDO
1039 DO k=1,12
1040 IF(ixs20(k,n-numels8-numels10)==ii) GOTO 222
1041 ENDDO
1042 GOTO 230
1043 222 CONTINUE
1044 ic=ic+1
1045 nuser = ixs(11,n)
1046 IF (nuser>nuserm) THEN
1047 nel = n
1048 nuserm = nuser
1049 ENDIF
1050 nnod = 20
1051 ELSEIF(n <= numels8+numels10+numels20+numels16)THEN
1052 DO 224 jj=1,4
1053 ii=irect(jj,i)
1054 DO k=1,8
1055 IF(ixs(k+1,n)==ii) GOTO 224
1056 ENDDO
1057 DO k=1,8
1058 IF(ixs16(k,n-numels8-numels10-numels20)==ii) GOTO 224
1059 ENDDO
1060 GOTO 230
1061 224 CONTINUE
1062 ic=ic+1
1063 nuser = ixs(11,n)
1064 IF (nuser>nuserm) THEN
1065 nel = n
1066 nuserm = nuser
1067 ENDIF
1068 nnod = 16
1069 ELSE
1070 GOTO 230
1071 END IF
1072 230 CONTINUE
1073C-----------------------------------------------
1074 RETURN
1075 END
1076!||====================================================================
1077!|| i24gapm ../starter/source/interfaces/inter3d1/i24sti3.F
1078!||--- called by ------------------------------------------------------
1079!|| i24sti3 ../starter/source/interfaces/inter3d1/i24sti3.F
1080!||--- calls -----------------------------------------------------
1081!|| ancmsg ../starter/source/output/message/message.F
1082!|| friction_parts_search ../starter/source/interfaces/inter3d1/i7sti3.F
1083!|| i4gmx3 ../starter/source/interfaces/inter3d1/i4gmx3.F
1084!|| incoq3 ../starter/source/interfaces/inter3d1/incoq3.F
1085!|| ineltc ../starter/source/interfaces/inter3d1/inelt.F
1086!|| inelts_np ../starter/source/interfaces/inter3d1/i24sti3.F
1087!|| insol3d ../starter/source/interfaces/inter3d1/insol3.F
1088!|| volint ../starter/source/interfaces/inter3d1/volint.F
1089!||--- uses -----------------------------------------------------
1090!|| message_mod ../starter/share/message_module/message_mod.F
1091!||====================================================================
1092 SUBROUTINE i24gapm(
1093 1 X ,IRECT ,STF ,IXS ,PM ,
1094 2 GEO ,NRT ,IXC ,NINT ,STFAC ,
1095 3 NTY ,GAP ,NOINT ,STFN ,NSN ,
1096 4 MS ,NSV ,IXTG ,IGAP ,GAP_M ,
1097 6 IXT ,IXP ,SLSFAC,DXM ,NDX ,
1098 9 KNOD2ELS ,KNOD2ELC ,KNOD2ELTG ,NOD2ELS ,
1099 A NOD2ELC,NOD2ELTG ,IGRSURF ,INTTH,
1100 B IELES ,IELEC ,AREAS ,SH4TREE ,SH3TREE ,
1101 C IPART ,IPARTC ,IPARTTG ,THK ,THK_PART ,
1102 D IXR ,ITAB ,BGAPSMX ,IXS10 ,MSEGTYP ,
1103 E IXS16 ,IXS20 ,GAP_N ,GAPS1 ,GAPS2 ,
1104 F GAPMX , GAPMN ,GAPSCALE ,NSHIFT ,GAPMAX_M,
1105 G ID ,TITR ,IGEO ,FILLSOL ,NRTT ,
1106 H PM_STACK , IWORKSH ,INTFRIC,TAGPRT_FRIC,IPARTFRICS,
1107 I IPARTFRICM,IPARTS,INTBUF_FRIC_TAB,ELEM_LINKED_TO_SEGMENT,IGSTI,
1108 J FLAG_ELEM_INTER25 )
1109C-----------------------------------------------
1110C M o d u l e s
1111C-----------------------------------------------
1112 USE my_alloc_mod
1113 USE message_mod
1114 USE intbuf_fric_mod
1115 USE groupdef_mod
1116 use element_mod , only : nixs,nixc,nixtg,nixt,nixp,nixr
1117C-----------------------------------------------
1118C I m p l i c i t T y p e s
1119C-----------------------------------------------
1120#include "implicit_f.inc"
1121C-----------------------------------------------
1122C C o m m o n B l o c k s
1123C-----------------------------------------------
1124#include "com01_c.inc"
1125#include "com04_c.inc"
1126#include "param_c.inc"
1127#include "scr17_c.inc"
1128#include "scr08_c.inc"
1129C-----------------------------------------------
1130C D u m m y A r g u m e n t s
1131C-----------------------------------------------
1132 INTEGER NRT, NINT, NTY, NOINT,NSN,IGAP, NDDIM,NDX,INTFRIC,IGSTI
1133 INTEGER IRECT(4,*), IXS(NIXS,*), IXC(NIXC,*),
1134 . NSV(*), IXTG(NIXTG,*), IXT(NIXT,*), IXP(NIXP,*),
1135 . KNOD2ELS(*), KNOD2ELC(*), KNOD2ELTG(*), NOD2ELS(*), NOD2ELC(*),
1136 . NOD2ELTG(*), IELES(*), INTTH, IELEC(*),
1137 . SH3TREE(KSH3TREE,*), SH4TREE(KSH4TREE,*),IXR(NIXR,*) ,
1138 . IPART(LIPART1,*), IPARTC(*), IPARTTG(*),
1139 . ITAB(*), IXS10(6,*),MSEGTYP(*), IXS16(*), IXS20(*),NSHIFT,
1140 . IGEO(NPROPGI,*),NRTT,IWORKSH(3,*),TAGPRT_FRIC(*),IPARTFRICS(*),
1141 . IPARTFRICM(*),IPARTS(*)
1142 INTEGER, DIMENSION(NUMELS), INTENT(INOUT):: ELEM_LINKED_TO_SEGMENT !< working array, dim=numels
1143C REAL
1144 my_real
1145 . STFAC, GAP,BGAPSMX,GAPS1 ,GAPS2,GAPMX ,GAPMN ,GAPSCALE
1146C REAL
1147 my_real
1148 . X(3,*), STF(*), PM(NPROPM,*), GEO(NPROPG,*), STFN(*),
1149 . ms(*),gap_m(*),gap_n(12,*),
1150 . areas(*),thk(*),thk_part(*),slsfac,dxm ,gapmax_m, fillsol(*),
1151 . pm_stack(3,*)
1152 INTEGER ID
1153 CHARACTER(LEN=NCHARTITLE) :: TITR
1154 TYPE(INTBUF_FRIC_STRUCT_) INTBUF_FRIC_TAB(*)
1155 TYPE (SURF_) :: IGRSURF
1156 INTEGER, INTENT(IN) :: FLAG_ELEM_INTER25(NINTER25,NUMELS)
1157C-----------------------------------------------
1158C L o c a l V a r i a b l e s
1159C-----------------------------------------------
1160 INTEGER I, J, INRT, NELS, MT, JJ, JJJ, NELC,
1161 . MG, NELTG,
1162 . IP, NREV,IGTYP,IPGMAT,IGMAT,
1163 . ISUBSTACK,IPL,IPG,NINV,ICONTR,NIN25
1164 INTEGER, DIMENSION(:),ALLOCATABLE :: TAGELEMS,INDEXE
1165C REAL
1166 my_real
1167 . AREA, VOL, DX, GAPM, DDX,
1168 . ST,BULK
1169 INTEGER :: IELEM(2)
1170 LOGICAL :: PRINT_ERROR
1171 INTEGER, DIMENSION(4) :: NODE_ID
1172C----------------------
1173 NREV=0
1174 ipgmat = 700
1175 IF(numels > 0) THEN
1176 CALL my_alloc(tagelems,numels)
1177 tagelems = 0
1178 CALL my_alloc(indexe,numels)
1179 indexe = 0
1180 ENDIF
1181 ninv = 0
1182 DO i=1+nshift,nrt+nshift
1183 stf(i)=zero
1184 IF(intth > 0 ) ieles(i) = 0
1185 IF(slsfac<zero)stf(i)=slsfac
1186 gapm =zero
1187 gap_m(i)=gapm
1188 inrt=i-nshift
1189 CALL i4gmx3(x,irect,i,gapmx)
1190C-----------------to avoid too much print-out in 0.out file
1191 CALL inelts_np(x ,irect(1,1+nshift),ixs ,nrev ,nels ,
1192 . inrt ,area ,noint,0 ,igrsurf%ELTYP,
1193 . igrsurf%ELEM)
1194 IF(nels/=0)THEN
1195 mt=ixs(1,nels)
1196 mg=ixs(nixs-1,nels)
1197 icontr = igeo(97,mg)
1198 IF(mt>0)THEN
1199 DO jj=1,8
1200 jjj=ixs(jj+1,nels)
1201 xc(jj)=x(1,jjj)
1202 yc(jj)=x(2,jjj)
1203 zc(jj)=x(3,jjj)
1204 END DO
1205 CALL volint(vol)
1206 IF (icontr==1 .OR. igsti==-1) THEN
1207 bulk = pm(107,mt)
1208! IF (ICONTR==1 ) BULK = HUNDRED*BULK
1209 ELSE
1210 bulk = pm(32,mt)
1211 END IF
1212 stf(i)=slsfac*fillsol(nels)*area*area*bulk/vol
1213 ELSE
1214 IF(nint>=0) THEN
1215 CALL ancmsg(msgid=95,
1216 . msgtype=msgwarning,
1217 . anmode=aninfo_blind_2,
1218 . i1=id,
1219 . c1=titr,
1220 . i2=ixs(nixs,nels),
1221 . c2='SOLID',
1222 . i3=i)
1223 ENDIF
1224 IF(nint<0) THEN
1225 CALL ancmsg(msgid=96,
1226 . msgtype=msgwarning,
1227 . anmode=aninfo_blind_2,
1228 . i1=id,
1229 . c1=titr,
1230 . i2=ixs(nixs,nels),
1231 . c2='SOLID',
1232 . i3=i)
1233 ENDIF
1234 ENDIF
1235 gap_n(1,i)=vol/area
1236C -----Friction model ------
1237 IF(intfric > 0) THEN
1238 ip= iparts(nels)
1239 ipg = tagprt_fric(ip)
1240 IF(ipg > 0) THEN
1241 CALL friction_parts_search (
1242 . ipg,intbuf_fric_tab(intfric)%S_TABPARTS_FRIC,
1243 . intbuf_fric_tab(intfric)%TABPARTS_FRIC,ipl)
1244 ipartfricm(i) = ipl
1245 ENDIF
1246 ENDIF
1247C------------------------------------
1248 cycle
1249 ELSE
1250 CALL ineltc(nelc ,neltg ,inrt ,igrsurf%ELTYP, igrsurf%ELEM)
1251 IF(neltg/=0) THEN
1252 mt=ixtg(1,neltg)
1253 mg=ixtg(5,neltg)
1254 igtyp = igeo(11,mg)
1255 igmat = igeo(98,mg)
1256 ip = iparttg(neltg)
1257 IF ( thk_part(ip) /= zero .AND. iintthick == 0) THEN
1258 dx=thk_part(ip)*gapscale
1259 ELSEIF ( thk(numelc+neltg) /= zero .AND. iintthick==0)THEN
1260 dx=thk(numelc+neltg)*gapscale
1261 ELSEIF(igtyp == 17 .OR. igtyp == 51 .OR. igtyp ==52) THEN
1262 dx=thk(numelc+neltg)*gapscale
1263 ELSE
1264 dx=geo(1,mg)*gapscale
1265 ENDIF
1266 gapm=half*dx
1267 gaps2=max(gaps2,gapm)
1268 gapmn = min(gapmn,dx)
1269 dxm=dxm+dx
1270 ndx=ndx+1
1271 IF(mt>0)THEN
1272 IF(igtyp == 11 .AND. igmat > 0) THEN
1273 IF ( thk(numelc+neltg) /= zero .AND. iintthick ==0)THEN
1274 stf(i)=slsfac*thk(numelc+neltg)*geo(ipgmat + 2 ,mg)
1275 ELSE
1276 stf(i)=slsfac*geo(1,mg)*geo(ipgmat + 2 ,mg)
1277 ENDIF
1278 ELSEIF(igtyp ==52 .OR.
1279 . ((igtyp == 17 .OR. igtyp == 51) .AND. igmat > 0))THEN
1280 isubstack = iworksh(3,numelc+neltg)
1281 st=pm_stack(2,isubstack)
1282 stf(i)=slsfac*thk(numelc+neltg)*st
1283 ELSE
1284 IF ( thk(numelc+neltg) /= zero .AND. iintthick ==0)THEN
1285 stf(i)=slsfac*thk(numelc+neltg)*pm(20,mt)
1286 ELSEIF(igtyp == 17 .OR. igtyp == 51) THEN
1287 stf(i)=slsfac*thk(numelc+neltg)*pm(20,mt)
1288 ELSE
1289 stf(i)=slsfac*geo(1,mg)*pm(20,mt)
1290 ENDIF
1291 ENDIF
1292 ELSE
1293 IF(nint>=0) THEN
1294 CALL ancmsg(msgid=95,
1295 . msgtype=msgwarning,
1296 . anmode=aninfo_blind_2,
1297 . i1=id,
1298 . c1=titr,
1299 . i2=ixtg(nixtg,neltg),
1300 . c2='SHELL',
1301 . i3=i)
1302 END IF
1303 IF(nint<0) THEN
1304 CALL ancmsg(msgid=96,
1305 . msgtype=msgwarning,
1306 . anmode=aninfo_blind_2,
1307 . i1=id,
1308 . c1=titr,
1309 . i2=ixtg(nixtg,neltg),
1310 . c2='SHELL',
1311 . i3=i)
1312 END IF
1313 END IF
1314 gap_m(i)=gapm
1315C ----Friction model ------
1316 IF(intfric > 0) THEN
1317 ip= iparttg(neltg)
1318 ipg = tagprt_fric(ip)
1319 IF(ipg > 0) THEN
1320 CALL friction_parts_search (
1321 . ipg,intbuf_fric_tab(intfric)%S_TABPARTS_FRIC,
1322 . intbuf_fric_tab(intfric)%TABPARTS_FRIC,ipl)
1323 ipartfricm(i) = ipl
1324 ENDIF
1325 ENDIF
1326C-------coating shell stif=max(sol,shell)
1327 IF (msegtyp(i)>nrtt) THEN
1328 print_error = .false.
1329 nin25 = 0
1330 CALL insol3d(x,irect,ixs,nint,nels,i ,
1331 . area,noint,knod2els ,nod2els ,0,
1332 . ixs10,ixs16,ixs20,tagelems,indexe,
1333 . ninv,ielem,elem_linked_to_segment,print_error,
1334 . nin25,nty, flag_elem_inter25 )
1335 IF(print_error) THEN
1336 node_id(1:4) = itab(irect(1:4,i))
1337
1338 CALL ancmsg(msgid=3062,
1339 . msgtype=msgwarning,
1340 . anmode=aninfo_blind_1,
1341 . i1=id,
1342 . i2=node_id(1),
1343 . i3=node_id(2),
1344 . i4=node_id(3),
1345 . i5=node_id(4),
1346 . c1=titr ,
1347 . prmod=msg_print)
1348 ENDIF
1349 IF(nels/=0) THEN
1350 mt=ixs(1,nels)
1351 IF(mt>0)THEN
1352 DO jj=1,8
1353 jjj=ixs(jj+1,nels)
1354 xc(jj)=x(1,jjj)
1355 yc(jj)=x(2,jjj)
1356 zc(jj)=x(3,jjj)
1357 END DO
1358 CALL volint(vol)
1359 stf(i)=max(stf(i),slsfac*area*area*pm(32,mt)/vol)
1360 gap_n(1,i)=vol/area
1361 END IF
1362C ----Friction model ------
1363 IF(intfric > 0) THEN
1364 ip= iparts(nels)
1365 ipg = tagprt_fric(ip)
1366 IF(ipg > 0) THEN
1367 CALL friction_parts_search (
1368 . ipg,intbuf_fric_tab(intfric)%S_TABPARTS_FRIC,
1369 . intbuf_fric_tab(intfric)%TABPARTS_FRIC,ipl)
1370 ipartfricm(i) = ipl
1371 ENDIF
1372 ENDIF
1373 END if!(NELS/=0) THEN
1374 END IF !(MSEGTYP==8) THEN
1375
1376 cycle
1377 ELSEIF(nelc/=0) THEN
1378 mt=ixc(1,nelc)
1379 mg=ixc(6,nelc)
1380 igtyp=igeo(11,mg)
1381 igmat = igeo(98,mg)
1382 ip = ipartc(nelc)
1383 IF ( thk_part(ip) /= zero .AND. iintthick == 0) THEN
1384 dx=thk_part(ip)*gapscale
1385 ELSEIF ( thk(nelc) /= zero .AND. iintthick == 0) THEN
1386 dx=thk(nelc)*gapscale
1387 ELSEIF(igtyp == 17 .OR. igtyp == 51 .OR. igtyp ==52)THEN
1388 dx=thk(nelc)*gapscale
1389 ELSE
1390 dx=geo(1,mg)*gapscale
1391 ENDIF
1392 gapm=half*dx
1393 gaps2=max(gaps2,gapm)
1394 gapmn = min(gapmn,dx)
1395 dxm=dxm+dx
1396 ndx=ndx+1
1397 IF(mt>0)THEN
1398 IF(igtyp == 11 .AND. igmat > 0) THEN
1399 IF ( thk(nelc) /= zero .AND. iintthick == 0) THEN
1400 stf(i)=slsfac*thk(nelc)*geo(ipgmat + 2 ,mg)
1401 ELSE
1402 stf(i)=slsfac*geo(1,mg)*geo(ipgmat + 2 ,mg)
1403 ENDIF
1404 ELSEIF(igtyp ==52 .OR.
1405 . ((igtyp == 17 .OR. igtyp == 51) .AND. igmat > 0))THEN
1406 isubstack = iworksh(3,nelc)
1407 st=pm_stack(2,isubstack)
1408 stf(i)=slsfac*thk(nelc)*st
1409 ELSE
1410 IF ( thk(nelc) /= zero .AND. iintthick == 0) THEN
1411 stf(i)=slsfac*thk(nelc)*pm(20,mt)
1412 ELSEIF(igtyp == 17 .OR. igtyp ==51) THEN
1413 stf(i)=slsfac*thk(nelc)*pm(20,mt)
1414 ELSE
1415 stf(i)=slsfac*geo(1,mg)*pm(20,mt)
1416 ENDIF
1417 ENDIF
1418 ELSE
1419 IF(nint>=0) THEN
1420 CALL ancmsg(msgid=95,
1421 . msgtype=msgwarning,
1422 . anmode=aninfo_blind_2,
1423 . i1=id,
1424 . c1=titr,
1425 . i2=ixc(nixc,nelc),
1426 . c2='SHELL',
1427 . i3=i)
1428 END IF
1429 IF(nint<0) THEN
1430 CALL ancmsg(msgid=96,
1431 . msgtype=msgwarning,
1432 . anmode=aninfo_blind_2,
1433 . i1=id,
1434 . c1=titr,
1435 . i2=ixc(nixc,nelc),
1436 . c2='SHELL',
1437 . i3=i)
1438 END IF
1439 END IF
1440 gap_m(i)=gapm
1441C -----Friction model ------
1442 IF(intfric > 0) THEN
1443 ip= ipartc(nelc)
1444 ipg = tagprt_fric(ip)
1445 IF(ipg > 0) THEN
1446 CALL friction_parts_search (
1447 . ipg,intbuf_fric_tab(intfric)%S_TABPARTS_FRIC,
1448 . intbuf_fric_tab(intfric)%TABPARTS_FRIC,ipl )
1449 ipartfricm(i) = ipl
1450 ENDIF
1451 ENDIF
1452C------------------------------------
1453C-------coating shell stif=max(sol,shell)
1454 IF (msegtyp(i)>nrtt) THEN
1455 print_error = .false.
1456 nin25 = 0
1457 CALL insol3d(x,irect,ixs,nint,nels,i ,
1458 . area,noint,knod2els ,nod2els ,0,
1459 . ixs10,ixs16,ixs20,tagelems,indexe ,
1460 . ninv,ielem,elem_linked_to_segment,print_error,
1461 . nin25,nty, flag_elem_inter25)
1462 IF(print_error) THEN
1463 node_id(1:4) = itab(irect(1:4,i))
1464
1465 CALL ancmsg(msgid=3062,
1466 . msgtype=msgwarning,
1467 . anmode=aninfo_blind_1,
1468 . i1=id,
1469 . i2=node_id(1),
1470 . i3=node_id(2),
1471 . i4=node_id(3),
1472 . i5=node_id(4),
1473 . c1=titr ,
1474 . prmod=msg_print)
1475 ENDIF
1476 IF(nels/=0) THEN
1477 mt=ixs(1,nels)
1478 IF(mt>0)THEN
1479 DO jj=1,8
1480 jjj=ixs(jj+1,nels)
1481 xc(jj)=x(1,jjj)
1482 yc(jj)=x(2,jjj)
1483 zc(jj)=x(3,jjj)
1484 END DO
1485 CALL volint(vol)
1486 stf(i)=max(stf(i),slsfac*area*area*pm(32,mt)/vol)
1487 gap_n(1,i)=vol/area
1488 END IF
1489C -----Friction model ------
1490 IF(intfric > 0) THEN
1491 ip= iparts(nels)
1492 ipg = tagprt_fric(ip)
1493 IF(ipg > 0) THEN
1494 CALL friction_parts_search (
1495 . ipg,intbuf_fric_tab(intfric)%S_TABPARTS_FRIC,
1496 . intbuf_fric_tab(intfric)%TABPARTS_FRIC,ipl )
1497 ipartfricm(i) = ipl
1498 ENDIF
1499 ENDIF
1500C------------------------------------
1501 END if!(NELS/=0) THEN
1502 END IF !(MSEGTYP==8) THEN
1503 cycle
1504 END IF
1505 END IF
1506C----------------------
1507C ELEMENTS SOLIDES
1508C----------------------
1509 print_error = .false.
1510 nin25 = 0
1511 CALL insol3d(x,irect,ixs,nint,nels,i ,
1512 . area,noint,knod2els ,nod2els ,0,
1513 . ixs10,ixs16,ixs20,tagelems,indexe,
1514 . ninv ,ielem,elem_linked_to_segment,print_error,
1515 . nin25,nty, flag_elem_inter25)
1516 IF(print_error) THEN
1517 node_id(1:4) = itab(irect(1:4,i))
1518
1519 CALL ancmsg(msgid=3062,
1520 . msgtype=msgwarning,
1521 . anmode=aninfo_blind_1,
1522 . i1=id,
1523 . i2=node_id(1),
1524 . i3=node_id(2),
1525 . i4=node_id(3),
1526 . i5=node_id(4),
1527 . c1=titr ,
1528 . prmod=msg_print)
1529 ENDIF
1530 IF(nels/=0) THEN
1531 mt=ixs(1,nels)
1532 IF(intth > 0 ) ieles(i) = nels
1533 IF(mt>0)THEN
1534 DO jj=1,8
1535 jjj=ixs(jj+1,nels)
1536 xc(jj)=x(1,jjj)
1537 yc(jj)=x(2,jjj)
1538 zc(jj)=x(3,jjj)
1539 ENDDO
1540 CALL volint(vol)
1541 stf(i)=slsfac*fillsol(nels)*area*area*pm(32,mt)/vol
1542 ELSE
1543 IF(nint>=0) THEN
1544 CALL ancmsg(msgid=95,
1545 . msgtype=msgwarning,
1546 . anmode=aninfo_blind_2,
1547 . i1=id,
1548 . c1=titr,
1549 . i2=ixs(nixs,nels),
1550 . c2='SOLID',
1551 . i3=i)
1552 ENDIF
1553 IF(nint<0) THEN
1554 CALL ancmsg(msgid=96,
1555 . msgtype=msgwarning,
1556 . anmode=aninfo_blind_2,
1557 . i1=id,
1558 . c1=titr,
1559 . i2=ixs(nixs,nels),
1560 . c2='SOLID',
1561 . i3=i)
1562 ENDIF
1563 ENDIF
1564 gap_n(1,i)=vol/area
1565C -----Friction model ------
1566 IF(intfric > 0) THEN
1567 ip= iparts(nels)
1568 ipg = tagprt_fric(ip)
1569 IF(ipg > 0) THEN
1570 CALL friction_parts_search (
1571 . ipg,intbuf_fric_tab(intfric)%S_TABPARTS_FRIC,
1572 . intbuf_fric_tab(intfric)%TABPARTS_FRIC,ipl)
1573 ipartfricm(i) = ipl
1574 ENDIF
1575 ENDIF
1576C----------------------------------
1577C-------add correction for different element
1578 ENDIF
1579C---------------------
1580C ELEMENTS COQUES
1581C---------------------
1582 CALL incoq3(irect,ixc ,ixtg ,nint ,nelc ,
1583 . neltg,i ,geo ,pm ,knod2elc ,
1584 . knod2eltg ,nod2elc ,nod2eltg,thk,nty,igeo,
1585 . pm_stack , iworksh )
1586 IF(neltg/=0) THEN
1587C
1588 mt=ixtg(1,neltg)
1589 mg=ixtg(5,neltg)
1590 igtyp = igeo(11,mg)
1591 ip = iparttg(neltg)
1592 IF ( thk_part(ip) /= zero .AND. iintthick == 0) THEN
1593 dx=thk_part(ip)*gapscale
1594 ELSEIF ( thk(numelc+neltg) /= zero .AND. iintthick == 0)THEN
1595 dx=thk(numelc+neltg)*gapscale
1596 ELSEIF(igtyp == 17 .OR. igtyp ==51 .OR. igtyp ==52) THEN
1597 dx=thk(numelc+neltg)*gapscale
1598 ELSE
1599 dx=geo(1,mg)*gapscale
1600 ENDIF
1601 gapm=half*dx
1602 gaps2=max(gaps2,gapm)
1603 gapmn = min(gapmn,dx)
1604 dxm=dxm+dx
1605 ndx=ndx+1
1606 gap_m(i)=max(gap_m(i),gapm)
1607 IF(mt>0)THEN
1608 IF(igtyp ==11 .AND. igmat > 0) THEN
1609 IF ( thk(numelc+neltg) /= zero .AND. iintthick == 0) THEN
1610 stf(i)=slsfac*thk(numelc+neltg)*geo(ipgmat + 2 ,mg)
1611 ELSE
1612 stf(i)=slsfac*geo(1,mg)*geo(ipgmat + 2 ,mg)
1613 ENDIF
1614 ELSEIF(igtyp == 52 .OR.
1615 . ((igtyp == 17 .OR. igtyp == 51).AND.igmat >0)) THEN
1616 isubstack = iworksh(3,numelc+neltg)
1617 stf(i)=slsfac*thk(numelc+neltg)*pm_stack( 2 ,isubstack)
1618 ELSE
1619 IF ( thk(numelc+neltg) /= zero .AND. iintthick == 0) THEN
1620 stf(i)=max(stf(i),slsfac*thk(numelc+neltg)*pm(20,mt))
1621 ELSEIF(igtyp == 17 .OR. igtyp ==51) THEN
1622 stf(i)=max(stf(i),slsfac*thk(numelc+neltg)*pm(20,mt))
1623 ELSE
1624 stf(i)=max(stf(i),slsfac*geo(1,mg)*pm(20,mt))
1625 ENDIF
1626 ENDIF
1627
1628 ELSE
1629 IF(nint>=0) THEN
1630 CALL ancmsg(msgid=95,
1631 . msgtype=msgwarning,
1632 . anmode=aninfo_blind_2,
1633 . i1=id,
1634 . c1=titr,
1635 . i2=ixtg(nixtg,neltg),
1636 . c2='SHELL',
1637 . i3=i)
1638 ENDIF
1639 IF(nint<0) THEN
1640 CALL ancmsg(msgid=96,
1641 . msgtype=msgwarning,
1642 . anmode=aninfo_blind_2,
1643 . i1=id,
1644 . c1=titr,
1645 . i2=ixtg(nixtg,neltg),
1646 . c2='SHELL',
1647 . i3=i)
1648 ENDIF
1649 ENDIF
1650C ----- Friction model ------
1651 IF(intfric > 0) THEN
1652 ip= iparttg(neltg)
1653 ipg = tagprt_fric(ip)
1654 IF(ipg > 0) THEN
1655 CALL friction_parts_search (
1656 . ipg,intbuf_fric_tab(intfric)%S_TABPARTS_FRIC,
1657 . intbuf_fric_tab(intfric)%TABPARTS_FRIC,ipl)
1658 ipartfricm(i) = ipl
1659 ENDIF
1660 ENDIF
1661C------------------------------------
1662 ELSEIF(nelc/=0) THEN
1663 mt=ixc(1,nelc)
1664 mg=ixc(6,nelc)
1665 ip = ipartc(nelc)
1666 igtyp = igeo(11,mg)
1667 igmat = igeo(98,mg)
1668 IF ( thk_part(ip) /= zero .AND. iintthick == 0) THEN
1669 dx=thk_part(ip)*gapscale
1670 ELSEIF ( thk(nelc) /= zero .AND. iintthick == 0) THEN
1671 dx=thk(nelc)*gapscale
1672 ELSEIF(igtyp == 17 .OR. igtyp == 51 .OR. igtyp ==52) THEN
1673 dx=thk(nelc)*gapscale
1674 ELSE
1675 dx=geo(1,mg)*gapscale
1676 ENDIF
1677 gapm=half*dx
1678 gaps2=max(gaps2,gapm)
1679 gapmn = min(gapmn,dx)
1680 dxm=dxm+dx
1681 ndx=ndx+1
1682 gap_m(i)=max(gap_m(i),gapm)
1683 IF(mt>0)THEN
1684 IF(igtyp == 11 .AND. igmat > 0) THEN
1685 IF ( thk(nelc) /= zero .AND. iintthick == 0) THEN
1686 stf(i)=slsfac*thk(nelc)*geo(ipgmat + 2 ,mg)
1687 ELSE
1688 stf(i)=slsfac*geo(1,mg)*geo(ipgmat + 2 ,mg)
1689 ENDIF
1690 ELSEIF(igtyp ==52 .OR.
1691 . ((igtyp == 17 .OR. igtyp == 51) .AND. igmat > 0))THEN
1692 isubstack = iworksh(3,nelc)
1693 st=pm_stack(2,isubstack)
1694 stf(i)=slsfac*thk(nelc)*st
1695 ELSE
1696 IF ( thk(nelc) /= zero .AND. iintthick == 0) THEN
1697 stf(i)=max(stf(i),slsfac*thk(nelc)*pm(20,mt))
1698 ELSEIF(igtyp == 17 .OR. igtyp == 51 ) THEN
1699 stf(i)=max(stf(i),slsfac*thk(nelc)*pm(20,mt))
1700 ELSE
1701 stf(i)=max(stf(i),slsfac*geo(1,mg)*pm(20,mt))
1702 ENDIF
1703 ENDIF
1704 ELSE
1705 IF(nint>=0) THEN
1706 CALL ancmsg(msgid=95,
1707 . msgtype=msgwarning,
1708 . anmode=aninfo_blind_2,
1709 . i1=id,
1710 . c1=titr,
1711 . i2=ixc(nixc,nelc),
1712 . c2='SHELL',
1713 . i3=i)
1714 ENDIF
1715 IF(nint<0) THEN
1716 CALL ancmsg(msgid=96,
1717 . msgtype=msgwarning,
1718 . anmode=aninfo_blind_2,
1719 . i1=id,
1720 . c1=titr,
1721 . i2=ixc(nixc,nelc),
1722 . c2='SHELL',
1723 . i3=i)
1724 ENDIF
1725 ENDIF
1726C ----- Friction model ------
1727 IF(intfric > 0) THEN
1728 ip= ipartc(nelc)
1729 ipg = tagprt_fric(ip)
1730 IF(ipg > 0) THEN
1731 CALL friction_parts_search (
1732 . ipg,intbuf_fric_tab(intfric)%S_TABPARTS_FRIC,
1733 . intbuf_fric_tab(intfric)%TABPARTS_FRIC,ipl )
1734 ipartfricm(i) = ipl
1735 ENDIF
1736 ENDIF
1737C------------------------------------
1738 ENDIF
1739C
1740 IF(nels+nelc+neltg==0)THEN
1741
1742C In SPMD you need an element associated with the edge otherwise error
1743 IF(nint>0) THEN
1744 CALL ancmsg(msgid=481,
1745 . msgtype=msgerror,
1746 . anmode=aninfo_blind_2,
1747 . i1=id,
1748 . c1=titr,
1749 . i2=i)
1750 ENDIF
1751 IF(nint<0) THEN
1752 CALL ancmsg(msgid=482,
1753 . msgtype=msgerror,
1754 . anmode=aninfo_blind_2,
1755 . i1=id,
1756 . c1=titr,
1757 . i2=i)
1758 ENDIF
1759
1760 ENDIF
1761 END DO
1762C
1763 IF(numels > 0) DEALLOCATE(tagelems,indexe)
1764C
1765 CALL ancmsg(msgid=3022,
1766 . msgtype=msgwarning,
1767 . anmode=aninfo_blind_1,
1768 . i1=id,
1769 . c1=titr,
1770 . prmod=msg_print)
1771 CALL ancmsg(msgid=3024,
1772 . msgtype=msgwarning,
1773 . anmode=aninfo_blind_1,
1774 . i1=id,
1775 . c1=titr,
1776 . prmod=msg_print)
1777 IF(ninv > 0 .AND.nint>0)
1778 . CALL ancmsg(msgid=3023,
1779 . msgtype=msgwarning,
1780 . anmode=aninfo_blind_1,
1781 . i1=id,
1782 . c1=titr,
1783 . i2=ninv)
1784C
1785 IF(ninv > 0 .AND.nint< 0)
1786 . CALL ancmsg(msgid=3025,
1787 . msgtype=msgwarning,
1788 . anmode=aninfo_blind_1,
1789 . i1=id,
1790 . c1=titr,
1791 . i2=ninv)
1792C
1793C IF (IPRI>=5.AND.NREV>0) WRITE (IOUT,1400) NREV,NOINT
1794C---- due to cycle -------
1795 DO i=1+nshift,nrt+nshift
1796 gap_m(i)=min(gap_m(i),gapmax_m)
1797 END DO
1798C-----------------------------------------------
1799 RETURN
1800 !1400 FORMAT(I10,' MAIN SEGMENTS',' OF INTERFACE',I10,
1801 ! + ' ARE REVERSED THE NORMAL DIRECTION')
1802 END
1803!||====================================================================
1804!|| i24bord ../starter/source/interfaces/inter3d1/i24sti3.F
1805!||--- called by ------------------------------------------------------
1806!|| i24sti3 ../starter/source/interfaces/inter3d1/i24sti3.F
1807!||--- calls -----------------------------------------------------
1808!||====================================================================
1809 SUBROUTINE i24bord(NSEG,SURF_NODES ,TAGB)
1810C-----------------------------------------------
1811C I m p l i c i t T y p e s
1812C-----------------------------------------------
1813#include "implicit_f.inc"
1814C-----------------------------------------------
1815C D u m m y A r g u m e n t s
1816C-----------------------------------------------
1817 INTEGER TAGB(*),NSEG,SURF_NODES(NSEG,4)
1818C-----------------------------------------------
1819C L o c a l V a r i a b l e s
1820C-----------------------------------------------
1821 INTEGER I,J,K,L,NLMAX,STAT,LL,I1,I2,I3,I4,I5,I1M,I2M,IS,BORD,BOLD
1822 INTEGER NEXTK(4),IWORK(70000),NL
1823 INTEGER, DIMENSION(:,:), ALLOCATABLE ::
1824 . LINEIX
1825 INTEGER, DIMENSION(:), ALLOCATABLE ::
1826 . INDEX
1827 DATA NEXTK/2,3,4,1/
1828C=======================================================================
1829 NLMAX = 4*nseg
1830 ALLOCATE (lineix(2,nlmax) ,stat=stat)
1831 ALLOCATE (index(2*nlmax) ,stat=stat)
1832c---------------------------------------
1833c search for all lines on the surface
1834c---------------------------------------
1835 is = 0
1836 ll = 0
1837 DO j=1,nseg
1838 is = is+1
1839 i1=surf_nodes(j,1)
1840 i2=surf_nodes(j,2)
1841 i3=surf_nodes(j,3)
1842 i4=surf_nodes(j,4)
1843 DO k=1,4
1844 i1=surf_nodes(j,k)
1845 i2=surf_nodes(j,nextk(k))
1846 ll = ll+1
1847 IF(i2 > i1)THEN
1848 lineix(1,ll) = i1
1849 lineix(2,ll) = i2
1850 ELSE
1851 lineix(1,ll) = i2
1852 lineix(2,ll) = i1
1853 ENDIF
1854 ENDDO
1855 ENDDO
1856C
1857 CALL my_orders(0,iwork,lineix,index,ll,2)
1858
1859c---------------------------------------
1860c removal of duplicate lines
1861c---------------------------------------
1862 i1m = lineix(1,index(1))
1863 i2m = lineix(2,index(1))
1864 bord=1
1865 bold=1
1866 DO l=2,ll
1867 i1 = lineix(1,index(l))
1868 i2 = lineix(2,index(l))
1869 IF(i1m == i2m)THEN
1870c triangle we do nothing
1871 bold=1
1872 ELSEIF(bold == 0)THEN
1873c ditto previous we do nothing
1874 bold=1
1875 ELSEIF(i2 == i2m .and. i1 == i1m)THEN
1876c idem according to pas de bord
1877 bord=0
1878 bold=0
1879 ELSE
1880 bord=1 ! bord
1881 bold=1
1882 tagb(i1m) = 1
1883 tagb(i2m) = 1
1884 ENDIF
1885 i1m = i1
1886 i2m = i2
1887 ENDDO
1888
1889 IF(bord==1)THEN
1890c last edge is a border
1891 tagb(i1) = 1
1892 tagb(i2) = 1
1893 ENDIF
1894
1895
1896 DEALLOCATE (index)
1897 DEALLOCATE (lineix)
1898C-----------
1899 RETURN
1900 END
1901!||====================================================================
1902!|| i24normns ../starter/source/interfaces/inter3d1/i24sti3.F
1903!||--- called by ------------------------------------------------------
1904!|| i24sti3 ../starter/source/interfaces/inter3d1/i24sti3.F
1905!|| i25sti3 ../starter/source/interfaces/inter3d1/i25sti3.F
1906!||--- calls -----------------------------------------------------
1907!|| normv3 ../starter/source/interfaces/inter3d1/i24tools.F
1908!|| normvec ../starter/source/interfaces/inter3d1/i24sti3.F
1909!||====================================================================
1910 SUBROUTINE i24normns(
1911 1 X ,IRECT ,NRT ,NSN ,NSV ,PEN_OLD, STF)
1912C============================================================================
1913C-----------------------------------------------
1914C I m p l i c i t T y p e s
1915C-----------------------------------------------
1916#include "implicit_f.inc"
1917C-----------------------------------------------
1918C C o m m o n B l o c k s
1919C-----------------------------------------------
1920#include "com04_c.inc"
1921C-----------------------------------------------
1922C D u m m y A r g u m e n t s
1923C-----------------------------------------------
1924 INTEGER NRT,IRECT(4,*),NSN,NSV(*)
1925 my_real
1926 . x(3,*),pen_old(5,nsn)
1927 my_real , INTENT(IN) :: stf(nrt)
1928C-----------------------------------------------
1929C L o c a l V a r i a b l e s
1930C-----------------------------------------------
1931 INTEGER I, J,NN(4),NS
1932C REAL
1933 my_real
1934 . r(3),s(3),t(3),det
1935 my_real, DIMENSION(:,:), ALLOCATABLE :: norm
1936 INTEGER, DIMENSION(:), ALLOCATABLE :: ITAG
1937C=======================================================================
1938 ALLOCATE(norm(3,numnod),itag(numnod))
1939 DO i=1,numnod
1940 norm(1,i) = zero
1941 norm(2,i) = zero
1942 norm(3,i) = zero
1943 itag(i) =0
1944 ENDDO
1945 DO i=1,nrt
1946 IF(stf(i) > zero) THEN
1947 DO j=1,4
1948 nn(j)=irect(j,i)
1949 itag(nn(j)) =itag(nn(j))+1
1950 END DO
1951C------Node 1
1952 DO j=1,3
1953 r(j) = x(j,nn(2))-x(j,nn(1))
1954 s(j) = x(j,nn(4))-x(j,nn(1))
1955 END DO
1956 CALL normvec(r,s,t)
1957 DO j=1,3
1958 norm(j,nn(1)) = norm(j,nn(1))+t(j)
1959 END DO
1960C------Node 2
1961 DO j=1,3
1962 r(j) = x(j,nn(3))-x(j,nn(2))
1963 s(j) = x(j,nn(1))-x(j,nn(2))
1964 END DO
1965 CALL normvec(r,s,t)
1966 DO j=1,3
1967 norm(j,nn(2)) = norm(j,nn(2))+t(j)
1968 END DO
1969C------Node 3,4
1970 IF (nn(4)/=nn(3)) THEN
1971 DO j=1,3
1972 r(j) = x(j,nn(4))-x(j,nn(3))
1973 s(j) = x(j,nn(2))-x(j,nn(3))
1974 END DO
1975 CALL normvec(r,s,t)
1976 DO j=1,3
1977 norm(j,nn(3)) = norm(j,nn(3))+t(j)
1978 END DO
1979 DO j=1,3
1980 r(j) = x(j,nn(1))-x(j,nn(4))
1981 s(j) = x(j,nn(3))-x(j,nn(4))
1982 END DO
1983 CALL normvec(r,s,t)
1984 DO j=1,3
1985 norm(j,nn(4)) = norm(j,nn(4))+t(j)
1986 END DO
1987 ELSE ! norm_n3=norm_n2
1988 DO j=1,3
1989 norm(j,nn(3)) = norm(j,nn(3))+t(j)
1990 END DO
1991 END IF
1992 ENDIF
1993 ENDDO
1994C----re-normalizing---
1995 DO i=1,numnod
1996 IF (itag(i) >1) THEN
1997 CALL normv3(norm(1,i),det)
1998 END IF
1999 ENDDO
2000C
2001 DO i=1,nsn
2002 ns = nsv(i)
2003 pen_old(1,i) = norm(1,ns)
2004 pen_old(2,i) = norm(2,ns)
2005 pen_old(3,i) = norm(3,ns)
2006 ENDDO
2007C-----------
2008 DEALLOCATE(norm,itag)
2009 RETURN
2010 END
2011!||====================================================================
2012!|| normvec ../starter/source/interfaces/inter3d1/i24sti3.f
2013!||--- called by ------------------------------------------------------
2014!|| i24normns ../starter/source/interfaces/inter3d1/i24sti3.F
2015!|| sh_offset_nproj ../starter/source/elements/shell/shell_offset/shell_offset_nproj.F90
2016!||--- calls -----------------------------------------------------
2017!|| normv3 ../starter/source/interfaces/inter3d1/i24tools.F
2018!||====================================================================
2019 SUBROUTINE normvec(R,S,T)
2020C-----------------------------------------------
2021C I m p l i c i t T y p e s
2022C-----------------------------------------------
2023#include "implicit_f.inc"
2024C-----------------------------------------------
2025C D u m m y A r g u m e n t s
2026C-----------------------------------------------
2027 my_real
2028 . r(3) , s(3) , t(3)
2029C-----------------------------------------------
2030C L o c a l V a r i a b l e s
2031C-----------------------------------------------
2032
2033 my_real
2034 . det
2035C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2036C T = R x S
2037C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2038 t(1) = r(2) * s(3) - r(3) * s(2)
2039 t(2) = r(3) * s(1) - r(1) * s(3)
2040 t(3) = r(1) * s(2) - r(2) * s(1)
2041 CALL normv3(t,det)
2042 RETURN
2043 END
2044!||====================================================================
2045!|| i24ll_kg ../starter/source/interfaces/inter3d1/i24sti3.f
2046!||--- called by ------------------------------------------------------
2047!|| inint3 ../starter/source/interfaces/inter3d1/inint3.F
2048!||--- calls -----------------------------------------------------
2049!|| volint ../starter/source/interfaces/inter3d1/volint.F
2050!||--- uses -----------------------------------------------------
2051!|| message_mod ../starter/share/message_module/message_mod.F
2052!||====================================================================
2053 SUBROUTINE i24ll_kg(
2054 1 X ,IRECT ,IXS ,PM ,WA ,
2055 2 GEO ,NRT ,IXC ,NINT ,NTY ,
2056 3 NOINT ,NSN ,NSV ,IXTG ,IXT ,
2057 6 IXP ,IPART ,IPARTC,IPARTTG,THK ,
2058 D THK_PART,IXR ,ITAB ,IXS10 ,IXS16 ,
2059 E IXS20 ,NMN ,MSR ,LL_S ,LL_M ,
2060 J IPARTT,IPARTP,IPARTR,IGEO )
2061C-----------------------------------------------
2062 USE message_mod
2063 use element_mod , only : nixs,nixc,nixtg,nixt,nixp,nixr
2064C
2065C-----------------------------------------------
2066C I m p l i c i t T y p e s
2067C-----------------------------------------------
2068#include "implicit_f.inc"
2069C-----------------------------------------------
2070C C o m m o n B l o c k s
2071C-----------------------------------------------
2072#include "com01_c.inc"
2073#include "com04_c.inc"
2074#include "param_c.inc"
2075#include "scr17_c.inc"
2076#include "scr08_c.inc"
2077C-----------------------------------------------
2078C D u m m y A r g u m e n t s
2079C-----------------------------------------------
2080 INTEGER NMN, NTY, NOINT,NSN,NRT,NINT
2081 INTEGER IRECT(4,*), IXS(NIXS,*), IXC(NIXC,*),MSR(*),
2082 . NSV(*), IXTG(NIXTG,*), IXT(NIXT,*), IXP(NIXP,*),
2083 . ixr(nixr,*) ,ipart(lipart1,*), ipartc(*), iparttg(*),
2084 . itab(*), ixs10(6,*), ixs16(8,*), ixs20(12,*)
2085 INTEGER, DIMENSION(NUMELT), INTENT(IN) :: IPARTT
2086 INTEGER, DIMENSION(NUMELP), INTENT(IN) :: IPARTP
2087 INTEGER, DIMENSION(NUMELR), INTENT(IN) :: IPARTR
2088 INTEGER, DIMENSION(NPROPGI,NUMGEO) ,INTENT(IN):: IGEO
2089C REAL
2090 my_real
2091 . X(3,*), PM(NPROPM,*), GEO(NPROPG,*), WA(*),
2092 . THK(*),THK_PART(*),LL_S(*),LL_M(*)
2093C-----------------------------------------------
2094C L o c a l V a r i a b l e s
2095C-----------------------------------------------
2096 INTEGER I, N, JJ, JJJ,
2097 . MG, IE,
2098 . ip, k, igtyp
2099C REAL
2100 my_real
2101 . vol, dx
2102C----------------------
2103 DO i=1,numnod
2104 wa(i)=ep10
2105 ENDDO
2106 DO i=1,nsn
2107 ll_s(i)=ep10
2108 ENDDO
2109 DO i=1,nmn
2110 ll_m(i)=ep10
2111 ENDDO
2112C----SHELLS ------------
2113 DO i=1,numelc
2114 mg=ixc(6,i)
2115 ip = ipartc(i)
2116 IF ( thk_part(ip) /= zero .AND. iintthick == 0) THEN
2117 dx=thk_part(ip)
2118 ELSEIF ( thk(i) /= zero .AND. iintthick == 0) THEN
2119 dx=thk(i)
2120 ELSE
2121 dx=geo(1,mg)
2122 ENDIF
2123 wa(ixc(2,i))=min(wa(ixc(2,i)),dx)
2124 wa(ixc(3,i))=min(wa(ixc(3,i)),dx)
2125 wa(ixc(4,i))=min(wa(ixc(4,i)),dx)
2126 wa(ixc(5,i))=min(wa(ixc(5,i)),dx)
2127 ENDDO
2128 DO i=1,numeltg
2129 mg=ixtg(5,i)
2130 ip = iparttg(i)
2131 IF ( thk_part(ip) /= zero .AND. iintthick == 0) THEN
2132 dx=thk_part(ip)
2133 ELSEIF ( thk(numelc+i) /= zero .AND. iintthick == 0) THEN
2134 dx=thk(numelc+i)
2135 ELSE
2136 dx=geo(1,mg)
2137 ENDIF
2138 wa(ixtg(2,i))=min(wa(ixtg(2,i)),dx)
2139 wa(ixtg(3,i))=min(wa(ixtg(3,i)),dx)
2140 wa(ixtg(4,i))=min(wa(ixtg(4,i)),dx)
2141 ENDDO
2142C----truss------------
2143 DO i=1,numelt
2144 mg=ixt(4,i)
2145 ip = ipartt(i)
2146 IF ( thk_part(ip) > zero ) THEN
2147 dx=thk_part(ip)
2148 ELSE
2149 dx=sqrt(geo(1,mg))
2150 END IF
2151 wa(ixt(2,i))=min(wa(ixt(2,i)),dx)
2152 wa(ixt(3,i))=min(wa(ixt(3,i)),dx)
2153 ENDDO
2154C----beam------------
2155 DO i=1,numelp
2156 mg=ixp(5,i)
2157 ip = ipartp(i)
2158 IF ( thk_part(ip) > zero ) THEN
2159 dx=thk_part(ip)
2160 ELSE
2161 dx=sqrt(geo(1,mg))
2162 END IF
2163 wa(ixp(2,i))=min(wa(ixp(2,i)),dx)
2164 wa(ixp(3,i))=min(wa(ixp(3,i)),dx)
2165 ENDDO
2166 DO i=1,numelr
2167 ip = ipartr(i)
2168 IF ( thk_part(ip) > zero ) THEN
2169 mg=ixr(1,i)
2170 igtyp = igeo(11,mg)
2171 dx=thk_part(ip)
2172 wa(ixr(2,i))=max(wa(ixr(2,i)),dx)
2173 wa(ixr(3,i))=max(wa(ixr(3,i)),dx)
2174 IF (igtyp==12) wa(ixr(4,i))=max(wa(ixr(4,i)),dx)
2175 END IF
2176 ENDDO
2177C----solides------------
2178 DO i=1,numels
2179 mg=ixs(1,i)
2180 IF(mg>0)THEN
2181 DO jj=1,8
2182 jjj=ixs(jj+1,i)
2183 xc(jj)=x(1,jjj)
2184 yc(jj)=x(2,jjj)
2185 zc(jj)=x(3,jjj)
2186 END DO
2187 CALL volint(vol)
2188 dx=vol**third
2189 DO k=1,8
2190 wa(ixs(k+1,i))=min(wa(ixs(k+1,i)),dx)
2191 ENDDO
2192 IF(i <= numels8)THEN
2193 ELSEIF(i <= numels8+numels10)THEN
2194 ie = i-numels8
2195 DO k=1,6
2196 n= ixs10(k,ie)
2197 wa(n)=min(wa(n),dx)
2198 ENDDO
2199 ELSEIF(i <= numels8+numels10+numels20)THEN
2200 ie = i-numels8-numels10
2201 DO k=1,12
2202 n= ixs20(k,ie)
2203 wa(n)=min(wa(n),dx)
2204 ENDDO
2205 ELSEIF(i <= numels8+numels10+numels20+numels16)THEN
2206 ie = i-numels8-numels10-numels20
2207 DO k=1,8
2208 n= ixs16(k,ie)
2209 wa(n)=min(wa(n),dx)
2210 ENDDO
2211 END IF
2212 END if!(MG>0)THEN
2213 ENDDO
2214C
2215 DO i=1,nsn
2216 ll_s(i)=min(ll_s(i),wa(nsv(i)))
2217 ENDDO
2218 DO i=1,nmn
2219 ll_m(i)=min(ll_m(i),wa(msr(i)))
2220 ENDDO
2221C-----------------------------------------------
2222 RETURN
2223 END
2224!||====================================================================
2225!|| inelts_np ../starter/source/interfaces/inter3d1/i24sti3.F
2226!||--- called by ------------------------------------------------------
2227!|| i24gapm ../starter/source/interfaces/inter3d1/i24sti3.F
2228!||--- calls -----------------------------------------------------
2229!|| norma1 ../starter/source/interfaces/inter3d1/norma1.F
2230!||--- uses -----------------------------------------------------
2231!||====================================================================
2232 SUBROUTINE inelts_np(X ,IRECT ,IXS ,NREV ,NEL ,
2233 . I ,AREA ,NOINT ,IR ,SURF_ELTYP,
2234 . SURF_ELEM)
2235 use element_mod , only : nixs
2236C-----------------------------------------------
2237C I m p l i c i t T y p e s
2238C-----------------------------------------------
2239#include "implicit_f.inc"
2240C-----------------------------------------------
2241C D u m m y A r g u m e n t s
2242C-----------------------------------------------
2243 INTEGER NREV, NEL, I, NOINT,IR,SURF_ELTYP(*),SURF_ELEM(*)
2244C REAL
2245 my_real
2246 . area
2247 INTEGER IRECT(4,*), IXS(NIXS,*)
2248C REAL
2249 my_real
2250 . x(3,*)
2251C-----------------------------------------------
2252C L o c a l V a r i a b l e s
2253C-----------------------------------------------
2254 INTEGER IY(4), N, JJ, II, K, NN, KK, IC, IAD,
2255 . nuser, nuserm
2256C REAL
2257 my_real
2258 . n1, n2, n3, dds
2259 my_real :: xx1(4), xx2(4),xx3(4),xs1,ys1,zs1,xc,yc,zc
2260C-----------------------------------------------
2261C E x t e r n a l F u n c t i o n s
2262C-----------------------------------------------
2263C---Remove print-out in 0.out file (could be too much)
2264 ic =0
2265 nel=0
2266 IF (surf_eltyp(i) /=1) RETURN
2267C
2268 nel=surf_elem(i)
2269C-----------------------------------------------
2270C VERIFICATION OF THE ORIENTATION OF THE SEGMENTS
2271C-----------------------------------------------
2272 xs1=0.
2273 ys1=0.
2274 zs1=0.
2275 DO 100 jj=1,4
2276 nn=irect(jj,i)
2277 iy(jj)=nn
2278 xx1(jj)=x(1,nn)
2279 xx2(jj)=x(2,nn)
2280 xx3(jj)=x(3,nn)
2281 xs1=xs1+.25*x(1,nn)
2282 ys1=ys1+.25*x(2,nn)
2283 100 zs1=zs1+.25*x(3,nn)
2284C
2285 CALL norma1(n1,n2,n3,area,xx1,xx2,xx3)
2286 xc=0.
2287 yc=0.
2288 zc=0.
2289 DO 110 k=1,8
2290 kk=ixs(k+1,nel)
2291 xc=xc+x(1,kk)
2292 yc=yc+x(2,kk)
2293 zc=zc+x(3,kk)
2294 110 CONTINUE
2295 xc=xc*one_over_8
2296 yc=yc*one_over_8
2297 zc=zc*one_over_8
2298 IF(ir/=0) RETURN
2299 IF(ic>=2)RETURN
2300 dds=n1*(xc-xs1)+n2*(yc-ys1)+n3*(zc-zs1)
2301 IF(dds<0) RETURN
2302 IF(iy(3)==iy(4)) THEN
2303 irect(1,i)=iy(2)
2304 irect(2,i)=iy(1)
2305 ELSE
2306 DO 120 kk=1,4
2307 120 irect(kk,i)=iy(4-kk+1)
2308 ENDIF
2309 nrev = nrev +1
2310C
2311 RETURN
2312 END
2313!||====================================================================
2314!|| insolbox ../starter/source/interfaces/inter3d1/i24sti3.F
2315!||--- uses -----------------------------------------------------
2316!||====================================================================
2317 SUBROUTINE insolbox(X ,S_TYPE ,S_EL ,NOINT ,IXS ,
2318 . IXS10 ,IXS16 ,IXS20 ,NS ,GAP ,
2319 . IPART_E,IPART_NS,IPEN0 ,INS )
2320 use element_mod , only : nixs
2321C-----------------------------------------------
2322C I m p l i c i t T y p e s
2323C-----------------------------------------------
2324#include "implicit_f.inc"
2325C-----------------------------------------------
2326C C o m m o n B l o c k s
2327C-----------------------------------------------
2328#include "com04_c.inc"
2329C-----------------------------------------------
2330C D u m m y A r g u m e n t s
2331C-----------------------------------------------
2332 INTEGER S_TYPE ,S_EL,NS,INS,NOINT,IPART_E,IPART_NS,IPEN0
2333 INTEGER IXS(NIXS,*), IXS10(6,*), IXS16(8,*), IXS20(12,*)
2334 my_real
2335 . x(3,*),gap
2336C-----------------------------------------------
2337C L o c a l V a r i a b l e s
2338C-----------------------------------------------
2339 INTEGER J,N,NC4(4),NC8(8)
2340C REAL
2341 my_real
2342 . xi,yi,zi,xmin,ymin,zmin,xmax,ymax,zmax
2343C-----------------------------------------------
2344C E x t e r n a l F u n c t i o n s
2345C-----------------------------------------------
2346C
2347C-----------------------------------------------
2348 IF (ipen0==0.AND.ipart_e==ipart_ns) THEN
2349 ins = 0
2350 RETURN
2351 END IF
2352 ins = 1
2353 xmin=ep30
2354 xmax=-ep30
2355 ymin=ep30
2356 ymax=-ep30
2357 zmin=ep30
2358 zmax=-ep30
2359 IF (s_type==0.OR.s_el==0) RETURN
2360 nc4(1)=ixs(2,s_el)
2361 nc4(2)=ixs(4,s_el)
2362 nc4(3)=ixs(7,s_el)
2363 nc4(4)=ixs(6,s_el)
2364 nc8(1:8)=ixs(2:9,s_el)
2365 SELECT CASE (s_type)
2366 CASE(4)
2367 DO j=1,4
2368 n= nc4(j)
2369 IF(n==ns) THEN
2370 ins = 0
2371 RETURN
2372 END IF
2373 xmin=min(xmin,x(1,n))
2374 xmax=max(xmax,x(1,n))
2375 ymin=min(ymin,x(2,n))
2376 ymax=max(ymax,x(2,n))
2377 zmin=min(zmin,x(3,n))
2378 zmax=max(zmax,x(3,n))
2379 END DO
2380 CASE(8)
2381 DO j=1,8
2382 n = nc8(j)
2383 IF(n==ns) THEN
2384 ins = 0
2385 RETURN
2386 END IF
2387 xmin=min(xmin,x(1,n))
2388 xmax=max(xmax,x(1,n))
2389 ymin=min(ymin,x(2,n))
2390 ymax=max(ymax,x(2,n))
2391 zmin=min(zmin,x(3,n))
2392 zmax=max(zmax,x(3,n))
2393 END DO
2394 CASE(10)
2395 DO j=1,4
2396 n= nc4(j)
2397 IF(n==ns) THEN
2398 ins = 0
2399 RETURN
2400 END IF
2401 xmin=min(xmin,x(1,n))
2402 xmax=max(xmax,x(1,n))
2403 ymin=min(ymin,x(2,n))
2404 ymax=max(ymax,x(2,n))
2405 zmin=min(zmin,x(3,n))
2406 zmax=max(zmax,x(3,n))
2407 END DO
2408 DO j=1,6
2409 n=ixs10(j,s_el-numels8)
2410 IF(n==ns) THEN
2411 ins = 0
2412 RETURN
2413 END IF
2414 xmin=min(xmin,x(1,n))
2415 xmax=max(xmax,x(1,n))
2416 ymin=min(ymin,x(2,n))
2417 ymax=max(ymax,x(2,n))
2418 zmin=min(zmin,x(3,n))
2419 zmax=max(zmax,x(3,n))
2420 ENDDO
2421 CASE(16)
2422 DO j=1,8
2423 n = nc8(j)
2424 IF(n==ns) THEN
2425 ins = 0
2426 RETURN
2427 END IF
2428 xmin=min(xmin,x(1,n))
2429 xmax=max(xmax,x(1,n))
2430 ymin=min(ymin,x(2,n))
2431 ymax=max(ymax,x(2,n))
2432 zmin=min(zmin,x(3,n))
2433 zmax=max(zmax,x(3,n))
2434 END DO
2435 DO j=1,8
2436 n = ixs16(j,s_el-numels8-numels10-numels20)
2437 IF(n==ns) THEN
2438 ins = 0
2439 RETURN
2440 END IF
2441 xmin=min(xmin,x(1,n))
2442 xmax=max(xmax,x(1,n))
2443 ymin=min(ymin,x(2,n))
2444 ymax=max(ymax,x(2,n))
2445 zmin=min(zmin,x(3,n))
2446 zmax=max(zmax,x(3,n))
2447 ENDDO
2448 CASE(20)
2449 DO j=1,8
2450 n = nc8(j)
2451 IF(n==ns) THEN
2452 ins = 0
2453 RETURN
2454 END IF
2455 xmin=min(xmin,x(1,n))
2456 xmax=max(xmax,x(1,n))
2457 ymin=min(ymin,x(2,n))
2458 ymax=max(ymax,x(2,n))
2459 zmin=min(zmin,x(3,n))
2460 zmax=max(zmax,x(3,n))
2461 END DO
2462 DO j=1,12
2463 n =ixs20(j,s_el-numels8-numels10)
2464 IF(n==ns) THEN
2465 ins = 0
2466 RETURN
2467 END IF
2468 xmin=min(xmin,x(1,n))
2469 xmax=max(xmax,x(1,n))
2470 ymin=min(ymin,x(2,n))
2471 ymax=max(ymax,x(2,n))
2472 zmin=min(zmin,x(3,n))
2473 zmax=max(zmax,x(3,n))
2474 ENDDO
2475 CASE DEFAULT
2476 RETURN
2477 END SELECT
2478C
2479 xi = x(1,ns)
2480 yi = x(2,ns)
2481 zi = x(3,ns)
2482 IF (ipart_e /= ipart_ns) THEN
2483 xmin = xmin-gap
2484 xmax = xmax+gap
2485 ymin = ymin-gap
2486 ymax = ymax+gap
2487 zmin = zmin-gap
2488 zmax = zmax+gap
2489 END IF
2490 IF(xi < xmin) THEN
2491 ins = 0
2492 RETURN
2493 END IF
2494 IF(xi > xmax) THEN
2495 ins = 0
2496 RETURN
2497 END IF
2498 IF(yi < ymin) THEN
2499 ins = 0
2500 RETURN
2501 END IF
2502 IF(yi > ymax) THEN
2503 ins = 0
2504 RETURN
2505 END IF
2506 IF(zi < zmin) THEN
2507 ins = 0
2508 RETURN
2509 END IF
2510 IF(zi > zmax) THEN
2511 ins = 0
2512 RETURN
2513 END IF
2514C-----------------------------------------------
2515 RETURN
2516 END
2517
my_real
#define my_real
Definition cppsort.cpp:32
if
if(complex_arithmetic) id
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
area
subroutine area(d1, x, x2, y, y2, eint, stif0)
Definition hm_read_prop32.F:567
normvec
subroutine normvec(r, s, t)
Definition i24sti3.F:2020
i24ll_kg
subroutine i24ll_kg(x, irect, ixs, pm, wa, geo, nrt, ixc, nint, nty, noint, nsn, nsv, ixtg, ixt, ixp, ipart, ipartc, iparttg, thk, thk_part, ixr, itab, ixs10, ixs16, ixs20, nmn, msr, ll_s, ll_m, ipartt, ipartp, ipartr, igeo)
Definition i24sti3.F:2061
i24normns
subroutine i24normns(x, irect, nrt, nsn, nsv, pen_old, stf)
Definition i24sti3.F:1912
i24sti3
subroutine i24sti3(x, irect, stf, ixs, pm, geo, nrt, ixc, nint, stfac, nty, gap, noint, stfn, nsn, ms, nsv, ixtg, igap, wa, gap_s, gap_m, gapmin, ixt, ixp, gapinf, gapmax_s, inacti, knod2els, knod2elc, knod2eltg, nod2els, nod2elc, nod2eltg, igrsurf, intth, ieles, ielec, areas, sh4tree, sh3tree, ipart, ipartc, iparttg, thk, thk_part, ixr, itab, bgapsmx, ixs10, msegtyp, nrt_sh, ixs16, ixs20, gap_n, mvoisn, ilev, igrsurf2, gapmax_m, id, titr, igap0, pen_old, ipartns, iparts, igeo, fillsol, pm_stack, iworksh, intfric, tagprt_fric, ipartfrics, ipartfricm, intbuf_fric_tab, intnitsche, nrts, irects, ielnrts, adrects, facnrts, nmn, msr, ipartt, ipartp, ipartr, elem_linked_to_segment, igsti, flag_elem_inter25)
Definition i24sti3.F:55
i24bord
subroutine i24bord(nseg, surf_nodes, tagb)
Definition i24sti3.F:1810
insolbox
subroutine insolbox(x, s_type, s_el, noint, ixs, ixs10, ixs16, ixs20, ns, gap, ipart_e, ipart_ns, ipen0, ins)
Definition i24sti3.F:2320
i24gapm
subroutine i24gapm(x, irect, stf, ixs, pm, geo, nrt, ixc, nint, stfac, nty, gap, noint, stfn, nsn, ms, nsv, ixtg, igap, gap_m, ixt, ixp, slsfac, dxm, ndx, knod2els, knod2elc, knod2eltg, nod2els, nod2elc, nod2eltg, igrsurf, intth, ieles, ielec, areas, sh4tree, sh3tree, ipart, ipartc, iparttg, thk, thk_part, ixr, itab, bgapsmx, ixs10, msegtyp, ixs16, ixs20, gap_n, gaps1, gaps2, gapmx, gapmn, gapscale, nshift, gapmax_m, id, titr, igeo, fillsol, nrtt, pm_stack, iworksh, intfric, tagprt_fric, ipartfrics, ipartfricm, iparts, intbuf_fric_tab, elem_linked_to_segment, igsti, flag_elem_inter25)
Definition i24sti3.F:1109
inelts_np
subroutine inelts_np(x, irect, ixs, nrev, nel, i, area, noint, ir, surf_eltyp, surf_elem)
Definition i24sti3.F:2235
insol3et
subroutine insol3et(x, irect, ixs, nint, nel, i, area, noint, knod2els, nod2els, ixs10, ixs16, ixs20, nnod)
Definition i24sti3.F:962
normv3
subroutine normv3(v, norm)
Definition i24tools.F:129
i4gmx3
subroutine i4gmx3(x, irect, i, gapmax)
Definition i4gmx3.F:35
friction_parts_search
subroutine friction_parts_search(ip, npartsfric, partsfric, ipl)
Definition i7sti3.F:1268
incoq3
subroutine incoq3(irect, ixc, ixtg, nint, nel, neltg, is, geo, pm, knod2elc, knod2eltg, nod2elc, nod2eltg, thk, nty, igeo, pm_stack, iworksh)
Definition incoq3.F:46
ineltc
subroutine ineltc(nelc, neltg, is, surf_eltyp, surf_elem)
Definition inelt.F:134
insol3d
subroutine insol3d(x, irect, ixs, nint, nel, i, area, noint, knod2els, nod2els, ir, ixs10, ixs16, ixs20, tagelems, indexe, ninv, ielem_m, elem_linked_to_segment, print_error, nin25, nty, flag_elem_inter25)
Definition insol3.F:195
ymax
subroutine ymax(idn, fac, npc, pld, stiffmin, stiffmax, stiffini, stiffavg)
Definition law100_upd.F:274
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
norma1
subroutine norma1(n1, n2, n3, area, xx1, xx2, xx3)
Definition norma1.F:38
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
starter
program starter
Definition starter.F:39
volint
subroutine volint(vol)
Definition volint.F:38