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