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 (output, 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 (output, 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 ( type(output_), intent(inout) output,
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 61 of file lag_mult.F.

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

◆ lag_multp()

subroutine lag_multp ( type(output_), intent(inout) output,
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 441 of file lag_mult.F.

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