OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
lag_mpc.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!|| lag_mpc ../engine/source/tools/lagmul/lag_mpc.F
25!||--- called by ------------------------------------------------------
26!|| lag_mult ../engine/source/tools/lagmul/lag_mult.F
27!||====================================================================
28 SUBROUTINE lag_mpc(
29 1 RBMPC ,IMPCNC ,IMPCNN ,IMPCDL ,IMPCSK ,
30 2 SKEW ,IADLL ,LLL ,JLL ,SLL ,
31 3 XLL ,COMNTAG ,ICFTAG ,JCFTAG ,MS ,
32 4 IN ,V ,VR ,A ,AR ,
33 5 ISKIP ,NCF_S ,NC )
34C-----------------------------------------------
35C I m p l i c i t T y p e s
36C-----------------------------------------------
37#include "implicit_f.inc"
38C-----------------------------------------------
39C C o m m o n B l o c k s
40C-----------------------------------------------
41#include "com08_c.inc"
42#include "param_c.inc"
43C-----------------------------------------------
44C D u m m y A r g u m e n t s
45C-----------------------------------------------
46 INTEGER NC, ISKIP, NCF_S,
47 . IMPCNC(*),IMPCNN(*),IMPCDL(*),IMPCSK(*),LLL(*),JLL(*),
48 . SLL(*),IADLL(*),COMNTAG(*),ICFTAG(*),JCFTAG(*)
49C REAL
50 my_real
51 . xll(*),skew(lskew,*),rbmpc(*),ms(*),in(*),v(3,*),vr(3,*),
52 . a(3,*),ar(3,*)
53C-----------------------------------------------
54C L o c a l V a r i a b l e s
55C-----------------------------------------------
56 INTEGER I, J, JJ, LL, IK, NK, KF, ISK, NN, NDL, IDL, NUMC, IC
57 my_real COEF,HH,R,S1,S2,S3
58C-----------------------------------------------
59C NC : nombre de condition cinematique
60C IC : numero de la condition cinematique (1,NC)
61C IK :
62C I : numero global du noeud (1,NUMNOD)
63C J : direction 1,2,3,4,5,6
64C------
65C IADLL(NC) : IAD = IADLL(IC)
66C IK = IAD,IAD+1,IAD+2,...
67C LLL(LAG_NKF) : I = LLL(IK)
68C JLL(LAG_NKF) : J = JLL(IK)
69C======================================================================|
70 s1 = 0
71 s2 = 0
72 kf = 0
73 nn = 0
74 s3 = -huge(s3)
75 DO i=1,nummpc
76 hh = zero
77 r = zero
78 nc = nc + 1
79 ik = iadll(nc)-1
80 numc = impcnc(i)
81 nk = 0
82 DO j=1,numc
83 kf = kf+1
84 nn = impcnn(kf)
85 ndl = impcdl(kf)
86 isk = impcsk(kf)
87 coef= rbmpc(kf)
88C---
89 IF(isk==1)THEN
90 nk = nk + 1
91 ik = ik + 1
92 lll(ik) = nn
93 jll(ik) = ndl
94 sll(ik) = 0
95 xll(ik) = coef
96 IF (ndl>3) THEN
97 ndl = ndl - 3
98 hh = hh + coef*coef / in(nn)
99 r = r + coef*(vr(ndl,nn) / dt12 + ar(ndl,nn))
100 ELSE
101 hh = hh + coef*coef / ms(nn)
102 r = r + coef*(v(ndl,nn) / dt12 + a(ndl,nn))
103 ENDIF
104 ELSE
105 idl = ndl
106 IF (ndl>3) idl = ndl - 3
107 IF (idl==1) THEN
108 s1 = coef*skew(1,isk)
109 s2 = coef*skew(2,isk)
110 s3 = coef*skew(3,isk)
111 ELSEIF (idl==2) THEN
112 s1 = coef*skew(4,isk)
113 s2 = coef*skew(5,isk)
114 s3 = coef*skew(6,isk)
115 ELSEIF (idl==3) THEN
116 s1 = coef*skew(7,isk)
117 s2 = coef*skew(8,isk)
118 s3 = coef*skew(9,isk)
119 ENDIF
120 nk = nk + 3
121 IF (ndl>3) THEN
122 ik = ik + 1
123 lll(ik) = nn
124 jll(ik) = 4
125 sll(ik) = 0
126 xll(ik) = s1
127 ik = ik + 1
128 lll(ik) = nn
129 jll(ik) = 5
130 sll(ik) = 0
131 xll(ik) = s2
132 ik = ik + 1
133 lll(ik) = nn
134 jll(ik) = 6
135 sll(ik) = 0
136 xll(ik) = s3
137 hh = hh + (s1*s1 + s2*s2 + s3*s3) / in(nn)
138 r = r + s1*(vr(1,nn) / dt12 + ar(1,nn))
139 . + s2*(vr(2,nn) / dt12 + ar(2,nn))
140 . + s3*(vr(3,nn) / dt12 + ar(3,nn))
141 ELSE
142 ik = ik + 1
143 lll(ik) = nn
144 jll(ik) = 1
145 sll(ik) = 0
146 xll(ik) = s1
147 ik = ik + 1
148 lll(ik) = nn
149 jll(ik) = 2
150 sll(ik) = 0
151 xll(ik) = s2
152 ik = ik + 1
153 lll(ik) = nn
154 jll(ik) = 3
155 sll(ik) = 0
156 xll(ik) = s3
157 hh = hh + (s1*s1 + s2*s2 + s3*s3) / ms(nn)
158 r = r + s1*(v(1,nn) / dt12 + a(1,nn))
159 . + s2*(v(2,nn) / dt12 + a(2,nn))
160 . + s3*(v(3,nn) / dt12 + a(3,nn))
161 ENDIF
162 ENDIF
163 ENDDO
164 iadll(nc+1) = iadll(nc) + nk
165C
166C--- Solving local Lagrange multipliers
167 IF (hh/=zero) r = r / hh
168 DO ik=iadll(nc),iadll(nc+1)-1
169 jj = jll(ik)
170 ll = lll(ik)
171 IF (jj>3) THEN
172 jj = jj - 3
173 ar(jj,ll) = ar(jj,ll) - xll(ik)*r / in(ll)
174 ELSE
175 a(jj,ll) = a(jj,ll) - xll(ik)*r / ms(ll)
176 ENDIF
177 ENDDO
178 IF (comntag(nn)==1) THEN
179 iskip = iskip + 1
180 nc = nc - 1
181 ELSE
182 ic = nc - ncf_s
183 icftag(ic) = ic + iskip
184 jcftag(ic+iskip) = nc
185 ENDIF
186 ENDDO
187C---
188 RETURN
189 END
190C
191!||====================================================================
192!|| lag_mpcp ../engine/source/tools/lagmul/lag_mpc.F
193!||--- called by ------------------------------------------------------
194!|| lag_multp ../engine/source/tools/lagmul/lag_mult.F
195!||====================================================================
196 SUBROUTINE lag_mpcp(
197 1 RBMPC ,IMPCNC ,IMPCNN ,IMPCDL ,IMPCSK ,
198 2 SKEW ,LAGCOMC ,LAGCOMK ,NC ,IK )
199C-----------------------------------------------
200C I m p l i c i t T y p e s
201C-----------------------------------------------
202#include "implicit_f.inc"
203C-----------------------------------------------
204C C o m m o n B l o c k s
205C-----------------------------------------------
206#include "param_c.inc"
207C-----------------------------------------------
208C D u m m y A r g u m e n t s
209C-----------------------------------------------
210 INTEGER NC, IK,
211 . IMPCNC(*),IMPCNN(*),IMPCDL(*),IMPCSK(*)
212C REAL
213 my_real
214 . LAGCOMK(4,*),LAGCOMC(2,*),
215 . SKEW(LSKEW,*),RBMPC(*)
216C-----------------------------------------------
217C L o c a l V a r i a b l e s
218C-----------------------------------------------
219 INTEGER I, J, JJ, LL, NK, KF, ISK, NN, NDL, IDL, NUMC, IC
220 my_real coef,hh,r,s1,s2,s3
221C-----------------------------------------------
222C NC : nombre de condition cinematique
223C IC : numero de la condition cinematique (1,NC)
224C IK :
225C I : numero global du noeud (1,NUMNOD)
226C J : direction 1,2,3,4,5,6
227C------
228C BLL => LAGCOMC(2)
229C IADLL => LAGCOMC(1)
230C LLL => LAGCOMK(1)
231C JLL => LAGCOMK(2)
232C SLL => LAGCOMK(3)
233C XLL => LAGCOMK(4)
234C======================================================================|
235 kf = 0
236 DO i=1,nummpc
237 nc = nc + 1
238 numc = impcnc(i)
239 nk = 0
240 DO j=1,numc
241 kf = kf+1
242 nn = impcnn(kf)
243 ndl = impcdl(kf)
244 isk = impcsk(kf)
245 coef= rbmpc(kf)
246C---
247 IF(isk==1)THEN
248 nk = nk + 1
249 ik = ik + 1
250 lagcomk(1,ik) = nn
251 lagcomk(2,ik) = ndl
252 lagcomk(3,ik) = 0
253 lagcomk(4,ik) = coef
254 ELSE
255 nk = nk + 3
256 IF (ndl==1) THEN
257 ik = ik + 1
258 lagcomk(1,ik) = nn
259 lagcomk(2,ik) = 1
260 lagcomk(3,ik) = 0
261 lagcomk(4,ik) = coef*skew(1,isk)
262 ik = ik + 1
263 lagcomk(1,ik) = nn
264 lagcomk(2,ik) = 2
265 lagcomk(3,ik) = 0
266 lagcomk(4,ik) = coef*skew(2,isk)
267 ik = ik + 1
268 lagcomk(1,ik) = nn
269 lagcomk(2,ik) = 3
270 lagcomk(3,ik) = 0
271 lagcomk(4,ik) = coef*skew(3,isk)
272 ELSEIF (ndl==2) THEN
273 ik = ik + 1
274 lagcomk(1,ik) = nn
275 lagcomk(2,ik) = 1
276 lagcomk(3,ik) = 0
277 lagcomk(4,ik) = coef*skew(4,isk)
278 ik = ik + 1
279 lagcomk(1,ik) = nn
280 lagcomk(2,ik) = 2
281 lagcomk(3,ik) = 0
282 lagcomk(4,ik) = coef*skew(5,isk)
283 ik = ik + 1
284 lagcomk(1,ik) = nn
285 lagcomk(2,ik) = 3
286 lagcomk(3,ik) = 0
287 lagcomk(4,ik) = coef*skew(6,isk)
288 ELSEIF (ndl==3) THEN
289 ik = ik + 1
290 lagcomk(1,ik) = nn
291 lagcomk(2,ik) = 1
292 lagcomk(3,ik) = 0
293 lagcomk(4,ik) = coef*skew(7,isk)
294 ik = ik + 1
295 lagcomk(1,ik) = nn
296 lagcomk(2,ik) = 2
297 lagcomk(3,ik) = 0
298 lagcomk(4,ik) = coef*skew(8,isk)
299 ik = ik + 1
300 lagcomk(1,ik) = nn
301 lagcomk(2,ik) = 3
302 lagcomk(3,ik) = 0
303 lagcomk(4,ik) = coef*skew(9,isk)
304 ELSEIF (ndl==4) THEN
305 ik = ik + 1
306 lagcomk(1,ik) = nn
307 lagcomk(2,ik) = 4
308 lagcomk(3,ik) = 0
309 lagcomk(4,ik) = coef*skew(1,isk)
310 ik = ik + 1
311 lagcomk(1,ik) = nn
312 lagcomk(2,ik) = 5
313 lagcomk(3,ik) = 0
314 lagcomk(4,ik) = coef*skew(2,isk)
315 ik = ik + 1
316 lagcomk(1,ik) = nn
317 lagcomk(2,ik) = 6
318 lagcomk(3,ik) = 0
319 lagcomk(4,ik) = coef*skew(3,isk)
320 ELSEIF (ndl==5) THEN
321 ik = ik + 1
322 lagcomk(1,ik) = nn
323 lagcomk(2,ik) = 4
324 lagcomk(3,ik) = 0
325 lagcomk(4,ik) = coef*skew(4,isk)
326 ik = ik + 1
327 lagcomk(1,ik) = nn
328 lagcomk(2,ik) = 5
329 lagcomk(3,ik) = 0
330 lagcomk(4,ik) = coef*skew(5,isk)
331 ik = ik + 1
332 lagcomk(1,ik) = nn
333 lagcomk(2,ik) = 6
334 lagcomk(3,ik) = 0
335 lagcomk(4,ik) = coef*skew(6,isk)
336 ELSEIF (ndl==6) THEN
337 ik = ik + 1
338 lagcomk(1,ik) = nn
339 lagcomk(2,ik) = 4
340 lagcomk(3,ik) = 0
341 lagcomk(4,ik) = coef*skew(7,isk)
342 ik = ik + 1
343 lagcomk(1,ik) = nn
344 lagcomk(2,ik) = 5
345 lagcomk(3,ik) = 0
346 lagcomk(4,ik) = coef*skew(8,isk)
347 ik = ik + 1
348 lagcomk(1,ik) = nn
349 lagcomk(2,ik) = 6
350 lagcomk(3,ik) = 0
351 lagcomk(4,ik) = coef*skew(9,isk)
352 ENDIF
353 ENDIF
354 ENDDO
355 lagcomc(1,nc)=nk
356 lagcomc(2,nc)=zero ! a verifier
357C voir si utile
358c IF (COMNTAG(NN)==1) THEN
359c ISKIP = ISKIP + 1
360c NC = NC - 1
361c ELSE
362c IC = NC - NCF_S
363c ICFTAG(IC) = IC + ISKIP
364c JCFTAG(IC+ISKIP) = NC
365c ENDIF
366 ENDDO
367C---
368 RETURN
369 END
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_mpcp
subroutine lag_mpcp(rbmpc, impcnc, impcnn, impcdl, impcsk, skew, lagcomc, lagcomk, nc, ik)
Definition lag_mpc.F:199