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