OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
rbe2_imp0.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!|| rbe2_imp0 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
25!||--- called by ------------------------------------------------------
26!|| upd_glob_k ../engine/source/implicit/upd_glob_k.F
27!||--- calls -----------------------------------------------------
28!|| prerbe2 ../engine/source/constraints/general/rbe2/rbe2f.F
29!|| rbe2_imp1 ../engine/source/constraints/general/rbe2/rbe2_imp0.f
30!|| rbe2_impl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
31!||====================================================================
32 SUBROUTINE rbe2_imp0(
33 1 IRBE2 ,LRBE2 ,X ,NSRB2 ,ISB2 ,
34 2 IKC ,NDOF ,IDDL ,IADK ,JDIK ,
35 3 DIAG_K ,LT_K ,B ,WEIGHT ,ITAB ,
36 4 SKEW )
37C-----------------------------------------------
38C I m p l i c i t T y p e s
39C-----------------------------------------------
40#include "implicit_f.inc"
41C-----------------------------------------------
42C C o m m o n B l o c k s
43C-----------------------------------------------
44#include "com04_c.inc"
45#include "param_c.inc"
46C-----------------------------------------------
47C D u m m y A r g u m e n t s
48C-----------------------------------------------
49 INTEGER WEIGHT(*),IRBE2(NRBE2L,*),LRBE2(*),
50 . IADK(*),JDIK(*),NDOF(*),ITAB(*),
51 . IDDL(*),IKC(*),ISB2(*),NSRB2(*)
52C REAL
53 my_real
54 . x(3,*), skew(lskew,*),diag_k(*),lt_k(*),b(*)
55C-----------------------------------------------
56C L o c a l V a r i a b l e s
57C-----------------------------------------------
58 INTEGER I, J, N, M, NS ,NML, IAD,JJ,IROT,IADS,MAX_M,
59 . JT(3,NRBE2),JR(3,NRBE2),NM,NN,NSJ,IADJ,NSN,ISK,IC,IRAD
60C REAL
61C-----------------------------------------------
62 CALL prerbe2(irbe2 ,jt ,jr )
63 iadj=1
64 DO n=1,nrbe2
65 iad = irbe2(1,n)
66 m = irbe2(3,n)
67 nsn = irbe2(5,n)
68 isk =irbe2(7,n)
69 nsj =irbe2(8,n)
70 irad =irbe2(11,n)
71 ic =jt(1,n)+jt(2,n)+jt(3,n)+jr(1,n)+jr(2,n)+jr(3,n)
72 IF (isk>1.AND.ic<6) THEN
73 CALL rbe2_impl(m ,nsn ,lrbe2(iad+1) ,x ,nsrb2(iad+1),
74 2 isb2(iadj),jt(1,n) ,jr(1,n),ikc ,ndof ,
75 3 iddl ,iadk ,jdik ,diag_k,lt_k ,b ,
76 4 skew(1,isk),itab ,irad )
77 ELSE
78 CALL rbe2_imp1(m ,nsn ,lrbe2(iad+1) ,x ,nsrb2(iad+1),
79 2 isb2(iadj),jt(1,n) ,jr(1,n),ikc ,ndof ,
80 3 iddl ,iadk ,jdik ,diag_k,lt_k ,b ,
81 4 itab ,irad )
82 END IF
83 iadj=iadj+nsj
84 ENDDO
85C
86 RETURN
87 END
88!||====================================================================
89!|| rbe2_impi ../engine/source/constraints/general/rbe2/rbe2_imp0.F
90!||--- called by ------------------------------------------------------
91!|| upd_int_k ../engine/source/implicit/upd_glob_k.F
92!||--- calls -----------------------------------------------------
93!|| prerbe2 ../engine/source/constraints/general/rbe2/rbe2f.F
94!|| rbe2_imp1 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
95!|| rbe2_impl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
96!||====================================================================
97 SUBROUTINE rbe2_impi(
98 1 IRBE2 ,LRBE2 ,X ,SKEW ,
99 2 NSB2 ,ISB2 ,IKC ,NDOF ,IDDL ,
100 3 IADK ,JDIK ,DIAG_K ,LT_K ,B ,
101 4 WEIGHT ,ITAB )
102C-----------------------------------------------
103C I m p l i c i t T y p e s
104C-----------------------------------------------
105#include "implicit_f.inc"
106C-----------------------------------------------
107C C o m m o n B l o c k s
108C-----------------------------------------------
109#include "com04_c.inc"
110#include "param_c.inc"
111C-----------------------------------------------
112C D u m m y A r g u m e n t s
113C-----------------------------------------------
114 INTEGER WEIGHT(*),IRBE2(NRBE2L,*),LRBE2(*),
115 . IADK(*),JDIK(*),NDOF(*),ITAB(*),
116 . IDDL(*),IKC(*),NSB2(*),ISB2(*)
117C REAL
118 my_real
119 . X(3,*), SKEW(LSKEW,*), DIAG_K(*),LT_K(*),B(*)
120C-----------------------------------------------
121C L o c a l V a r i a b l e s
122C-----------------------------------------------
123 INTEGER I, J, N, M, NS ,NML, IAD,JJ,IROT,IADS,IC,
124 . JT(3,NRBE2),JR(3,NRBE2),NM,NN,NSN,IADJ,ISK,IRAD
125C REAL
126C-----------------------------------------------
127 CALL prerbe2(irbe2 ,jt ,jr )
128 iadj=1
129 DO n=1,nrbe2
130 iad = irbe2(1,n)
131 m = irbe2(3,n)
132 nsn = irbe2(5,n)
133 isk = irbe2(7,n)
134 irad =irbe2(11,n)
135C----------debug: only for the lowest hierarchy
136 IF (irbe2(9,n)==0) THEN
137 DO j=1,3
138 jr(j,n)=0
139 ENDDO
140 END IF
141 ic =jt(1,n)+jt(2,n)+jt(3,n)
142 IF (ndof(m)>0) THEN
143 IF (isk>1.AND.ic/=3) THEN
144 CALL rbe2_impl(m ,nsn ,lrbe2(iad+1) ,x ,nsb2(iad+1),
145 2 isb2(iadj),jt(1,n) ,jr(1,n),ikc ,ndof ,
146 3 iddl ,iadk ,jdik ,diag_k,lt_k ,b ,
147 4 skew(1,isk),itab ,irad )
148 ELSE
149 IF (irbe2(9,n)==0) jr(1,n)=-1
150 CALL rbe2_imp1(m ,nsn ,lrbe2(iad+1) ,x ,nsb2(iad+1),
151 2 isb2(iadj),jt(1,n) ,jr(1,n),ikc ,ndof ,
152 3 iddl ,iadk ,jdik ,diag_k,lt_k ,b ,
153 4 itab ,irad )
154 ENDIF
155 END IF
156 DO j =1,nsn
157 iadj=iadj+nsb2(iad+j)
158 ENDDO
159 ENDDO
160C
161 RETURN
162 END
163!||====================================================================
164!|| rbe2_imp1 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
165!||--- called by ------------------------------------------------------
166!|| rbe2_imp0 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
167!|| rbe2_impi ../engine/source/constraints/general/rbe2/rbe2_imp0.F
168!||--- calls -----------------------------------------------------
169!|| get_kii ../engine/source/implicit/imp_glob_k.F
170!|| get_kij ../engine/source/implicit/imp_glob_k.F
171!|| print_wkij ../engine/source/implicit/imp_glob_k.F
172!|| put_kii ../engine/source/implicit/imp_glob_k.F
173!|| put_kij ../engine/source/implicit/imp_glob_k.F
174!|| sym_kdd ../engine/source/constraints/general/rbe2/rbe2_imp0.F
175!|| updk_bc ../engine/source/constraints/general/rbe3/rbe3_imp0.F
176!|| updk_bc2 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
177!|| updkb_rb ../engine/source/constraints/general/rbody/rby_imp0.F
178!|| updkb_rb1 ../engine/source/constraints/general/rbody/rby_imp0.F
179!||====================================================================
180 SUBROUTINE rbe2_imp1(M ,NSN ,ISL ,X ,NSJ ,
181 2 ISJ ,JT ,JR ,IKC ,NDOF ,
182 3 IDDL ,IADK ,JDIK ,DIAG_K,LT_K ,
183 4 B ,ITAB ,IRAD )
184C-----------------------------------------------
185C I m p l i c i t T y p e s
186C-----------------------------------------------
187#include "implicit_f.inc"
188C-----------------------------------------------
189C D u m m y A r g u m e n t s
190C-----------------------------------------------
191 INTEGER M, NSN,ISL(*),NSJ(*),ISJ(*) ,JT(3),JR(3),IRAD
192 INTEGER IADK(*),JDIK(*),NDOF(*),IDDL(*),IKC(*),ITAB(*)
193C REAL
194 my_real
195 . X(3,*),DIAG_K(*),LT_K(*),B(*)
196C-----------------------------------------------
197C L o c a l V a r i a b l e s
198C-----------------------------------------------
199 INTEGER NIR, I, J, J1, J2, J3, J4, K, JD, II, L, JJ,
200 . I1,ID,NL,NI,NJ,NIDOF,ND,NDI,NDJ,NDM,NM,L1,NM1,
201 . NIR1,IR,IP,ISTIF,IMD,N,NTDOF
202C REAL
203 my_real
204 . kdd(6,6),bd(6),xs,ys,zs,tmp
205C------------------------------------
206C VITESSES DES NOEUDS SECONDS
207C------------------------------------
208 ip =5
209 imd = iddl(m)+1
210 nd = ndof(m)
211C--------boucle secnd nodes--
212 ntdof=jt(1)+jt(2)+jt(3)+jr(1)+jr(2)+jr(3)
213C-----cas exception: e.g.:contact-----
214 IF ((jt(1)+jt(2)+jt(3))==3.AND.jr(1)<0) THEN
215 ntdof=6
216 jr(1)=0
217 ENDIF
218 j1=0
219 DO i=1,nsn
220C--------block diagonal Kmm--
221 n = isl(i)
222 IF (ndof(n)>0) THEN
223 xs=x(1,n)-x(1,m)
224 ys=x(2,n)-x(2,m)
225 zs=x(3,n)-x(3,m)
226 DO k=1,6
227 bd(k)=zero
228 DO j=1,6
229 kdd(k,j)=zero
230 ENDDO
231 ENDDO
232 DO k=1,min(3,ndof(n))
233 id = iddl(n)+k
234 ikc(id)=16*jt(k)
235 bd(k)=b(id)*jt(k)
236 ENDDO
237 DO k=min(3,ndof(n))+1,ndof(n)
238 id = iddl(n)+k
239 ikc(id)=16*jr(k-3)
240 bd(k)=b(id)*jr(k-3)
241 ENDDO
242 CALL get_kii(n ,iddl ,iadk,diag_k,lt_k ,kdd,ndof(n))
243 IF (irad==0) CALL updk_bc(jt,jr,kdd ,istif)
244 CALL updkb_rb(ndof(n),xs,ys,zs,kdd,bd)
245 IF (irad>0)CALL updk_bc(jt,jr,kdd ,istif)
246C-------Update K,B---
247 CALL put_kii(m ,iddl ,iadk,diag_k,lt_k ,kdd,nd)
248 DO k=1,nd
249 id = imd+k-1
250 b(id) = b(id) + bd(k)
251 ENDDO
252C--------no diag--Kjm=sum(KjsCsm)--
253 ndm=0
254 DO i1 = 1,nsj(i)
255 ni=isj(i1+j1)
256 nidof=ndof(ni)
257C NDM = MAX(NDM,NIDOF)
258 DO k=1,6
259 DO j=1,6
260 kdd(k,j)=zero
261 ENDDO
262 ENDDO
263 CALL get_kij(ni,n,iddl,iadk,jdik,lt_k,kdd,nidof,ndof(n),ir)
264 IF (ir==1) CALL print_wkij(itab(ni) ,itab(n) ,ip )
265 IF (irad==0) CALL updk_bc2(jt,jr,kdd,istif)
266C------- Update ---
267 CALL updkb_rb1(nidof,ndof(n),xs,ys,zs,kdd)
268 IF (irad>0) CALL updk_bc2(jt,jr,kdd ,istif)
269 IF (ni==m) THEN
270 CALL sym_kdd(6,kdd)
271 CALL put_kii(m ,iddl ,iadk,diag_k,lt_k ,kdd,nd)
272 ELSE
273 CALL put_kij(ni,m,iddl,iadk,jdik,lt_k,kdd,nidof,nd,ir)
274 IF (ir==1) CALL print_wkij(itab(ni) ,itab(m) ,ip )
275 ENDIF
276 ENDDO
277 j1=j1+nsj(i)
278 IF (ntdof<6) THEN
279 DO k=1,6
280 DO j=k,6
281 kdd(k,j)=zero
282 ENDDO
283 ENDDO
284 CALL get_kii(n ,iddl ,iadk,diag_k,lt_k ,kdd,ndof(n))
285 DO k=1,6
286 DO j=k+1,6
287 kdd(j,k)=kdd(k,j)
288 ENDDO
289 ENDDO
290 IF (irad==0) CALL updk_bc2(jt,jr,kdd ,istif)
291 CALL updkb_rb1(ndof(n),ndof(n),xs,ys,zs,kdd)
292 IF (irad>0) CALL updk_bc2(jt,jr,kdd ,istif)
293 CALL put_kij(n,m,iddl,iadk,jdik,lt_k,kdd,ndof(n),nd,ir)
294 IF (ir==1) CALL print_wkij(itab(n) ,itab(m) ,ip )
295 ENDIF
296 ENDIF
297C-------fin -boucle secnd nodes--
298 ENDDO
299C
300 RETURN
301 END
302!||====================================================================
303!|| rbe2_impl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
304!||--- called by ------------------------------------------------------
305!|| rbe2_imp0 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
306!|| rbe2_impi ../engine/source/constraints/general/rbe2/rbe2_imp0.F
307!||--- calls -----------------------------------------------------
308!|| cdi_skew ../engine/source/constraints/general/rbe2/rbe2_imp0.F
309!|| get_kii ../engine/source/implicit/imp_glob_k.F
310!|| get_kij ../engine/source/implicit/imp_glob_k.F
311!|| print_wkij ../engine/source/implicit/imp_glob_k.F
312!|| put_kii ../engine/source/implicit/imp_glob_k.F
313!|| put_kij ../engine/source/implicit/imp_glob_k.F
314!|| rbe2_bcl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
315!|| rbe2_impbl ../engine/source/constraints/general/rbe2/rbe2_imp0.f
316!|| sym_kdd ../engine/source/constraints/general/rbe2/rbe2_imp0.F
317!|| updcdik2_cdi ../engine/source/constraints/general/rbe2/rbe2_imp0.F
318!|| updk2_cdi ../engine/source/constraints/general/rbe2/rbe2_imp0.F
319!||====================================================================
320 SUBROUTINE rbe2_impl(M ,NSN ,ISL ,X ,NSJ ,
321 2 ISJ ,JT ,JR ,IKC ,NDOF ,
322 3 IDDL ,IADK ,JDIK ,DIAG_K,LT_K ,
323 4 B ,SKEW ,ITAB ,IRAD )
324C-----------------------------------------------
325C I m p l i c i t T y p e s
326C-----------------------------------------------
327#include "implicit_f.inc"
328C-----------------------------------------------
329C D u m m y A r g u m e n t s
330C-----------------------------------------------
331 INTEGER M, NSN,ISL(*),NSJ(*),ISJ(*) ,JT(3),JR(3),IRAD
332 INTEGER IADK(*),JDIK(*),NDOF(*),IDDL(*),IKC(*),ITAB(*)
333C REAL
334 my_real
335 . x(3,*),diag_k(*),lt_k(*),b(*),skew(*)
336C-----------------------------------------------
337C L o c a l V a r i a b l e s
338C-----------------------------------------------
339 INTEGER NIR, I, J, J1, J2, J3, J4, K, JD, II, L, JJ,
340 . I1,ID,NL,NI,NJ,NIDOF,ND,NDI,NDJ,NDM,NM,L1,NM1,
341 . NIR1,IR,IP,ISTIF,IMD,N,NT,NR,IC,JT1(3),JR1(3)
342C REAL
343 my_real
344 . KDD(6,6),BD(6),XS,YS,ZS,TMP,CDT(3,3),CDTR(3,3),CDR(3,3)
345C------------------------------------
346C VITESSES DES NOEUDS SECONDS
347C------------------------------------
348 ip =5
349 imd = iddl(m)+1
350 nd = ndof(m)
351 nt=jt(1)+jt(2)+jt(3)
352 nr=jr(1)+jr(2)+jr(3)
353C--------upd B--
354 CALL rbe2_impbl(m ,nsn ,isl ,x ,jt ,
355 1 jr ,ndof ,iddl ,b ,skew ,
356 2 irad )
357C--------boucle secnd nodes--
358 j1=0
359 DO i=1,nsn
360C--------block diagonal Kmm--
361 n = isl(i)
362 IF (ndof(n)>0) THEN
363 xs=x(1,n)-x(1,m)
364 ys=x(2,n)-x(2,m)
365 zs=x(3,n)-x(3,m)
366 DO k=1,6
367 DO j=1,6
368 kdd(k,j)=zero
369 ENDDO
370 ENDDO
371 DO k=1,min(3,ndof(n))
372 id = iddl(n)+k
373 IF (nt==3)ikc(id)=16*jt(k)
374 ENDDO
375 DO k=min(3,ndof(n))+1,ndof(n)
376 id = iddl(n)+k
377c IKC(ID)=16*JR(K-3)
378 IF (nr==3) ikc(id)=16*jr(k-3)
379 ENDDO
380 CALL cdi_skew(xs,ys,zs,jt,jr,skew,cdt,cdr,cdtr,jt1,jr1,irad)
381 CALL get_kii(n ,iddl ,iadk,diag_k,lt_k ,kdd,ndof(n))
382c CALL UPDK_BC(JT1,JR1,KDD ,ISTIF)
383C-------Update K,B---
384 DO k=1,6
385 DO j=k+1,6
386 kdd(j,k)=kdd(k,j)
387 ENDDO
388 ENDDO
389 CALL updcdik2_cdi(nd,cdt,cdr,cdtr,kdd)
390 CALL put_kii(m ,iddl ,iadk,diag_k,lt_k ,kdd,nd)
391C--------no diag--Kjm=sum(KjsCsm)--
392 DO i1 = 1,nsj(i)
393 ni=isj(i1+j1)
394 nidof=ndof(ni)
395C NDM = MAX(NDM,NIDOF)
396 DO k=1,6
397 DO j=1,6
398 kdd(k,j)=zero
399 ENDDO
400 ENDDO
401 CALL get_kij(ni,n,iddl,iadk,jdik,lt_k,kdd,nidof,ndof(n),ir)
402 IF (ir==1) CALL print_wkij(itab(ni) ,itab(n) ,ip )
403c CALL UPDK_BC2(JT1,JR1,KDD ,ISTIF)
404C------- Update ---
405 CALL updk2_cdi(nidof,ndof(n),cdt,cdr,cdtr,kdd)
406 IF (ni==m) THEN
407 CALL sym_kdd(6,kdd)
408 CALL put_kii(m ,iddl ,iadk,diag_k,lt_k ,kdd,nd)
409 ELSE
410 CALL put_kij(ni,m,iddl,iadk,jdik,lt_k,kdd,nidof,nd,ir)
411 IF (ir==1) CALL print_wkij(itab(ni) ,itab(m) ,ip )
412 ENDIF
413 ENDDO
414 j1=j1+nsj(i)
415C IF ((NT+NR)<6) THEN
416 DO k=1,6
417 DO j=k,6
418 kdd(k,j)=zero
419 ENDDO
420 ENDDO
421 CALL get_kii(n ,iddl ,iadk,diag_k,lt_k ,kdd,ndof(n))
422 DO k=1,6
423 DO j=k+1,6
424 kdd(j,k)=kdd(k,j)
425 ENDDO
426 ENDDO
427 CALL updk2_cdi(ndof(n),ndof(n),cdt,cdr,cdtr,kdd)
428 CALL put_kij(n,m,iddl,iadk,jdik,lt_k,kdd,ndof(n),nd,ir)
429 IF (ir==1) CALL print_wkij(itab(n) ,itab(m) ,ip )
430C ENDIF
431 IF (nt>0.AND.nt<3) THEN
432 ic = jt(1)*100+jt(2)*10+jt(3)
433 ir =0
434 CALL rbe2_bcl(ic ,skew ,iddl ,ikc ,iadk ,
435 1 jdik ,diag_k,lt_k ,n ,ir )
436 ENDIF
437 IF (nr>0.AND.nr<3) THEN
438 ic = jr(1)*100+jr(2)*10+jr(3)
439 ir =1
440 CALL rbe2_bcl(ic ,skew ,iddl ,ikc ,iadk ,
441 1 jdik ,diag_k,lt_k ,n ,ir )
442 ENDIF
443 ENDIF
444C-------fin -boucle secnd nodes--
445 ENDDO
446C
447 RETURN
448 END
449!||====================================================================
450!|| rbe2_impr1 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
451!||--- called by ------------------------------------------------------
452!|| imp_dykv ../engine/source/implicit/imp_dyna.F
453!|| imp_dykv0 ../engine/source/implicit/imp_dyna.F
454!|| upd_rhs ../engine/source/implicit/upd_glob_k.F
455!|| upd_rhs_fr ../engine/source/implicit/imp_solv.F
456!||--- calls -----------------------------------------------------
457!|| prerbe2 ../engine/source/constraints/general/rbe2/rbe2f.F
458!|| rbe2_impb0 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
459!|| rbe2_impbl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
460!||====================================================================
461 SUBROUTINE rbe2_impr1(
462 1 IRBE2 ,LRBE2 ,X ,SKEW ,NDOF ,
463 2 IDDL ,B ,WEIGHT)
464C-----------------------------------------------
465C I m p l i c i t T y p e s
466C-----------------------------------------------
467#include "implicit_f.inc"
468C-----------------------------------------------
469C C o m m o n B l o c k s
470C-----------------------------------------------
471#include "com04_c.inc"
472#include "param_c.inc"
473C-----------------------------------------------
474C D u m m y A r g u m e n t s
475C-----------------------------------------------
476 INTEGER WEIGHT(*),IRBE2(NRBE2L,*),LRBE2(*),
477 . ndof(*),iddl(*),irad
478C REAL
479 my_real
480 . x(3,*), skew(lskew,*), b(*)
481C-----------------------------------------------
482C L o c a l V a r i a b l e s
483C-----------------------------------------------
484 INTEGER I, J, N, M, NS ,NML, IAD,JJ,IROT,IADS,
485 . JT(3,NRBE2),JR(3,NRBE2),NSN,NSJ,ISK
486C REAL
487C-----------------------------------------------
488 CALL PRERBE2(IRBE2 ,JT ,JR )
489 DO N=1,nrbe2
490 iad = irbe2(1,n)
491 m = irbe2(3,n)
492 nsn = irbe2(5,n)
493 isk = irbe2(7,n)
494 irad = irbe2(11,n)
495 IF (isk>1) THEN
496 CALL rbe2_impbl(m ,nsn ,lrbe2(iad+1),x ,jt(1,n),
497 1 jr(1,n),ndof ,iddl ,b ,skew(1,isk),
498 2 irad )
499 ELSE
500 CALL rbe2_impb0(m ,nsn ,lrbe2(iad+1),x ,jt(1,n),
501 1 jr(1,n),ndof ,iddl ,b ,irad )
502 END IF
503 ENDDO
504C
505 RETURN
506 END
507!||====================================================================
508!|| rbe2_impb0 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
509!||--- called by ------------------------------------------------------
510!|| rbe2_impr1 ../engine/source/constraints/general/rbe2/rbe2_imp0.f
511!||--- calls -----------------------------------------------------
512!|| updb_rb ../engine/source/constraints/general/rbody/rby_imp0.F
513!||====================================================================
514 SUBROUTINE rbe2_impb0(M ,NSN ,ISL ,X ,JT ,
515 2 JR ,NDOF ,IDDL ,B ,IRAD )
516C-----------------------------------------------
517C I m p l i c i t T y p e s
518C-----------------------------------------------
519#include "implicit_f.inc"
520C-----------------------------------------------
521C D u m m y A r g u m e n t s
522C-----------------------------------------------
523 INTEGER M, NSN,ISL(*),JT(3),JR(3),NDOF(*),IDDL(*),IRAD
524C REAL
525 my_real
526 . X(3,*),B(*)
527C-----------------------------------------------
528C L o c a l V a r i a b l e s
529C-----------------------------------------------
530 INTEGER ISK, I, N, J,NI,NJ,J1,K,L,ID,JD,ND,IMD,NIDOF
531C REAL
532 my_real
533 . xs,ys,zs,bd(6)
534C------------------------------------
535C VITESSES DES NOEUDS SECONDS
536C------------------------------------
537 IF (ndof(m)<=0) RETURN
538C
539 nd = ndof(m)
540 DO i=1,nsn
541C--------block diagonal Kmm--
542 n = isl(i)
543 IF (ndof(n)>0) THEN
544 xs=x(1,n)-x(1,m)
545 ys=x(2,n)-x(2,m)
546 zs=x(3,n)-x(3,m)
547 DO k=1,6
548 bd(k)=zero
549 ENDDO
550 IF (irad>0) THEN
551 DO k=1,min(3,ndof(n))
552 id = iddl(n)+k
553 bd(k)=b(id)
554 ENDDO
555 CALL updb_rb(ndof(n),xs,ys,zs,bd)
556 DO k=1,min(3,ndof(n))
557 id = iddl(n)+k
558 bd(k)=b(id)*jt(k)
559 ENDDO
560 DO k=min(3,ndof(n))+1,ndof(n)
561 id = iddl(n)+k
562 bd(k)=(bd(k)+b(id))*jr(k-3)
563 ENDDO
564 ELSE
565 DO k=1,min(3,ndof(n))
566 id = iddl(n)+k
567 bd(k)=b(id)*jt(k)
568 ENDDO
569 DO k=min(3,ndof(n))+1,ndof(n)
570 id = iddl(n)+k
571 bd(k)=b(id)*jr(k-3)
572 ENDDO
573 CALL updb_rb(ndof(n),xs,ys,zs,bd)
574 END IF !(IRAD>0) THEN
575C-------Update B---
576 DO k=1,nd
577 id = iddl(m)+k
578 b(id) = b(id) + bd(k)
579 ENDDO
580 ENDIF
581 ENDDO
582C
583 RETURN
584 END
585!||====================================================================
586!|| rbe2_impbl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
587!||--- called by ------------------------------------------------------
588!|| rbe2_impl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
589!|| rbe2_impr1 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
590!||--- calls -----------------------------------------------------
591!|| cdi_skew ../engine/source/constraints/general/rbe2/rbe2_imp0.f
592!|| rbe2impbsn ../engine/source/constraints/general/rbe2/rbe2_imp0.F
593!||====================================================================
594 SUBROUTINE rbe2_impbl(M ,NSN ,ISL ,X ,JT ,
595 2 JR ,NDOF ,IDDL ,B ,SKEW ,
596 3 IRAD )
597C-----------------------------------------------
598C I m p l i c i t T y p e s
599C-----------------------------------------------
600#include "implicit_f.inc"
601C-----------------------------------------------
602C D u m m y A r g u m e n t s
603C-----------------------------------------------
604 INTEGER M, NSN,ISL(*),JT(3),JR(3),NDOF(*),IDDL(*),IRAD
605C REAL
606 my_real
607 . X(3,*),B(*),SKEW(*)
608C-----------------------------------------------
609C L o c a l V a r i a b l e s
610C-----------------------------------------------
611 INTEGER ISK, I, N, J,NI,NJ,J1,K,L,ID,JD,ND,IMD,NDS,
612 . IT,IR,IC,JT1(3),JR1(3)
613C REAL
614 my_real
615 . xs,ys,zs,lxs,lys,lzs,bd(6),bdl(6),bb(3),bm(3),
616 . cdt(3,3),cdtr(3,3),cdr(3,3)
617C------------------------------------
618C VITESSES DES NOEUDS SECONDS
619C------------------------------------
620 IF (ndof(m)<=0) RETURN
621C
622 nd = ndof(m)
623C-------translation-------
624 DO i=1,nsn
625C-------
626 n = isl(i)
627 IF (ndof(n)>0) THEN
628 xs=x(1,n)-x(1,m)
629 ys=x(2,n)-x(2,m)
630 zs=x(3,n)-x(3,m)
631 DO k=1,3
632 bb(k)=zero
633 bm(k)=zero
634 bd(k)=zero
635 bd(k+3)=zero
636 ENDDO
637 CALL cdi_skew(xs,ys,zs,jt,jr,skew,cdt,cdr,cdtr,jt1,jr1,irad)
638 DO k=1,min(3,ndof(n))
639 id = iddl(n)+k
640 bb(k)=b(id)
641C BB(K)=B(ID)*JT1(K)
642 ENDDO
643 DO k=4,ndof(n)
644 id = iddl(n)+k
645 bm(k-3)=b(id)
646C BM(K-3)=B(ID)*JR1(K-3)
647 ENDDO
648 DO k=1,3
649 DO l=1,3
650 bd(k)=bd(k)+cdt(l,k)*bb(l)
651 bd(k+3)=bd(k+3)+cdr(l,k)*bm(l)
652 bd(k+3)=bd(k+3)+cdtr(l,k)*bb(l)
653 ENDDO
654 ENDDO
655C-------Update B---
656 DO k=1,nd
657 id = iddl(m)+k
658 b(id) = b(id) + bd(k)
659 ENDDO
660 ENDIF
661 ENDDO
662 ic = jt(1)*100+jt(2)*10+jt(3)
663 IF (ic>0.AND.ic<111) THEN
664 ir = 0
665 CALL rbe2impbsn(nsn ,isl ,b ,ic ,ndof ,
666 1 iddl ,skew ,ir )
667 END IF
668 ic = jr(1)*100+jr(2)*10+jr(3)
669 IF (ic>0.AND.ic<111) THEN
670 ir = 1
671 CALL rbe2impbsn(nsn ,isl ,b ,ic ,ndof ,
672 1 iddl ,skew ,ir )
673 END IF
674C
675 RETURN
676 END
677!||====================================================================
678!|| sym_kdd ../engine/source/constraints/general/rbe2/rbe2_imp0.F
679!||--- called by ------------------------------------------------------
680!|| rbe2_imp1 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
681!|| rbe2_impl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
682!||====================================================================
683 SUBROUTINE sym_kdd(ND,KDD)
684C-----------------------------------------------
685C I m p l i c i t T y p e s
686C-----------------------------------------------
687#include "implicit_f.inc"
688C-----------------------------------------------
689C D u m m y A r g u m e n t s
690C-----------------------------------------------
691 INTEGER ND
692C REAL
693 my_real
694 . kdd(nd,nd)
695C-----------------------------------------------
696C L o c a l V a r i a b l e s
697C-----------------------------------------------
698 INTEGER I, J,K,L
699 DO I=1,nd
700 DO j=1,nd
701 kdd(i,j)=kdd(i,j)+kdd(j,i)
702 ENDDO
703 ENDDO
704C
705 RETURN
706 END
707!||====================================================================
708!|| cdi_skew ../engine/source/constraints/general/rbe2/rbe2_imp0.F
709!||--- called by ------------------------------------------------------
710!|| rbe2_frk ../engine/source/constraints/general/rbe2/rbe2_imp0.F
711!|| rbe2_impbl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
712!|| rbe2_impkd ../engine/source/constraints/general/rbe2/rbe2_imp0.f
713!|| rbe2_impl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
714!||--- calls -----------------------------------------------------
715!|| cdi_bcn ../engine/source/constraints/general/rbe2/rbe2_imp0.F
716!|| cdi_bcn1 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
717!||====================================================================
718 SUBROUTINE cdi_skew(XS,YS,ZS,JT,JR,SKEW,KT,KR,KTR,JT1,JR1,IRAD)
719C-----------------------------------------------
720C I m p l i c i t T y p e s
721C-----------------------------------------------
722#include "implicit_f.inc"
723C-----------------------------------------------
724C D u m m y A r g u m e n t s
725C-----------------------------------------------
726 INTEGER JT(3),JR(3),JT1(3),JR1(3),IRAD
727C REAL
728 my_real
729 . XS,YS,ZS,SKEW(*),KT(3,3),KR(3,3),KTR(3,3)
730C-----------------------------------------------
731C L o c a l V a r i a b l e s
732C-----------------------------------------------
733 INTEGER I, J,ICT
734C------------------------KT=QtJTQ-----------------------
735 ICT = jt(1)*100+jt(2)*10+jt(3)
736 CALL cdi_bcn(ict ,skew ,jt ,kt ,jt1 )
737 ict = jr(1)*100+jr(2)*10+jr(3)
738 CALL cdi_bcn(ict ,skew ,jr ,kr ,jr1 )
739 CALL cdi_bcn1(xs,ys,zs,jt,jr,skew,ktr,irad)
740C
741 RETURN
742 END
743!||====================================================================
744!|| updk2_cdi ../engine/source/constraints/general/rbe2/rbe2_imp0.F
745!||--- called by ------------------------------------------------------
746!|| rbe2_frk ../engine/source/constraints/general/rbe2/rbe2_imp0.F
747!|| rbe2_impl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
748!|| updcdik2_cdi ../engine/source/constraints/general/rbe2/rbe2_imp0.f
749!||====================================================================
750 SUBROUTINE updk2_cdi(NI,NJ,CDT,CDR,CDTR,KDD)
751C-----------------------------------------------
752C I m p l i c i t T y p e s
753C-----------------------------------------------
754#include "implicit_f.inc"
755C-----------------------------------------------
756C D u m m y A r g u m e n t s
757C-----------------------------------------------
758 INTEGER NI,NJ
759C REAL
760 my_real
761 . xs,ys,zs, kdd(6,6),cdt(3,3),cdr(3,3),cdtr(3,3)
762C-----------------------------------------------
763C L o c a l V a r i a b l e s
764C-----------------------------------------------
765 INTEGER I, J,L
766C REAL
767 my_real
768 . K(6,6)
769C------------------------------------
770C-------------produit {K'}=-[K][CDI]
771c-----with [CDI]=-[[CDT] [CDTR]]-----
772c---- [[0] [CDR] ]-----
773C
774 DO i=1,6
775 DO j=1,6
776 k(i,j)=zero
777 ENDDO
778 ENDDO
779 DO i=1,3
780 DO j=1,3
781 DO l=1,3
782 k(i,j)=k(i,j)+kdd(i,l)*cdt(l,j)
783 k(i+3,j)=k(i+3,j)+kdd(i+3,l)*cdt(l,j)
784 k(i,j+3)=k(i,j+3)+kdd(i,l)*cdtr(l,j)+
785 . kdd(i,l+3)*cdr(l,j)
786 k(i+3,j+3)=k(i+3,j+3)+kdd(i+3,l)*cdtr(l,j)+
787 . kdd(i+3,l+3)*cdr(l,j)
788 ENDDO
789 ENDDO
790 ENDDO
791C
792 DO i=1,ni
793 DO j=1,nj
794 kdd(i,j)=k(i,j)
795 ENDDO
796 ENDDO
797C
798 RETURN
799 END
800!||====================================================================
801!|| updcdik2_cdi ../engine/source/constraints/general/rbe2/rbe2_imp0.F
802!||--- called by ------------------------------------------------------
803!|| rbe2_frk ../engine/source/constraints/general/rbe2/rbe2_imp0.F
804!|| rbe2_impkd ../engine/source/constraints/general/rbe2/rbe2_imp0.F
805!|| rbe2_impl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
806!||--- calls -----------------------------------------------------
807!|| updk2_cdi ../engine/source/constraints/general/rbe2/rbe2_imp0.F
808!||====================================================================
809 SUBROUTINE updcdik2_cdi(ND,CDT,CDR,CDTR,KDD)
810C-----------------------------------------------
811C I m p l i c i t T y p e s
812C-----------------------------------------------
813#include "implicit_f.inc"
814C-----------------------------------------------
815C D u m m y A r g u m e n t s
816C-----------------------------------------------
817 INTEGER ND
818C REAL
819 my_real
820 . kdd(6,6),cdt(3,3),cdr(3,3),cdtr(3,3)
821C-----------------------------------------------
822C L o c a l V a r i a b l e s
823C-----------------------------------------------
824 INTEGER I, J,L
825C REAL
826 my_real
827 . K(6,6)
828C------------------------------------
829C-------------produit {K'}=[CDI]^t[K][CDI]
830c-----with [CDI]=-[[CDT] [CDTR]]-----
831c---- [[0] [CDR]]-----
832C------------------KDD-> [K][CDI]
833 CALL updk2_cdi(nd,nd,cdt,cdr,cdtr,kdd)
834 DO i=1,6
835 DO j=1,6
836 k(i,j)=zero
837 ENDDO
838 ENDDO
839 DO i=1,nd
840 DO j=1,nd
841 k(i,j)=kdd(j,i)
842 ENDDO
843 ENDDO
844 CALL updk2_cdi(nd,nd,cdt,cdr,cdtr,k)
845C
846 DO i=1,nd
847 DO j=1,nd
848 kdd(i,j)=k(i,j)
849 ENDDO
850 ENDDO
851C
852 RETURN
853 END
854!||====================================================================
855!|| rbe2_bcl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
856!||--- called by ------------------------------------------------------
857!|| rbe2_impl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
858!||--- calls -----------------------------------------------------
859!|| bc_updk ../engine/source/constraints/general/bcs/bc_imp0.F
860!|| bc_updk2 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
861!|| dir_rbe2 ../engine/source/constraints/general/rbe2/rbe2v.F
862!|| l_dir ../engine/source/constraints/general/bcs/bc_imp0.F
863!||====================================================================
864 SUBROUTINE rbe2_bcl(ICT ,SKEW ,IADN ,IFIX ,IADK ,
865 1 JDIK ,DIAG_K,LT_K ,I ,IR )
866C-----------------------------------------------
867C I m p l i c i t T y p e s
868C-----------------------------------------------
869#include "implicit_f.inc"
870C-----------------------------------------------
871C D u m m y A r g u m e n t s
872C-----------------------------------------------
873 INTEGER ICT,IADN(*),IFIX(*),IADK(*) ,JDIK(*),I,IR
874 my_real
875 . SKEW(*),DIAG_K(*),LT_K(*)
876C-----------------------------------------------
877C L o c a l V a r i a b l e s
878C-----------------------------------------------
879 INTEGER J,K,J1,L,ND
880 my_real
881 . EJ(3),EJ1(3),S,EA,EB
882C----------------100-------------------------
883 ND = iadn(i)
884 IF (ir>0) nd = iadn(i) + 3
885C-----IF J,J1 change during the deformation---
886 DO j=1,3
887 IF (ifix(nd +j) == 17) ifix(nd +j)=0
888 END DO
889C
890 SELECT CASE (ict)
891 CASE(100)
892 ej(1)=skew(1)
893 ej(2)=skew(2)
894 ej(3)=skew(3)
895 CALL l_dir(ej,j)
896 CALL bc_updk(i ,iadn ,ej ,j ,ir ,
897 1 iadk ,jdik ,diag_k,lt_k )
898 ifix(nd +j) = 17
899C----------------010-------------------------
900 CASE(10)
901 ej(1)=skew(4)
902 ej(2)=skew(5)
903 ej(3)=skew(6)
904 CALL l_dir(ej,j)
905 CALL bc_updk(i ,iadn ,ej ,j ,ir ,
906 1 iadk ,jdik ,diag_k,lt_k )
907 ifix(nd +j) = 17
908C----------------001-------------------------
909 CASE(1)
910 ej(1)=skew(7)
911 ej(2)=skew(8)
912 ej(3)=skew(9)
913 CALL l_dir(ej,j)
914 CALL bc_updk(i ,iadn ,ej ,j ,ir ,
915 1 iadk ,jdik ,diag_k,lt_k )
916 ifix(nd +j) = 17
917C----------------011-------------------------
918 CASE(11)
919 ej(1)=skew(7)
920 ej(2)=skew(8)
921 ej(3)=skew(9)
922 CALL l_dir(ej,j)
923 ifix(nd +j) = 17
924 ej1(1)=skew(4)
925 ej1(2)=skew(5)
926 ej1(3)=skew(6)
927 CALL l_dir(ej1,j1)
928 IF (j1==j) THEN
929 ej1(j)=zero
930 CALL l_dir(ej1,j1)
931 ej1(1)=skew(4)/skew(3+j1)
932 ej1(2)=skew(5)/skew(3+j1)
933 ej1(3)=skew(6)/skew(3+j1)
934 ENDIF
935 CALL dir_rbe2(j ,j1 ,k )
936 s=one/(one-ej(j1)*ej1(j))
937 ea=-s*(ej(j1)*ej1(k)-ej(k))
938 eb=-s*(ej1(j)*ej(k)-ej1(k))
939 CALL bc_updk2(i ,iadn ,j ,j1 ,k ,
940 1 ir ,ea ,eb ,iadk ,jdik ,
941 2 diag_k,lt_k )
942 ifix(nd +j1) = 17
943C----------------101-------------------------
944 CASE(101)
945 ej(1)=skew(7)
946 ej(2)=skew(8)
947 ej(3)=skew(9)
948 CALL l_dir(ej,j)
949 ifix(nd +j) = 17
950 ej1(1)=skew(1)
951 ej1(2)=skew(2)
952 ej1(3)=skew(3)
953 CALL l_dir(ej1,j1)
954 IF (j1==j) THEN
955 ej1(j)=zero
956 CALL l_dir(ej1,j1)
957 ej1(1)=skew(1)/skew(j1)
958 ej1(2)=skew(2)/skew(j1)
959 ej1(3)=skew(3)/skew(j1)
960 ENDIF
961 CALL dir_rbe2(j ,j1 ,k )
962 s=one/(one-ej(j1)*ej1(j))
963 ea=-s*(ej(j1)*ej1(k)-ej(k))
964 eb=-s*(ej1(j)*ej(k)-ej1(k))
965 CALL bc_updk2(i ,iadn ,j ,j1 ,k ,
966 1 ir ,ea ,eb ,iadk ,jdik ,
967 2 diag_k,lt_k )
968 ifix(nd +j1) = 17
969C----------------110-------------------------
970 CASE(110)
971 ej(1)=skew(4)
972 ej(2)=skew(5)
973 ej(3)=skew(6)
974 CALL l_dir(ej,j)
975 ifix(nd +j) = 17
976 ej1(1)=skew(1)
977 ej1(2)=skew(2)
978 ej1(3)=skew(3)
979 CALL l_dir(ej1,j1)
980 IF (j1==j) THEN
981 ej1(j)=zero
982 CALL l_dir(ej1,j1)
983 ej1(1)=skew(1)/skew(j1)
984 ej1(2)=skew(2)/skew(j1)
985 ej1(3)=skew(3)/skew(j1)
986 ENDIF
987 CALL dir_rbe2(j ,j1 ,k )
988 s=one/(one-ej(j1)*ej1(j))
989 ea=-s*(ej(j1)*ej1(k)-ej(k))
990 eb=-s*(ej1(j)*ej(k)-ej1(k))
991 CALL bc_updk2(i ,iadn ,j ,j1 ,k ,
992 1 ir ,ea ,eb ,iadk ,jdik ,
993 2 diag_k,lt_k )
994 ifix(nd +j1) = 17
995 END SELECT
996C
997 RETURN
998 END
999!||====================================================================
1000!|| cdi_bcn ../engine/source/constraints/general/rbe2/rbe2_imp0.F
1001!||--- called by ------------------------------------------------------
1002!|| cdi_skew ../engine/source/constraints/general/rbe2/rbe2_imp0.F
1003!|| rbe2fl ../engine/source/constraints/general/rbe2/rbe2f.F
1004!|| rbe2frf ../engine/source/constraints/general/rbe2/rbe2f.F
1005!|| sms_rbe_1 ../engine/source/ams/sms_rbe2.F
1006!|| sms_rbe_5 ../engine/source/ams/sms_rbe2.F
1007!||--- calls -----------------------------------------------------
1008!|| dir_rbe2 ../engine/source/constraints/general/rbe2/rbe2v.F
1009!|| l_dir ../engine/source/constraints/general/bcs/bc_imp0.F
1010!||====================================================================
1011 SUBROUTINE cdi_bcn(ICT ,SKEW ,JT ,KT ,JT1 )
1012C-----------------------------------------------
1013C I m p l i c i t T y p e s
1014C-----------------------------------------------
1015#include "implicit_f.inc"
1016C-----------------------------------------------
1017C D u m m y A r g u m e n t s
1018C-----------------------------------------------
1019 INTEGER JT(3) ,ICT,JT1(3)
1020 my_real
1021 . SKEW(*),KT(3,3)
1022C-----------------------------------------------
1023C L o c a l V a r i a b l e s
1024C-----------------------------------------------
1025 INTEGER I,J,K,J1,L,ND
1026 my_real
1027 . EJ(3),EJ1(3),S,EA,EB
1028C-------JT1 presente the real consentration dof----------------------
1029 DO I=1,3
1030 do j=1,3
1031 kt(i,j)=zero
1032 ENDDO
1033 jt1(i) = 0
1034 ENDDO
1035C----------------100-------------------------
1036 SELECT CASE (ict)
1037 CASE(100)
1038 ej(1)=skew(1)
1039 ej(2)=skew(2)
1040 ej(3)=skew(3)
1041 CALL l_dir(ej,j)
1042 DO i=1,3
1043 kt(j,i)=ej(i)
1044 ENDDO
1045 jt1(j) = 1
1046C----------------010-------------------------
1047 CASE(10)
1048 ej(1)=skew(4)
1049 ej(2)=skew(5)
1050 ej(3)=skew(6)
1051 CALL l_dir(ej,j)
1052 DO i=1,3
1053 kt(j,i)=ej(i)
1054 ENDDO
1055 jt1(j) = 1
1056C----------------001-------------------------
1057 CASE(1)
1058 ej(1)=skew(7)
1059 ej(2)=skew(8)
1060 ej(3)=skew(9)
1061 CALL l_dir(ej,j)
1062 DO i=1,3
1063 kt(j,i)=ej(i)
1064 ENDDO
1065 jt1(j) = 1
1066C----------------011-------------------------
1067 CASE(11)
1068 ej(1)=skew(7)
1069 ej(2)=skew(8)
1070 ej(3)=skew(9)
1071 CALL l_dir(ej,j)
1072 ej1(1)=skew(4)
1073 ej1(2)=skew(5)
1074 ej1(3)=skew(6)
1075 CALL l_dir(ej1,j1)
1076 IF (j1==j) THEN
1077 ej1(j)=zero
1078 CALL l_dir(ej1,j1)
1079 ej1(1)=skew(4)/skew(3+j1)
1080 ej1(2)=skew(5)/skew(3+j1)
1081 ej1(3)=skew(6)/skew(3+j1)
1082 ENDIF
1083 CALL dir_rbe2(j ,j1 ,k )
1084 s=one/(one-ej(j1)*ej1(j))
1085 ea=s*(ej(j1)*ej1(k)-ej(k))
1086 eb=s*(ej1(j)*ej(k)-ej1(k))
1087 kt(j,j)=ej(j)
1088 kt(j,k)=-ea
1089 kt(j1,j1)=ej1(j1)
1090 kt(j1,k)=-eb
1091 jt1(j) = 1
1092 jt1(j1) = 1
1093C----------------101-------------------------
1094 CASE(101)
1095 ej(1)=skew(7)
1096 ej(2)=skew(8)
1097 ej(3)=skew(9)
1098 CALL l_dir(ej,j)
1099 ej1(1)=skew(1)
1100 ej1(2)=skew(2)
1101 ej1(3)=skew(3)
1102 CALL l_dir(ej1,j1)
1103 IF (j1==j) THEN
1104 ej1(j)=zero
1105 CALL l_dir(ej1,j1)
1106 ej1(1)=skew(1)/skew(j1)
1107 ej1(2)=skew(2)/skew(j1)
1108 ej1(3)=skew(3)/skew(j1)
1109 ENDIF
1110 CALL dir_rbe2(j ,j1 ,k )
1111 s=one/(one-ej(j1)*ej1(j))
1112 ea=s*(ej(j1)*ej1(k)-ej(k))
1113 eb=s*(ej1(j)*ej(k)-ej1(k))
1114 kt(j,j)=ej(j)
1115 kt(j,k)=-ea
1116 kt(j1,j1)=ej1(j1)
1117 kt(j1,k)=-eb
1118 jt1(j) = 1
1119 jt1(j1) = 1
1120C----------------110-------------------------
1121 CASE(110)
1122 ej(1)=skew(4)
1123 ej(2)=skew(5)
1124 ej(3)=skew(6)
1125 CALL l_dir(ej,j)
1126 ej1(1)=skew(1)
1127 ej1(2)=skew(2)
1128 ej1(3)=skew(3)
1129 CALL l_dir(ej1,j1)
1130 IF (j1==j) THEN
1131 ej1(j)=zero
1132 CALL l_dir(ej1,j1)
1133 ej1(1)=skew(1)/skew(j1)
1134 ej1(2)=skew(2)/skew(j1)
1135 ej1(3)=skew(3)/skew(j1)
1136 ENDIF
1137 CALL dir_rbe2(j ,j1 ,k )
1138 s=one/(one-ej(j1)*ej1(j))
1139 ea=s*(ej(j1)*ej1(k)-ej(k))
1140 eb=s*(ej1(j)*ej(k)-ej1(k))
1141 kt(j,j)=ej(j)
1142 kt(j,k)=-ea
1143 kt(j1,j1)=ej1(j1)
1144 kt(j1,k)=-eb
1145 jt1(j) = 1
1146 jt1(j1) = 1
1147C----------------111-------------------------
1148 CASE(111)
1149 DO i=1,3
1150 kt(i,i)=one
1151 jt1(i) = 1
1152 ENDDO
1153 END SELECT
1154C
1155 RETURN
1156 END
1157!||====================================================================
1158!|| rbe2impbsn ../engine/source/constraints/general/rbe2/rbe2_imp0.F
1159!||--- called by ------------------------------------------------------
1160!|| rbe2_impbl ../engine/source/constraints/general/rbe2/rbe2_imp0.F
1161!||--- calls -----------------------------------------------------
1162!|| dir_rbe2 ../engine/source/constraints/general/rbe2/rbe2v.F
1163!|| l_dir ../engine/source/constraints/general/bcs/bc_imp0.F
1164!||====================================================================
1165 SUBROUTINE rbe2impbsn(NSL ,ISL ,B ,ICT ,NDOF ,
1166 2 IDDL ,SKEW ,IR )
1167C-----------------------------------------------
1168C I m p l i c i t T y p e s
1169C-----------------------------------------------
1170#include "implicit_f.inc"
1171C-----------------------------------------------
1172C D u m m y A r g u m e n t s
1173C-----------------------------------------------
1174 INTEGER NSL ,ISL(*) ,ICT, NDOF(*),IDDL(*),IR
1175 my_real
1176 . skew(*),b(*)
1177C-----------------------------------------------
1178C L o c a l V a r i a b l e s
1179C-----------------------------------------------
1180 INTEGER I,J,K,J1,L,NS,ND,NR
1181 my_real
1182 . EJ(3),EJ1(3),S,EA,EB
1183C----------------100-------------------------
1184 IF (IR==0) then
1185 nr = 0
1186 ELSE
1187 nr = 3
1188 ENDIF
1189 SELECT CASE (ict)
1190 CASE(100)
1191 ej(1)=skew(1)
1192 ej(2)=skew(2)
1193 ej(3)=skew(3)
1194 CALL l_dir(ej,j)
1195 j1=0
1196 CALL dir_rbe2(j ,j1 ,k )
1197C----------------010-------------------------
1198 CASE(10)
1199 ej(1)=skew(4)
1200 ej(2)=skew(5)
1201 ej(3)=skew(6)
1202 CALL l_dir(ej,j)
1203 j1=0
1204 CALL dir_rbe2(j ,j1 ,k )
1205C----------------001-------------------------
1206 CASE(1)
1207 ej(1)=skew(7)
1208 ej(2)=skew(8)
1209 ej(3)=skew(9)
1210 CALL l_dir(ej,j)
1211 j1=0
1212 CALL dir_rbe2(j ,j1 ,k )
1213C----------------011-------------------------
1214 CASE(11)
1215 ej(1)=skew(7)
1216 ej(2)=skew(8)
1217 ej(3)=skew(9)
1218 CALL l_dir(ej,j)
1219 ej1(1)=skew(4)
1220 ej1(2)=skew(5)
1221 ej1(3)=skew(6)
1222 CALL l_dir(ej1,j1)
1223 IF (j1==j) THEN
1224 ej1(j)=zero
1225 CALL l_dir(ej1,j1)
1226 ej1(1)=skew(4)/skew(3+j1)
1227 ej1(2)=skew(5)/skew(3+j1)
1228 ej1(3)=skew(6)/skew(3+j1)
1229 ENDIF
1230 CALL dir_rbe2(j ,j1 ,k )
1231 s=one/(one-ej(j1)*ej1(j))
1232 ea=s*(ej(j1)*ej1(k)-ej(k))
1233 eb=s*(ej1(j)*ej(k)-ej1(k))
1234C----------------101-------------------------
1235 CASE(101)
1236 ej(1)=skew(7)
1237 ej(2)=skew(8)
1238 ej(3)=skew(9)
1239 CALL l_dir(ej,j)
1240 ej1(1)=skew(1)
1241 ej1(2)=skew(2)
1242 ej1(3)=skew(3)
1243 CALL l_dir(ej1,j1)
1244 IF (j1==j) THEN
1245 ej1(j)=zero
1246 CALL l_dir(ej1,j1)
1247 ej1(1)=skew(1)/skew(j1)
1248 ej1(2)=skew(2)/skew(j1)
1249 ej1(3)=skew(3)/skew(j1)
1250 ENDIF
1251 CALL dir_rbe2(j ,j1 ,k )
1252 s=one/(one-ej(j1)*ej1(j))
1253 ea=s*(ej(j1)*ej1(k)-ej(k))
1254 eb=s*(ej1(j)*ej(k)-ej1(k))
1255C----------------110-------------------------
1256 CASE(110)
1257 ej(1)=skew(4)
1258 ej(2)=skew(5)
1259 ej(3)=skew(6)
1260 CALL l_dir(ej,j)
1261 ej1(1)=skew(1)
1262 ej1(2)=skew(2)
1263 ej1(3)=skew(3)
1264 CALL l_dir(ej1,j1)
1265 IF (j1==j) THEN
1266 ej1(j)=zero
1267 CALL l_dir(ej1,j1)
1268 ej1(1)=skew(1)/skew(j1)
1269 ej1(2)=skew(2)/skew(j1)
1270 ej1(3)=skew(3)/skew(j1)
1271 ENDIF
1272 CALL dir_rbe2(j ,j1 ,k )
1273 s=one/(one-ej(j1)*ej1(j))
1274 ea=s*(ej(j1)*ej1(k)-ej(k))
1275 eb=s*(ej1(j)*ej(k)-ej1(k))
1276 END SELECT
1277C
1278 DO i=1,nsl
1279 ns = isl(i)
1280 IF (ndof(ns)==0) cycle
1281 nd =iddl(ns)+nr
1282C-------------------100---------------------
1283 IF (ict == 100 ) THEN
1284 b(nd+j1)=b(nd+j1)-ej(j1)*b(nd+j)
1285 b(nd+k)=b(nd+k)-ej(k)*b(nd+j)
1286C-------------------010---------------------
1287 ELSEIF (ict == 10) THEN
1288 b(nd+j1)=b(nd+j1)-ej(j1)*b(nd+j)
1289 b(nd+k)=b(nd+k)-ej(k)*b(nd+j)
1290C-------------------001---------------------
1291 ELSEIF (ict == 1) THEN
1292 b(nd+j1)=b(nd+j1)-ej(j1)*b(nd+j)
1293 b(nd+k)=b(nd+k)-ej(k)*b(nd+j)
1294C-------------------011---------------------
1295 ELSEIF (ict == 11) THEN
1296 b(nd+k)=b(nd+k)+ea*b(nd+j)+eb*b(nd+j1)
1297C-------------------101---------------------
1298 ELSEIF (ict == 101) THEN
1299 b(nd+k)=b(nd+k)+ea*b(nd+j)+eb*b(nd+j1)
1300C-------------------110---------------------
1301 ELSEIF (ict == 110 ) THEN
1302 b(nd+k)=b(nd+k)+ea*b(nd+j)+eb*b(nd+j1)
1303 ENDIF
1304 ENDDO
1305C
1306 RETURN
1307 END
1308!||====================================================================
1309!|| bc_updk2 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
1310!||--- called by ------------------------------------------------------
1311!|| bc_updk2d ../engine/source/constraints/general/bcs/bc_imp0.F
1312!|| rbe2_bcl ../engine/source/constraints/general/rbe2/rbe2_imp0.f
1313!||--- calls -----------------------------------------------------
1314!|| get_kii ../engine/source/implicit/imp_glob_k.F
1315!|| put_kii ../engine/source/implicit/imp_glob_k.F
1316!||====================================================================
1317 SUBROUTINE bc_updk2(N ,IDDL ,J ,L ,K ,
1318 1 IR ,EJ ,EL ,IADK ,JDIK ,
1319 2 DIAG_K,LT_K )
1320C-----------------------------------------------
1321C I m p l i c i t T y p e s
1322C-----------------------------------------------
1323#include "implicit_f.inc"
1324C-----------------------------------------------
1325C C o m m o n B l o c k s
1326C-----------------------------------------------
1327#include "impl1_c.inc"
1328C-----------------------------------------------
1329C D u m m y A r g u m e n t s
1330C-----------------------------------------------
1331 INTEGER N,J ,L ,K,IDDL(*),IR,IADK(*) ,JDIK(*)
1332 my_real
1333 . EJ,EL,DIAG_K(*),LT_K(*)
1334C-----------------------------------------------
1335C L o c a l V a r i a b l e s
1336C-----------------------------------------------
1337 INTEGER I,ND,J1,K1,L1,ID,SHF,JFT,KFT,LFT,NL,NJ,
1338 . IT(6),KK,IDJ,IDL,JJ,SHL
1339 my_real
1340 . kdd(6,6),kii(6,6)
1341C------------K :free; J,L to be condentrated----------------------
1342 IF (ir==0) THEN
1343 nd = 3
1344 ELSE
1345 nd = 6
1346 ENDIF
1347 IF (ej==zero.AND.el==zero) RETURN
1348 DO i=1,nd
1349 DO jj=1,nd
1350 kii(i,jj)=zero
1351 ENDDO
1352 ENDDO
1353 IF (ir==0) THEN
1354 j1 = j
1355 k1 = k
1356 l1 = l
1357 ELSE
1358 j1 = j + 3
1359 k1 = k + 3
1360 l1 = l + 3
1361 ENDIF
1362C-------------first KNN------------
1363 CALL get_kii(n ,iddl ,iadk,diag_k,lt_k ,kdd,nd)
1364 DO i=1,nd
1365 DO jj=i+1,nd
1366 kdd(jj,i)=kdd(i,jj)
1367 ENDDO
1368 ENDDO
1369 kii(k1,k1)=ej*(kdd(j1,j1)*ej+two*el*kdd(j1,l1)-two*kdd(j1,k1))
1370 . +el*(kdd(l1,l1)*el-two*kdd(l1,k1))
1371C +++ couplage t,r-----
1372 IF (ir/=0) THEN
1373 kii(k,k1)=-kdd(k,j1)*ej-kdd(k,l1)*el
1374 kii(j,k1)=-kdd(j,j1)*ej-kdd(j,l1)*el
1375 kii(l,k1)=-kdd(l,j1)*ej-kdd(l,l1)*el
1376 ENDIF
1377C ---
1378 CALL put_kii(n ,iddl ,iadk,diag_k,lt_k ,kii,nd)
1379C -----------KIJ-----
1380 idj = iddl(n)+ j1
1381 idl = iddl(n)+ l1
1382 IF (ikpat==0) THEN
1383 shf = iabs(j-3)
1384 nj = iadk(idj+1)-iadk(idj)-shf
1385 jft = iadk(idj)+shf-1
1386 shl = iabs(l-3)
1387 nl = iadk(idl+1)-iadk(idl)-shl
1388 lft = iadk(idl)+shl-1
1389 kft = iadk(iddl(n)+ k1)+iabs(k-3)-1
1390 DO jj = 1, nj
1391 lt_k(kft+jj) = lt_k(kft+jj)-ej*lt_k(jft+jj)
1392 ENDDO
1393 DO jj = 1, nl
1394 lt_k(kft+jj) = lt_k(kft+jj)-el*lt_k(lft+jj)
1395 ENDDO
1396 DO i = 1, iddl(n)
1397 nj =0
1398 nl =0
1399 DO jj = iadk(i), iadk(i+1)-1
1400 IF (jdik(jj)==idj) nj = jj
1401 IF (jdik(jj)==idl) nl = jj
1402 ENDDO
1403 IF (nj>0) lt_k(nj+k1-j1) = lt_k(nj+k1-j1)-ej*lt_k(nj)
1404 IF (nl>0) lt_k(nj+k1-j1) = lt_k(nj+k1-j1)-el*lt_k(nl)
1405 ENDDO
1406 ELSE
1407 shf = j1-1
1408 shl = l1-1
1409 nj = iadk(idj+1)-iadk(idj)-shf
1410 jft = iadk(idj)-1
1411 nl = iadk(idl+1)-iadk(idl)-shl
1412 lft = iadk(idl)-1
1413 kft = iadk(iddl(n)+k1)-1
1414 DO jj = 1, nj
1415 lt_k(kft+jj) = lt_k(kft+jj)-ej*lt_k(jft+jj)
1416 ENDDO
1417 DO jj = 1, nl
1418 lt_k(kft+jj) = lt_k(kft+jj)-el*lt_k(lft+jj)
1419 ENDDO
1420C---------
1421 DO i = iddl(n)+nd+1, nddl_l
1422 nj =0
1423 nl =0
1424 DO jj = iadk(i), iadk(i+1)-1
1425 IF (jdik(jj)==idj) nj = jj
1426 IF (jdik(jj)==idl) nl = jj
1427 ENDDO
1428 IF (nj>0) lt_k(nj+k1-j1) = lt_k(nj+k1-j1)-ej*lt_k(nj)
1429 IF (nl>0) lt_k(nj+k1-j1) = lt_k(nj+k1-j1)-el*lt_k(nl)
1430 ENDDO
1431 ENDIF
1432C
1433 RETURN
1434 END
1435!||====================================================================
1436!|| cdi_bcn1 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
1437!||--- called by ------------------------------------------------------
1438!|| cdi_skew ../engine/source/constraints/general/rbe2/rbe2_imp0.F
1439!|| rbe2_frd ../engine/source/constraints/general/rbe2/rbe2v.F
1440!|| rbe2dl2 ../engine/source/constraints/general/rbe2/rbe2v.F
1441!|| rbe2fl ../engine/source/constraints/general/rbe2/rbe2f.F
1442!|| rbe2frf ../engine/source/constraints/general/rbe2/rbe2f.F
1443!|| rbe2vl1 ../engine/source/constraints/general/rbe2/rbe2v.F
1444!||--- calls -----------------------------------------------------
1445!|| dir_rbe2 ../engine/source/constraints/general/rbe2/rbe2v.F
1446!|| l_dir ../engine/source/constraints/general/bcs/bc_imp0.F
1447!||====================================================================
1448 SUBROUTINE cdi_bcn1(XS,YS,ZS,JT,JR,SKEW,KTR,IRAD)
1449C-----------------------------------------------
1450C I m p l i c i t T y p e s
1451C-----------------------------------------------
1452#include "implicit_f.inc"
1453C-----------------------------------------------
1454C D u m m y A r g u m e n t s
1455C-----------------------------------------------
1456 INTEGER JT(3) ,JR(3),IRAD
1457 my_real
1458 . xs,ys,zs,skew(*),ktr(3,3)
1459C-----------------------------------------------
1460C L o c a l V a r i a b l e s
1461C-----------------------------------------------
1462 INTEGER I,J,K,J1,L,ND,ICT
1463 my_real
1464 . EJ(3),EJ1(3),S,XL,YL,ZL,VQ(3,3),KK(3,3),SA,SB
1465C-------JT1 presente the real consentration dof----------------------
1466 DO I=1,3
1467 vq(1,i)= skew(i)
1468 vq(2,i)= skew(i+3)
1469 vq(3,i)= skew(i+6)
1470 kk(i,i)=zero
1471 ENDDO
1472 xl = vq(1,1)*xs+ vq(1,2)*ys+vq(1,3)*zs
1473 yl = vq(2,1)*xs+ vq(2,2)*ys+vq(2,3)*zs
1474 zl = vq(3,1)*xs+ vq(3,2)*ys+vq(3,3)*zs
1475 IF (irad>0) THEN
1476 kk(1,2) =zl*jr(2)
1477 kk(1,3) =-yl*jr(3)
1478 kk(2,1) =-zl*jr(1)
1479 kk(2,3) =xl*jr(3)
1480 kk(3,1) =yl*jr(1)
1481 kk(3,2) =-xl*jr(2)
1482 ict = jr(1)*100+jr(2)*10+jr(3)
1483C--------Nastran's formulation
1484 ELSE
1485 kk(1,2) =zl*jt(1)
1486 kk(1,3) =-yl*jt(1)
1487 kk(2,1) =-zl*jt(2)
1488 kk(2,3) =xl*jt(2)
1489 kk(3,1) =yl*jt(3)
1490 kk(3,2) =-xl*jt(3)
1491 ict = jt(1)*100+jt(2)*10+jt(3)
1492 END IF !(IR>0) THEN
1493C--------[Q]^t[Rs][Q]--------
1494 DO j=1,3
1495 ktr(1,j)=kk(1,2)*vq(2,j)+kk(1,3)*vq(3,j)
1496 ktr(2,j)=kk(2,1)*vq(1,j)+kk(2,3)*vq(3,j)
1497 ktr(3,j)=kk(3,1)*vq(1,j)+kk(3,2)*vq(2,j)
1498 ENDDO
1499C
1500 DO i=1,3
1501 DO j=1,3
1502 kk(i,j)=ktr(i,j)
1503 ktr(i,j)=zero
1504 ENDDO
1505 ENDDO
1506C----------------100-------------------------
1507 SELECT CASE (ict)
1508 CASE(100)
1509 ej(1)=skew(1)
1510 ej(2)=skew(2)
1511 ej(3)=skew(3)
1512 CALL l_dir(ej,j)
1513 DO i=1,3
1514 ktr(j,i)=kk(1,i)/ej(j)
1515 ENDDO
1516C----------------010-------------------------
1517 CASE(10)
1518 ej(1)=skew(4)
1519 ej(2)=skew(5)
1520 ej(3)=skew(6)
1521 CALL l_dir(ej,j)
1522 DO i=1,3
1523 ktr(j,i)=kk(2,i)/ej(j)
1524 ENDDO
1525C----------------001-------------------------
1526 CASE(1)
1527 ej(1)=skew(7)
1528 ej(2)=skew(8)
1529 ej(3)=skew(9)
1530 CALL l_dir(ej,j)
1531 DO i=1,3
1532 ktr(j,i)=kk(3,i)/ej(j)
1533 ENDDO
1534C----------------011-------------------------
1535 CASE(11)
1536 ej(1)=skew(7)
1537 ej(2)=skew(8)
1538 ej(3)=skew(9)
1539 CALL l_dir(ej,j)
1540 ej1(1)=skew(4)
1541 ej1(2)=skew(5)
1542 ej1(3)=skew(6)
1543 CALL l_dir(ej1,j1)
1544 IF (j1==j) THEN
1545 ej1(j)=zero
1546 CALL l_dir(ej1,j1)
1547 ej1(1)=skew(4)/skew(3+j1)
1548 ej1(2)=skew(5)/skew(3+j1)
1549 ej1(3)=skew(6)/skew(3+j1)
1550 ENDIF
1551 CALL dir_rbe2(j ,j1 ,k )
1552 s=one/(one-ej(j1)*ej1(j))
1553 sa = s/skew(6+j)
1554 sb = s/skew(3+j1)
1555 DO i=1,3
1556 ktr(j,i)=sa*kk(3,i)-sb*ej(j1)*kk(2,i)
1557 ktr(j1,i)=sb*kk(2,i)-sa*ej1(j)*kk(3,i)
1558 ENDDO
1559C----------------101-------------------------
1560 CASE(101)
1561 ej(1)=skew(7)
1562 ej(2)=skew(8)
1563 ej(3)=skew(9)
1564 CALL l_dir(ej,j)
1565 ej1(1)=skew(1)
1566 ej1(2)=skew(2)
1567 ej1(3)=skew(3)
1568 CALL l_dir(ej1,j1)
1569 IF (j1==j) THEN
1570 ej1(j)=zero
1571 CALL l_dir(ej1,j1)
1572 ej1(1)=skew(1)/skew(j1)
1573 ej1(2)=skew(2)/skew(j1)
1574 ej1(3)=skew(3)/skew(j1)
1575 ENDIF
1576 CALL dir_rbe2(j ,j1 ,k )
1577 s=one/(one-ej(j1)*ej1(j))
1578 sa = s/skew(6+j)
1579 sb = s/skew(j1)
1580 DO i=1,3
1581 ktr(j,i)=sa*kk(3,i)-sb*ej(j1)*kk(1,i)
1582 ktr(j1,i)=sb*kk(1,i)-sa*ej1(j)*kk(3,i)
1583 ENDDO
1584C----------------110-------------------------
1585 CASE(110)
1586 ej(1)=skew(4)
1587 ej(2)=skew(5)
1588 ej(3)=skew(6)
1589 CALL l_dir(ej,j)
1590 ej1(1)=skew(1)
1591 ej1(2)=skew(2)
1592 ej1(3)=skew(3)
1593 CALL l_dir(ej1,j1)
1594 IF (j1==j) THEN
1595 ej1(j)=zero
1596 CALL l_dir(ej1,j1)
1597 ej1(1)=skew(1)/skew(j1)
1598 ej1(2)=skew(2)/skew(j1)
1599 ej1(3)=skew(3)/skew(j1)
1600 ENDIF
1601 CALL dir_rbe2(j ,j1 ,k )
1602 s=one/(one-ej(j1)*ej1(j))
1603 sa = s/skew(3+j)
1604 sb = s/skew(j1)
1605 DO i=1,3
1606 ktr(j,i)=sa*kk(2,i)-sb*ej(j1)*kk(1,i)
1607 ktr(j1,i)=sb*kk(1,i)-sa*ej1(j)*kk(2,i)
1608 ENDDO
1609C----------------111-------------------------
1610 CASE(111)
1611 ktr =zero
1612 IF (irad>0) THEN
1613 ktr(1,2) = zs*jr(2)
1614 ktr(1,3) =-ys*jr(3)
1615 ktr(2,1) =-zs*jr(1)
1616 ktr(2,3) = xs*jr(3)
1617 ktr(3,1) = ys*jr(1)
1618 ktr(3,2) =-xs*jr(2)
1619!--------Nastran's formulation
1620 ELSE
1621 ktr(1,2) = zs*jt(1)
1622 ktr(1,3) =-ys*jt(1)
1623 ktr(2,1) =-zs*jt(2)
1624 ktr(2,3) = xs*jt(2)
1625 ktr(3,1) = ys*jt(3)
1626 ktr(3,2) =-xs*jt(3)
1627 END IF !(IR>0) THEN
1628 END SELECT
1629C
1630 RETURN
1631 END
1632!||====================================================================
1633!|| rbe2_impkd ../engine/source/constraints/general/rbe2/rbe2_imp0.F
1634!||--- called by ------------------------------------------------------
1635!|| diag_int ../engine/source/mpi/implicit/imp_fri.F
1636!|| updk_mv ../engine/source/airbag/monv_imp0.F
1637!||--- calls -----------------------------------------------------
1638!|| bcl_impkd ../engine/source/constraints/general/bcs/bc_imp0.F
1639!|| cdi_skew ../engine/source/constraints/general/rbe2/rbe2_imp0.F
1640!|| updcdik2_cdi ../engine/source/constraints/general/rbe2/rbe2_imp0.F
1641!||====================================================================
1642 SUBROUTINE rbe2_impkd(M ,NS ,X ,ISK ,JT ,
1643 2 JR ,NDOF ,SKEW0 ,KDD ,DIAG_KM,
1644 3 DIAG_KN,IRAD )
1645C-----------------------------------------------
1646C I m p l i c i t T y p e s
1647C-----------------------------------------------
1648#include "implicit_f.inc"
1649C-----------------------------------------------
1650C D u m m y A r g u m e n t s
1651C-----------------------------------------------
1652 INTEGER M, NS,JT(3),JR(3),IRAD,NDOF(*),ISK
1653C REAL
1654 my_real
1655 . x(3,*),diag_km(6),diag_kn(6),kdd(6,6),skew0(9)
1656C-----------------------------------------------
1657C C o m m o n B l o c k s
1658C-----------------------------------------------
1659#include "param_c.inc"
1660C-----------------------------------------------
1661C L o c a l V a r i a b l e s
1662C-----------------------------------------------
1663 INTEGER NIR, I, J, J1, J2, J3, J4, K, JD, II, L, JJ,
1664 . I1,ID,NL,NI,NJ,NIDOF,ND,NDI,NDJ,NDM,NM,L1,NM1,
1665 . NIR1,IR,IP,ISTIF,IMD,N,NT,NR,IC,JT1(3),JR1(3)
1666C REAL
1667 my_real
1668 . xs,ys,zs,tmp,cdt(3,3),cdtr(3,3),cdr(3,3),skew(lskew),
1669 . kii(6,6)
1670C------------------------------------
1671C VITESSES DES NOEUDS SECONDS
1672C------------------------------------
1673 nd = ndof(m)
1674 nt=jt(1)+jt(2)+jt(3)
1675 nr=jr(1)+jr(2)+jr(3)
1676 IF (isk>1) THEN
1677 DO k=1,lskew
1678 skew(k)=skew0(k)
1679 ENDDO
1680 ELSE
1681 DO k=1,lskew
1682 skew(k)=zero
1683 ENDDO
1684 skew(1)=one
1685 skew(5)=one
1686 skew(9)=one
1687 ENDIF
1688C
1689 DO k=1,6
1690 DO j=1,6
1691 kii(k,j)=kdd(k,j)
1692 ENDDO
1693 ENDDO
1694C--------block diagonal Kmm--
1695 n = ns
1696 IF (ndof(n)>0) THEN
1697 xs=x(1,n)-x(1,m)
1698 ys=x(2,n)-x(2,m)
1699 zs=x(3,n)-x(3,m)
1700 CALL cdi_skew(xs,ys,zs,jt,jr,skew,cdt,cdr,cdtr,jt1,jr1,irad)
1701C-------Update K,
1702 CALL updcdik2_cdi(nd,cdt,cdr,cdtr,kii)
1703 DO k=1,6
1704 diag_km(k)=diag_km(k)+kii(k,k)
1705 ENDDO
1706 IF (nt>0.AND.nt<3) THEN
1707 ic = jt(1)*4+jt(2)*2+jt(3)
1708 CALL bcl_impkd(ic ,i1 ,skew ,kii ,diag_kn )
1709 ENDIF
1710 IF (nr>0.AND.nr<3) THEN
1711 ic = jr(1)*4+jr(2)*2+jr(3)
1712 DO k=1,3
1713 DO j=1,3
1714 kii(k,j)=kdd(k+3,j+3)
1715 ENDDO
1716 ENDDO
1717 CALL bcl_impkd(ic ,i1 ,skew ,kii ,diag_kn(4))
1718 ENDIF
1719 ENDIF
1720C
1721 RETURN
1722 END
1723!||====================================================================
1724!|| rbe2_frk ../engine/source/constraints/general/rbe2/rbe2_imp0.F
1725!||--- called by ------------------------------------------------------
1726!|| upd_kml ../engine/source/mpi/implicit/imp_fri.F
1727!|| upd_ksl ../engine/source/mpi/implicit/imp_fri.F
1728!||--- calls -----------------------------------------------------
1729!|| cdi_skew ../engine/source/constraints/general/rbe2/rbe2_imp0.F
1730!|| put_kmii ../engine/source/implicit/imp_glob_k.F
1731!|| updcdik2_cdi ../engine/source/constraints/general/rbe2/rbe2_imp0.F
1732!|| updk2_cdi ../engine/source/constraints/general/rbe2/rbe2_imp0.F
1733!||====================================================================
1734 SUBROUTINE rbe2_frk(NS ,M ,X ,ISK ,SKEW0 ,
1735 1 IRAD ,NDOF ,IDDL ,JT ,JR ,
1736 2 IADK ,JDIK ,DIAG_K,LT_K ,B ,
1737 3 A ,KSS ,KSM ,KNM ,KRM ,
1738 4 IDLM ,ISS,ISM )
1739C-----------------------------------------------
1740C I m p l i c i t T y p e s
1741C-----------------------------------------------
1742#include "implicit_f.inc"
1743C-----------------------------------------------
1744C D u m m y A r g u m e n t s
1745C-----------------------------------------------
1746 INTEGER IADK(*),JDIK(*),NDOF(*),IDDL(*),IRAD,
1747 . m, ns,idlm ,iss,ism,isk,jt(3),jr(3)
1748C REAL
1749 my_real
1750 . x(3,*),diag_k(*),lt_k(*),b(*),a(3,*),
1751 . kss(6),ksm(3,3),knm(3,3),krm(3,3),skew0(*)
1752C-----------------------------------------------
1753C C o m m o n B l o c k s
1754C-----------------------------------------------
1755#include "param_c.inc"
1756C-----------------------------------------------
1757C L o c a l V a r i a b l e s
1758C-----------------------------------------------
1759 INTEGER I, J, J1, J2, J3, J4, K, JD, II, L, JJ,
1760 . ND,NDI,NDJ,NDM,NM,L1,NM1,
1761 . IMD,N,NT,NR,IC,JT1(3),JR1(3),NDOFI
1762C REAL
1763 my_real
1764 . xs,ys,zs,cdt(3,3),cdtr(3,3),cdr(3,3),skew(lskew),
1765 . kdd(6,6)
1766C-------------------B is not modified-----------------
1767 nd = ndof(m)
1768 ndofi = 3
1769 IF (isk>1) THEN
1770 DO k=1,lskew
1771 skew(k)=skew0(k)
1772 ENDDO
1773 ELSE
1774 DO k=1,lskew
1775 skew(k)=zero
1776 ENDDO
1777 skew(1)=one
1778 skew(5)=one
1779 skew(9)=one
1780 ENDIF
1781 n = ns
1782C
1783 DO k=1,6
1784 DO j=1,6
1785 kdd(k,j)=zero
1786 ENDDO
1787 ENDDO
1788 IF (iss>0) THEN
1789 DO k=1,ndofi
1790 kdd(k,k) = kss(k)
1791 ENDDO
1792 kdd(1,2) = kss(4)
1793 kdd(1,3) = kss(5)
1794 kdd(2,3) = kss(6)
1795 xs=x(1,n)-x(1,m)
1796 ys=x(2,n)-x(2,m)
1797 zs=x(3,n)-x(3,m)
1798 CALL cdi_skew(xs,ys,zs,jt,jr,skew,cdt,cdr,cdtr,jt1,jr1,irad)
1799C-------Update K,
1800 CALL updcdik2_cdi(nd,cdt,cdr,cdtr,kdd)
1801 CALL put_kmii(idlm,iadk,diag_k,lt_k,kdd,nd)
1802 ENDIF
1803 IF (ism>0) THEN
1804C--------no diag--Kjm=sum(KjsCsm)--
1805 DO k=1,ndofi
1806 DO j=1,ndofi
1807 kdd(k,j) = ksm(k,j)
1808 ENDDO
1809 ENDDO
1810 xs=x(1,n)-x(1,m)
1811 ys=x(2,n)-x(2,m)
1812 zs=x(3,n)-x(3,m)
1813 CALL cdi_skew(xs,ys,zs,jt,jr,skew,cdt,cdr,cdtr,jt1,jr1,irad)
1814C------- Update ---
1815 CALL updk2_cdi(ndofi,ndofi,cdt,cdr,cdtr,kdd)
1816 DO k=1,ndofi
1817 DO j=1,ndofi
1818 knm(k,j)=kdd(j,k)
1819 krm(k,j)=kdd(j,k+ndofi)
1820 ENDDO
1821 ENDDO
1822 ENDIF
1823C
1824 RETURN
1825 END
1826
bc_updk
subroutine bc_updk(n, iddl, ej, jj, ir, iadk, jdik, diag_k, lt_k)
Definition bc_imp0.F:491
l_dir
subroutine l_dir(ej, j)
Definition bc_imp0.F:405
bcl_impkd
subroutine bcl_impkd(ict, isk, skew, kdd, diag_k)
Definition bc_imp0.F:914
my_real
#define my_real
Definition cppsort.cpp:32
print_wkij
subroutine print_wkij(ni, nj, iflag)
Definition imp_glob_k.F:890
put_kmii
subroutine put_kmii(id, iadk, k_diag, k_lt, kii, nd)
Definition imp_glob_k.F:1186
put_kii
subroutine put_kii(ni, iddl, iadk, k_diag, k_lt, kii, nd)
Definition imp_glob_k.F:653
put_kij
subroutine put_kij(ni, nj, iddl, iadk, jdik, k_lt, kij, nk, nl, ierr)
Definition imp_glob_k.F:810
get_kii
subroutine get_kii(ni, iddl, iadk, k_diag, k_lt, kii, nd)
Definition imp_glob_k.F:591
get_kij
subroutine get_kij(ni, nj, iddl, iadk, jdik, k_lt, kij, nk, nl, ierr)
Definition imp_glob_k.F:713
prerbe2
subroutine prerbe2(irbe2, jt, jr)
Definition kinchk.F:1974
min
#define min(a, b)
Definition macros.h:20
rbe2_impr1
subroutine rbe2_impr1(irbe2, lrbe2, x, skew, ndof, iddl, b, weight)
Definition rbe2_imp0.F:464
updk2_cdi
subroutine updk2_cdi(ni, nj, cdt, cdr, cdtr, kdd)
Definition rbe2_imp0.F:751
rbe2_impbl
subroutine rbe2_impbl(m, nsn, isl, x, jt, jr, ndof, iddl, b, skew, irad)
Definition rbe2_imp0.F:597
cdi_bcn1
subroutine cdi_bcn1(xs, ys, zs, jt, jr, skew, ktr, irad)
Definition rbe2_imp0.F:1449
rbe2_frk
subroutine rbe2_frk(ns, m, x, isk, skew0, irad, ndof, iddl, jt, jr, iadk, jdik, diag_k, lt_k, b, a, kss, ksm, knm, krm, idlm, iss, ism)
Definition rbe2_imp0.F:1739
rbe2_bcl
subroutine rbe2_bcl(ict, skew, iadn, ifix, iadk, jdik, diag_k, lt_k, i, ir)
Definition rbe2_imp0.F:866
rbe2_impb0
subroutine rbe2_impb0(m, nsn, isl, x, jt, jr, ndof, iddl, b, irad)
Definition rbe2_imp0.F:516
rbe2impbsn
subroutine rbe2impbsn(nsl, isl, b, ict, ndof, iddl, skew, ir)
Definition rbe2_imp0.F:1167
rbe2_imp0
subroutine rbe2_imp0(irbe2, lrbe2, x, nsrb2, isb2, ikc, ndof, iddl, iadk, jdik, diag_k, lt_k, b, weight, itab, skew)
Definition rbe2_imp0.F:37
rbe2_imp1
subroutine rbe2_imp1(m, nsn, isl, x, nsj, isj, jt, jr, ikc, ndof, iddl, iadk, jdik, diag_k, lt_k, b, itab, irad)
Definition rbe2_imp0.F:184
rbe2_impi
subroutine rbe2_impi(irbe2, lrbe2, x, skew, nsb2, isb2, ikc, ndof, iddl, iadk, jdik, diag_k, lt_k, b, weight, itab)
Definition rbe2_imp0.F:102
cdi_bcn
subroutine cdi_bcn(ict, skew, jt, kt, jt1)
Definition rbe2_imp0.F:1012
bc_updk2
subroutine bc_updk2(n, iddl, j, l, k, ir, ej, el, iadk, jdik, diag_k, lt_k)
Definition rbe2_imp0.F:1320
sym_kdd
subroutine sym_kdd(nd, kdd)
Definition rbe2_imp0.F:684
rbe2_impl
subroutine rbe2_impl(m, nsn, isl, x, nsj, isj, jt, jr, ikc, ndof, iddl, iadk, jdik, diag_k, lt_k, b, skew, itab, irad)
Definition rbe2_imp0.F:324
updcdik2_cdi
subroutine updcdik2_cdi(nd, cdt, cdr, cdtr, kdd)
Definition rbe2_imp0.F:810
rbe2_impkd
subroutine rbe2_impkd(m, ns, x, isk, jt, jr, ndof, skew0, kdd, diag_km, diag_kn, irad)
Definition rbe2_imp0.F:1645
cdi_skew
subroutine cdi_skew(xs, ys, zs, jt, jr, skew, kt, kr, ktr, jt1, jr1, irad)
Definition rbe2_imp0.F:719
dir_rbe2
subroutine dir_rbe2(j, j1, k)
Definition rbe2v.F:714
updk_bc2
subroutine updk_bc2(jt, jr, k, istif)
Definition rbe3_imp0.F:663
updk_bc
subroutine updk_bc(jt, jr, k, istif)
Definition rbe3_imp0.F:615
updkb_rb
subroutine updkb_rb(ndl, xs, ys, zs, kdd, bd)
Definition rby_imp0.F:324
updb_rb
subroutine updb_rb(ndl, xs, ys, zs, bd)
Definition rby_imp0.F:773
updkb_rb1
subroutine updkb_rb1(ni, nj, xs, ys, zs, kdd)
Definition rby_imp0.F:425