OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i25sti3.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!|| i25sti3 ../starter/source/interfaces/inter3d1/i25sti3.F
25!||--- called by ------------------------------------------------------
26!|| inint3 ../starter/source/interfaces/inter3d1/inint3.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| friction_parts_search ../starter/source/interfaces/inter3d1/i7sti3.F
30!|| i24normns ../starter/source/interfaces/inter3d1/i24sti3.F
31!|| i25bord ../starter/source/interfaces/inter3d1/i25sti3.F
32!|| i25gapm ../starter/source/interfaces/inter3d1/i25sti3.F
33!|| insol3et ../starter/source/interfaces/inter3d1/i24sti3.F
34!||--- uses -----------------------------------------------------
35!|| message_mod ../starter/share/message_module/message_mod.F
36!||====================================================================
37 SUBROUTINE i25sti3(
38 1 X ,IRECT ,STF ,IXS ,PM ,
39 2 GEO ,NRT ,IXC ,NINT ,STFAC ,
40 3 NTY ,GAP ,NOINT ,
41 4 STFN ,NSN ,MS ,NSV ,IXTG ,
42 5 IGAP ,WA ,GAP_S ,GAP_M ,GAPMIN ,
43 6 GAPSCALE ,IXT ,IXP ,GAPINF ,GAPMAX_S ,
44 9 INACTI ,KNOD2ELS ,KNOD2ELC ,KNOD2ELTG ,NOD2ELS ,
45 A NOD2ELC ,NOD2ELTG ,INTTH,
46 B IELES ,IELEM ,AREAS ,SH4TREE ,SH3TREE ,
47 C IPART ,IPARTC ,IPARTTG ,THK ,THK_PART ,
48 D IXR ,ITAB ,BGAPSMX ,IXS10 ,MSEGTYP ,
49 E NRT_SH ,IXS16 ,IXS20 ,GAP_N ,
50 F ILEV ,GAPMAX_M ,ID,TITR ,IGAP0 ,
51 G PEN_OLD ,IPARTS ,IGEO ,FILLSOL ,
52 H PM_STACK , IWORKSH ,PERCENT_SIZE,GAP_S_L ,GAP_M_L ,
53 I KNOD2EL1D ,NOD2EL1D ,INTFRIC ,TAGPRT_FRIC,IPARTFRICS,
54 J IPARTFRICM,INTBUF_FRIC_TAB,IVIS2 ,GAPM_MX ,GAPS_MX ,
55 K GAPM_L_MX ,GAPS_L_MX ,IPARTSM ,DRAD ,IPARTT ,
56 J IPARTP ,IPARTR ,IELEM_M ,IDEL_SOLID,ELEM_LINKED_TO_SEGMENT,
57 K NIN25 , FLAG_ELEM_INTER25,THK_S,THK_M ,THK_S_SCALE,
58 L THK_M_SCALE)
59C-----------------------------------------------
60 USE my_alloc_mod
61 USE intbuf_fric_mod
62 USE message_mod
63 USE names_and_titles_mod , ONLY : nchartitle
64 use element_mod , only :nixs,nixc,nixtg,nixt,nixp,nixr
65C-----------------------------------------------
66C I m p l i c i t T y p e s
67C-----------------------------------------------
68#include "implicit_f.inc"
69C-----------------------------------------------
70C C o m m o n B l o c k s
71C-----------------------------------------------
72#include "com01_c.inc"
73#include "com04_c.inc"
74#include "param_c.inc"
75#include "remesh_c.inc"
76#include "scr03_c.inc"
77#include "scr17_c.inc"
78#include "units_c.inc"
79C-----------------------------------------------
80C D u m m y A r g u m e n t s
81C-----------------------------------------------
82 INTEGER NRT, NINT, NTY, NOINT,NSN,IGAP,INTFRIC,
83 . inacti,nrt_sh ,ilev ,igap0,igeo(npropgi,*), ivis2
84 INTEGER IRECT(4,*), IXS(NIXS,*), IXC(NIXC,*),
85 . nsv(*), ixtg(nixtg,*), ixt(nixt,*), ixp(nixp,*),
86 . knod2els(*), knod2elc(*), knod2eltg(*), nod2els(*), nod2elc(*),
87 . nod2eltg(*), intth,
88 . sh3tree(ksh3tree,*), sh4tree(ksh4tree,*),ixr(nixr,*) ,
89 . ipart(lipart1,*), ipartc(*), iparttg(*),
90 . itab(*), ixs10(6,*),msegtyp(*), ixs16(*), ixs20(*),
91 . iworksh(3,*), knod2el1d(*),nod2el1d(*),tagprt_fric(*),
92 . ipartfrics(*),ipartfricm(*),ipartsm(*),ieles(*),ielem(*)
93C REAL
94 my_real
95 . stfac, gap, gapscale, gapmin,gapinf, gapmax_s,bgapsmx ,gapmax_m,
96 . percent_size, gapm_mx, gaps_mx, gaps_l_mx, gapm_l_mx,drad
97C REAL
98 my_real
99 . x(3,*), stf(*), pm(npropm,*), geo(npropg,*), stfn(*),
100 . ms(*),wa(*),gap_s(*),gap_m(*),gap_n(4,*),
101 . areas(*),thk(*),thk_part(*),pen_old(5,nsn), fillsol(*),
102 . pm_stack(20,*),gap_s_l(*),gap_m_l(*)
103 INTEGER ID,IPARTS(*)
104 INTEGER, DIMENSION(NUMELT), INTENT(IN) :: IPARTT
105 INTEGER, DIMENSION(NUMELP), INTENT(IN) :: IPARTP
106 INTEGER, DIMENSION(NUMELR), INTENT(IN) :: IPARTR
107 CHARACTER(LEN=NCHARTITLE) :: TITR
108 TYPE(INTBUF_FRIC_STRUCT_) INTBUF_FRIC_TAB(*)
109 INTEGER , INTENT(INOUT) :: IDEL_SOLID
110 INTEGER , INTENT(INOUT) :: IELEM_M(2,NRT+NRT_SH)
111 INTEGER, DIMENSION(NUMELS), INTENT(INOUT):: ELEM_LINKED_TO_SEGMENT !< working array, dim=numels
112 INTEGER, INTENT(IN) :: NIN25
113 INTEGER, INTENT(IN) :: FLAG_ELEM_INTER25(NINTER25,NUMELS)
114 my_real, INTENT(IN) :: THK_S,THK_M ,THK_S_SCALE,THK_M_SCALE
115C-----------------------------------------------
116C L o c a l V a r i a b l e s
117C-----------------------------------------------
118 INTEGER NDX, I, J, INRT, NELS,
119 . mg, l, nn,n1,n2,n3,n4,ie,
120 . ip, nlev, mylev,
121 . ns,igtyp,nrtt,nnod,ipfmax,ipl,
122 . ipflmax,ipg,nelem,stat
123 INTEGER, DIMENSION(:), ALLOCATABLE :: TAGB
124 INTEGER JPERM(4)
125C REAL
126 my_real
127 . dxm, gapmx, gapmn, area, dx,
128 . sx1,sy1,sz1,sx2,sy2,sz2,sx3,sy3,sz3,
129 . slsfac,xl,gaps_mn
130 DATA jperm/2,3,4,1/
131 INTEGER, DIMENSION(:),ALLOCATABLE ::INRTIE
132C--------------------------------------------------------------
133C CALCULATION OF SEGMENT STIFFNESSES
134C V16: IN CASE A SEGMENT BELONGS TO BOTH
135C A BRICK AND A SHELL, WE CHOOSE THE STIFFNESS OF THE SHELL
136C OF THE SHELL UNLESS THE SHELL MATERIAL IS NULL.
137C---------------------------------------------------------------
138C NRT->NRT0
139 ALLOCATE(tagb(numnod))
140 slsfac = stfac
141C
142 IF(igap==3)THEN
143 DO i=1,nrt
144 gap_m_l(i)=ep30
145 ENDDO
146 DO i=1,nsn
147 gap_s_l(i)=ep30
148 ENDDO
149 ENDIF
150C
151 dxm=zero
152 ndx=0
153 gapmx=ep30
154 gapmn=ep30
155 gapm_mx =zero
156 gaps_mx =zero
157 gaps_mn =ep30
158 gaps_l_mx=zero
159 gapm_l_mx=zero
160C-----
161 gapmin = zero
162C-----NRTT:NRTM
163C NRT_SH nb of shells before symetrization, NRT nb of MAIN segments before symetrization (symetrization in i25surfi)
164 nrtt =nrt+nrt_sh
165C-----
166 IF(intth > 0)THEN
167 nelem = numelc+numeltg+numels+numelr
168 + + numelp+numelt+numelq+numelr+numelx+numelig3d
169 ALLOCATE(inrtie(nelem),stat=stat)
170 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
171 . msgtype=msgerror,
172 . c1='INRTIE')
173 inrtie=0
174 END IF
175C------------------------------------
176 IF(igap==3)THEN
177 DO i=1,numnod
178 wa(i)=ep30
179 ENDDO
180 DO i=1,nrt
181 xl = ep30
182
183 DO j=1,4
184 n1=irect(j,i)
185 n2=irect(jperm(j),i)
186 IF(n1 /= n2 .AND. n1 /= 0)
187 . xl=min(xl,sqrt((x(1,n1)-x(1,n2))**2+(x(2,n1)-x(2,n2))**2+
188 . (x(3,n1)-x(3,n2))**2))
189 ENDDO
190
191 gap_m_l(i)=min(percent_size*xl,gapmax_m)
192 gapm_l_mx =max(gapm_l_mx,gap_m_l(i))
193
194 DO j=1,4
195 wa(irect(j,i)) = min(wa(irect(j,i)),percent_size*xl)
196 ENDDO
197 ENDDO
198
199 DO i=1,nsn
200 gap_s_l(i)=wa(nsv(i))
201 gap_s_l(i)=min(gap_s_l(i),gapmax_s)
202 ENDDO
203
204 ENDIF
205C------------------------------------
206C GAP NODES SECONDS
207C------------------------------------
208 DO i=1,numnod
209 wa(i)=zero
210 ENDDO
211 DO i=1,numelc
212 mg=ixc(6,i)
213 ip = ipartc(i)
214 igtyp = igeo(11,mg)
215 IF ( igap == 5.AND.thk_s /= zero) THEN
216 dx=half*thk_s
217 ELSEIF ( thk_part(ip) /= zero .AND. iintthick == 0) THEN
218 dx=half*thk_part(ip)
219 ELSEIF ( thk(i) /= zero .AND. iintthick == 0) THEN
220 dx=half*thk(i)
221 ELSEIF(igtyp == 17 .OR. igtyp == 51 .OR.igtyp ==52) THEN
222 dx=half*thk(i)
223 ELSE
224 dx=half*geo(1,mg)
225 ENDIF
226 wa(ixc(2,i))=max(wa(ixc(2,i)),dx)
227 wa(ixc(3,i))=max(wa(ixc(3,i)),dx)
228 wa(ixc(4,i))=max(wa(ixc(4,i)),dx)
229 wa(ixc(5,i))=max(wa(ixc(5,i)),dx)
230 ENDDO
231 DO i=1,numeltg
232 mg=ixtg(5,i)
233 ip = iparttg(i)
234 igtyp = igeo(11,mg)
235 IF ( igap == 5.AND.thk_s /= zero ) THEN
236 dx=half*thk_s
237 ELSEIF ( thk_part(ip) /= zero .AND. iintthick == 0) THEN
238 dx=half*thk_part(ip)
239 ELSEIF ( thk(numelc+i) /= zero .AND. iintthick == 0) THEN
240 dx=half*thk(numelc+i)
241 ELSEIF(igtyp == 17 .OR. igtyp == 51 .OR. igtyp ==52) THEN
242 dx=half*thk(numelc+i)
243 ELSE
244 dx=half*geo(1,mg)
245 ENDIF
246 wa(ixtg(2,i))=max(wa(ixtg(2,i)),dx)
247 wa(ixtg(3,i))=max(wa(ixtg(3,i)),dx)
248 wa(ixtg(4,i))=max(wa(ixtg(4,i)),dx)
249 ENDDO
250C-----for case of coating shell--
251 IF (ilev/=3) THEN
252 DO i=1,numnod
253 tagb(i) = 0
254 END DO
255 DO i=1,nrt
256C MSEGTYP==0 <=> Solide
257 IF (msegtyp(i) /= 0) THEN
258 DO j =1,4
259 nn= irect(j,i)
260 tagb(nn) = 1
261 END DO
262 END IF
263 END DO
264 DO i=1,numnod
265 IF (tagb(i)==0) wa(i)=0
266 END DO
267 END IF
268C-------
269 DO i=1,numelt
270 mg=ixt(4,i)
271 ip = ipartt(i)
272 IF ( igap == 5.AND.thk_s /= zero) THEN
273 dx=half*thk_s
274 ELSEIF ( thk_part(ip) > zero ) THEN
275 dx=half*thk_part(ip)
276 ELSE
277 dx=half*sqrt(geo(1,mg))
278 END IF
279 wa(ixt(2,i))=max(wa(ixt(2,i)),dx)
280 wa(ixt(3,i))=max(wa(ixt(3,i)),dx)
281 ENDDO
282 DO i=1,numelp
283 mg=ixp(5,i)
284 ip = ipartp(i)
285 IF ( igap == 5.AND.thk_s /= zero) THEN
286 dx=half*thk_s
287 ELSEIF ( thk_part(ip) > zero ) THEN
288 dx=half*thk_part(ip)
289 ELSE
290 dx=half*sqrt(geo(1,mg))
291 END IF
292 wa(ixp(2,i))=max(wa(ixp(2,i)),dx)
293 wa(ixp(3,i))=max(wa(ixp(3,i)),dx)
294 ENDDO
295 DO i=1,numelr
296 ip = ipartr(i)
297 mg=ixr(1,i)
298 igtyp = igeo(11,mg)
299 IF ( igap == 5.AND.thk_s /= zero) THEN
300 dx=half*thk_s
301 wa(ixr(2,i))=max(wa(ixr(2,i)),dx)
302 wa(ixr(3,i))=max(wa(ixr(3,i)),dx)
303 IF (igtyp==12) wa(ixr(4,i))=max(wa(ixr(4,i)),dx)
304 ELSEIF ( thk_part(ip) > zero ) THEN
305 dx=half*thk_part(ip)
306 wa(ixr(2,i))=max(wa(ixr(2,i)),dx)
307 wa(ixr(3,i))=max(wa(ixr(3,i)),dx)
308 IF (igtyp==12) wa(ixr(4,i))=max(wa(ixr(4,i)),dx)
309 END IF
310 ENDDO
311 DO i=1,nsn
312 IF ( igap == 5.AND.thk_s /= zero) THEN
313 gap_s(i)= thk_s_scale*wa(nsv(i))
314 ELSE
315 gap_s(i)=gapscale * wa(nsv(i))
316 ENDIF
317 gap_s(i)=min(gap_s(i),gapmax_s)
318 ENDDO
319C---------put SECONDARY node on the free edge to GAP=0
320 IF(igap0 == 1)THEN
321 DO i=1,numnod
322 tagb(i)=0
323 ENDDO
324C
325 IF(ilev /= 3 )THEN
326 CALL i25bord(nrt ,irect ,tagb ) ! provisional (igap0 = 1)
327C IAD =ISURF2(3)
328C CALL I24BORD(ISURF2 ,IBUFSSG(IAD) ,TAGB )
329 ENDIF
330C IF(ILEV == 2)THEN
331C IAD =ISURF(3)
332C CALL I24BORD(ISURF ,IBUFSSG(IAD) ,TAGB )
333C ENDIF
334 DO i=1,nsn
335 ns = nsv(i)
336 IF( tagb(ns) > 0 ) gap_s(i) = zero
337 ENDDO
338 ENDIF
339C
340 DO i=1,nsn
341 IF(igap /= 3) THEN
342 gaps_mx=max(gaps_mx,gap_s(i))
343 gaps_mn=min(gaps_mn,gap_s(i))
344 ELSE
345 gaps_mx = max(gaps_mx,gap_s(i))
346 gaps_l_mx = max(gaps_l_mx,gap_s_l(i))
347 gaps_mn = min(gaps_mn,gap_s(i),gap_s_l(i))
348 END IF
349 ENDDO
350C
351C ---- FRUCTION Model Secondary Nodes Parts ------
352C-----------if node connects to both shell and solid -> takes shells
353
354 IF(intfric > 0) THEN
355C
356 IF(numels/=0)THEN
357 DO i = 1,nsn
358 ipfmax = 0
359 ipflmax = 0
360 DO j= knod2els(nsv(i))+1,knod2els(nsv(i)+1)
361 ie = nod2els(j)
362 ip = iparts(ie)
363 ipg = tagprt_fric(ip)
364 IF(ipg > 0.AND.ip>ipfmax) THEN
365 CALL friction_parts_search (
366 . ipg,intbuf_fric_tab(intfric)%S_TABPARTS_FRIC,
367 . intbuf_fric_tab(intfric)%TABPARTS_FRIC,ipl )
368 IF(ipl /=0) THEN
369 ipfmax = ip
370 ipflmax = ipl
371 ENDIF
372 ENDIF
373 ENDDO
374C
375C
376 IF(ipfmax/=0) THEN
377 ipartfrics(i) = ipflmax
378 ENDIF
379
380 ENDDO
381 ENDIF
382C
383 IF(numelc/=0.OR.numeltg/=0) THEN
384 DO i = 1,nsn
385 ipfmax = 0
386 ipflmax = 0
387 DO j= knod2elc(nsv(i))+1,knod2elc(nsv(i)+1)
388 ie = nod2elc(j)
389 ip = ipartc(ie)
390 ipg = tagprt_fric(ip)
391 IF(ipg > 0.AND.ip>ipfmax) THEN
392 CALL friction_parts_search (
393 . ipg,intbuf_fric_tab(intfric)%S_TABPARTS_FRIC,
394 . intbuf_fric_tab(intfric)%TABPARTS_FRIC,ipl )
395 IF(ipl /=0) THEN
396 ipfmax = ip
397 ipflmax = ipl
398 ENDIF
399 ENDIF
400 ENDDO
401C
402 DO j= knod2eltg(nsv(i))+1,knod2eltg(nsv(i)+1)
403 ie = nod2eltg(j)
404 ip = iparttg(ie)
405 ipg = tagprt_fric(ip)
406 IF(ipg > 0.AND.ip>ipfmax) THEN
407 CALL friction_parts_search (
408 . ipg,intbuf_fric_tab(intfric)%S_TABPARTS_FRIC,
409 . intbuf_fric_tab(intfric)%TABPARTS_FRIC,ipl )
410
411 IF(ipl /=0) THEN
412 ipfmax = ip
413 ipflmax = ipl
414 ENDIF
415 ENDIF
416 ENDDO
417C
418 IF(ipfmax/=0) THEN
419 ipartfrics(i) = ipflmax
420 ENDIF
421
422 ENDDO
423 ENDIF
424C
425
426 ENDIF
427
428C----------------------------------
429
430C------------------------------------
431C GAP STIF FACES MAIN
432C------------------------------------
433 CALL i25gapm(
434 1 x ,irect ,stf ,ixs ,pm ,
435 2 geo ,nrt ,ixc ,nint ,stfac ,
436 3 nty ,gap ,noint ,stfn ,nsn ,
437 4 ms ,nsv ,ixtg ,igap ,gap_m ,
438 6 ixt ,ixp ,
439 8 slsfac,dxm ,ndx ,
440 9 knod2els ,knod2elc ,knod2eltg ,nod2els ,
441 a nod2elc,nod2eltg ,intth,
442 b ieles ,ielem ,areas ,sh4tree ,sh3tree ,
443 c ipart ,ipartc ,iparttg ,thk ,thk_part ,
444 d ixr ,itab ,bgapsmx ,ixs10 ,msegtyp ,
445 e ixs16 ,ixs20 ,gap_n ,gaps_mx ,gapm_mx ,
446 f gapmx , gapmn ,gapscale ,gapmax_m,
447 g id ,titr ,igeo ,fillsol ,nrtt ,
448 h pm_stack, iworksh,intfric,tagprt_fric,ipartfrics,
449 i ipartfricm,iparts,intbuf_fric_tab,ipartsm,inrtie,
450 j ivis2 ,ielem_m ,idel_solid,elem_linked_to_segment,
451 k nin25 ,flag_elem_inter25 ,thk_m ,thk_m_scale)
452C---------------------------
453C GAP
454C---------------------------
455 gapmx=sqrt(gapmx)
456 gapmx=min(gapmx,gapmax_m)
457C GAP VARIABLE :
458C - GAPMIN CONTIENT ONE GAP MINIMUM UTILISE SI GAP_S(I)+GAP_M(J) < GAPMIN
459C - GAP CONTIENT LE SUP DE (GAP_S(I)+GAP_M(J),GAPMIN)
460 IF(gap<=zero)THEN
461 IF(ndx/=0)THEN
462 gapmin = gapmn
463 gapmin = min(half*gapmx,gapmin)
464 ELSE
465C GAPMIN = EM01 * GAPMX
466 gapmin = zero
467 ENDIF
468C WRITE(IOUT,1300)GAPMIN
469 ELSE
470 gapmin = gap
471 ENDIF
472C------recalculate GAP_MIN,MAX
473 gapmx=zero
474 gapmn=ep30
475 DO i=1,nrt
476 gapmx=max(gapmx,gap_m(i))
477 gapmn=min(gapmn,gap_m(i))
478 END DO
479 IF(ipri>=1) THEN
480 IF(gap<=zero)THEN
481 WRITE(iout,1400)gaps_mn,gaps_mx
482 WRITE(iout,1500)gapmn,gapm_mx
483 END IF
484 END if!(IPRI>=1) THEN
485C
486C ABOVE VARIABLE GAPS
487 IF( igap == 3) THEN
488 gap = min(gaps_mx+gapm_mx,gaps_l_mx+gapm_l_mx)
489 ELSE
490 gap = gaps_mx+gapm_mx
491 END IF
492C---------------------------------------------
493C INITIALIZATION TO ONE for NODAL SCALING SET A ONE DU MULTIPLICATEUR NODALE DES RIGIDITES
494C---------------------------------------------
495 DO 610 l=1,nsn
496 stfn(l) = one
497 610 CONTINUE
498C
499C Right Gap to be used in Sorting criteria
500C
501 bgapsmx = zero
502 gapinf=ep30
503 DO i = 1, nsn
504 bgapsmx = max(bgapsmx,gap_s(i))
505 ENDDO
506 DO i = 1, nrt
507C
508C GAPINF among shells only
509 IF(msegtyp(i)/=0) gapinf = min(gapinf,gap_m(i))
510 ENDDO
511 gapinf=max(gapinf,gapmin)
512C
513 DO i=1,nrt
514 CALL insol3et(x ,irect ,ixs ,nint ,nels,i ,
515 . area ,noint ,knod2els,nod2els,ixs10 ,
516 . ixs16,ixs20 ,nnod)
517C-------supposing only small segments (sub-triangles) for 10 nodes tetras --------------
518 IF (nnod==10) THEN
519 gap_n(1,i) = three*one_over_8*gap_n(1,i)
520 stf(i) = sixteen*stf(i)
521 ELSEIF (nnod==16) THEN
522 gap_n(1,i) = gap_n(1,i)/4
523 END IF
524 END DO
525 IF (inacti/=0) THEN
526 CALL i24normns(
527 1 x ,irect ,nrt ,nsn ,nsv ,pen_old,stf )
528 END IF
529C calculation of the second surface. ---
530 IF(intth > 0 .OR. ivis2==-1) THEN
531
532 IF(numelc/=0) THEN
533
534 IF(nadmesh==0)THEN
535 DO i = 1,nsn
536 areas(i) = zero
537 DO j= knod2elc(nsv(i))+1,knod2elc(nsv(i)+1)
538 ie = nod2elc(j)
539 sx1 = x(1,ixc(4,ie)) - x(1,ixc(2,ie))
540 sy1 = x(2,ixc(4,ie)) - x(2,ixc(2,ie))
541 sz1 = x(3,ixc(4,ie)) - x(3,ixc(2,ie))
542 sx2 = x(1,ixc(5,ie)) - x(1,ixc(3,ie))
543 sy2 = x(2,ixc(5,ie)) - x(2,ixc(3,ie))
544 sz2 = x(3,ixc(5,ie)) - x(3,ixc(3,ie))
545 sx3 = sy1*sz2 - sz1*sy2
546 sy3 = sz1*sx2 - sx1*sz2
547 sz3 = sx1*sy2 - sy1*sx2
548 areas(i) = areas(i)
549 . + one_over_8*sqrt(sx3*sx3+sy3*sy3+sz3*sz3)
550C
551 IF(intth > 0) THEN
552 ieles(i) = ixc(1,ie)
553 ENDIF
554 END DO
555C
556 DO j= knod2eltg(nsv(i))+1,knod2eltg(nsv(i)+1)
557 ie = nod2eltg(j)
558 sx1 = x(1,ixtg(3,ie)) - x(1,ixtg(2,ie))
559 sy1 = x(2,ixtg(3,ie)) - x(2,ixtg(2,ie))
560 sz1 = x(3,ixtg(3,ie)) - x(3,ixtg(2,ie))
561 sx2 = x(1,ixtg(4,ie)) - x(1,ixtg(2,ie))
562 sy2 = x(2,ixtg(4,ie)) - x(2,ixtg(2,ie))
563 sz2 = x(3,ixtg(4,ie)) - x(3,ixtg(2,ie))
564 sx3 = sy1*sz2 - sz1*sy2
565 sy3 = sz1*sx2 - sx1*sz2
566 sz3 = sx1*sy2 - sy1*sx2
567 areas(i) = areas(i)
568 . + one_over_6*sqrt(sx3*sx3+sy3*sy3+sz3*sz3)
569C
570 IF(intth > 0) THEN
571 ieles(i) = ixtg(1,ie)
572 ENDIF
573 END DO
574 END DO
575 ELSE
576 DO i = 1,nsn
577 areas(i) = zero
578 DO j= knod2elc(nsv(i))+1,knod2elc(nsv(i)+1)
579 ie = nod2elc(j)
580
581 ip = ipartc(ie)
582 nlev =ipart(10,ip)
583 mylev=sh4tree(3,ie)
584 IF(mylev < 0) mylev=-(mylev+1)
585
586 IF(mylev==nlev)THEN
587 sx1 = x(1,ixc(4,ie)) - x(1,ixc(2,ie))
588 sy1 = x(2,ixc(4,ie)) - x(2,ixc(2,ie))
589 sz1 = x(3,ixc(4,ie)) - x(3,ixc(2,ie))
590 sx2 = x(1,ixc(5,ie)) - x(1,ixc(3,ie))
591 sy2 = x(2,ixc(5,ie)) - x(2,ixc(3,ie))
592 sz2 = x(3,ixc(5,ie)) - x(3,ixc(3,ie))
593 sx3 = sy1*sz2 - sz1*sy2
594 sy3 = sz1*sx2 - sx1*sz2
595 sz3 = sx1*sy2 - sy1*sx2
596 areas(i) = areas(i)
597 . + one_over_8*sqrt(sx3*sx3+sy3*sy3+sz3*sz3)
598C
599 IF(intth > 0) THEN
600 ieles(i) = ixc(1,ie)
601 ENDIF
602 END IF
603
604 END DO
605C
606 DO j= knod2eltg(nsv(i))+1,knod2eltg(nsv(i)+1)
607 ie = nod2eltg(j)
608
609 ip = iparttg(ie)
610 nlev =ipart(10,ip)
611 mylev=sh3tree(3,ie)
612 IF(mylev < 0) mylev=-(mylev+1)
613
614 IF(mylev==nlev)THEN
615 sx1 = x(1,ixtg(3,ie)) - x(1,ixtg(2,ie))
616 sy1 = x(2,ixtg(3,ie)) - x(2,ixtg(2,ie))
617 sz1 = x(3,ixtg(3,ie)) - x(3,ixtg(2,ie))
618 sx2 = x(1,ixtg(4,ie)) - x(1,ixtg(2,ie))
619 sy2 = x(2,ixtg(4,ie)) - x(2,ixtg(2,ie))
620 sz2 = x(3,ixtg(4,ie)) - x(3,ixtg(2,ie))
621 sx3 = sy1*sz2 - sz1*sy2
622 sy3 = sz1*sx2 - sx1*sz2
623 sz3 = sx1*sy2 - sy1*sx2
624 areas(i) = areas(i)
625 . + one_over_6*sqrt(sx3*sx3+sy3*sy3+sz3*sz3)
626C
627 IF(intth > 0) THEN
628 ieles(i) = ixtg(1,ie)
629 ENDIF
630 END IF
631
632 END DO
633 END DO
634 END IF
635 ENDIF
636 ENDIF
637
638C
639 IF(intth > 0 ) THEN
640
641 IF(ilev /= 3 )THEN
642 IF(numels/=0)THEN
643 DO i = 1,nsn
644 areas(i) = zero
645 DO j= knod2els(nsv(i))+1,knod2els(nsv(i)+1)
646 ie = nod2els(j)
647 inrt = inrtie(ie)
648 IF(inrt/=0)THEN
649 n1=irect(1,inrt)
650 n2=irect(2,inrt)
651 n3=irect(3,inrt)
652 n4=irect(4,inrt)
653
654 IF(n3 /= n4) THEN
655 sx1 = x(1,n3) - x(1,n1)
656 sy1 = x(2,n3) - x(2,n1)
657 sz1 = x(3,n3) - x(3,n1)
658 sx2 = x(1,n4) - x(1,n2)
659 sy2 = x(2,n4) - x(2,n2)
660 sz2 = x(3,n4) - x(3,n2)
661 sx3 = sy1*sz2 - sz1*sy2
662 sy3 = sz1*sx2 - sx1*sz2
663 sz3 = sx1*sy2 - sy1*sx2
664 area = one_over_8*sqrt(sx3*sx3+sy3*sy3+sz3*sz3)
665 areas(i) = areas(i) + area
666C
667
668 ELSE
669 sx1 = x(1,n2) - x(1,n1)
670 sy1 = x(2,n2) - x(2,n1)
671 sz1 = x(3,n2) - x(3,n1)
672 sx2 = x(1,n3) - x(1,n1)
673 sy2 = x(2,n3) - x(2,n1)
674 sz2 = x(3,n3) - x(3,n1)
675 sx3 = sy1*sz2 - sz1*sy2
676 sy3 = sz1*sx2 - sx1*sz2
677 sz3 = sx1*sy2 - sy1*sx2
678 area = one_over_6*sqrt(sx3*sx3+sy3*sy3+sz3*sz3)
679 areas(i) = areas(i) + area
680 ENDIF
681 IF(intth > 0) THEN
682 ieles(i) = ixs(1,ie)
683 ENDIF
684 ENDIF
685 END DO
686 ENDDO
687 ENDIF
688 ENDIF
689
690 END IF
691C
692 IF(intth > 0)THEN
693 IF(drad==zero)THEN
694 drad=max(gap,gapmx)
695 ELSEIF(drad<gap)THEN
696 drad=gap
697 END IF
698 WRITE(iout,2001)drad
699
700 IF(drad>gapmx)THEN
701 CALL ancmsg(msgid=918,
702 . msgtype=msgwarning,
703 . anmode=aninfo_blind_2,
704 . i1=id,
705 . c1=titr,
706 . r1=drad ,
707 . r2=gapmx,
708 . i2=id)
709 END IF
710 END IF
711
712 IF(intth > 0) DEALLOCATE(inrtie)
713
714 DEALLOCATE(tagb)
715
716 RETURN
717 1300 FORMAT(2x,'GAP MIN = ',1pg20.13)
718 1400 FORMAT(2x,'MIN,MAX OF SECONDARY GAP: ',2(1pg20.13))
719 1500 FORMAT(2x,'MIN,MAX OF MAIN GAP: ',2(1pg20.13)/)
720 2001 FORMAT(2x,'Maximum distance for radiation computation = ',
721 . 1pg20.13)
722 END
723!||====================================================================
724!|| i25gapm ../starter/source/interfaces/inter3d1/i25sti3.F
725!||--- called by ------------------------------------------------------
726!|| i25sti3 ../starter/source/interfaces/inter3d1/i25sti3.F
727!||--- calls -----------------------------------------------------
728!|| ancmsg ../starter/source/output/message/message.F
729!|| friction_parts_search ../starter/source/interfaces/inter3d1/i7sti3.F
730!|| i4gmx3 ../starter/source/interfaces/inter3d1/i4gmx3.F
731!|| incoq3 ../starter/source/interfaces/inter3d1/incoq3.F
732!|| insol3d ../starter/source/interfaces/inter3d1/insol3.F
733!|| volint ../starter/source/interfaces/inter3d1/volint.F
734!||--- uses -----------------------------------------------------
735!|| message_mod ../starter/share/message_module/message_mod.F
736!||====================================================================
737 SUBROUTINE i25gapm(
738 1 X ,IRECT ,STF ,IXS ,PM ,
739 2 GEO ,NRT ,IXC ,NINT ,STFAC ,
740 3 NTY ,GAP ,NOINT ,STFN ,NSN ,
741 4 MS ,NSV ,IXTG ,IGAP ,GAP_M ,
742 6 IXT ,IXP ,
743 7 SLSFAC,DXM ,NDX ,
744 9 KNOD2ELS ,KNOD2ELC ,KNOD2ELTG ,NOD2ELS ,
745 A NOD2ELC,NOD2ELTG ,INTTH,
746 B IELES ,IELEM ,AREAS ,SH4TREE ,SH3TREE ,
747 C IPART ,IPARTC ,IPARTTG ,THK ,THK_PART ,
748 D IXR ,ITAB ,BGAPSMX ,IXS10 ,MSEGTYP ,
749 E IXS16 ,IXS20 ,GAP_N ,GAPS1 ,GAPS2 ,
750 F GAPMX , GAPMN ,GAPSCALE ,GAPMAX_M,
751 G ID ,TITR ,IGEO ,FILLSOL ,NRTT ,
752 H PM_STACK, IWORKSH,INTFRIC,TAGPRT_FRIC,IPARTFRICS,
753 I IPARTFRICM,IPARTS,INTBUF_FRIC_TAB,IPARTSM,INRTIE,
754 J IVIS2 ,IELEM_M ,IDEL_SOLID,ELEM_LINKED_TO_SEGMENT,
755 F NIN25 ,FLAG_ELEM_INTER25,THK_M ,THK_M_SCALE)
756C-----------------------------------------------
757 USE message_mod
758 USE intbuf_fric_mod
759 USE my_alloc_mod
760 USE names_and_titles_mod , ONLY : nchartitle
761 use element_mod , only : nixs,nixc,nixtg,nixt,nixp,nixr
762C-----------------------------------------------
763C I m p l i c i t T y p e s
764C-----------------------------------------------
765#include "implicit_f.inc"
766C-----------------------------------------------
767C C o m m o n B l o c k s
768C-----------------------------------------------
769#include "com01_c.inc"
770#include "com04_c.inc"
771#include "param_c.inc"
772#include "scr17_c.inc"
773#include "scr08_c.inc"
774C-----------------------------------------------
775C D u m m y A r g u m e n t s
776C-----------------------------------------------
777 INTEGER NRT, NINT, NTY, NOINT,NSN,IGAP, NDX,INTFRIC
778 INTEGER IRECT(4,*), IXS(NIXS,*), IXC(NIXC,*),
779 . NSV(*), IXTG(NIXTG,*), IXT(NIXT,*), IXP(NIXP,*),
780 . KNOD2ELS(*), KNOD2ELC(*), KNOD2ELTG(*), NOD2ELS(*), NOD2ELC(*),
781 . NOD2ELTG(*), IELES(*), INTTH, IELEM(*),
782 . SH3TREE(KSH3TREE,*), SH4TREE(KSH4TREE,*),IXR(NIXR,*) ,
783 . IPART(LIPART1,*), IPARTC(*), IPARTTG(*),IPARTS(*),
784 . ITAB(*), IXS10(6,*),MSEGTYP(*), IXS16(*), IXS20(*),
785 . IGEO(NPROPGI,*),NRTT,IWORKSH(3,*),TAGPRT_FRIC(*),IPARTFRICS(*),
786 . IPARTFRICM(*) ,IPARTSM(*),INRTIE(*)
787 INTEGER , INTENT(IN) :: IVIS2
788 my_real
789 . STFAC, GAP,BGAPSMX,GAPS1 ,GAPS2,GAPMX ,GAPMN ,GAPSCALE
790 my_real
791 . X(3,*), STF(*), PM(NPROPM,*), GEO(NPROPG,*), STFN(*),
792 . MS(*),GAP_M(*),GAP_N(4,*),
793 . AREAS(*),THK(*),THK_PART(*),SLSFAC,DXM ,GAPMAX_M, FILLSOL(*),
794 . PM_STACK(20,*)
795 INTEGER ID
796 CHARACTER(LEN=NCHARTITLE) :: TITR
797 TYPE(intbuf_fric_struct_) INTBUF_FRIC_TAB(*)
798 INTEGER , INTENT(INOUT) :: IELEM_M(2,NRTT)
799 INTEGER , INTENT(INOUT) :: IDEL_SOLID
800 INTEGER, DIMENSION(NUMELS), INTENT(INOUT):: ELEM_LINKED_TO_SEGMENT !< working array, dim=numels
801 INTEGER, INTENT(IN) :: NIN25
802 INTEGER, INTENT(INOUT) :: FLAG_ELEM_INTER25(NINTER25,NUMELS)
803 my_real, INTENT(IN) :: THK_M ,THK_M_SCALE
804C-----------------------------------------------
805C L o c a l V a r i a b l e s
806C-----------------------------------------------
807 INTEGER I, J, NELS, MT, JJ, JJJ, NELC,
808 . MG, NELTG,
809 . IP,NREV,IGTYP,IPGMAT,IGMAT,
810 . ISUBSTACK,IPL,IPG,ISOL,NINV,NSOL_INT,NELS2,MT2,OFC,OFTG,ICONTR
811 INTEGER, DIMENSION(:),ALLOCATABLE :: TAGELEMS,INDEXE
812 LOGICAL :: PRINT_ERROR
813 INTEGER, DIMENSION(4) :: NODE_ID
814C REAL
815 my_real
816 . area, vol, dx, gapm,
817 .
818 . stc,stf2,stf1,vol2,bulk
819C----------------------
820 isol = 0
821 nrev=0
822 ipgmat = 700
823C
824 ofc=numels+numelq
825 oftg=ofc+numelc+numelt+numelp+numelr
826C
827
828 IF(numels > 0) THEN
829 CALL my_alloc(tagelems,numels)
830 tagelems = 0
831 CALL my_alloc(indexe,numels)
832 indexe = 0
833 ENDIF
834
835 ninv = 0
836 nsol_int = 0
837
838 DO i=1,nrt
839 stf(i)=zero
840 IF(intth > 0 ) ielem(i) = 0
841 IF(slsfac<zero)stf(i)=slsfac
842 gapm =zero
843 gap_m(i)=gapm
844 CALL i4gmx3(x,irect,i,gapmx)
845C----------------------
846C ELEMENTS SOLIDES
847C----------------------
848 print_error = .false.
849 CALL insol3d(x,irect,ixs,nint,nels,i ,
850 . area,noint,knod2els ,nod2els ,0,
851 . ixs10,ixs16,ixs20,tagelems,indexe,
852 . ninv ,ielem_m(1,i),
853 . elem_linked_to_segment ,print_error,
854 . nin25,nty, flag_elem_inter25 )
855
856 IF(print_error) THEN
857 node_id(1:4) = itab(irect(1:4,i))
858
859 CALL ancmsg(msgid=3062,
860 . msgtype=msgwarning,
861 . anmode=aninfo_blind_1,
862 . i1=id,
863 . i2=node_id(1),
864 . i3=node_id(2),
865 . i4=node_id(3),
866 . i5=node_id(4),
867 . c1=titr ,
868 . prmod=msg_print)
869 ENDIF
870
871 IF(nels/=0) THEN
872 mt=ixs(1,nels)
873 mg=ixs(nixs-1,nels)
874 icontr = igeo(97,mg)
875 IF(intth > 0 ) ielem(i) = mt
876 IF(intth > 0 ) inrtie(nels) = i
877 IF(mt>0)THEN
878 DO jj=1,8
879 jjj=ixs(jj+1,nels)
880 xc(jj)=x(1,jjj)
881 yc(jj)=x(2,jjj)
882 zc(jj)=x(3,jjj)
883 ENDDO
884 CALL volint(vol)
885 IF (icontr==1 ) THEN
886 bulk = pm(107,mt)
887 ELSE
888 bulk = pm(32,mt)
889 END IF
890 stf(i)=slsfac*fillsol(nels)*area*area*bulk/vol
891 IF(ielem_m(2,i) > 0) THEN ! If internal segment shared between 2 elements
892 nels2 =ielem_m(2,i)
893 mt2=ixs(1,nels2)
894 DO jj=1,8
895 jjj=ixs(jj+1,nels2 )
896 xc(jj)=x(1,jjj)
897 yc(jj)=x(2,jjj)
898 zc(jj)=x(3,jjj)
899 ENDDO
900 CALL volint(vol2)
901 stf2 = slsfac*fillsol(nels2)*area*area*pm(32,mt2)/vol2
902 stf1 = stf(i)
903 stf(i) = half*(stf2+stf1) ! Internal segment Stiff = Mean(STIFF)
904 ENDIF
905 ELSE
906 IF(nint>=0) THEN
907 CALL ancmsg(msgid=95,
908 . msgtype=msgwarning,
909 . anmode=aninfo_blind_2,
910 . i1=id,
911 . c1=titr,
912 . i2=ixs(nixs,nels),
913 . c2='SOLID',
914 . i3=i)
915 ENDIF
916 IF(nint<0) THEN
917 CALL ancmsg(msgid=96,
918 . msgtype=msgwarning,
919 . anmode=aninfo_blind_2,
920 . i1=id,
921 . c1=titr,
922 . i2=ixs(nixs,nels),
923 . c2='SOLID',
924 . i3=i)
925 ENDIF
926 ENDIF
927 isol = 1
928 gap_n(1,i)=vol/area
929 IF(ielem_m(2,i) > 0) gap_n(1,i) = half*(gap_n(1,i) + vol2/area) ! Internal segment Gap = Mean(Gap)
930 IF(ielem_m(2,i) > 0) nsol_int = nsol_int + 1
931C--------Correction for different elements
932 IF(nels>numels8.AND.nels<=numels8+numels10)THEN
933 gap_n(1,i) = three*one_over_8*gap_n(1,i)
934 stf(i) = sixteen*stf(i)
935 ELSEIF(nels>numels8+numels10+numels20.AND.nels<=numels8+numels10+numels20+numels16) THEN
936 gap_n(1,i) = gap_n(1,i)/4
937 END IF
938
939C -----Friction model ------
940 IF(intfric > 0) THEN
941 ip= iparts(nels)
942 ipartsm(i) = ip
943 ipg = tagprt_fric(ip)
944 IF(ipg > 0) THEN
945 CALL friction_parts_search (
946 . ipg,intbuf_fric_tab(intfric)%S_TABPARTS_FRIC,
947 . intbuf_fric_tab(intfric)%TABPARTS_FRIC,ipl )
948 ipartfricm(i) = ipl
949 ENDIF
950 ENDIF
951C -----Case of internal segment : put stiffness to negative ------
952 IF(ielem_m(2,i) > 0) stf(i) = - stf(i)
953
954C------------------------------------
955 ENDIF
956C---------------------
957C ELEMENTS COQUES
958C---------------------
959 CALL incoq3(irect,ixc ,ixtg ,nint ,nelc ,
960 . neltg,i ,geo ,pm ,knod2elc ,
961 . knod2eltg ,nod2elc ,nod2eltg,thk,nty,igeo,
962 . pm_stack , iworksh)
963
964 IF(neltg/=0) THEN
965C
966 mt=ixtg(1,neltg)
967 mg=ixtg(5,neltg)
968 igtyp = igeo(11,mg)
969 ip = iparttg(neltg)
970 ielem_m(1,i) = oftg+neltg
971 ielem_m(2,i) = 0
972
973 IF(intth > 0 ) ielem(i) = mt
974 IF ( igap == 5.AND.thk_m /= zero) THEN
975 dx=thk_m_scale*thk_m
976 ELSEIF ( thk_part(ip) /= zero .AND. iintthick == 0) THEN
977 dx=thk_part(ip)*gapscale
978 ELSEIF ( thk(numelc+neltg) /= zero .AND. iintthick == 0)THEN
979 dx=thk(numelc+neltg)*gapscale
980 ELSEIF(igtyp == 17 .OR. igtyp == 51 .OR. igtyp ==52) THEN
981 dx=thk(numelc+neltg)*gapscale
982 ELSE
983 dx=geo(1,mg)*gapscale
984 ENDIF
985 gapm=half*dx
986 gaps2=max(gaps2,gapm)
987 gapmn = min(gapmn,dx)
988 dxm=dxm+dx
989 ndx=ndx+1
990 gap_m(i)=max(gap_m(i),gapm)
991C -----Friction model ------
992 IF(intfric > 0) THEN
993 ip= iparttg(neltg)
994 ipartsm(i) = ip
995 ipg = tagprt_fric(ip)
996 IF(ipg > 0) THEN
997 CALL friction_parts_search (
998 . ipg,intbuf_fric_tab(intfric)%S_TABPARTS_FRIC,
999 . intbuf_fric_tab(intfric)%TABPARTS_FRIC,ipl )
1000 ipartfricm(i) = ipl
1001
1002 ENDIF
1003 ENDIF
1004C------------------------------------
1005 IF(mt>0)THEN
1006 IF(igtyp ==11 .AND. igmat > 0 ) THEN
1007 IF ( thk(numelc+neltg) /= zero .AND. iintthick == 0) THEN
1008 stc=slsfac*thk(numelc+neltg)*geo(ipgmat + 2 ,mg)
1009 ELSE
1010 stc=slsfac*geo(1,mg)*geo(ipgmat + 2 ,mg)
1011 ENDIF
1012 ELSEIF(igtyp ==52.OR.
1013 . ((igtyp == 17 .OR. igtyp == 51) .AND. igmat > 0))THEN
1014 isubstack = iworksh(3,numelc+neltg)
1015 stc=slsfac*thk(numelc+neltg)*pm_stack(2 ,isubstack)
1016 ELSE
1017 IF ( thk(numelc+neltg) /= zero .AND. iintthick == 0) THEN
1018 stc=slsfac*thk(numelc+neltg)*pm(20,mt)
1019 ELSEIF(igtyp == 17 .OR. igtyp == 51) THEN
1020 stc=slsfac*thk(numelc+neltg)*pm(20,mt)
1021 ELSE
1022 stc=slsfac*geo(1,mg)*pm(20,mt)
1023 ENDIF
1024 ENDIF
1025C
1026 stf(i)=max(stf(i),stc)
1027 IF (msegtyp(i) > 0) THEN ! (MSEGTYP /=0 .AND. MSEGTYP <= NRTT) .OR. MSEGTYP > NRTT
1028 j= msegtyp(i)
1029 IF(j > nrtt) j=j-nrtt
1030 stf(j) = stc
1031 gap_m(j)= gap_m(i)
1032 IF(intth > 0 ) ielem(j) = ielem(i)
1033 IF(intfric > 0) ipartfricm(j)=ipartfricm(i)
1034 ielem_m(1,j) = ielem_m(1,i)
1035 ielem_m(2,j) = 0
1036 IF(intfric > 0)ipartsm(j) = ip
1037 END IF
1038C
1039 ELSE
1040 IF(nint>=0) THEN
1041 CALL ancmsg(msgid=95,
1042 . msgtype=msgwarning,
1043 . anmode=aninfo_blind_2,
1044 . i1=id,
1045 . c1=titr,
1046 . i2=ixtg(nixtg,neltg),
1047 . c2='SHELL',
1048 . i3=i)
1049 ENDIF
1050 IF(nint<0) THEN
1051 CALL ancmsg(msgid=96,
1052 . msgtype=msgwarning,
1053 . anmode=aninfo_blind_2,
1054 . i1=id,
1055 . c1=titr,
1056 . i2=ixtg(nixtg,neltg),
1057 . c2='SHELL',
1058 . i3=i)
1059 ENDIF
1060 ENDIF
1061 ELSEIF(nelc/=0) THEN
1062 mt=ixc(1,nelc)
1063 mg=ixc(6,nelc)
1064 ip = ipartc(nelc)
1065 igtyp = igeo(11,mg)
1066 igmat = igeo(98,mg)
1067 ielem_m(1,i) = ofc+nelc
1068 ielem_m(2,i) = 0
1069
1070 IF(intth > 0 ) ielem(i) = mt
1071 IF ( igap == 5.AND.thk_m /= zero) THEN
1072 dx=thk_m_scale*thk_m
1073 ELSEIF (thk_part(ip) /= zero .AND. iintthick == 0) THEN
1074 dx=thk_part(ip)*gapscale
1075 ELSEIF ( thk(nelc) /= zero .AND. iintthick == 0) THEN
1076 dx=thk(nelc)*gapscale
1077 ELSEIF(igtyp == 17 .OR. igtyp == 51 .OR. igtyp ==52) THEN
1078 dx=thk(nelc)*gapscale
1079 ELSE
1080 dx=geo(1,mg)*gapscale
1081 ENDIF
1082 gapm=half*dx
1083 gaps2=max(gaps2,gapm)
1084 gapmn = min(gapmn,dx)
1085 dxm=dxm+dx
1086 ndx=ndx+1
1087 gap_m(i)=max(gap_m(i),gapm)
1088C -----Friction model ------
1089 IF(intfric > 0) THEN
1090 ip= ipartc(nelc)
1091 ipartsm(i) = ip
1092 ipg = tagprt_fric(ip)
1093 IF(ipg > 0) THEN
1094 CALL friction_parts_search (
1095 . ipg,intbuf_fric_tab(intfric)%S_TABPARTS_FRIC,
1096 . intbuf_fric_tab(intfric)%TABPARTS_FRIC,ipl )
1097 ipartfricm(i) = ipl
1098
1099 ENDIF
1100 ENDIF
1101C------------------------------------
1102 IF(mt>0)THEN
1103 IF(igtyp == 11 .AND. igmat > 0) THEN
1104 IF ( thk(nelc) /= zero .AND. iintthick == 0) THEN
1105 stc=slsfac*thk(nelc)*geo(ipgmat + 2 ,mg)
1106 ELSE
1107 stc=slsfac*geo(1,mg)*geo(ipgmat + 2 ,mg)
1108 ENDIF
1109 ELSEIF(igtyp ==52.OR.
1110 . ((igtyp == 17 .OR. igtyp == 51) .AND. igmat > 0))THEN
1111 isubstack = iworksh(3,nelc)
1112 stc=slsfac*thk(nelc)*pm_stack(2,isubstack)
1113 ELSE
1114 IF ( thk(nelc) /= zero .AND. iintthick == 0) THEN
1115 stc=slsfac*thk(nelc)*pm(20,mt)
1116 ELSEIF(igtyp == 17 .OR. igtyp == 51) THEN
1117 stc=slsfac*thk(nelc)*pm(20,mt)
1118 ELSE
1119 stc=slsfac*geo(1,mg)*pm(20,mt)
1120 ENDIF
1121 ENDIF
1122C
1123 stf(i)=max(stf(i),stc)
1124 IF (msegtyp(i) > 0) THEN ! (MSEGTYP /=0 .AND. MSEGTYP <= NRTT) .OR. MSEGTYP > NRTT
1125 j= msegtyp(i)
1126 IF(j > nrtt) j=j-nrtt
1127 stf(j) = stc
1128 gap_m(j)= gap_m(i)
1129 IF(intth > 0 ) ielem(j) = ielem(i)
1130 IF(intfric > 0) ipartfricm(j)=ipartfricm(i)
1131 ielem_m(1,j) = ielem_m(1,i)
1132 ielem_m(2,j) = 0
1133 IF(intfric > 0) ipartsm(j) = ip
1134 END IF
1135C
1136 ELSE
1137 IF(nint>=0) THEN
1138 CALL ancmsg(msgid=95,
1139 . msgtype=msgwarning,
1140 . anmode=aninfo_blind_2,
1141 . i1=id,
1142 . c1=titr,
1143 . i2=ixc(nixc,nelc),
1144 . c2='SHELL',
1145 . i3=i)
1146 ENDIF
1147 IF(nint<0) THEN
1148 CALL ancmsg(msgid=96,
1149 . msgtype=msgwarning,
1150 . anmode=aninfo_blind_2,
1151 . i1=id,
1152 . c1=titr,
1153 . i2=ixc(nixc,nelc),
1154 . c2='SHELL',
1155 . i3=i)
1156 ENDIF
1157 ENDIF
1158 ENDIF
1159C
1160 IF(nels+nelc+neltg==0)THEN
1161C In SPMD you need an element associated with the edge otherwise error
1162 IF(nint>0) THEN
1163 CALL ancmsg(msgid=481,
1164 . msgtype=msgerror,
1165 . anmode=aninfo_blind_2,
1166 . i1=id,
1167 . c1=titr,
1168 . i2=i)
1169 ENDIF
1170 IF(nint<0) THEN
1171 CALL ancmsg(msgid=482,
1172 . msgtype=msgerror,
1173 . anmode=aninfo_blind_2,
1174 . i1=id,
1175 . c1=titr,
1176 . i2=i)
1177 ENDIF
1178 ENDIF
1179 END DO
1180C
1181 IF(numels > 0) DEALLOCATE(tagelems,indexe)
1182C
1183 CALL ancmsg(msgid=3022,
1184 . msgtype=msgwarning,
1185 . anmode=aninfo_blind_1,
1186 . i1=id,
1187 . c1=titr,
1188 . prmod=msg_print)
1189 CALL ancmsg(msgid=3024,
1190 . msgtype=msgwarning,
1191 . anmode=aninfo_blind_1,
1192 . i1=id,
1193 . c1=titr,
1194 . prmod=msg_print)
1195 IF(ninv > 0 .AND.nint>0)
1196 . CALL ancmsg(msgid=3023,
1197 . msgtype=msgwarning,
1198 . anmode=aninfo_blind_1,
1199 . i1=id,
1200 . c1=titr,
1201 . i2=ninv)
1202C
1203 IF(ninv > 0 .AND.nint< 0)
1204 . CALL ancmsg(msgid=3025,
1205 . msgtype=msgwarning,
1206 . anmode=aninfo_blind_1,
1207 . i1=id,
1208 . c1=titr,
1209 . i2=ninv)
1210C
1211 IF(ivis2 ==-1.AND.isol /=0) THEN
1212 CALL ancmsg(msgid=2096,
1213 . msgtype=msgerror,
1214 . anmode=aninfo_blind_2,
1215 . i1=id,
1216 . c1=titr)
1217 ENDIF
1218C
1219 DO i=1,nrtt
1220 gap_m(i)=min(gap_m(i),gapmax_m)
1221 END DO
1222C Update option erosion solid : only if /SURF/PART/ALL is defined on solid parts
1223 IF(nsol_int == 0) THEN
1224 idel_solid = 0
1225 ENDIF
1226
1227C-----------------------------------------------
1228 RETURN
1229 1400 FORMAT(i10,' MAIN SEGMENTS',' OF INTERFACE',i10,
1230 + ' ARE REVERSED THE NORMAL DIRECTION')
1231 END
1232!||====================================================================
1233!|| i25bord ../starter/source/interfaces/inter3d1/i25sti3.F
1234!||--- called by ------------------------------------------------------
1235!|| i25sti3 ../starter/source/interfaces/inter3d1/i25sti3.F
1236!||--- calls -----------------------------------------------------
1237!||====================================================================
1238 SUBROUTINE i25bord(NRTM ,IRECT ,TAGB )
1239C============================================================================
1240C-----------------------------------------------
1241C I m p l i c i t T y p e s
1242C-----------------------------------------------
1243#include "implicit_f.inc"
1244C-----------------------------------------------
1245C D u m m y A r g u m e n t s
1246C-----------------------------------------------
1247 INTEGER NRTM, IRECT(4,*), TAGB(*)
1248C-----------------------------------------------
1249C L o c a l V a r i a b l e s
1250C-----------------------------------------------
1251 INTEGER J,K,L,NLMAX,STAT,LL,I1,I2,I3,I4,I1M,I2M,IS,BORD,BOLD
1252 INTEGER NEXTK(4),IWORK(70000)
1253 INTEGER, DIMENSION(:,:), ALLOCATABLE ::
1254 . LINEIX
1255 INTEGER, DIMENSION(:), ALLOCATABLE ::
1256 . index
1257
1258
1259 DATA nextk/2,3,4,1/
1260C=======================================================================
1261 nlmax = 4*nrtm
1262
1263 ALLOCATE (lineix(2,nlmax) ,stat=stat)
1264 ALLOCATE (index(2*nlmax) ,stat=stat)
1265c---------------------------------------
1266c search for all lines on the surface
1267c---------------------------------------
1268 is = 0
1269 ll = 0
1270 DO j=1,nrtm
1271 is = is+1
1272 i1=irect(1,j)
1273 i2=irect(2,j)
1274 i3=irect(3,j)
1275 i4=irect(4,j)
1276 DO k=1,3
1277 i1=irect(k,j)
1278 i2=irect(nextk(k),j)
1279 ll = ll+1
1280 IF(i2 > i1)THEN
1281 lineix(1,ll) = i1
1282 lineix(2,ll) = i2
1283 ELSE
1284 lineix(1,ll) = i2
1285 lineix(2,ll) = i1
1286 ENDIF
1287 ENDDO
1288 IF(i3/=i4)THEN
1289 k=4
1290 i1=irect(k,j)
1291 i2=irect(nextk(k),j)
1292 ll = ll+1
1293 IF(i2 > i1)THEN
1294 lineix(1,ll) = i1
1295 lineix(2,ll) = i2
1296 ELSE
1297 lineix(1,ll) = i2
1298 lineix(2,ll) = i1
1299 ENDIF
1300 END IF
1301 ENDDO
1302C
1303 CALL my_orders(0,iwork,lineix,index,ll,2)
1304
1305c---------------------------------------
1306c removal of double lines
1307c---------------------------------------
1308 i1m = lineix(1,index(1))
1309 i2m = lineix(2,index(1))
1310 bord=1
1311 bold=1
1312 DO l=2,ll
1313 i1 = lineix(1,index(l))
1314 i2 = lineix(2,index(l))
1315 IF(i2 == i2m .and. i1 == i1m)THEN
1316C is not on the edge
1317 bord=0
1318 bold=0
1319 ELSEIF(bold == 0)THEN
1320C just reattached, we proceed with this new edge.
1321C BORD=0
1322 bold=1
1323 ELSE
1324 bord=1 ! bord
1325 bold=1
1326 tagb(i1m) = 1
1327 tagb(i2m) = 1
1328 ENDIF
1329 i1m = i1
1330 i2m = i2
1331 ENDDO
1332
1333 IF(bord==1)THEN
1334c last edge is an edge
1335 tagb(i1) = 1
1336 tagb(i2) = 1
1337 ENDIF
1338
1339
1340 DEALLOCATE (index)
1341 DEALLOCATE (lineix)
1342C-----------
1343 RETURN
1344 END
1345
my_real
#define my_real
Definition cppsort.cpp:32
if
if(complex_arithmetic) id
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:1912
insol3et
subroutine insol3et(x, irect, ixs, nint, nel, i, area, noint, knod2els, nod2els, ixs10, ixs16, ixs20, nnod)
Definition i24sti3.F:962
i25gapm
subroutine i25gapm(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, intth, ieles, ielem, areas, sh4tree, sh3tree, ipart, ipartc, iparttg, thk, thk_part, ixr, itab, bgapsmx, ixs10, msegtyp, ixs16, ixs20, gap_n, gaps1, gaps2, gapmx, gapmn, gapscale, gapmax_m, id, titr, igeo, fillsol, nrtt, pm_stack, iworksh, intfric, tagprt_fric, ipartfrics, ipartfricm, iparts, intbuf_fric_tab, ipartsm, inrtie, ivis2, ielem_m, idel_solid, elem_linked_to_segment, nin25, flag_elem_inter25, thk_m, thk_m_scale)
Definition i25sti3.F:756
i25sti3
subroutine i25sti3(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, gapscale, ixt, ixp, gapinf, gapmax_s, inacti, knod2els, knod2elc, knod2eltg, nod2els, nod2elc, nod2eltg, intth, ieles, ielem, areas, sh4tree, sh3tree, ipart, ipartc, iparttg, thk, thk_part, ixr, itab, bgapsmx, ixs10, msegtyp, nrt_sh, ixs16, ixs20, gap_n, ilev, gapmax_m, id, titr, igap0, pen_old, iparts, igeo, fillsol, pm_stack, iworksh, percent_size, gap_s_l, gap_m_l, knod2el1d, nod2el1d, intfric, tagprt_fric, ipartfrics, ipartfricm, intbuf_fric_tab, ivis2, gapm_mx, gaps_mx, gapm_l_mx, gaps_l_mx, ipartsm, drad, ipartt, ipartp, ipartr, ielem_m, idel_solid, elem_linked_to_segment, nin25, flag_elem_inter25, thk_s, thk_m, thk_s_scale, thk_m_scale)
Definition i25sti3.F:59
i25bord
subroutine i25bord(nrtm, irect, tagb)
Definition i25sti3.F:1239
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
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
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
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
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
volint
subroutine volint(vol)
Definition volint.F:38