OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i20sti3.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!|| i20sti3 ../starter/source/interfaces/inter3d1/i20sti3.F
25!||--- called by ------------------------------------------------------
26!|| i20ini3 ../starter/source/interfaces/inter3d1/i20ini3.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| bitget ../starter/source/interfaces/inter3d1/bitget.f
30!|| bitset ../starter/source/interfaces/inter3d1/bitget.F
31!|| bitunset ../starter/source/interfaces/inter3d1/bitget.F
32!|| i20nelts ../starter/source/interfaces/inter3d1/inelt.F
33!|| i4gmx3 ../starter/source/interfaces/inter3d1/i4gmx3.F
34!|| incoq3 ../starter/source/interfaces/inter3d1/incoq3.F
35!|| ineltc ../starter/source/interfaces/inter3d1/inelt.F
36!|| insol3 ../starter/source/interfaces/inter3d1/insol3.F
37!|| volint ../starter/source/interfaces/inter3d1/volint.F
38!||--- uses -----------------------------------------------------
39!|| message_mod ../starter/share/message_module/message_mod.F
40!||====================================================================
41 SUBROUTINE i20sti3(
42 1 PM ,GEO ,X ,MS ,
43 2 IXS ,IXC ,IXTG ,IXT ,
44 3 IXP ,WA ,NINT ,NTY ,
45 4 NOINT ,NRT ,NSN ,IRECT ,
46 5 NSV ,INACTI ,GAP ,IGAP ,
47 6 GAP_S ,GAP_M ,GAPMIN ,GAPINF ,
48 7 GAPMAX ,STFAC ,STF ,STFN ,
49 8 KNOD2ELS ,KNOD2ELC ,KNOD2ELTG ,NOD2ELS ,
50 9 NOD2ELC ,NOD2ELTG ,IGRSURF1 ,IFS2 ,
51 A IGRSURF2 ,INTTH ,IELES ,
52 B IELEC ,AREAS ,IPARTC ,IPARTTG ,
53 C THK ,THK_PART ,GAP_SH ,XANEW ,
54 D GAPSHMAX ,NBINFLG ,MBINFLG ,NLN ,
55 E NLG ,GAPSOL ,IXS10 ,IXS16 ,
56 F IXS20 ,ID,TITR ,IGEO ,PM_STACK ,
57 G IWORKSH )
58C-----------------------------------------------
59C M o d u l e s
60C-----------------------------------------------
61 USE groupdef_mod
62 USE message_mod
63 USE names_and_titles_mod , ONLY : nchartitle
64C-----------------------------------------------
65C I m p l i c i t T y p e s
66C-----------------------------------------------
67#include "implicit_f.inc"
68C-----------------------------------------------
69C C o m m o n B l o c k s
70C-----------------------------------------------
71#include "param_c.inc"
72#include "com01_c.inc"
73#include "com04_c.inc"
74#include "scr05_c.inc"
75#include "scr08_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, NDDIM,
80 . INACTI,IFS2,NLN
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 . IPARTC(*), IPARTTG(*),NBINFLG(*),MBINFLG(*),NLG(*) ,
86 . IXS10(6,*), IXS16(*), IXS20(*), IGEO(NPROPGI,*),IWORKSH(3,*)
87C REAL
88 my_real
89 . STFAC, GAP,GAPMIN,GAPINF, GAPMAX,GAPSHMAX,GAPSOLIDMAX,GAPSOL
90C REAL
91 my_real
92 . X(3,*), STF(*), PM(NPROPM,*), GEO(NPROPG,*), STFN(*),
93 . MS(*),WA(*),GAP_S(*),GAP_M(*),GAP_SH(*),AREAS(*),
94 . THK(*),THK_PART(*),XANEW(3,*),PM_STACK(20,*)
95 INTEGER ID
96 CHARACTER(LEN=NCHARTITLE) :: TITR
97 TYPE (SURF_) :: IGRSURF1
98 TYPE (SURF_) :: IGRSURF2
99C-----------------------------------------------
100C L o c a l V a r i a b l e s
101C-----------------------------------------------
102 INTEGER NDX, I, J, INRT, NELS,NELS2, MT, JJ, JJJ, NELC,
103 . MG, NUM, NPT, LL, L, NN, NELTG,N1,N2,N3,N4,IE,IP,NM1,
104 . igtyp,ipgmat,igmat,isubstack
105C REAL
106 my_real
107 . dxm, gapmx, gapmn, area, vol, dx,gaps1,gaps2, gapm, ddx,
108 . gaptmp, gapscale,sx1,sy1,sz1,sx2,sy2,sz2,sx3,sy3,sz3,
109 . slsfac,gapinfs,gapinfm,gapsups,gapsupm,st
110 INTEGER TAG(NUMNOD)
111 INTEGER BITUNSET,BITGET,BITSET
112 EXTERNAL bitunset,bitget,bitset
113C--------------------------------------------------------------
114C CALCUL DES RIGIDITES DES SEGMENTS
115C V16 : DANS LE CAS OU ONE SEGMENT APPARTIENT A LA FOIS
116C A UNE BRIQUE ET A UNE COQUE ON CHOISIT LA RIGIDITE
117C DE LA COQUE SAUF SI LE MATERIAU COQUE EST NUL.
118C---------------------------------------------------------------
119
120C---------------------------------------------------------------
121 slsfac = one
122C---------------------------------------------------------------
123 ipgmat = 700
124 igmat = 0
125 DO i=1,numnod
126 xanew(1,i)=x(1,i)
127 xanew(2,i)=x(2,i)
128 xanew(3,i)=x(3,i)
129 tag(i)=0
130 ENDDO
131 dxm=0.
132 ndx=0
133 gapsolidmax=ep30
134 gapmx=ep30
135 gapmn=ep30
136 gaps1=zero
137 gaps2=zero
138 IF(igap==2)THEN
139 igap = 1
140 gapscale = gapmin
141 gapmin = zero
142 ELSE
143 gapscale = one
144 ENDIF
145C------------------------------------
146C GAP NOEUDS SECONDS
147C------------------------------------
148 IF(igap>=1)THEN
149 DO i=1,numnod
150 wa(i)=zero
151 ENDDO
152 DO i=1,numelc
153 mg=ixc(6,i)
154 igtyp = igeo(11,mg)
155 ip = ipartc(i)
156 IF ( thk_part(ip) /= zero .AND. iintthick == 0) THEN
157 dx=half*thk_part(ip)
158 ELSEIF ( thk(i) /= zero .AND. iintthick == 0) THEN
159 dx=half*thk(i)
160 ELSEIF(igtyp == 17 .OR. igtyp == 51 .OR.igtyp == 52)THEN
161 dx=half*thk(i)
162 ELSE
163 dx=half*geo(1,mg)
164 ENDIF
165 wa(ixc(2,i))=max(wa(ixc(2,i)),dx)
166 wa(ixc(3,i))=max(wa(ixc(3,i)),dx)
167 wa(ixc(4,i))=max(wa(ixc(4,i)),dx)
168 wa(ixc(5,i))=max(wa(ixc(5,i)),dx)
169 ENDDO
170 DO i=1,numeltg
171 mg=ixtg(5,i)
172 igtyp = igeo(11,mg)
173 ip = iparttg(i)
174 IF ( thk_part(ip) /= zero .AND. iintthick == 0) THEN
175 dx=half*thk_part(ip)
176 ELSEIF (thk(numelc+i)/=zero .AND. iintthick==0) THEN
177 dx=half*thk(numelc+i)
178 ELSEIF(igtyp == 17 .OR. igtyp == 51 .OR. igtyp == 52) THEN
179 dx=half*thk(numelc+i)
180 ELSE
181 dx=half*geo(1,mg)
182 ENDIF
183 wa(ixtg(2,i))=max(wa(ixtg(2,i)),dx)
184 wa(ixtg(3,i))=max(wa(ixtg(3,i)),dx)
185 wa(ixtg(4,i))=max(wa(ixtg(4,i)),dx)
186 ENDDO
187 DO i=1,numelt
188 mg=ixt(4,i)
189 dx=half*sqrt(geo(1,mg))
190 wa(ixt(2,i))=max(wa(ixt(2,i)),dx)
191 wa(ixt(3,i))=max(wa(ixt(3,i)),dx)
192 ENDDO
193 DO i=1,numelp
194 mg=ixp(5,i)
195 dx=0.5*sqrt(geo(1,mg))
196 wa(ixp(2,i))=max(wa(ixp(2,i)),dx)
197 wa(ixp(3,i))=max(wa(ixp(3,i)),dx)
198 ENDDO
199 DO i=1,nsn
200 gap_s(i)=gapscale * wa(nsv(i))
201 gaps1=max(gaps1,gap_s(i))
202 ENDDO
203 ENDIF
204C
205C calcul du surface second. ---
206 IF(intth > 0 ) THEN
207 DO i = 1,nsn
208 areas(i) = zero
209 DO j= knod2elc(nsv(i))+1,knod2elc(nsv(i)+1)
210 ie = nod2elc(j)
211 sx1 = x(1,ixc(4,ie)) - x(1,ixc(2,ie))
212 sy1 = x(2,ixc(4,ie)) - x(2,ixc(2,ie))
213 sz1 = x(3,ixc(4,ie)) - x(3,ixc(2,ie))
214 sx2 = x(1,ixc(5,ie)) - x(1,ixc(3,ie))
215 sy2 = x(2,ixc(5,ie)) - x(2,ixc(3,ie))
216 sz2 = x(3,ixc(5,ie)) - x(3,ixc(3,ie))
217 sx3 = sy1*sz2 - sz1*sy2
218 sy3 = sz1*sx2 - sx1*sz2
219 sz3 = sx1*sy2 - sy1*sx2
220 areas(i) = areas(i) + one_over_8*sqrt(sx3*sx3+sy3*sy3+sz3*sz3)
221 ENDDO
222 ielec(i) = ixc(1,ie)
223 ENDDO
224 ENDIF
225C
226C------------------------------------
227C STIF NOEUDS SECONDS
228C------------------------------------
229 IF(slsfac >= zero)THEN
230 DO i=1,numelc
231 mg=ixc(6,i)
232 igtyp = igeo(11,mg)
233 ip = ipartc(i)
234 IF ( thk_part(ip) /= zero .AND. iintthick == 0) THEN
235 dx=half*thk_part(ip)
236 ELSEIF ( thk(i) /= zero .AND. iintthick == 0) THEN
237 dx=half*thk(i)
238 ELSEIF(igtyp == 17 .OR. igtyp == 51 .OR. igtyp == 52)THEN
239 dx=half*thk(i)
240 ELSE
241 dx=half*geo(1,mg)
242 ENDIF
243 wa(ixc(2,i))=max(wa(ixc(2,i)),dx)
244 wa(ixc(3,i))=max(wa(ixc(3,i)),dx)
245 wa(ixc(4,i))=max(wa(ixc(4,i)),dx)
246 wa(ixc(5,i))=max(wa(ixc(5,i)),dx)
247 ENDDO
248 DO i=1,numeltg
249 mg=ixtg(5,i)
250 igtyp = igeo(11,mg)
251 ip = iparttg(i)
252 IF ( thk_part(ip) /= zero .AND. iintthick == 0) THEN
253 dx=half*thk_part(ip)
254 ELSEIF (thk(numelc+i)/=zero .AND. iintthick==0) THEN
255 dx=half*thk(numelc+i)
256 ELSEIF(igtyp == 17 .OR. igtyp == 51 .OR. igtyp == 52)THEN
257 dx=half*thk(numelc+i)
258 ELSE
259 dx=half*geo(1,mg)
260 ENDIF
261 wa(ixtg(2,i))=max(wa(ixtg(2,i)),dx)
262 wa(ixtg(3,i))=max(wa(ixtg(3,i)),dx)
263 wa(ixtg(4,i))=max(wa(ixtg(4,i)),dx)
264 ENDDO
265 DO i=1,numelt
266 mg=ixt(4,i)
267 dx=half*sqrt(geo(1,mg))
268 wa(ixt(2,i))=max(wa(ixt(2,i)),dx)
269 wa(ixt(3,i))=max(wa(ixt(3,i)),dx)
270 ENDDO
271 DO i=1,numelp
272 mg=ixp(5,i)
273 dx=0.5*sqrt(geo(1,mg))
274 wa(ixp(2,i))=max(wa(ixp(2,i)),dx)
275 wa(ixp(3,i))=max(wa(ixp(3,i)),dx)
276 ENDDO
277 ! new interface buffer development : GAP_S not sized when IGAP=0 (cf bufintr)
278
279c DO I=1,NSN
280c GAP_S(I)=GAPSCALE * WA(NSV(I))
281c GAPS1=MAX(GAPS1,GAP_S(I))
282c ENDDO
283 ENDIF
284
285C------------------------------------
286C SURFACE DE COQUE OU SOLIDE
287C------------------------------------
288C------------------------------------
289C STIF FACES MAIN
290C------------------------------------
291
292 DO 500 i=1,nrt
293 stf(i)=zero
294 IF(intth > 0 ) ieles(i) = 0
295 IF(slsfac<zero)THEN
296 stf(i)=slsfac
297 ENDIF
298 gap_sh(i)=zero
299 gapm =zero
300 inrt=i
301 CALL i4gmx3(x,irect,inrt,gapmx)
302C----------------------
303 nm1=igrsurf1%NSEG
304 IF(inrt <= nm1)THEN
305 CALL i20nelts(x ,irect(1,inrt),ixs ,nint,nels ,
306 . inrt ,area ,noint,0 ,igrsurf1%ELTYP,
307 . igrsurf1%ELEM)
308 ELSE
309 CALL i20nelts(x ,irect(1,inrt),ixs ,nint,nels ,
310 . inrt-nm1 ,area ,noint,0 ,igrsurf2%ELTYP,
311 . igrsurf2%ELEM)
312 ENDIF
313 IF(nels /= 0)THEN
314 mt=ixs(1,nels)
315 IF(mt>0)THEN
316 DO jj=1,8
317 jjj=ixs(jj+1,nels)
318 xc(jj)=x(1,jjj)
319 yc(jj)=x(2,jjj)
320 zc(jj)=x(3,jjj)
321 END DO
322 CALL volint(vol)
323 stf(i)=slsfac*area*area*pm(100,mt)/vol
324 ELSE
325 IF(nint>=0) THEN
326 CALL ancmsg(msgid=95,
327 . msgtype=msgwarning,
328 . anmode=aninfo_blind_2,
329 . i1=id,
330 . c1=titr,
331 . i2=ixs(nixs,nels),
332 . c2='SOLID',
333 . i3=i)
334 ENDIF
335 IF(nint<0) THEN
336 CALL ancmsg(msgid=96,
337 . msgtype=msgwarning,
338 . anmode=aninfo_blind_2,
339 . i1=id,
340 . c1=titr,
341 . i2=ixs(nixs,nels),
342 . c2='SOLID',
343 . i3=i)
344 ENDIF
345 ENDIF
346 IF(igap/=0)THEN
347 gap_sh(i)=min(vol/area,sqrt(area))/six
348 gapsolidmax = min(gapsolidmax,vol/(area*four))
349 gapmn=min(gapmn,half*gap_sh(i))
350 gap_m(i)=zero
351 tag(irect(1,inrt)) = 1
352 tag(irect(2,inrt)) = 1
353 tag(irect(3,inrt)) = 1
354 tag(irect(4,inrt)) = 1
355c NBINFLG(IRECT(1,INRT))=BITUNSET(NBINFLG(IRECT(1,INRT)),7)
356c NBINFLG(IRECT(2,INRT))=BITUNSET(NBINFLG(IRECT(2,INRT)),7)
357c NBINFLG(IRECT(3,INRT))=BITUNSET(NBINFLG(IRECT(3,INRT)),7)
358c NBINFLG(IRECT(4,INRT))=BITUNSET(NBINFLG(IRECT(4,INRT)),7)
359 ENDIF
360 mbinflg(i)=bitset(mbinflg(i),8)
361 GO TO 500
362 ELSE
363 IF(inrt <= nm1)THEN
364 CALL ineltc(nelc ,neltg ,inrt ,igrsurf1%ELTYP,igrsurf1%ELEM)
365 ELSE
366 CALL ineltc(nelc ,neltg ,inrt-nm1,igrsurf2%ELTYP,igrsurf2%ELEM)
367 ENDIF
368 IF(neltg/=0) THEN
369 mt=ixtg(1,neltg)
370 mg=ixtg(5,neltg)
371 igtyp = igeo(11,mg)
372 ip = iparttg(neltg)
373 IF ( thk_part(ip) /= zero .AND. iintthick == 0) THEN
374 dx=thk_part(ip)*gapscale
375 ELSEIF(thk(numelc+neltg)/=zero.AND.iintthick==0)THEN
376 dx=thk(numelc+neltg)*gapscale
377 ELSEIF(igtyp == 17 .OR. igtyp == 51 .OR. igtyp == 52)THEN
378 dx=thk(numelc+neltg)*gapscale
379 ELSE
380 dx=geo(1,mg)*gapscale
381 ENDIF
382 gapm=half*dx
383 gaps2=max(gaps2,gapm)
384 gapmn = min(gapmn,dx)
385 dxm=dxm+dx
386 ndx=ndx+1
387 igmat = igeo(98,mg)
388 IF(mt>0)THEN
389 IF(igtyp == 11 .AND. igmat > 0) THEN
390 IF ( thk(numelc+neltg) /=zero.AND.iintthick==0)THEN
391 stf(i)=slsfac*thk(numelc+neltg)*geo(ipgmat + 2 ,mg)
392 ELSE
393 stf(i)=slsfac*geo(1,mg)*geo(ipgmat + 2 ,mg)
394 ENDIF
395 ELSEIF(igtyp == 52 .OR.
396 . ((igtyp == 17 .OR. igtyp == 51) .AND. igmat > 0))THEN
397 isubstack = iworksh(3,numelc+neltg)
398 st=pm_stack(2,isubstack)
399 stf(i)=slsfac*thk(numelc+neltg)*st
400 ELSE
401 IF ( thk(numelc+neltg) /=zero.AND.iintthick==0)THEN
402 stf(i)=slsfac*thk(numelc+neltg)*pm(20,mt)
403 ELSEIF(igtyp == 17 .OR. igtyp == 51) THEN
404 stf(i)=slsfac*thk(numelc+neltg)*pm(20,mt)
405 ELSE
406 stf(i)=slsfac*geo(1,mg)*pm(20,mt)
407 ENDIF
408 ENDIF
409 ELSE
410 IF(nint>=0) THEN
411 CALL ancmsg(msgid=95,
412 . msgtype=msgwarning,
413 . anmode=aninfo_blind_2,
414 . i1=id,
415 . c1=titr,
416 . i2=ixtg(nixtg,neltg),
417 . c2='SHELL',
418 . i3=i)
419 END IF
420 IF(nint<0) THEN
421 CALL ancmsg(msgid=96,
422 . msgtype=msgwarning,
423 . anmode=aninfo_blind_2,
424 . i1=id,
425 . c1=titr,
426 . i2=ixtg(nixtg,neltg),
427 . c2='SHELL',
428 . i3=i)
429 END IF
430 END IF
431 IF(igap/=0) gap_m(i)=gapm
432 mbinflg(i)=bitset(mbinflg(i),3)
433 GO TO 500
434 ELSEIF(nelc/=0) THEN
435 mt=ixc(1,nelc)
436 mg=ixc(6,nelc)
437 igtyp = igeo(11,mg)
438 ip = ipartc(nelc)
439 igmat = igeo(99,mg)
440 IF ( thk_part(ip) /= zero .AND. iintthick == 0) THEN
441 dx=thk_part(ip)*gapscale
442 ELSEIF ( thk(nelc) /= zero .AND. iintthick == 0) THEN
443 dx=thk(nelc)*gapscale
444 ELSEIF(igtyp == 17 .OR. igtyp == 51 .OR. igtyp == 52) THEN
445 dx=thk(nelc)*gapscale
446 ELSE
447 dx=geo(1,mg)*gapscale
448 ENDIF
449 gapm=half*dx
450 gaps2=max(gaps2,gapm)
451 gapmn = min(gapmn,dx)
452 dxm=dxm+dx
453 ndx=ndx+1
454 IF(mt>0)THEN
455 IF(igtyp == 11 .AND. igmat > 0) THEN
456 IF ( thk(nelc) /= zero .AND. iintthick == 0) THEN
457 stf(i)=slsfac*thk(nelc)*geo(ipgmat + 2 ,mg)
458 ELSE
459 stf(i)=slsfac*geo(1,mg)*geo(ipgmat + 2 ,mg)
460 ENDIF
461 ELSEIF(igtyp==52 .OR.
462 . ((igtyp == 17 .OR. igtyp == 51) .AND. igmat > 0))THEN
463 isubstack = iworksh(3,nelc)
464 st=pm_stack(2,isubstack)
465 stf(i)=slsfac*thk(nelc)*st
466 ELSE
467 IF ( thk(nelc) /= zero .AND. iintthick == 0) THEN
468 stf(i)=slsfac*thk(nelc)*pm(20,mt)
469 ELSEIF(igtyp == 17) THEN
470 stf(i)=slsfac*thk(nelc)*pm(20,mt)
471 ELSE
472 stf(i)=slsfac*geo(1,mg)*pm(20,mt)
473 ENDIF
474 ENDIF
475 ELSE
476 IF(nint>=0) THEN
477 CALL ancmsg(msgid=95,
478 . msgtype=msgwarning,
479 . anmode=aninfo_blind_2,
480 . i1=id,
481 . c1=titr,
482 . i2=ixc(nixc,nelc),
483 . c2='SHELL',
484 . i3=i)
485 END IF
486 IF(nint<0) THEN
487 CALL ancmsg(msgid=96,
488 . msgtype=msgwarning,
489 . anmode=aninfo_blind_2,
490 . i1=id,
491 . c1=titr,
492 . i2=ixc(nixc,nelc),
493 . c2='SHELL',
494 . i3=i)
495 END IF
496 END IF
497 IF(igap/=0) gap_m(i)=gapm
498 mbinflg(i)=bitset(mbinflg(i),4)
499 GO TO 500
500 END IF
501 END IF
502C----------------------
503C SURFACE DE SEGMENTS
504C----------------------
505C----------------------
506C ELEMENTS SOLIDES
507C----------------------
508 CALL insol3(x,irect,ixs,nint,nels,inrt,
509 . area,noint,knod2els ,nod2els ,0,ixs10,
510 . ixs16,ixs20)
511 IF(nels/=0) THEN
512 gapm=zero
513 mt=ixs(1,nels)
514 IF(intth > 0 ) ieles(i) = nels
515 IF(mt>0)THEN
516 DO 100 jj=1,8
517 jjj=ixs(jj+1,nels)
518 xc(jj)=x(1,jjj)
519 yc(jj)=x(2,jjj)
520 zc(jj)=x(3,jjj)
521 100 CONTINUE
522 CALL volint(vol)
523 stf(i)=slsfac*area*area*pm(100,mt)/vol
524 ELSE
525 IF(nint>=0) THEN
526 CALL ancmsg(msgid=95,
527 . msgtype=msgwarning,
528 . anmode=aninfo_blind_2,
529 . i1=id,
530 . c1=titr,
531 . i2=ixs(nixs,nels),
532 . c2='SOLID',
533 . i3=i)
534 ENDIF
535 IF(nint<0) THEN
536 CALL ancmsg(msgid=96,
537 . msgtype=msgwarning,
538 . anmode=aninfo_blind_2,
539 . i1=id,
540 . c1=titr,
541 . i2=ixs(nixs,nels),
542 . c2='SOLID',
543 . i3=i)
544 ENDIF
545 ENDIF
546 IF(igap/=0)THEN
547 gap_sh(i)=min(vol/area,sqrt(area))/six
548 gapsolidmax = min(gapsolidmax,vol/(area*four))
549 gapmn=min(gapmn,half*gap_sh(i))
550 gap_m(i)=zero
551 tag(irect(1,inrt)) = 1
552 tag(irect(2,inrt)) = 1
553 tag(irect(3,inrt)) = 1
554 tag(irect(4,inrt)) = 1
555c NBINFLG(IRECT(1,INRT))=BITUNSET(NBINFLG(IRECT(1,INRT)),7)
556c NBINFLG(IRECT(2,INRT))=BITUNSET(NBINFLG(IRECT(2,INRT)),7)
557c NBINFLG(IRECT(3,INRT))=BITUNSET(NBINFLG(IRECT(3,INRT)),7)
558c NBINFLG(IRECT(4,INRT))=BITUNSET(NBINFLG(IRECT(4,INRT)),7)
559 ENDIF
560 mbinflg(i)=bitset(mbinflg(i),8)
561 ENDIF
562C---------------------
563C ELEMENTS COQUES
564C---------------------
565 CALL incoq3(irect,ixc ,ixtg ,nint ,nelc ,
566 . neltg,inrt,geo ,pm ,knod2elc ,
567 . knod2eltg ,nod2elc ,nod2eltg,thk,nty,igeo,
568 . pm_stack , iworksh)
569 IF(neltg/=0) THEN
570C
571 mt=ixtg(1,neltg)
572 mg=ixtg(5,neltg)
573 igtyp = igeo(11,mg)
574 ip = iparttg(neltg)
575 IF ( thk_part(ip) /= zero .AND. iintthick == 0) THEN
576 dx=thk_part(ip)*gapscale
577 ELSEIF ( thk(numelc+neltg) /= zero .AND. iintthick == 0)THEN
578 dx=thk(numelc+neltg)*gapscale
579 ELSEIF(igtyp ==17) THEN
580 dx=thk(numelc+neltg)*gapscale
581 ELSE
582 dx=geo(1,mg)*gapscale
583 ENDIF
584 gapm=half*dx
585 gaps2=max(gaps2,gapm)
586 gapmn = min(gapmn,dx)
587 dxm=dxm+dx
588 ndx=ndx+1
589 igmat = igeo(98,mg)
590 IF(mt>0)THEN
591 IF(igtyp == 11 .AND. igmat > 0) THEN
592 IF ( thk(numelc+neltg) /= zero .AND. iintthick == 0) THEN
593 stf(i)=slsfac*thk(numelc+neltg)*geo(ipgmat + 2 ,mg)
594 ELSE
595 stf(i)=slsfac*geo(1,mg)*geo(ipgmat + 2 ,mg)
596 ENDIF
597 ELSEIF(igtyp==52 .OR.
598 . ((igtyp == 17 .OR. igtyp == 51) .AND. igmat > 0))THEN
599 isubstack = iworksh(3,numelc+neltg)
600 st=pm_stack(2,isubstack)
601 stf(i)=slsfac*thk(numelc+neltg)*st
602 ELSE
603 IF ( thk(numelc+neltg) /= zero .AND. iintthick == 0) THEN
604 stf(i)=slsfac*thk(numelc+neltg)*pm(20,mt)
605 ELSEIF(igtyp == 17) THEN
606 stf(i)=slsfac*thk(numelc+neltg)*pm(20,mt)
607 ELSE
608 stf(i)=slsfac*geo(1,mg)*pm(20,mt)
609 ENDIF
610 ENDIF
611 ELSE
612 IF(nint>=0) THEN
613 CALL ancmsg(msgid=95,
614 . msgtype=msgwarning,
615 . anmode=aninfo_blind_2,
616 . i1=id,
617 . c1=titr,
618 . i2=ixtg(nixtg,neltg),
619 . c2='SHELL',
620 . i3=i)
621 ENDIF
622 IF(nint<0) THEN
623 CALL ancmsg(msgid=96,
624 . msgtype=msgwarning,
625 . anmode=aninfo_blind_2,
626 . i1=id,
627 . c1=titr,
628 . i2=ixtg(nixtg,neltg),
629 . c2='SHELL',
630 . i3=i)
631 ENDIF
632 ENDIF
633 IF(igap/=0) gap_m(i)=gapm
634 mbinflg(i)=bitset(mbinflg(i),3)
635 ELSEIF(nelc/=0) THEN
636 mt=ixc(1,nelc)
637 mg=ixc(6,nelc)
638 igtyp = igeo(11,mg)
639 ip = ipartc(nelc)
640 IF ( thk_part(ip) /= zero .AND. iintthick == 0) THEN
641 dx=thk_part(ip)*gapscale
642 ELSEIF ( thk(nelc) /= zero .AND. iintthick == 0) THEN
643 dx=thk(nelc)*gapscale
644 ELSEIF(igtyp ==17) THEN
645 dx=thk(nelc)*gapscale
646 ELSE
647 dx=geo(1,mg)*gapscale
648 ENDIF
649 gapm=half*dx
650 gaps2=max(gaps2,gapm)
651 gapmn = min(gapmn,dx)
652 dxm=dxm+dx
653 ndx=ndx+1
654 igmat = igeo(98,mg)
655 IF(mt>0)THEN
656 IF(igtyp == 11 .AND. igmat > 0) THEN
657 IF ( thk(nelc) /= zero .AND. iintthick == 0) THEN
658 stf(i)=slsfac*thk(nelc)*geo(ipgmat + 2 ,mg)
659 ELSE
660 stf(i)=slsfac*geo(1,mg)*geo(ipgmat + 2 ,mg)
661 ENDIF
662 ELSEIF(igtyp==52 .OR.
663 . ((igtyp == 17 .OR. igtyp == 51) .AND. igmat > 0))THEN
664 isubstack = iworksh(3,nelc)
665 st=pm_stack(2,isubstack)
666 stf(i)=slsfac*thk(nelc)*st
667 ELSE
668 IF ( thk(nelc) /= zero .AND. iintthick == 0) THEN
669 stf(i)=slsfac*thk(nelc)*pm(20,mt)
670 ELSEIF(igtyp ==17) THEN
671 stf(i)=slsfac*thk(nelc)*pm(20,mt)
672 ELSE
673 stf(i)=slsfac*geo(1,mg)*pm(20,mt)
674 ENDIF
675 ENDIF
676 ELSE
677 IF(nint>=0) THEN
678 CALL ancmsg(msgid=95,
679 . msgtype=msgwarning,
680 . anmode=aninfo_blind_2,
681 . i1=id,
682 . c1=titr,
683 . i2=ixc(nixc,nelc),
684 . c2='SHELL',
685 . i3=i)
686 ENDIF
687 IF(nint<0) THEN
688 CALL ancmsg(msgid=96,
689 . msgtype=msgwarning,
690 . anmode=aninfo_blind_2,
691 . i1=id,
692 . c1=titr,
693 . i2=ixc(nixc,nelc),
694 . c2='SHELL',
695 . i3=i)
696 ENDIF
697 ENDIF
698 IF(igap/=0) gap_m(i)=gapm
699 mbinflg(i)=bitset(mbinflg(i),4)
700 ENDIF
701C
702 IF(nels+nelc+neltg==0)THEN
703
704C en SPMD il faut un element associe a l'arrete sinon erreur
705 IF(nint>0) THEN
706 CALL ancmsg(msgid=481,
707 . msgtype=msgerror,
708 . anmode=aninfo_blind_2,
709 . i1=id,
710 . c1=titr,
711 . i2=i)
712 ENDIF
713 IF(nint<0) THEN
714 CALL ancmsg(msgid=482,
715 . msgtype=msgerror,
716 . anmode=aninfo_blind_2,
717 . i1=id,
718 . c1=titr,
719 . i2=i)
720 ENDIF
721
722 ENDIF
723 500 CONTINUE
724C---------------------------
725C GAP
726C---------------------------
727 gapmx=sqrt(gapmx)
728 IF(igap==0)THEN
729C GAP FIXE
730 IF(gap<=zero)THEN
731 IF(ndx/=0)THEN
732 gap = dxm/ndx
733 gap = min(half*gapmx,gap)
734 ELSE
735 gap = em01 * gapmx
736 ENDIF
737c WRITE(IOUT,1300)GAP
738 ENDIF
739 gapmin = gap
740 IF(inacti/=7.AND.gap>0.5*gapmx)THEN
741 gaptmp = half*gapmx
742 CALL ancmsg(msgid=94,
743 . msgtype=msgwarning,
744 . anmode=aninfo_blind_2,
745 . i1=id,
746 . c1=titr,
747 . r1=gap,
748 . r2=gaptmp)
749 ENDIF
750 ELSE
751C GAP VARIABLE :
752C - GAPMIN CONTIENT ONE GAP MINIMUM UTILISE SI GAP_S(I)+GAP_M(J) < GAPMIN
753C - GAP CONTIENT LE SUP DE (GAP_S(I)+GAP_M(J),GAPMIN)
754 IF(gap<=zero)THEN
755 IF(ndx/=0)THEN
756 gapmin = gapmn
757 gapmin = min(half*gapmx,gapmin)
758 ELSE
759c GAPMIN = EM01 * GAPMX
760 gapmin = min(gapmn,em01 * gapmx)
761 ENDIF
762c WRITE(IOUT,1300)GAPMIN
763 ELSE
764 gapmin = gap
765 ENDIF
766C SUP DES GAPS VARIABLES
767 gap = max(gaps1+gaps2,gapmin)
768 gap=min(gap,gapmax)
769 IF(inacti/=7.AND.gap>half*gapmx)THEN
770 gaptmp = 0.5*gapmx
771 CALL ancmsg(msgid=477,
772 . msgtype=msgwarning,
773 . anmode=aninfo_blind_2,
774 . i1=id,
775 . c1=titr,
776 . r1=gap)
777 ENDIF
778 ENDIF
779C---------------------------------------------
780C MISE A ONE DU MULTIPLICATEUR NODALE DES RIGIDITES
781C---------------------------------------------
782c STFN est temporairement de 1 a NSN au lien de 1 a NLN
783 DO l=1,nsn
784 stfn(l) = 1.
785 ENDDO
786C---------------------------------------------
787C LIMITATION DU GAP DES SOLIDES
788C---------------------------------------------
789 IF (igap/=0) THEN
790 DO i = 1, nrt
791 IF(gap_m(i) == zero)THEN
792 gap_sh(i) = min(gapsolidmax,gap_sh(i))
793 gap_sh(i) = max(gapsol,gap_sh(i))
794c GAP_M pour tri
795 gap_m(i)=gap_m(i)+two*gap_sh(i)
796 ENDIF
797 ENDDO
798 ENDIF
799C
800C Calcul du gap reel a utiliser lors du critere de retri
801C
802 gapshmax = zero
803 IF (igap==0) THEN
804 gapinf=gap
805 ELSE
806 gapinfs=ep30
807 gapinfm=ep30
808 gapsups = zero
809 gapsupm = zero
810 DO i = 1, nsn
811 gapinfs = min(gapinfs,gap_s(i))
812 gapsups = max(gapsups,gap_s(i))
813 ENDDO
814 DO i = 1, nrt
815c GAP_M(I)=GAP_M(I)+TWO*GAP_SH(I)
816 gapinfm = min(gapinfm,gap_m(i))
817 gapsupm = max(gapsupm,gap_m(i))
818 gapshmax = max(gapshmax,gap_sh(i))
819 ENDDO
820 gapinf= max(gapinfs+gapinfm,gapmin)
821 gap = min(gapsups+gapsupm,gapmax)
822 ENDIF
823
824 DO i=1,nln
825 IF(tag(nlg(i)) == 1)nbinflg(i)=bitunset(nbinflg(i),7)
826 ENDDO
827C------------
828 RETURN
829 1300 FORMAT(2x,'GAP MIN = ',1pg20.13)
830 END
831!||====================================================================
832!|| i20sti3e ../starter/source/interfaces/inter3d1/i20sti3.F
833!||--- called by ------------------------------------------------------
834!|| i20ini3 ../starter/source/interfaces/inter3d1/i20ini3.F
835!||--- calls -----------------------------------------------------
836!|| ancmsg ../starter/source/output/message/message.F
837!|| get_u_geo ../starter/source/user_interface/uaccess.F
838!|| i11coq ../starter/source/interfaces/inter3d1/i11coq.F
839!|| i11fil ../starter/source/interfaces/inter3d1/i11coq.f
840!|| i11gmx3 ../starter/source/interfaces/inter3d1/i11gmx3.F
841!|| i11sol ../starter/source/interfaces/inter3d1/i11sol.F
842!|| my_exit ../starter/source/output/analyse/analyse.c
843!|| volint ../starter/source/interfaces/inter3d1/volint.F
844!||--- uses -----------------------------------------------------
845!|| message_mod ../starter/share/message_module/message_mod.F
846!||====================================================================
847 SUBROUTINE i20sti3e(
848 1 X ,IXLIN ,STF ,IXS ,PM ,
849 2 GEO ,NRT ,IXC ,NINTR ,SLSFAC,
850 3 NTY ,GAPMAX,NOINT ,GAP_SM,
851 4 MS ,IXTG ,IXT ,IXP ,IXR ,
852 5 IGAP ,GAPMIN,GAP0 ,GAPINF,NSNE ,
853 6 IPARTC,IPARTTG,THK ,THK_PART,IXS10,
854 7 ID ,TITR ,KXX ,IXX ,IGEO,
855 8 NOD2EL1D,KNOD2EL1D,KNOD2ELS,KNOD2ELC,KNOD2ELTG,
856 9 NOD2ELS,NOD2ELC,NOD2ELTG ,LELX ,PM_STACK,IWORKSH)
857C-----------------------------------------------
858C M o d u l e s
859C-----------------------------------------------
860 USE message_mod
861 USE names_and_titles_mod , ONLY : nchartitle
862C-----------------------------------------------
863C I m p l i c i t T y p e s
864C-----------------------------------------------
865#include "implicit_f.inc"
866C-----------------------------------------------
867C C o m m o n B l o c k s
868C-----------------------------------------------
869#include "units_c.inc"
870#include "param_c.inc"
871#include "com04_c.inc"
872#include "scr08_c.inc"
873#include "scr23_c.inc"
874C-----------------------------------------------
875C D u m m y A r g u m e n t s
876C-----------------------------------------------
877 INTEGER NRT, NINTR, NTY, NOINT,IGAP,NSNE
878C REAL
879 my_real
880 . SLSFAC, GAPMAX,GAPMIN,GAP0
881 INTEGER IXLIN(2,*), IXS(NIXS,*), IXC(NIXC,*),
882 . IXTG(NIXTG,*),IXT(NIXT,*),IXP(NIXP,*),IXR(NIXR,*),
883 . IPARTC(*), IPARTTG(*),IXS10(*),KXX(NIXX,*),IXX(*),
884 . IGEO(NPROPGI,*),
885 . knod2els(*), knod2elc(*), knod2eltg(*),
886 . nod2els(*), nod2elc(*), nod2eltg(*),
887 . nod2el1d(*),knod2el1d(*),iworksh(3,*)
888C REAL
889 my_real
890 . x(3,*), stf(*), pm(npropm,*), geo(npropg,*),
891 . ms(*),gap_sm(*),xl2, gapinf,thk(*),thk_part(*),lelx(*),
892 . pm_stack(20,*)
893 INTEGER ID
894 CHARACTER(LEN=NCHARTITLE) :: TITR
895C-----------------------------------------------
896C L o c a l V a r i a b l e s
897C-----------------------------------------------
898 INTEGER NDX, I, INRT, NELS, MT, JJ, JJJ, NELC, J,
899 . MG, NUM, NPT, LL, L, NN, NELTG,NELT,NELP,NELR,
900 . IGTYP, I1, I2,IP,NELX,IPGMAT,IGMAT,ISUBSTACK
901C REAL
902 my_real
903 . dxm, gapmx, gapmn, area, vol, dx,gap1,gaps1,gaptmp,
904 . get_u_geo,st
905C-----------------------------------------------
906 EXTERNAL get_u_geo
907C--------------------------------------------------------------
908C CALCUL DES RIGIDITES DES SEGMENTS
909C V16 : DANS LE CAS OU ONE SEGMENT APPARTIENT A LA FOIS
910C A UNE BRIQUE ET A UNE COQUE ON CHOISIT LA RIGIDITE
911C DE LA COQUE SAUF SI LE MATERIAU COQUE EST NUL.
912C---------------------------------------------------------------
913 dxm=zero
914 ndx=0
915 gaps1=zero
916 gapmx=ep30
917 gapmn=ep30
918
919C
920 DO 500 i=1,nrt
921 stf(i)=zero
922 gap_sm(i)=zero
923 inrt=i
924 CALL i11gmx3(x,ixlin,inrt,gapmx,xl2)
925C----------------------
926C ELEMENTS SOLIDES
927C----------------------
928 CALL i11sol(x,ixlin,ixs,nintr,nels,inrt,
929 . area,noint,knod2els,nod2els,ixs10)
930 IF(nels/=0) THEN
931 mt=ixs(1,nels)
932 IF(mt>0)THEN
933 DO 100 jj=1,8
934 jjj=ixs(jj+1,nels)
935 xc(jj)=x(1,jjj)
936 yc(jj)=x(2,jjj)
937 zc(jj)=x(3,jjj)
938 100 CONTINUE
939 CALL volint(vol)
940 IF(xl2>0.0)THEN
941 stf(i)=slsfac*vol*pm(100,mt)/xl2
942 ELSE
943 stf(i)=zero
944 ENDIF
945 ELSE
946C IF(NINTR>=0)WRITE (IOUT,1500) IXS(11,NELS),I, NOINT
947 IF(nintr>=0) THEN
948 CALL ancmsg(msgid=95,
949 . msgtype=msgwarning,
950 . anmode=aninfo_blind_2,
951 . i1=id,
952 . c1=titr,
953 . i2=ixs(nixs,nels),
954 . c2='SOLID',
955 . i3=i)
956 ENDIF
957C IF(NINTR<0)WRITE (IOUT,1600) IXS(11,NELS),I, NOINT
958C IWARN=IWARN+1
959 IF(nintr<0) THEN
960 CALL ancmsg(msgid=96,
961 . msgtype=msgwarning,
962 . anmode=aninfo_blind_2,
963 . i1=id,
964 . c1=titr,
965 . i2=ixs(nixs,nels),
966 . c2='SOLID',
967 . i3=i)
968 ENDIF
969 ENDIF
970 ENDIF
971C---------------------
972C ELEMENTS COQUES
973C---------------------
974 CALL i11coq(ixlin,ixc ,ixtg,nintr,nelc ,
975 . neltg,inrt,geo,pm,thk,igeo,
976 . knod2elc,knod2eltg,nod2elc,nod2eltg,
977 . pm_stack, iworksh )
978 IF(neltg/=0) THEN
979C
980 mt=ixtg(1,neltg)
981 mg=ixtg(5,neltg)
982 igtyp = igeo(11,mg)
983 dx=geo(1,mg)
984 IF(igtyp == 17 .OR. igtyp == 51 .OR. igtyp ==52)
985 . dx = thk(numelc + neltg)
986 gap_sm(i)=half*dx
987 gaps1=max(gaps1,gap_sm(i))
988 gapmn = min(gapmn,dx)
989 dxm=dxm+dx
990 ndx=ndx+1
991 igmat = igeo(98,mg)
992 ipgmat=700
993 IF(mt>0)THEN
994 IF(igtyp == 11 .AND. igmat > 0)THEN
995 stf(i)=slsfac*dx*geo(ipgmat + 2 ,mg)
996 ELSEIF(igtyp==52 .OR.
997 . ((igtyp == 17 .OR. igtyp == 51 ) .AND. igmat > 0))THEN
998 isubstack = iworksh(3,neltg + numelc)
999 stf(i)=slsfac*dx*pm_stack(2,isubstack)
1000 ELSE
1001 stf(i)=slsfac*dx*pm(20,mt)
1002 ENDIF
1003 ELSE
1004C IF(NINTR>=0)WRITE (IOUT,1700) IXTG(NIXTG,NELTG),I, NOINT
1005 IF(nintr>=0) THEN
1006 CALL ancmsg(msgid=95,
1007 . msgtype=msgwarning,
1008 . anmode=aninfo_blind_2,
1009 . i1=id,
1010 . c1=titr,
1011 . i2=ixtg(nixtg,neltg),
1012 . c2='SHELL',
1013 . i3=i)
1014 ENDIF
1015C IF(NINTR<0)WRITE (IOUT,1800) IXTG(NIXTG,NELTG),I, NOINT
1016C IWARN=IWARN+1
1017 IF(nintr<0) THEN
1018 CALL ancmsg(msgid=96,
1019 . msgtype=msgwarning,
1020 . anmode=aninfo_blind_2,
1021 . i1=id,
1022 . c1=titr,
1023 . i2=ixtg(nixtg,neltg),
1024 . c2='SHELL',
1025 . i3=i)
1026 ENDIF
1027 ENDIF
1028 ELSEIF(nelc/=0) THEN
1029C
1030 mt=ixc(1,nelc)
1031 mg=ixc(6,nelc)
1032 igtyp = igeo(11,mg)
1033 dx=geo(1,mg)
1034 IF(igtyp == 17 .OR. igtyp == 51 .OR. igtyp ==52)
1035 . dx = thk(nelc)
1036 gap_sm(i)=half*dx
1037 gaps1=max(gaps1,gap_sm(i))
1038 gapmn = min(gapmn,dx)
1039 dxm=dxm+dx
1040 ndx=ndx+1
1041 igmat = igeo(98,mg)
1042 IF(mt>0)THEN
1043 IF(igtyp == 11 .AND. igmat > 0) THEN
1044 stf(i)=slsfac*dx*geo(ipgmat + 2 ,mg)
1045 ELSEIF(igtyp ==52 .OR.
1046 . ((igtyp == 17 .OR. igtyp == 51) .AND. igmat > 0))THEN
1047 isubstack = iworksh(3,nelc)
1048 stf(i)=slsfac*dx*pm_stack(2,isubstack)
1049 ELSE
1050 stf(i)=slsfac*dx*pm(20,mt)
1051 ENDIF
1052 ELSE
1053C IF(NINTR>=0)WRITE (IOUT,1700) IXC(7,NELC),I, NOINT
1054 IF(nintr>=0) THEN
1055 CALL ancmsg(msgid=95,
1056 . msgtype=msgwarning,
1057 . anmode=aninfo_blind_2,
1058 . i1=id,
1059 . c1=titr,
1060 . i2=ixc(nixc,nelc),
1061 . c2='SHELL',
1062 . i3=i)
1063 ENDIF
1064C IF(NINTR<0)WRITE (IOUT,1800) IXC(7,NELC),I, NOINT
1065C IWARN=IWARN+1
1066 IF(nintr<0) THEN
1067 CALL ancmsg(msgid=96,
1068 . msgtype=msgwarning,
1069 . anmode=aninfo_blind_2,
1070 . i1=id,
1071 . c1=titr,
1072 . i2=ixc(nixc,nelc),
1073 . c2='SHELL',
1074 . i3=i)
1075 ENDIF
1076 ENDIF
1077 ENDIF
1078C---------------------
1079C ELEMENTS TIGE POUTRE RESSORT
1080C---------------------
1081 CALL i11fil(ixlin,ixt,ixp,ixr,nintr,nelt ,
1082 . nelp,nelr,nelx,inrt,nod2el1d,
1083 . knod2el1d,kxx,ixx)
1084
1085 IF(nelt/=0) THEN
1086C
1087 mt=ixt(1,nelt)
1088 mg=ixt(4,nelt)
1089 dx=sqrt(geo(1,mg))
1090 IF(igtyp == 17 .OR. igtyp == 51 .OR. igtyp == 52 )
1091 . dx = sqrt(thk(numelc + nelt))
1092 gap_sm(i)=max(gap_sm(i),half*dx)
1093 gaps1=max(gaps1,gap_sm(i))
1094 gapmn = min(gapmn,dx)
1095 dxm=dxm+dx
1096 ndx=ndx+1
1097 igmat = igeo(98,mg)
1098 IF(mt>0)THEN
1099 IF(igtyp == 11 .AND. igmat > 0) THEN
1100 stf(i)=slsfac*dx*geo(ipgmat + 2 ,mg)
1101 ELSEIF((igtyp == 17 .OR. igtyp == 17) .AND. igmat > 0) THEN
1102 isubstack = iworksh(3,numelc + nelt)
1103 stf(i)=slsfac*dx*pm_stack(2,isubstack)
1104 ELSE
1105 stf(i)=slsfac*dx*pm(20,mt)
1106 ENDIF
1107 ELSE
1108C IF(NINTR>=0)WRITE (IOUT,1700) IXT(NIXT,NELT),I, NOINT
1109 IF(nintr>=0) THEN
1110 CALL ancmsg(msgid=95,
1111 . msgtype=msgwarning,
1112 . anmode=aninfo_blind_2,
1113 . i1=id,
1114 . c1=titr,
1115 . i2=ixt(nixt,nelt),
1116 . c2='TRUSS',
1117 . i3=i)
1118 ENDIF
1119C IF(NINTR<0)WRITE (IOUT,1800) IXT(NIXT,NELT),I, NOINT
1120C IWARN=IWARN+1
1121 IF(nintr<0) THEN
1122 CALL ancmsg(msgid=96,
1123 . msgtype=msgwarning,
1124 . anmode=aninfo_blind_2,
1125 . i1=id,
1126 . c1=titr,
1127 . i2=ixt(nixt,nelt),
1128 . c2='TRUSS',
1129 . i3=i)
1130 ENDIF
1131 ENDIF
1132 ELSEIF(nelp/=0) THEN
1133C
1134 mt=ixp(1,nelp)
1135 mg=ixp(5,nelp)
1136 dx=sqrt(geo(1,mg))
1137 gap_sm(i)=max(gap_sm(i),half*dx)
1138 gaps1=max(gaps1,gap_sm(i))
1139 gapmn = min(gapmn,dx)
1140 dxm=dxm+dx
1141 ndx=ndx+1
1142 IF(mt>0)THEN
1143 stf(i)=slsfac*dx*pm(20,mt)
1144 ELSE
1145C IF(NINTR>=0)WRITE (IOUT,1700) IXP(NIXP,NELP),I, NOINT
1146 IF(nintr>=0) THEN
1147 CALL ancmsg(msgid=95,
1148 . msgtype=msgwarning,
1149 . anmode=aninfo_blind_2,
1150 . i1=id,
1151 . c1=titr,
1152 . i2=ixp(nixp,nelp),
1153 . c2='beam',
1154 . I3=I)
1155 ENDIF
1156C IF(NINTR<0)WRITE (IOUT,1800) IXP(NIXP,NELP),I, NOINT
1157C IWARN=IWARN+1
1158 IF(NINTR<0) THEN
1159 CALL ANCMSG(MSGID=96,
1160 . MSGTYPE=MSGWARNING,
1161 . ANMODE=ANINFO_BLIND_2,
1162 . I1=ID,
1163 . C1=TITR,
1164 . I2=IXP(NIXP,NELP),
1165 . C2='beam',
1166 . I3=I)
1167 ENDIF
1168 ENDIF
1169 ELSEIF(NELR/=0) THEN
1170C
1171 MG=IXR(1,NELR)
1172 MT = IXR(5,NELR)
1173 IF(MG>0)THEN
1174 IGTYP=NINT(GEO(12,MG))
1175.OR. IF(IGTYP==4IGTYP==12)THEN
1176 STF(I)=SLSFAC*GEO(2,MG)
1177.OR. ELSEIF(IGTYP==8IGTYP==13)THEN
1178 STF(I)=SLSFAC*MAX(GEO(3,MG),GEO(10,MG),GEO(15,MG))
1179 ELSEIF(IGTYP == 23)THEN
1180 STF(I)=SLSFAC*MAX(PM(191,MT),PM(192,MT),PM(193,MT))
1181 ELSEIF(IGTYP==25)THEN
1182 STF(I)=SLSFAC*GEO(10,MG)
1183 ELSEIF(IGTYP>=29)THEN
1184 STF(I)=SLSFAC*GEO(3,MG)
1185 ELSE
1186 WRITE(6,'(a)') 'internal error 987'
1187 CALL MY_EXIT(2)
1188C STOP 987
1189 ENDIF
1190 ELSE
1191C IF(NINTR>=0)WRITE (IOUT,1700) IXR(NIXR,NELR),I, NOINT
1192 IF(NINTR>=0) THEN
1193 CALL ANCMSG(MSGID=95,
1194 . MSGTYPE=MSGWARNING,
1195 . ANMODE=ANINFO_BLIND_2,
1196 . I1=ID,
1197 . C1=TITR,
1198 . I2=IXR(NIXR,NELR),
1199 . C2='spring',
1200 . I3=I)
1201 ENDIF
1202C IF(NINTR<0)WRITE (IOUT,1800) IXR(NIXR,NELR),I, NOINT
1203C IWARN=IWARN+1
1204 IF(NINTR<0) THEN
1205 CALL ANCMSG(MSGID=96,
1206 . MSGTYPE=MSGWARNING,
1207 . ANMODE=ANINFO_BLIND_2,
1208 . I1=ID,
1209 . C1=TITR,
1210 . I2=IXR(NIXR,NELR),
1211 . C2='spring',
1212 . I3=I)
1213 ENDIF
1214 ENDIF
1215 ELSEIF(NELX/=0) THEN
1216C
1217 MG=KXX(2,NELX)
1218 IF(MG>0)THEN
1219 STF(I)=SLSFAC*GET_U_GEO(4,MG)*(KXX(3,NELX)-1)/LELX(NELX)
1220 ELSE
1221 IF(NINTR>=0) THEN
1222 CALL ANCMSG(MSGID=95,
1223 . MSGTYPE=MSGWARNING,
1224 . ANMODE=ANINFO_BLIND_2,
1225 . I1=ID,
1226 . C1=TITR,
1227 . I2=KXX(NIXX,NELX),
1228 . C2='xelem',
1229 . I3=I)
1230 ENDIF
1231 IF(NINTR<0) THEN
1232 CALL ANCMSG(MSGID=96,
1233 . MSGTYPE=MSGWARNING,
1234 . ANMODE=ANINFO_BLIND_2,
1235 . I1=ID,
1236 . C1=TITR,
1237 . I2=KXX(NIXX,NELX),
1238 . C2='xelem',
1239 . I3=I)
1240 ENDIF
1241 ENDIF
1242 ENDIF
1243C---------------------------
1244 IF(NELS+NELC+NELTG+NELT+NELP+NELR+NUMELX==0.)THEN
1245C en SPMD il faut un element associe a l'arrete sinon erreur
1246 IF(NINTR>0) THEN
1247 CALL ANCMSG(MSGID=481,
1248 . MSGTYPE=MSGERROR,
1249 . ANMODE=ANINFO_BLIND_2,
1250 . I1=ID,
1251 . C1=TITR,
1252 . I2=I)
1253 ENDIF
1254 IF(NINTR<0) THEN
1255 CALL ANCMSG(MSGID=482,
1256 . MSGTYPE=MSGERROR,
1257 . ANMODE=ANINFO_BLIND_2,
1258 . I1=ID,
1259 . C1=TITR,
1260 . I2=I)
1261 ENDIF
1262 ENDIF
1263
1264 500 CONTINUE
1265C---------------------------
1266C GAP
1267C---------------------------
1268 GAPMX=SQRT(GAPMX)
1269 IF(IGAP==0)THEN
1270C---------------------------
1271C GAP FIXE
1272C---------------------------
1273 IF(GAP0>ZERO)THEN
1274 GAP1 = GAP0
1275 ELSE
1276 IF(NDX/=0)THEN
1277 GAP1 = MIN(HALF*GAPMX,DXM/NDX)
1278 ELSE
1279 GAP1 = EM01* GAPMX
1280 ENDIF
1281 IF(NINTR<0)WRITE(IOUT,1300)HALF*(GAPMIN+GAP1)
1282 ENDIF
1283C
1284 IF(NINTR<0) GAP1 = HALF*(GAPMIN+GAP1)
1285 GAPMIN = GAP1
1286 GAPMAX = GAP1
1287C
1288 IF(GAP1>HALF*GAPMX)THEN
1289C WRITE(IOUT,1400)GAP1,0.5*GAPMX
1290C IWARN=IWARN+1
1291 GAPTMP = HALF*GAPMX
1292 CALL ANCMSG(MSGID=94,
1293 . MSGTYPE=MSGWARNING,
1294 . ANMODE=ANINFO_BLIND_2,
1295 . I1=ID,
1296 . C1=TITR,
1297 . R1=GAP1,
1298 . R2=GAPTMP)
1299 ENDIF
1300 ELSE
1301C---------------------------
1302C GAP VARIABLE
1303C---------------------------
1304 IF(GAP0>ZERO)THEN
1305 GAP1 = GAP0
1306 ELSE
1307 IF(NDX/=0)THEN
1308 GAP1 = MIN(HALF*GAPMX,GAPMN)
1309 ELSE
1310 GAP1 = EM01 * GAPMX
1311 ENDIF
1312 IF(NINTR<0)WRITE(IOUT,1300)HALF*(GAPMIN+GAP1)
1313 ENDIF
1314C GAP MINI ET SUP DES GAPS VARIABLES
1315 IF(NINTR>0)THEN
1316 GAPMIN = GAP1
1317 GAPMAX = GAPS1
1318 ELSE
1319 GAPMIN = HALF*(GAPMIN+GAP1)
1320 GAPMAX = MAX(GAPMAX+GAPS1,GAPMIN)
1321 ENDIF
1322C
1323 IF(GAPMAX>HALF*GAPMX)THEN
1324 GAPTMP = HALF*GAPMX
1325 CALL ANCMSG(MSGID=94,
1326 . MSGTYPE=MSGWARNING,
1327 . ANMODE=ANINFO_BLIND_2,
1328 . I1=ID,
1329 . C1=TITR,
1330 . R1=GAPMAX,
1331 . R2=GAPTMP)
1332 ENDIF
1333 ENDIF
1334C---------------------------
1335C STIF GLOBAL
1336C---------------------------
1337 IF(SLSFAC<ZERO)THEN
1338 DO I=1,NRT
1339 STF(I)=-SLSFAC
1340 ENDDO
1341 ENDIF
1342C---------------------------------------------
1343C
1344C Calcul du gap reel a utiliser lors du critere de retri
1345C
1346 IF (IGAP==0) THEN
1347 GAPINF=GAPMAX/TWO ! remultiplie par 2 dans i20ini3
1348 ELSE
1349 DO I = 1, NRT
1350 GAPINF = MIN(GAPINF,GAP_SM(I))
1351 ENDDO
1352 ENDIF
1353 RETURN
1354
1355 1300 FORMAT(2X,'computed gap = ',1PG20.13)
1356
1357 END
1358!||====================================================================
1359!|| i20nlg ../starter/source/interfaces/inter3d1/i20sti3.F
1360!||--- called by ------------------------------------------------------
1361!|| i20ini3 ../starter/source/interfaces/inter3d1/i20ini3.F
1362!||====================================================================
1363 SUBROUTINE I20NLG(NLN ,NRTM,NSN ,NLINS ,NLINM ,
1364 . NLG ,IRECT,NSV ,IXLINS,IXLINM,
1365 . NMN ,NSNE ,NMNE,MSR ,NSVE ,
1366 . MSRE ,STFA ,DXANC,XANEW,X ,
1367 . PENIA,ALPHAK)
1368C-----------------------------------------------
1369C I m p l i c i t T y p e s
1370C-----------------------------------------------
1371#include "implicit_f.inc"
1372C-----------------------------------------------
1373C C o m m o n B l o c k s
1374C-----------------------------------------------
1375#include "com04_c.inc"
1376C-----------------------------------------------
1377C D u m m y A r g u m e n t s
1378C-----------------------------------------------
1379 INTEGER NLN,NRTM, NSN,NLINS ,NLINM ,NMN ,NSNE ,NMNE
1380 INTEGER IRECT(4,NRTM), NSV(NSN),IXLINS(2,NLINS),IXLINM(2,NLINM),
1381 . MSR(NMN),NSVE(NSNE),MSRE(NMNE),NLG(NLN)
1382 my_real
1383 . STFA(*),DXANC(3,*),XANEW(3,*),X(3,*),PENIA(5,*),ALPHAK(3,*)
1384C-----------------------------------------------
1385C L o c a l V a r i a b l e s
1386C-----------------------------------------------
1387 INTEGER I,J,K
1388 INTEGER TAG(NUMNOD)
1389 my_real
1390 . AAA,STIF(NLN)
1391
1392 DO I=1,NLN
1393 J = NLG(I)
1394 TAG(J)=I
1395 ENDDO
1396
1397 DO K=1,NSN
1398 NSV(K)=TAG(NSV(K))
1399 ENDDO
1400 DO K=1,NMN
1401 MSR(K)=TAG(MSR(K))
1402 ENDDO
1403 DO K=1,NSNE
1404 NSVE(K)=TAG(NSVE(K))
1405 ENDDO
1406 DO K=1,NMNE
1407 MSRE(K)=TAG(MSRE(K))
1408 ENDDO
1409
1410 DO K=1,NRTM
1411 IRECT(1,K)=TAG(IRECT(1,K))
1412 IRECT(2,K)=TAG(IRECT(2,K))
1413 IRECT(3,K)=TAG(IRECT(3,K))
1414 IRECT(4,K)=TAG(IRECT(4,K))
1415 ENDDO
1416 DO K=1,NLINS
1417 IXLINS(1,K)=TAG(IXLINS(1,K))
1418 IXLINS(2,K)=TAG(IXLINS(2,K))
1419 ENDDO
1420 DO K=1,NLINM
1421 IXLINM(1,K)=TAG(IXLINM(1,K))
1422 IXLINM(2,K)=TAG(IXLINM(2,K))
1423 ENDDO
1424
1425 DO I=1,NLN
1426 STIF(I) = ONE
1427 ALPHAK(1,I) = ONE
1428 ALPHAK(2,I) = ONE
1429 ALPHAK(3,I) = ONE
1430 ENDDO
1431
1432 DO I=1,NSN
1433c en input STFA(1:NLN) est STFN(1:NSN) eventuellement mis a zero si pene initiale
1434 J = NSV(I)
1435 STIF(J) = STFA(I)
1436 ENDDO
1437
1438 DO I=1,NLN
1439 STFA(I) = STIF(I)
1440 ENDDO
1441
1442c STFA sera recalcule dans I20STIFN /inter3d1/i20stifn.F
1443 DO I=1,NLN
1444 DXANC(1,I) = XANEW(1,NLG(I))-X(1,NLG(I))
1445 DXANC(2,I) = XANEW(2,NLG(I))-X(2,NLG(I))
1446 DXANC(3,I) = XANEW(3,NLG(I))-X(3,NLG(I))
1447 PENIA(4,I) = SQRT(DXANC(1,I)*DXANC(1,I)
1448 + +DXANC(2,I)*DXANC(2,I)
1449 + +DXANC(3,I)*DXANC(3,I))
1450 PENIA(5,I) = PENIA(4,I)
1451 AAA = ONE/MAX(PENIA(4,I),EM20)
1452 PENIA(1,I) = DXANC(1,I)*AAA
1453 PENIA(2,I) = DXANC(2,I)*AAA
1454 PENIA(3,I) = DXANC(3,I)*AAA
1455 ENDDO
1456
1457 RETURN
1458 END
bitget
integer function bitget(i, n)
Definition bitget.F:37
area
subroutine area(d1, x, x2, y, y2, eint, stif0)
Definition hm_read_prop32.F:567
i11coq
subroutine i11coq(irect, ixc, ixtg, nint, nel, neltg, is, geo, pm, thk, igeo, knod2elc, knod2eltg, nod2elc, nod2eltg, pm_stack, iworksh)
Definition i11coq.F:34
i11fil
subroutine i11fil(irect, ixt, ixp, ixr, nint, nelt, nelp, nelr, nelx, is, nod2el1d, knod2el1d, kxx, ixx)
Definition i11coq.F:165
i11gmx3
subroutine i11gmx3(x, irect, i, gapmax, xl2)
Definition i11gmx3.F:32
i11sol
subroutine i11sol(x, irect, ixs, nint, nel, i, area, noint, knod2els, nod2els, ixs10)
Definition i11sol.F:32
i20sti3e
subroutine i20sti3e(x, ixlin, stf, ixs, pm, geo, nrt, ixc, nintr, slsfac, nty, gapmax, noint, gap_sm, ms, ixtg, ixt, ixp, ixr, igap, gapmin, gap0, gapinf, nsne, ipartc, iparttg, thk, thk_part, ixs10, id, titr, kxx, ixx, igeo, nod2el1d, knod2el1d, knod2els, knod2elc, knod2eltg, nod2els, nod2elc, nod2eltg, lelx, pm_stack, iworksh)
Definition i20sti3.F:857
i20sti3
subroutine i20sti3(pm, geo, x, ms, ixs, ixc, ixtg, ixt, ixp, wa, nint, nty, noint, nrt, nsn, irect, nsv, inacti, gap, igap, gap_s, gap_m, gapmin, gapinf, gapmax, stfac, stf, stfn, knod2els, knod2elc, knod2eltg, nod2els, nod2elc, nod2eltg, igrsurf1, ifs2, igrsurf2, intth, ieles, ielec, areas, ipartc, iparttg, thk, thk_part, gap_sh, xanew, gapshmax, nbinflg, mbinflg, nln, nlg, gapsol, ixs10, ixs16, ixs20, id, titr, igeo, pm_stack, iworksh)
Definition i20sti3.F:58
i4gmx3
subroutine i4gmx3(x, irect, i, gapmax)
Definition i4gmx3.F:35
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
i20nelts
subroutine i20nelts(x, irect, ixs, nint, nel, i, area, noint, ir, surf_eltyp, surf_elem)
Definition inelt.F:168
ineltc
subroutine ineltc(nelc, neltg, is, surf_eltyp, surf_elem)
Definition inelt.F:132
insol3
subroutine insol3(x, irect, ixs, nint, nel, i, area, noint, knod2els, nod2els, ir, ixs10, ixs16, ixs20)
Definition insol3.F:43
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
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
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