OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i9wal3.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!|| i9wal3 ../engine/source/interfaces/int09/i9wal3.F
25!||--- called by ------------------------------------------------------
26!|| i9wale ../engine/source/interfaces/int09/i9wale.F
27!||--- calls -----------------------------------------------------
28!|| bcs2 ../engine/source/constraints/general/bcs/bcs2.F
29!|| i9grd3 ../engine/source/interfaces/int09/i9grd3.F
30!|| shapeh ../engine/source/ale/inter/shapeh.F
31!|| spmd_glob_dsum9 ../engine/source/mpi/interfaces/spmd_th.F
32!|| spmd_glob_isum9 ../engine/source/mpi/interfaces/spmd_th.F
33!|| spmd_ibcast ../engine/source/mpi/generic/spmd_ibcast.F
34!|| spmd_rbcast ../engine/source/mpi/generic/spmd_rbcast.F
35!||--- uses -----------------------------------------------------
36!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
37!||====================================================================
38 SUBROUTINE i9wal3(X ,V ,W ,A ,CRST ,
39 2 NSV ,ILOC ,IRTL ,ICODE ,ISKEW ,
40 3 SKEW ,MSR ,LMSR ,NSEG ,IRECTS ,
41 4 IRECT ,UPW ,IXS ,ELBUF_TAB,
42 5 IPARG ,PM ,NALE ,EE ,IELES ,
43 6 IELEM ,TSTIF ,INTTH ,IEULT ,STENS ,
44 7 NOR ,ISIZES ,ISIZEM ,NRTS, NRTM, NSN,NMN )
45C-----------------------------------------------
46C M o d u l e s
47C-----------------------------------------------
48 USE elbufdef_mod
49C-----------------------------------------------
50C I m p l i c i t T y p e s
51C-----------------------------------------------
52#include "implicit_f.inc"
53C-----------------------------------------------
54C C o m m o n B l o c k s
55C-----------------------------------------------
56#include "com01_c.inc"
57#include "com08_c.inc"
58#include "scr08_a_c.inc"
59#include "param_c.inc"
60#include "task_c.inc"
61C-----------------------------------------------
62C D u m m y A r g u m e n t s
63C-----------------------------------------------
64 INTEGER, INTENT(IN) :: NRTS, NRTM, NSN,NMN
65 INTEGER IRECT(4,*), NSV(NSN), ILOC(*), IRTL(NSN), ICODE(*), ISKEW(*),
66 . MSR(*), IRECTS(4,*), LMSR(*), NSEG(*),IXS(NIXS,*),
67 . IPARG(NPARG,*), IELES(*), IELEM(*),NALE(*) ,
68 . INTTH, IEULT, ISIZES, ISIZEM
69C REAL
70 my_real
71 . upw, tstif,ttt, stens,
72 . x(3,*), v(3,*), w(3,*), a(3,*), crst(2,*), skew(lskew,*),
73 . pm(npropm,*),ee(*),nor(3,*)
74 TYPE (ELBUF_STRUCT_), TARGET, DIMENSION(NGROUP) :: ELBUF_TAB
75C-----------------------------------------------
76C L o c a l V a r i a b l e s
77C-----------------------------------------------
78 INTEGER II, N, L, JJ, NN, LL, LL1, LL2, LG, KK, KKK, K1, K2,
79 . I1, I2, IERR, IGROU, IELN,
80 . ixx(4), iperm(0:5),
81 . itemp(2), is, im, ilen,
82 . tags(isizes),tagm(isizem), lists(isizes),listm(isizem),
83 . icomerr(isizem+isizes),icomngr(isizem+isizes),
84 . icomnel(isizem+isizes)
85C REAL
86 my_real
87 . h(4), vmx, vmy, vmz, vx, vy, vz, vv, nx, ny, nz, vt,
88 . nnx, nny, nnz, fac, p, x1, y1, z1,x2, y2, z2, tx, ty, tz,
89 . efric, vols, volm, ts, tm ,tstifm, tstifs, dvn, tt2, tt3,
90 . tstift, phi, areas, aream, vn, wn, t2x, t2y, t2z, t2t,
91 . t3x, t3y, t3z, stensx, stensy, stensz,
92 . comarea(isizem+isizes),comstf(isizem+isizes),
93 . comt(isizem+isizes),comvol(isizem+isizes),combuf(isizem+isizes)
94 TYPE(g_bufel_) ,POINTER :: GBUF
95c
96 DATA IPERM/ 4, 1, 2, 3, 4, 1/
97C-----------------------------------------------
98C
99C Phase de Preparation pour SPMD
100C
101 IF(intth/=zero) THEN
102 IF(ispmd==0) THEN
103 DO ii = 1, nrts
104 tags(ii) = 0
105 ENDDO
106 DO ii = 1, nrtm
107 tagm(ii) = 0
108 ENDDO
109 is = 0
110 im = 0
111 DO ii = 1, nsn
112 l = irtl(ii)
113 IF(iloc(ii)>0.AND.nmn>0.AND.tagm(l)==0)THEN
114 im = im + 1
115 listm(im) = l
116 tagm(l) = im
117 ll1=nseg(ii)
118 ll2=nseg(ii+1)-1
119 DO ll=ll1,ll2
120 lg = lmsr(ll)
121 IF(tags(lg)==0) THEN
122 is = is + 1
123 lists(is) = lg
124 tags(lg) = is
125 ENDIF
126 ENDDO
127 ENDIF
128 ENDDO
129C
130C Compactage listes elem
131C
132 itemp(1) = is
133 itemp(2) = im
134 ENDIF
135C
136C Envoi liste facettes seconds/mains en contact
137C
138 IF(nspmd > 1) THEN
139 CALL spmd_ibcast(itemp,itemp,1,2,0,2)
140 is = itemp(1)
141 im = itemp(2)
142 ilen = im+is
143 CALL spmd_ibcast(listm,listm,1,im,0,2)
144 CALL spmd_ibcast(lists,lists,1,is,0,2)
145 END IF
146 DO ii = 1, im
147 l = listm(ii)
148 ix(1) = msr(irect(1,l))
149 ix(2) = msr(irect(2,l))
150 ix(3) = msr(irect(3,l))
151 ix(4) = msr(irect(4,l))
152 IF(ielem(l)>0) THEN
153 CALL i9grd3(
154 1 ierr ,comarea(ii),comstf(ii),comt(ii),comvol(ii),
155 2 ielem(l) ,x ,ixs(1,ielem(l)), ix,
156 3 iparg,pm ,elbuf_tab ,igrou ,ieln )
157 icomerr(ii) = ierr
158 icomngr(ii) = igrou
159 icomnel(ii) = ieln
160 ELSE
161 comarea(ii) = zero
162 comstf(ii) = zero
163 comt(ii) = zero
164 comvol(ii) = zero
165 icomerr(ii) = 0
166 icomngr(ii) = 0
167 icomnel(ii) = 0
168 ENDIF
169 combuf(ii) = zero
170 ENDDO
171C
172 DO ii = 1, is
173 l = lists(ii)
174 ixx(1)=nsv(irects(1,l))
175 ixx(2)=nsv(irects(2,l))
176 ixx(3)=nsv(irects(3,l))
177 ixx(4)=nsv(irects(4,l))
178 IF(ieles(l)>0) THEN
179 CALL i9grd3(
180 1 ierr ,comarea(im+ii),comstf(im+ii),comt(im+ii),comvol(im+ii),
181 2 ieles(l) ,x,ixs(1,ieles(l)) ,ixx ,
182 3 iparg,pm ,elbuf_tab ,igrou ,ieln )
183 icomerr(im+ii) = ierr
184 icomngr(im+ii) = igrou
185 icomnel(im+ii) = ieln
186 ELSE
187 comarea(im+ii) = zero
188 comstf(im+ii) = zero
189 comt(im+ii) = zero
190 comvol(im+ii) = zero
191 icomerr(im+ii) = 0
192 icomngr(im+ii) = 0
193 icomnel(im+ii) = 0
194 ENDIF
195 combuf(im+ii) = zero
196 ENDDO
197C
198 IF (nspmd > 1) THEN
199C
200C gather des valeurs
201C
202 CALL spmd_glob_dsum9(comarea,ilen)
203 CALL spmd_glob_dsum9(comstf,ilen)
204 CALL spmd_glob_dsum9(comt,ilen)
205 CALL spmd_glob_dsum9(comvol,ilen)
206 CALL spmd_glob_isum9(icomerr,ilen)
207 CALL spmd_glob_isum9(icomngr,ilen)
208 CALL spmd_glob_isum9(icomnel,ilen)
209C partie noeud sur P0 uniquement
210 IF(ispmd/=0) GOTO 900
211 END IF
212C interface traitee par p0
213 ELSE
214 IF(ispmd/=0) RETURN
215 ENDIF
216C
217 DO 800 ii=1,nsn
218 ll1=nseg(ii)
219 ll2=nseg(ii+1)-1
220 n=nsv(ii)
221 IF(iloc(ii)>0.AND.nmn>0)THEN
222C---------------------------------
223C CONTACT
224C---------------------------------
225 l=irtl(ii)
226 DO 10 jj=1,4
227 nn=irect(jj,l)
228 10 ix(jj)=msr(nn)
229C
230 CALL shapeh(h,crst(1,ii),crst(2,ii))
231C---------------------------------
232C VITESSE DE MAILLAGE
233C---------------------------------
234 vmx=zero
235 vmy=zero
236 vmz=zero
237C
238 DO 30 jj=1,4
239 vmx=vmx+w(1,ix(jj))*h(jj)
240 vmy=vmy+w(2,ix(jj))*h(jj)
241 30 vmz=vmz+w(3,ix(jj))*h(jj)
242C
243 dvn = (vmx-w(1,n)) * nor(1,ii)
244 . + (vmy-w(2,n)) * nor(2,ii)
245 . + (vmz-w(3,n)) * nor(3,ii)
246 w(1,n) = w(1,n) + dvn * nor(1,ii)
247 w(2,n) = w(2,n) + dvn * nor(2,ii)
248 w(3,n) = w(3,n) + dvn * nor(3,ii)
249C
250C---------------------------------
251C PONT THERMIQUE
252C---------------------------------
253 IF(intth/=zero)THEN
254 kk = tagm(l)
255 efric = half * ee(ii) / (ll2-ll1+1)
256 ierr = icomerr(kk)
257 aream = comarea(kk)
258 tstifm = comstf(kk)
259 tm = comt(kk)
260 volm = comvol(kk)
261 IF(ierr==0) THEN
262 DO ll = ll1,ll2
263 lg = lmsr(ll)
264 jj = tags(lg) + im
265 ierr = icomerr(jj)
266 areas = comarea(jj)
267 tstifs = comstf(jj)
268 ts = comt(jj)
269 vols = comvol(jj)
270 IF(ierr==0) THEN
271 tstift = tstifm + tstifs + tstif
272 phi = areas * dt1 * (tm-ts) / tstift
273 combuf(jj) = combuf(jj)
274 + + (efric+phi)/vols
275 combuf(kk) = combuf(kk)
276 + + (efric-phi)/volm
277 ENDIF
278 ENDDO
279 ENDIF
280c ENDIF
281 ENDIF
282C
283 ELSEIF(iloc(ii)<0.OR.nmn==0)THEN
284C------------------------------------------------------
285C BOUCLE SUR LES FACETTES CONNECTEES AU NOEUD II
286C------------------------------------------------------
287 iloc(ii) = -iloc(ii)
288C
289 vx = v(1,n) - w(1,n)
290 vy = v(2,n) - w(2,n)
291 vz = v(3,n) - w(3,n)
292 vv = max(em30,sqrt(vx**2+vy**2+vz**2))
293 nnx = zero
294 nny = zero
295 nnz = zero
296C------------------------------------------------------
297C BOUCLE SUR LES FACETTES CONNECTEES AU NOEUD II
298C------------------------------------------------------
299 DO 300 ll=ll1,ll2
300 lg=lmsr(ll)
301 DO 200 kkk=1,4
302 kk=kkk
303 200 IF(irects(kk,lg)==ii) GO TO 250
304 250 CONTINUE
305C------------------------------------------------------
306C CALCUL DE LA NORMALE AVEC UPWIND SUR L'AMONT
307C------------------------------------------------------
308 k1 = iperm(kk-1)
309 k2 = iperm(kk+1)
310 i1 = nsv(irects(k1,lg))
311 i2 = nsv(irects(k2,lg))
312 x1 = x(1,i1) - x(1,n)
313 y1 = x(2,i1) - x(2,n)
314 z1 = x(3,i1) - x(3,n)
315 x2 = x(1,i2) - x(1,n)
316 y2 = x(2,i2) - x(2,n)
317 z2 = x(3,i2) - x(3,n)
318 tx = x1 + x2
319 ty = y1 + y2
320 tz = z1 + z2
321 ttt = max(em30,sqrt(tx**2+ty**2+tz**2))
322 vt = v(1,n)*tx + v(2,n)*ty + v(3,n)*tz
323 p = onep0001 - upw*(half + sign(half,vt))
324 nx = y1 * z2 - z1 * y2
325 ny = z1 * x2 - x1 * z2
326 nz = x1 * y2 - y1 * x2
327C FAC = P / MAX(EM30,SQRT(NX**2+NY**2+NZ**2))
328 fac = p
329 nnx = nnx + nx*fac
330 nny = nny + ny*fac
331 nnz = nnz + nz*fac
332C-------------------------------------
333C TENSION DE SURFACE
334C-------------------------------------
335 IF(stens>zero)THEN
336 t2x = -x1 + x2
337 t2y = -y1 + y2
338 t2z = -z1 + z2
339 tt2 = max(em30,t2x**2+t2y**2+t2z**2)
340 t2t = (t2x*tx + t2y*ty +t2z*tz) / tt2
341 t3x = tx - t2x * t2t
342 t3y = ty - t2y * t2t
343 t3z = tz - t2z * t2t
344 tt3 = stens * sqrt(tt2/max(em30,t3x**2+t3y**2+t3z**2))
345 stensx = t3x * tt3
346 stensy = t3y * tt3
347 stensz = t3z * tt3
348 a(1,n) = a(1,n) + stensx
349 a(2,n) = a(2,n) + stensy
350 a(3,n) = a(3,n) + stensz
351 ENDIF
352 300 CONTINUE
353 fac = max(em30,sqrt(nnx**2+nny**2+nnz**2))
354 nnx = nnx/fac
355 nny = nny/fac
356 nnz = nnz/fac
357C
358C---------------------------------
359C W LAGRANGIEN SUIVANT N
360C---------------------------------
361C---------------------------------
362C BCS DE GRILLE
363C---------------------------------
364 IF(icode(n)/=0)THEN
365 dvn = vx * nnx + vy * nny + vz * nnz
366 w(1,n) = w(1,n) + dvn * nnx
367 w(2,n) = w(2,n) + dvn * nny
368 w(3,n) = w(3,n) + dvn * nnz
369 CALL bcs2(w(1,n),skew(1,iskew(n)),iskew(n),icode(n))
370 vn = v(1,n)*nnx + v(2,n)*nny + v(3,n)*nnz
371 wn = w(1,n)*nnx + w(2,n)*nny + w(3,n)*nnz
372C-------------------------------------
373C W LAGRANGIEN SUIVANT N + BCS
374C-------------------------------------
375 IF(abs(wn)>em30)THEN
376 fac = vn / wn
377 w(1,n) = w(1,n) * fac
378 w(2,n) = w(2,n) * fac
379 w(3,n) = w(3,n) * fac
380 ENDIF
381 ELSEIF(ieult/=0)THEN
382C-------------------------------------
383C W LAGRANGIEN SUIVANT N
384C W EULERIEN SUIVANT T
385C---------------------------------
386 vn = v(1,n)*nnx + v(2,n)*nny + v(3,n)*nnz
387 w(1,n) = vn * nnx
388 w(2,n) = vn * nny
389 w(3,n) = vn * nnz
390 ELSE
391C-------------------------------------
392C W LAGRANGIEN SUIVANT N
393C LIBRE SUIVANT T
394C---------------------------------
395 dvn = vx * nnx + vy * nny + vz * nnz
396 w(1,n) = w(1,n) + dvn * nnx
397 w(2,n) = w(2,n) + dvn * nny
398 w(3,n) = w(3,n) + dvn * nnz
399 ENDIF
400 ENDIF
401C
402 800 CONTINUE
403C
404C Phase de Finalisation pour SPMD
405C
406 900 CONTINUE
407 IF(intth/=zero) THEN
408 IF(nspmd > 1) THEN
409C
410C Envoi buffer elems updates
411C
412 CALL spmd_rbcast(combuf,combuf,1,ilen,0,2)
413 END IF
414C
415C Mise a jour ELBUF local
416C
417 DO ii = 1, im
418 l = listm(ii)
419 IF(ielem(l)>0) THEN
420 igrou = icomngr(ii)
421 ieln = icomnel(ii)
422 elbuf_tab(igrou)%GBUF%EINT(ieln) =
423 . elbuf_tab(igrou)%GBUF%EINT(ieln) + combuf(ii)
424 ENDIF
425 ENDDO
426C
427 DO ii = 1, is
428 l = lists(ii)
429 IF(ieles(l)>0) THEN
430 igrou = icomngr(im+ii)
431 ieln = icomnel(im+ii)
432 elbuf_tab(igrou)%GBUF%EINT(ieln) =
433 . elbuf_tab(igrou)%GBUF%EINT(ieln) + combuf(im+ii)
434 ENDIF
435 ENDDO
436 ENDIF
437C
438 RETURN
439 END
bcs2
subroutine bcs2(a, b, j, k)
Definition bcs2.F:32
my_real
#define my_real
Definition cppsort.cpp:32
i9grd3
subroutine i9grd3(ierr, area, tstif, t, vol, ii, x, ixs, ix, iparg, pm, elbuf_tab, igrou, ieln)
Definition i9grd3.F:36
i9wal3
subroutine i9wal3(x, v, w, a, crst, nsv, iloc, irtl, icode, iskew, skew, msr, lmsr, nseg, irects, irect, upw, ixs, elbuf_tab, iparg, pm, nale, ee, ieles, ielem, tstif, intth, ieult, stens, nor, isizes, isizem, nrts, nrtm, nsn, nmn)
Definition i9wal3.F:45
max
#define max(a, b)
Definition macros.h:21
shapeh
subroutine shapeh(h, s, t)
Definition shapeh.F:34
spmd_ibcast
subroutine spmd_ibcast(tabi, tabr, n1, n2, from, add)
Definition spmd_ibcast.F:57
spmd_rbcast
subroutine spmd_rbcast(tabi, tabr, n1, n2, from, add)
Definition spmd_rbcast.F:62
spmd_glob_dsum9
subroutine spmd_glob_dsum9(v, len)
Definition spmd_th.F:380
spmd_glob_isum9
subroutine spmd_glob_isum9(v, len)
Definition spmd_th.F:523