OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
lag_mult.F File Reference
#include "implicit_f.inc"
#include "param_c.inc"
#include "com04_c.inc"
#include "com08_c.inc"
#include "lagmult.inc"
#include "task_c.inc"
#include "com01_c.inc"
#include "spmd_c.inc"
#include "scr17_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine lag_mult (ipari, x, a, wat, v, ms, in, vr, itask, wag, itab, ixs, ixs20, ixs16, igrnod, fani, fsav, skew, ar, lambda, lagbuf, ibcslag, ixs10, gjbufi, gjbufr, ibmpc, rbmpc, npbyl, lpbyl, ibfv, vel, npf, tf, newfront, icontact, rwbuf, lprw, nprw, rbyl, d, dr, kinet, nsensor, sensor_tab, intbuf_tab, h3d_data, igrbric, python, nodes)
subroutine lag_multp (ipari, x, a, wat, v, ms, in, vr, wag, itab, ixs, ixs20, ixs16, fani, fsav, skew, ar, lambda, lagbuf, ibcslag, ixs10, gjbufi, gjbufr, ibmpc, rbmpc, npbyl, lpbyl, ibfv, vel, npf, tf, newfront, icontact, rwbuf, lprw, nprw, rbyl, d, dr, kinet, nodglob, weight, nbncl, nbikl, nbnodl, nbnodlr, fr_lagf, llagf, iad_elem, fr_elem, intbuf_tab, h3d_data, python, nodes)

Function/Subroutine Documentation

◆ lag_mult()

subroutine lag_mult ( integer, dimension(npari,*) ipari,
x,
a,
wat,
v,
ms,
in,
vr,
integer, intent(in) itask,
wag,
integer, dimension(*) itab,
integer, dimension(nixs,*) ixs,
integer, dimension(12,*) ixs20,
integer, dimension(8,*) ixs16,
type (group_), dimension(ngrnod) igrnod,
fani,
fsav,
skew,
ar,
lambda,
integer, dimension(*) lagbuf,
integer, dimension(*) ibcslag,
integer, dimension(6,*) ixs10,
integer, dimension(lkjni,*) gjbufi,
gjbufr,
integer, dimension(*) ibmpc,
rbmpc,
integer, dimension(nnpby,*) npbyl,
integer, dimension(*) lpbyl,
integer, dimension(nifv,*) ibfv,
vel,
integer, dimension(*) npf,
tf,
integer, dimension(*) newfront,
integer, dimension(*) icontact,
rwbuf,
integer, dimension(*) lprw,
integer, dimension(*) nprw,
rbyl,
d,
dr,
integer, dimension(*) kinet,
integer, intent(in) nsensor,
type (sensor_str_), dimension(nsensor), intent(in) sensor_tab,
type(intbuf_struct_), dimension(*) intbuf_tab,
type(h3d_database) h3d_data,
type (group_), dimension(ngrbric) igrbric,
type(python_), intent(inout) python,
type(nodal_arrays_), intent(in) nodes )

Definition at line 58 of file lag_mult.F.

70C======================================================================|
71C-----------------------------------------------
72C M o d u l e s
73C-----------------------------------------------
74 USE python_funct_mod
75 USE intbufdef_mod
76 USE h3d_mod
77 USE groupdef_mod
78 USE sensor_mod
79 USE nodal_arrays_mod
80C-----------------------------------------------
81C I m p l i c i t T y p e s
82C-----------------------------------------------
83#include "implicit_f.inc"
84C-----------------------------------------------
85C C o m m o n B l o c k s
86C-----------------------------------------------
87#include "param_c.inc"
88#include "com04_c.inc"
89#include "com08_c.inc"
90#include "lagmult.inc"
91 COMMON /lagglob/n_mult
92C-----------------------------------------------
93C D u m m y A r g u m e n t s
94C-----------------------------------------------
95 INTEGER ,INTENT(IN) :: NSENSOR,ITASK
96 INTEGER IPARI(NPARI,*),IXS(NIXS,*),IXS16(8,*),
97 . IXS10(6,*),IXS20(12,*),ITAB(*),
98 . LAGBUF(*),IBCSLAG(*),GJBUFI(LKJNI,*),
99 . IBMPC(*),NPBYL(NNPBY,*),LPBYL(*),IBFV(NIFV,*),NPF(*),
100 . NEWFRONT(*),ICONTACT(*),LPRW(*),NPRW(*),KINET(*)
101C REAL
102 my_real
103 . x(3,*), d(3,*), dr(3,*), a(3,*), ar(3,*), v(3,*), vr(3,*),
104 . ms(*), in(*), lambda(*),fani(3,*),fsav(nthvki,*),
105 . skew(lskew,*),wag(*),wat(*),gjbufr(lkjnr,*),rbmpc(*),
106 . vel(lfxvelr,*),tf(*),rwbuf(nrwlp,*),rbyl(nrby,*)
107
108 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
109 TYPE(H3D_DATABASE) :: H3D_DATA
110 TYPE (SENSOR_STR_) ,DIMENSION(NSENSOR) ,INTENT(IN) :: SENSOR_TAB
111 TYPE(PYTHON_), INTENT(INOUT) :: PYTHON
112 TYPE(nodal_arrays_), intent(in) :: nodes
113C-----------------------------------------------
114 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
115 TYPE (GROUP_) , DIMENSION(NGRBRIC) :: IGRBRIC
116C-----------------------------------------------
117C L o c a l V a r i a b l e s
118C-----------------------------------------------
119 INTEGER N,I,N_MULT,N_MUL_MX,NKMAX,LENH,NH,NTY,NCR,
120 . IP0,IP1,IP2,IP3,IP4,IP5,IP6,IP7,IP8,IP8A,IP8B,IP9,IP10,
121 . IP11,IP12,IP13,IP14,IP15,IP16,IP17,IP18,IP19,IP20,
122 . J1,J2,J3,J4,J5,K,N1,N2,N3,N4,N5,N6,LWAT,ISKIP,NCF_S,NCF_E,
123 . INUM,IDDL,ISKW,ITYP,NB_JLT,NB_JLT_NEW,NB_STOK_N,
124 . NUM_ISTOCK,KINDEX2,
125 . ILAGM, ISENS
126 my_real ts
127C======================================================================|
128 n_mul_mx = lag_ncf + lag_ncl
129 nkmax = lag_nkf + lag_nkl
130 nhmax = lag_nhf + lag_nhl
131 n_mult = 0
132 num_istock = 4*numnod
133 lwat = max(6*(numels16+numels20),nrwlag,2*numnod+num_istock)
134C
135 ip0 = 1
136 ip1 = ip0 + n_mul_mx
137 ip2 = ip1 + n_mul_mx + 1
138 ip3 = ip2 + nkmax
139 ip4 = ip3 + nkmax
140 ip5 = ip4 + nkmax
141 ip6 = ip5 + nkmax
142 ip7 = ip6 + numnod
143 ip8 = ip7 + lwat
144 ip8a= ip7 + numnod
145 ip8b= ip8a+ numnod
146 IF(itask==0)THEN
147 kindex2=ip8b
148 ELSE
149 kindex2=1
150 END IF
151 j1 = 1
152 j2 = j1 + lag_ncf + 1
153 j3 = j2 + lag_nhf
154 j4 = j3 + lag_ncf
155 j5 = j4 + lag_ncf
156C---
157 DO n=0,lag_ncf-1
158 lagbuf(j3+n) = 0
159 lagbuf(j4+n) = 0
160 ENDDO
161 DO n=1,n_mul_mx
162 lambda(n) = zero
163 ENDDO
164 DO n=ip0,ip1-1
165 wag(n) = zero
166 ENDDO
167 CALL init_int(wag(ip1),1)
168 CALL init_intv(wag(ip4), nkmax)
169C----------------------------------------------------
170C Tag coupled nodes
171C----------------------------------------------------
172 CALL init_intv(wag(ip6), numnod)
173C----------------------------------------------------
174 CALL my_barrier
175C ---------------------
176 IF(itask==0.AND.nbcslag>0) CALL ltag_bcs(wag(ip6) ,ngrnod,
177 . igrnod,ibcslag )
178C -------------------
179 CALL my_barrier
180C -------------------
181 IF(itask==0.AND.ninter>0) CALL ltag_i2main(wag(ip6) ,
182 . ipari ,intbuf_tab )
183C ---------------------
184 CALL my_barrier
185C -------------------
186 IF(itask==0.AND.ngjoint>0) CALL ltag_gjnt(wag(ip6),
187 . gjbufi )
188C -------------------
189 CALL my_barrier
190C -------------------
191 IF(itask==0.AND.nummpc>0) CALL ltag_mpc(wag(ip6) ,
192 . ibmpc ,ibmpc(nummpc+1))
193C -------------------
194 CALL my_barrier
195C -------------------
196 IF(itask==0.AND.nfvlag>0) CALL ltag_fxv(wag(ip6) ,
197 . ibfv )
198C -------------------
199 CALL my_barrier
200C -------------------
201 IF(itask==0.AND.nrbylag>0) CALL ltag_rby(wag(ip6) ,
202 . npbyl ,lpbyl )
203C----------------------------------------------------
204C Construct L matrix for interfaces and rigid walls
205C----------------------------------------------------
206 CALL my_barrier
207C -------------------
208 DO n=1,ninter
209 nty = ipari(7,n)
210C---
211 IF(nty==7.OR.nty==22)THEN
212 isens = 0
213 IF(nty==7) isens = ipari(64,n)
214 IF(isens > 0) THEN
215 ts = sensor_tab(isens)%TSTART
216 ELSE
217 ts = tt
218 ENDIF
219 nb_jlt = 0
220 nb_jlt_new= 0
221 nb_stok_n = 0
222 ilagm =ipari(33,n)
223 IF(ilagm /= 0) THEN
224 IF(tt>=ts) THEN
225 CALL i7main_lmult(
226 1 n ,ipari ,intbuf_tab,x ,
227 2 v ,a ,itask ,ms ,
228 3 wag(ip1) ,wag(ip2) ,wag(ip3) ,wag(ip4) ,wag(ip5) ,
229 4 n_mul_mx ,nkmax ,itab ,wat(kindex2),nb_jlt ,
230 5 nb_jlt_new,nb_stok_n ,newfront ,icontact ,wag(ip7) ,
231 6 wag(ip8a) ,wag(ip6) ,kinet )
232 ENDIF
233 ENDIF
234C---
235 ELSEIF(nty==16)THEN
236 ilagm =ipari(33,n)
237 IF(ilagm /= 0)CALL i16main(
238 1 n ,ipari ,intbuf_tab,x ,v ,
239 2 a ,itask ,igrnod ,wag(ip7) ,wat(ip8) ,
240 3 ms ,wag(ip1) ,wag(ip2) ,wag(ip3) ,wag(ip4) ,
241 4 wag(ip5) ,n_mul_mx ,ixs ,ixs16 ,ixs20 ,
242 5 nkmax ,ixs10 ,wag(ip6) ,igrbric)
243C---
244 ELSEIF(nty==17)THEN
245 ilagm =ipari(33,n)
246 IF(ilagm /= 0)CALL i17main(
247 1 n ,ipari ,intbuf_tab(n) ,x ,
248 2 v ,a ,itask ,igrbric ,
249 3 wag(ip7) ,ms ,n_mult ,wag(ip1) ,
250 4 wag(ip2) ,wag(ip3) ,wag(ip4) ,wag(ip5) ,n_mul_mx ,
251 5 ixs ,ixs16 ,ixs20 ,nkmax ,wag(ip6) )
252C---
253 ENDIF
254 ENDDO
255C -------------------
256 CALL my_barrier
257C -------------------
258 k=1
259 DO n=1,nrwall
260 n2=n +nrwall
261 n3=n2+nrwall
262 n4=n3+nrwall
263 n5=n4+nrwall
264 n6=n5+nrwall
265 IF(nprw(n6)==1)THEN
266 CALL lag_rwall(rwbuf(1,n),lprw(k),nprw(n),nprw(n2),nprw(n3),
267 2 wat(ip8),x ,v ,a ,wag(ip1),
268 3 wag(ip2),wag(ip3),wag(ip4),wag(ip5),wag(ip6),
269 4 n_mul_mx,nkmax ,n_mult )
270 ENDIF
271 k=k+nprw(n)
272 ENDDO
273C----------------------------------------------------
274C Construct L matrix for remaining options
275C----------------------------------------------------
276 iskip = 0
277 ncf_s = n_mult
278 DO n=ip7,ip8-1
279 wag(n) = zero
280 ENDDO
281C -------------------
282 CALL my_barrier
283C -------------------
284 IF(itask==0 .AND. nbcslag>0) CALL lag_bcs(
285 1 igrnod ,ibcslag ,skew ,wag(ip0) ,ngrnod ,
286 2 wag(ip1) ,wag(ip2) ,wag(ip3) ,wag(ip4) ,wag(ip5) ,
287 3 wag(ip6) ,lagbuf(j3),lagbuf(j4),ms ,in ,
288 4 v ,vr ,a ,ar ,iskip ,
289 5 ncf_s ,n_mult )
290C ---------------------
291 CALL my_barrier
292C ---------------------
293 IF(itask==0 .AND. ninter>0) CALL lag_i2main(
294 1 ipari ,intbuf_tab,wag(ip1) ,wag(ip2) ,wag(ip3) ,
295 2 wag(ip4) ,wag(ip5) ,wag(ip6) ,wag(ip7) ,lagbuf(j3),
296 3 lagbuf(j4),in ,ms ,x ,v ,
297 4 vr ,a ,ar ,iskip ,ncf_s ,
298 5 n_mult )
299C ---------------------
300 CALL my_barrier
301C ---------------------
302 IF(itask==0 .AND. ngjoint>0) CALL lag_gjnt(
303 1 gjbufi ,gjbufr ,x ,vr ,ar ,
304 2 wag(ip1) ,wag(ip2) ,wag(ip3) ,wag(ip4) ,wag(ip5) ,
305 3 wag(ip6) ,wag(ip7) ,lagbuf(j3),lagbuf(j4),ms ,
306 4 in ,v ,a ,iskip ,ncf_s ,
307 5 n_mult )
308C ---------------------
309 CALL my_barrier
310C ---------------------
311 IF(itask==0 .AND. nummpc>0) THEN
312 inum = nummpc+1
313 iddl = inum +lmpc
314 iskw = iddl +lmpc
315 CALL lag_mpc(
316 1 rbmpc ,ibmpc ,ibmpc(inum),ibmpc(iddl),ibmpc(iskw),
317 2 skew ,wag(ip1) ,wag(ip2) ,wag(ip3) ,wag(ip4) ,
318 3 wag(ip5) ,wag(ip6) ,lagbuf(j3) ,lagbuf(j4) ,ms ,
319 4 in ,v ,vr ,a ,ar ,
320 5 iskip ,ncf_s ,n_mult )
321 ENDIF
322C ---------------------
323 CALL my_barrier
324C ---------------------
325 IF(itask==0 .AND. nfvlag>0) CALL lag_fxv(
326 1 ibfv ,vel ,skew ,npf ,tf ,
327 2 wag(ip0) ,wag(ip1) ,wag(ip2) ,wag(ip3) ,wag(ip4) ,
328 3 wag(ip5) ,wag(ip6) ,lagbuf(j3),lagbuf(j4),ms ,
329 4 in ,v ,vr ,a ,ar ,
330 5 iskip ,ncf_s ,n_mult ,python, nodes)
331C ---------------------
332 ncf_e = n_mult
333C ---------------------
334C--- Rigid bodies
335C -------------------
336 CALL my_barrier
337C ---------------------
338 IF(itask==0 .AND. nrbylag>0) THEN
339 CALL lag_rby(
340 1 rbyl ,npbyl ,lpbyl ,ms ,in ,
341 2 wag(ip1) ,wag(ip2) ,wag(ip3) ,wag(ip4) ,wag(ip5) ,
342 3 wag(ip6) ,v ,vr ,a ,ar ,
343 4 x ,n_mult ,ncr )
344 ELSE
345 ncr = n_mult
346 ENDIF
347C=======================================================================
348C GRADIENT CONJUGUE
349C=======================================================================
350C -------------------
351 CALL my_barrier
352C -------------------
353 IF(itask==0) THEN
354 nh = nhmax + 3*(n_mul_mx - n_mult)
355C---
356 ip7 = ip6 + n_mult + 1
357 ip8 = ip7 + nh
358 ip9 = ip8 + nh
359 ip10 = ip9 + n_mult
360 ip11 = ip0
361 ip12 = ip10 + n_mult
362 ip13 = ip12 + n_mult
363 ip14 = ip13 + 6 * numnod
364 ip15 = ip14 + nh
365 ip16 = ip15 + n_mult
366 ip17 = ip16 + n_mult
367 ip18 = ip17 + n_mult
368 ip19 = ip18 + n_mult
369 ip20 = ip19 + n_mult
370C---
371 DO n=ip13,ip14-1
372 wag(n) = zero
373 ENDDO
374C -------------------------------------------------------------
375 CALL lag_mult_solv(
376 1 nh ,n_mult ,ncr ,a ,v ,
377 2 ms ,wag(ip1) ,wag(ip2) ,wag(ip3) ,wag(ip5) ,
378 3 wag(ip6) ,wag(ip7) ,wag(ip8) ,wag(ip9) ,wag(ip10) ,
379 4 wag(ip11) ,wag(ip12) ,wag(ip13) ,wag(ip14) ,wag(ip15) ,
380 5 wag(ip16) ,wag(ip17) ,wag(ip18) ,wag(ip19) ,lambda ,
381 6 rbyl ,npbyl ,ar ,vr ,in ,
382 7 lagbuf(j1),lagbuf(j2),lagbuf(j3),lagbuf(j4),ncf_s ,
383 8 ncf_e )
384 ENDIF
385C-------------------
386 CALL my_barrier
387C-------------------
388 IF(itask==0)
389 1 CALL rby_decond(x ,v ,vr ,a ,ar ,
390 2 wag(ip1),wag(ip2),wag(ip3),wag(ip5),lambda ,
391 3 ms ,in ,rbyl ,npbyl ,lpbyl ,
392 4 n_mult ,ncr )
393C-------------------
394 CALL my_barrier
395C-------------------
396 IF(itask==0)
397 . CALL lag_anith(wag(ip1),wag(ip2),wag(ip3),wag(ip4),wag(ip5),
398 . fani ,fsav ,n_mult ,h3d_data )
399c IF(ITASK==0 .AND. NRBYLAG>0)
400c . CALL LAGTH_RBY(LPBYL ,NPBYL ,FANI ,FSAV ,A ,AR ,X )
401C---
402 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
i16main
subroutine i16main(nin, ipari, intbuf_tab, x, v, a, itask, igrnod, eminx, wat, ms, iadll, lll, jll, sll, xll, n_mul_mx, ixs, ixs16, ixs20, nkmax, ixs10, comntag, igrbric)
Definition i16main.F:45
i17main
subroutine i17main(nin, ipari, intbuf_tab, x, v, a, itask, igrbric, eminx, ms, nc, iadll, lll, jll, sll, xll, n_mul_mx, ixs, ixs16, ixs20, nkmax, comntag)
Definition i17main.F:43
i7main_lmult
subroutine i7main_lmult(nin, ipari, intbuf_tab, x, v, a, itask, ms, iadll, lll, jll, sll, xll, n_mul_mx, nkmax, itab, index2, nb_jlt, nb_jlt_new, nb_stok_n, newfront, icontact, itag, xtag, comntag, kinet)
Definition i7main_lmult.F:46
lag_anith
subroutine lag_anith(iadll, lll, jll, sll, xll, fani, fsav, nc, h3d_data)
Definition lag_anith.F:33
lag_bcs
subroutine lag_bcs(igrnod, ibcslag, sk, rll, ngrnod, iadll, lll, jll, sll, xll, comntag, icftag, jcftag, mass, iner, v, vr, a, ar, iskip, ncf_s, nc)
Definition lag_bcs.F:35
lag_fxv
subroutine lag_fxv(ibfv, vel, skew, npf, tf, bll, iadll, lll, jll, sll, xll, comntag, icftag, jcftag, ms, in, v, vr, a, ar, iskip, ncf_s, nc, python, nodes)
Definition lag_fxv.F:40
lag_gjnt
subroutine lag_gjnt(gjbufi, gjbufr, x, vr, ar, iadll, lll, jll, sll, xll, comntag, ltsm, icftag, jcftag, ms, in, v, a, iskip, ncf_s, nc)
Definition lag_gjnt.F:39
lag_i2main
subroutine lag_i2main(ipari, intbuf_tab, iadll, lll, jll, sll, xll, comntag, ltsm, icftag, jcftag, in, ms, x, v, vr, a, ar, iskip, ncf_s, n_mult)
Definition lag_i2main.F:42
lag_mpc
subroutine lag_mpc(rbmpc, impcnc, impcnn, impcdl, impcsk, skew, iadll, lll, jll, sll, xll, comntag, icftag, jcftag, ms, in, v, vr, a, ar, iskip, ncf_s, nc)
Definition lag_mpc.F:34
lag_mult_solv
subroutine lag_mult_solv(nh, nc, ncr, a, v, mas, iadll, lll, jll, xll, iadh, jcih, hh, z, p, r, q, ltsm, hl, diag_h, diag_l, work1, work2, work3, lambda, rbyl, npbyl, ar, vr, in, iadhf, jcihf, icftag, jcftag, ncf_s, ncf_e)
Definition lag_mult_solv.F:41
ltag_rby
subroutine ltag_rby(comntag, npbyl, lpbyl)
Definition lag_ntag.F:288
ltag_i2main
subroutine ltag_i2main(comntag, ipari, intbuf_tab)
Definition lag_ntag.F:106
ltag_gjnt
subroutine ltag_gjnt(comntag, gjbufi)
Definition lag_ntag.F:215
init_intv
subroutine init_intv(intv, len)
Definition lag_ntag.F:44
ltag_mpc
subroutine ltag_mpc(comntag, impcnc, impcnn)
Definition lag_ntag.F:253
ltag_bcs
subroutine ltag_bcs(comntag, ngrnod, igrnod, ibcslag)
Definition lag_ntag.F:62
ltag_fxv
subroutine ltag_fxv(comntag, ibfv)
Definition lag_ntag.F:182
init_int
subroutine init_int(i, j)
Definition lag_ntag.F:31
lag_rby
subroutine lag_rby(rbyl, npbyl, lpbyl, mass, iner, iadll, lll, jll, sll, xll, comntag, v, vr, a, ar, x, nc, ncr)
Definition lag_rby.F:34
rby_decond
subroutine rby_decond(x, v, vr, a, ar, iadll, lll, jll, xll, lambda, mass, iner, rbyl, npbyl, lpbyl, nc, ncr)
Definition lag_rby_cond.F:282
lag_rwall
subroutine lag_rwall(rwl, nsw, nsn, itied, msr, index, x, v, a, iadll, lll, jll, sll, xll, comntag, n_mul_mx, nkmax, nc)
Definition lag_rwall.F:37
max
#define max(a, b)
Definition macros.h:21
groupdef_mod
Definition groupdef_mod.F:662
h3d_mod
Definition h3d_mod.F:308
my_barrier
subroutine my_barrier
Definition machine.F:31

◆ lag_multp()

subroutine lag_multp ( integer, dimension(npari,*) ipari,
x,
a,
wat,
v,
ms,
in,
vr,
wag,
integer, dimension(*) itab,
integer, dimension(nixs,*) ixs,
integer, dimension(12,*) ixs20,
integer, dimension(8,*) ixs16,
fani,
fsav,
skew,
ar,
lambda,
integer, dimension(*) lagbuf,
integer, dimension(*) ibcslag,
integer, dimension(6,*) ixs10,
integer, dimension(lkjni,*) gjbufi,
gjbufr,
integer, dimension(*) ibmpc,
rbmpc,
integer, dimension(nnpby,*) npbyl,
integer, dimension(*) lpbyl,
integer, dimension(nifv,*) ibfv,
vel,
integer, dimension(*) npf,
tf,
integer, dimension(*) newfront,
integer, dimension(*) icontact,
rwbuf,
integer, dimension(*) lprw,
integer, dimension(*) nprw,
rbyl,
d,
dr,
integer, dimension(*) kinet,
integer, dimension(*) nodglob,
integer, dimension(*) weight,
integer nbncl,
integer nbikl,
integer nbnodl,
integer nbnodlr,
integer, dimension(3,*) fr_lagf,
integer, dimension(*) llagf,
integer, dimension(2,*) iad_elem,
integer, dimension(*) fr_elem,
type(intbuf_struct_), dimension(*) intbuf_tab,
type(h3d_database) h3d_data,
type(python_), intent(inout) python,
type(nodal_arrays_), intent(in) nodes )

Definition at line 431 of file lag_mult.F.

444C-----------------------------------------------
445C M o d u l e s
446C-----------------------------------------------
447 USE python_funct_mod
448 USE nodal_arrays_mod
449 USE message_mod
450 USE intbufdef_mod
451 USE h3d_mod
452C======================================================================|
453C I m p l i c i t T y p e s
454C-----------------------------------------------
455#include "implicit_f.inc"
456C-----------------------------------------------
457C C o m m o n B l o c k s
458C-----------------------------------------------
459#include "param_c.inc"
460#include "com04_c.inc"
461#include "task_c.inc"
462#include "lagmult.inc"
463#include "com01_c.inc"
464#include "spmd_c.inc"
465#include "scr17_c.inc"
466 COMMON /lagglob/n_mult
467C-----------------------------------------------
468C D u m m y A r g u m e n t s
469C-----------------------------------------------
470 INTEGER NBNCL, NBIKL, NBNODL, NBNODLR
471 INTEGER IPARI(NPARI,*),IXS(NIXS,*),IXS16(8,*),
472 . IXS10(6,*),IXS20(12,*),ITAB(*),
473 . LAGBUF(*),IBCSLAG(*),GJBUFI(LKJNI,*),
474 . IBMPC(*),NPBYL(NNPBY,*),LPBYL(*),IBFV(NIFV,*),NPF(*),
475 . NEWFRONT(*),ICONTACT(*),LPRW(*),NPRW(*),KINET(*),
476 . NODGLOB(*), WEIGHT(*), FR_LAGF(3,*), LLAGF(*),
477 . IAD_ELEM(2,*), FR_ELEM(*)
478C REAL
479 my_real
480 . x(3,*), d(3,*), dr(3,*), a(3,*), ar(3,*), v(3,*), vr(3,*),
481 . ms(*), in(*), lambda(*),fani(3,*),fsav(6,*),
482 . skew(lskew,*),wag(*),wat(*),gjbufr(lkjnr,*),rbmpc(*),
483 . vel(lfxvelr,*),tf(*),rwbuf(nrwlp,*),rbyl(nrby,*)
484
485 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
486 TYPE(H3D_DATABASE) :: H3D_DATA
487 TYPE(PYTHON_), INTENT(INOUT) :: PYTHON
488 TYPE(nodal_arrays_), intent(in) :: nodes
489C-----------------------------------------------
490C L o c a l V a r i a b l e s
491C-----------------------------------------------
492 INTEGER N,I,N_MULT,N_MUL_MX,NKMAX,LENH,NH,NTY,NCR,
493 . IP0,IP1,IP2,IP3,IP4,IP5,IP6,IP7,IP8,IP8A,IP8B,IP9,IP10,
494 . IP11,IP12,IP13,IP14,IP15,IP16,IP17,IP18,IP19,IP20,
495 . J1,J2,J3,J4,J5,K,N1,N2,N3,N4,N5,N6,LWAT,ISKIP,
496 . NCF_S,NCF_E,
497 . INUM,IDDL,ISKW,ITYP,NB_JLT,NB_JLT_NEW,NB_STOK_N,
498 . NUM_ISTOCK,KINDEX2,
499 . ILAGM,IK0,N_IK, NNODMAX, ISIZ, LRBUF, NLAGF,
500 . INDEXLAG(NUMNODG)
501 my_real
502 . lagcom(2*nbncl+4*nbikl),
503 . ag(3,nbnodl),vg(3,nbnodl),msg(nbnodl),
504 . arg(3,nbnodlr),vrg(3,nbnodlr),ing(nbnodlr) ! NBNODLR = NBNODL ou 0 suivant iroddl
505C======================================================================|
506C
507 nlagf = fr_lagf(3,ispmd+1)
508 ik0 = 2*nbncl + 1
509 n_mul_mx = lag_ncf + lag_ncl
510 nkmax = lag_nkf + lag_nkl
511 nhmax = lag_nhf + lag_nhl
512 n_mult = 0
513 n_ik = 0
514 num_istock = 4*numnodg
515 lwat = max(6*(numels16+numels20),nrwlag,2*numnodg+num_istock)
516C
517 IF(ispmd==0) THEN
518 ip0 = 1
519 ip1 = ip0 + n_mul_mx
520 ip2 = ip1 + n_mul_mx + 1
521 ip3 = ip2 + nkmax
522 ip4 = ip3 + nkmax
523 ip5 = ip4 + nkmax
524 ip6 = ip5 + nkmax
525 ip7 = ip6 + numnodg
526 ip8 = ip7 + lwat
527 ip8a= ip7 + numnodg
528 ip8b= ip8a+ numnodg
529 kindex2=ip8b
530 j1 = 1 ! IADHF
531 j2 = j1 + lag_ncf + 1 ! JCIHF
532 j3 = j2 + lag_nhf ! ICFTAG
533 j4 = j3 + lag_ncf ! JCFTAG
534 j5 = j4 + lag_ncf
535C---
536 DO n=0,lag_ncf-1
537 lagbuf(j3+n) = 0
538 lagbuf(j4+n) = 0
539 ENDDO
540 DO n=1,n_mul_mx
541 lambda(n) = zero
542 ENDDO
543 DO n=ip0,ip1-1
544 wag(n) = zero
545 ENDDO
546 CALL init_int(wag(ip1),1)
547 CALL init_intv(wag(ip4), nkmax)
548C----------------------------------------------------
549C Tag coupled nodes
550C----------------------------------------------------
551 CALL init_intv(wag(ip6), numnod)
552 ELSE
553 ip0 = 1
554 ip1 = ip0
555 ip2 = ip1
556 ip3 = ip2
557 ip4 = ip3
558 ip5 = ip4
559 ip6 = ip5
560 ip7 = ip6
561 ip8 = ip7
562 ip8a= ip7
563 ip8b= ip8a
564 kindex2=ip8b
565 j1 = 1
566 j2 = j1
567 j3 = j2
568 j4 = j3
569 j5 = j4
570 END IF
571C----------------------------------------------------
572C ---------------------
573C -------------------
574C -------------------
575C ---------------------
576C -------------------
577C -------------------
578C -------------------
579C -------------------
580C -------------------
581C -------------------
582C -------------------
583C----------------------------------------------------
584C Construct L matrix for interfaces and rigid walls
585C----------------------------------------------------
586C -------------------
587 DO n=1,ninter
588 nty = ipari(7,n)
589C---
590 IF(nty==7.OR.nty==22)THEN
591 nb_jlt = 0
592 nb_jlt_new= 0
593 nb_stok_n = 0
594 ilagm =ipari(33,n)
595 IF(ilagm /= 0) THEN
596 IF(ispmd==0)THEN
597 CALL ancmsg(msgid=113,anmode=aninfo,
598 . c1='INT 7')
599 CALL arret(2)
600 END IF
601 END IF
602C---
603 ELSEIF(nty==16)THEN
604 ilagm =ipari(33,n)
605 IF(ilagm /= 0) THEN
606 IF(ispmd==0)THEN
607 CALL ancmsg(msgid=113,anmode=aninfo,
608 . c1='INT 16')
609 CALL arret(2)
610 END IF
611 END IF
612C---
613 ELSEIF(nty==17)THEN
614 ilagm =ipari(33,n)
615 IF(ilagm /= 0) THEN
616 IF(ispmd==0)THEN
617 CALL ancmsg(msgid=113,anmode=aninfo,
618 . c1='INT 17')
619 CALL arret(2)
620 END IF
621 END IF
622C---
623 ENDIF
624 ENDDO
625C -------------------
626C -------------------
627 k=1
628 DO n=1,nrwall
629 n2=n +nrwall
630 n3=n2+nrwall
631 n4=n3+nrwall
632 n5=n4+nrwall
633 n6=n5+nrwall
634 IF(nprw(n6)==1)THEN
635 IF(ispmd==0)THEN
636 CALL ancmsg(msgid=113,anmode=aninfo,
637 . c1='RWALL')
638 CALL arret(2)
639 END IF
640 ENDIF
641 k=k+nprw(n)
642 ENDDO
643C----------------------------------------------------
644C Construct L matrix for remaining options
645C----------------------------------------------------
646 iskip = 0
647 ncf_s = n_mult
648 DO n=ip7,ip8-1
649 wag(n) = zero
650 ENDDO
651C -------------------
652C -------------------
653 IF(ispmd==0 .AND. nbcslag>0)THEN
654 CALL ancmsg(msgid=113,anmode=aninfo,
655 . c1='BCS')
656 CALL arret(2)
657 END IF
658C ---------------------
659C ---------------------
660 IF(ninter>0) CALL lag_i2main(
661 1 ipari ,intbuf_tab,wag(ip1) ,wag(ip2) ,wag(ip3) ,
662 2 wag(ip4) ,wag(ip5) ,wag(ip6) ,wag(ip7) ,lagbuf(j3),
663 3 lagbuf(j4),in ,ms ,x ,v ,
664 4 vr ,a ,ar ,iskip ,ncf_s ,
665 5 n_mult )
666C ---------------------
667C ---------------------
668 IF(ispmd==0 .AND. ngjoint>0)THEN
669 CALL ancmsg(msgid=113,anmode=aninfo,
670 . c1='JOINT')
671 CALL arret(2)
672 END IF
673C ---------------------
674C ---------------------
675 IF(ispmd==0 .AND. nummpc>0) THEN
676 inum = nummpc+1
677 iddl = inum +lmpc
678 iskw = iddl +lmpc
679 CALL lag_mpcp(
680 1 rbmpc ,ibmpc ,ibmpc(inum),ibmpc(iddl),ibmpc(iskw),
681 2 skew ,lagcom ,lagcom(ik0),n_mult ,n_ik )
682 ENDIF
683C ---------------------
684C ---------------------
685 IF(nfvlag>0) CALL lag_fxvp(
686 1 ibfv ,vel ,skew ,npf ,tf ,
687 2 lagcom ,lagcom(ik0),n_mult ,nodglob ,weight ,
688 3 n_ik ,python, nodes)
689C ---------------------
690 ncf_e = n_mult
691C ---------------------
692C--- Rigid bodies
693C -------------------
694C ---------------------
695 IF(ispmd==0 .AND. nrbylag>0)THEN
696 CALL ancmsg(msgid=113,anmode=aninfo,
697 . c1='RBODY')
698 CALL arret(2)
699 END IF
700 ncr = n_mult
701C -------------------
702C communication SPMD LAG MULT : Pi => P0
703C -------------------
704 CALL spmd_get_mult(
705 1 lagcom ,lagcom(ik0),n_mult ,wag(ip0),wag(ip1),
706 2 wag(ip2) ,wag(ip3) ,wag(ip4),wag(ip5),wag(ip6),
707 2 lagbuf(j3),lagbuf(j4) ,fr_lagf ,n_ik )
708C=======================================================================
709C GRADIENT CONJUGUE
710C=======================================================================
711C -------------------
712C -------------------
713 IF(ispmd==0) THEN
714 nh = nhmax + 3*(n_mul_mx - n_mult)
715C---
716 ip7 = ip6 + n_mult + 1
717 ip8 = ip7 + nh
718 ip9 = ip8 + nh
719 ip10 = ip9 + n_mult
720 ip11 = ip0
721 ip12 = ip10 + n_mult
722 ip13 = ip12 + n_mult
723 ip14 = ip13 + 6 * numnodg
724 ip15 = ip14 + nh
725 ip16 = ip15 + n_mult
726 ip17 = ip16 + n_mult
727 ip18 = ip17 + n_mult
728 ip19 = ip18 + n_mult
729 ip20 = ip19 + n_mult
730C---
731 DO n=ip13,ip14-1
732 wag(n) = zero
733 ENDDO
734 ELSE
735 ip7 = ip6
736 ip8 = ip7
737 ip9 = ip8
738 ip10 = ip9
739 ip11 = ip0
740 ip12 = ip10
741 ip13 = ip12
742 ip14 = ip13
743 ip15 = ip14
744 ip16 = ip15
745 ip17 = ip16
746 ip18 = ip17
747 ip19 = ip18
748 ip20 = ip19
749 END IF
750C -------------------------------------------------------------
751C
752C Communication Pi => P0 A, AR, V, VR, MS, IN
753C
754 IF(iroddl==0)THEN
755 isiz = 8
756 ELSE
757 isiz = 15
758 END IF
759 CALL spmd_gg_mult(
760 1 a ,ar ,v ,vr ,ms ,
761 2 in ,ag ,arg ,vg ,vrg ,
762 3 msg ,ing ,fr_lagf,isiz ,nbnodl,
763 4 indexlag,nodglob ,llagf ,nlagf )
764 IF(ispmd==0) THEN
765 !iterative solver
766 CALL lag_mult_solvp(
767 1 nh ,n_mult ,ncr ,ag ,vg ,
768 2 msg ,wag(ip1) ,wag(ip2) ,wag(ip3) ,wag(ip5) ,
769 3 wag(ip6) ,wag(ip7) ,wag(ip8) ,wag(ip9) ,wag(ip10) ,
770 4 wag(ip11) ,wag(ip12) ,wag(ip13) ,wag(ip14) ,wag(ip15) ,
771 5 wag(ip16) ,wag(ip17) ,wag(ip18) ,wag(ip19) ,lambda ,
772 6 rbyl ,npbyl ,arg ,vrg ,ing ,
773 7 lagbuf(j1),lagbuf(j2),lagbuf(j3),lagbuf(j4),ncf_s ,
774 8 ncf_e ,indexlag )
775 END IF
776C
777C Communication P0 => Pi A, AR, V, VR, MS, IN
778C
779 IF(iroddl==0)THEN
780 isiz = 3
781 ELSE
782 isiz = 6
783 END IF
784 CALL spmd_sg_mult(
785 1 a ,ar ,ag ,arg ,fr_lagf,
786 2 isiz ,nbnodl ,llagf ,nlagf )
787C
788C Echange aux noeuds frontieres Pi <=> Pj A, AR, V, VR, MS, IN
789C
790 IF(iroddl==0)THEN
791 isiz = 4
792 ELSE
793 isiz = 7
794 END IF
795 lrbuf = 2*isiz*(iad_elem(1,nspmd+1)-iad_elem(1,1))+2*nspmd
796 CALL spmd_exch_mult(
797 1 a ,ar ,llagf ,nlagf ,fr_lagf,
798 2 iad_elem,fr_elem,lrbuf ,isiz )
799C
800 CALL rby_decond(x ,v ,vr ,a ,ar ,
801 2 wag(ip1),wag(ip2),wag(ip3),wag(ip5),lambda ,
802 3 ms ,in ,rbyl ,npbyl ,lpbyl ,
803 4 n_mult ,ncr )
804C AG => FANIG
805 CALL lag_anithp(wag(ip1),wag(ip2),wag(ip3),wag(ip4),wag(ip5),
806 2 fani ,fsav ,n_mult ,indexlag,ag ,
807 3 fr_lagf ,nbnodl ,llagf ,nlagf ,h3d_data)
808C---
809 RETURN
lag_anithp
subroutine lag_anithp(iadll, lll, jll, sll, xll, fani, fsav, nc, indexlag, fanig, fr_lagf, nbnodl, llagf, nlagf, h3d_data)
Definition lag_anith.F:114
lag_fxvp
subroutine lag_fxvp(ibfv, vel, skew, npf, tf, lagcomc, lagcomk, nc, nodglob, weight, ik, python, nodes)
Definition lag_fxv.F:179
lag_mpcp
subroutine lag_mpcp(rbmpc, impcnc, impcnn, impcdl, impcsk, skew, lagcomc, lagcomk, nc, ik)
Definition lag_mpc.F:199
lag_mult_solvp
subroutine lag_mult_solvp(nh, nc, ncr, a, v, mas, iadll, lll, jll, xll, iadh, jcih, hh, z, p, r, q, ltsm, hl, diag_h, diag_l, work1, work2, work3, lambda, rbyl, npbyl, ar, vr, in, iadhf, jcihf, icftag, jcftag, ncf_s, ncf_e, indexlag)
Definition lag_mult_solv.F:421
message_mod
Definition message_mod.F:1249
spmd_gg_mult
subroutine spmd_gg_mult(a, ar, v, vr, ms, in, ag, arg, vg, vrg, msg, ing, fr_lagf, isiz, nbnodl, indexlag, nodglob, llagf, nlagf_l)
Definition spmd_lag.F:774
spmd_get_mult
subroutine spmd_get_mult(lagcomc, lagcomk, n_mult, bll, iadll, lll, jll, sll, xll, comntag, icftag, jcftag, fr_lagf, n_ik)
Definition spmd_lag.F:725
spmd_sg_mult
subroutine spmd_sg_mult(a, ar, ag, arg, fr_lagf, isiz, nbnodl, llagf, nlagf_l)
Definition spmd_lag.F:842
spmd_exch_mult
subroutine spmd_exch_mult(a, ar, llagf, nlagf_l, fr_lagf, iad_elem, fr_elem, lrbuf, isiz)
Definition spmd_lag.F:895
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
arret
subroutine arret(nn)
Definition arret.F:87