OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
kinchk.F File Reference
#include "implicit_f.inc"
#include "com04_c.inc"
#include "kincod_c.inc"
#include "lagmult.inc"
#include "param_c.inc"
#include "scr17_c.inc"
#include "scr03_c.inc"
#include "units_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine kinchk (ikine, rwl, itab, nprw, lprw, kinet, npby, lpby, irbe2, lrbe2, irbe3, lrbe3, nom_opt, ptr_nopt_rwall, ptr_nopt_rbe2, ptr_nopt_rbe3, itagcyc)
subroutine kinrem (ikine, ikinew, rwl, itab, nprw, lprw, npby, lpby)
subroutine inivchk (ikine, rwl, itab, nprw, lprw, kinet, npby, lpby, irbe2, lrbe2, irbe3, lrbe3, frbe3, x, skew, v, vr)
subroutine rby_v0 (x, nod, m, nsn, d, dr)
subroutine rbe3_impd (irbe3, lrbe3, x, d, dr, frbe3, skew)
subroutine prerbe3 (irbe3, max_m, irotg, jt, jr)
subroutine rbe3cl (inrbe3, ilrbe3, ns, xyz, frbe3, skew, ng, irot, fdstnb, mdstnb)
subroutine rbe2_impd (irbe2, lrbe2, x, d, dr, skew)
subroutine prerbe2 (irbe2, jt, jr)
subroutine rbe2d0 (nsl, isl, x, v, vr, jt, jr, m)
subroutine rbe2dl (nsn, isl, x, v, vr, jt, jr, m, skew)

Function/Subroutine Documentation

◆ inivchk()

subroutine inivchk ( integer, dimension(*) ikine,
rwl,
integer, dimension(*) itab,
integer, dimension(*) nprw,
integer, dimension(*) lprw,
integer, dimension(*) kinet,
integer, dimension(nnpby,*) npby,
integer, dimension(*) lpby,
integer, dimension(nrbe2l,*) irbe2,
integer, dimension(*) lrbe2,
integer, dimension(nrbe3l,*) irbe3,
integer, dimension(*) lrbe3,
frbe3,
x,
skew,
v,
vr )

Definition at line 1288 of file kinchk.F.

1291C-----------------------------------------------
1292C I m p l i c i t T y p e s
1293C-----------------------------------------------
1294#include "implicit_f.inc"
1295C-----------------------------------------------
1296C C o m m o n B l o c k s
1297C-----------------------------------------------
1298#include "com04_c.inc"
1299#include "lagmult.inc"
1300#include "param_c.inc"
1301C-----------------------------------------------------------------
1302C D u m m y A r g u m e n t s
1303C-----------------------------------------------
1304 INTEGER IKINE(*),NPRW(*), LPRW(*),ITAB(*),KINET(*),
1305 . NPBY(NNPBY,*), LPBY(*),IRBE2(NRBE2L,*),LRBE2(*),
1306 . IRBE3(NRBE3L,*),LRBE3(*)
1307 my_real
1308 . rwl(nrwlp,*),v(3,*),vr(3,*),x(3,*),frbe3(*),skew(*)
1309C-----------------------------------------------
1310C L o c a l V a r i a b l e s
1311C-----------------------------------------------
1312 INTEGER I, J, K, L, N, KK, IKK, IKK2, NK, JWARN, ITYP, NE, NSL,
1313 . IK(10), RBWARN, RB2WARN, KRB, NSLRB,ICDG,ISEN,M
1314C-----------------------------------------------------------------
1315C=======================================================================
1316C CORRECTIONS AUTOMATIQUES INITIAL VELOCITIES
1317C=======================================================================
1318C should be done in hierarchy order: RBODY,RBE3,RBE2,int2...
1319C-----------------------------------------------------------------
1320 k=1
1321 DO i=1,nrbykin
1322 m =npby(1,i)
1323 nsl=npby(2,i)
1324 icdg=npby(3,i)
1325 isen=npby(4,i)
1326 IF (isen==0) THEN
1327 CALL rby_v0(x ,lpby(k) ,m ,nsl ,v ,vr )
1328 ENDIF
1329 k = k + nsl
1330 ENDDO
1331C-----------------------------------------------------------------
1332 DO i=nrbykin+1,nrbylag
1333 m =npby(1,i)
1334 nsl=npby(2,i)
1335 icdg=npby(3,i)
1336 isen=npby(4,i)
1337 IF (isen==0) THEN
1338 CALL rby_v0(x ,lpby(k) ,m ,nsl ,v ,vr )
1339 ENDIF
1340 k = k + 3*nsl
1341 ENDDO
1342C-----------------------------------------------------------------
1343 IF(nrbe3>0)THEN
1344 CALL rbe3_impd(irbe3 ,lrbe3 ,x ,v ,vr ,
1345 1 frbe3 ,skew )
1346 ENDIF
1347C-----------------------------------------------------------------
1348 IF(nrbe2>0)THEN
1349 CALL rbe2_impd(irbe2 ,lrbe2 ,x ,v ,vr ,
1350 1 skew )
1351 ENDIF
1352C-----------------------------------------------------------------
1353
1354 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
rbe2_impd
subroutine rbe2_impd(irbe2, lrbe2, x, d, dr, skew)
Definition kinchk.F:1928
rbe3_impd
subroutine rbe3_impd(irbe3, lrbe3, x, d, dr, frbe3, skew)
Definition kinchk.F:1406
rby_v0
subroutine rby_v0(x, nod, m, nsn, d, dr)
Definition kinchk.F:1362

◆ kinchk()

subroutine kinchk ( integer, dimension(*) ikine,
rwl,
integer, dimension(*) itab,
integer, dimension(*) nprw,
integer, dimension(*) lprw,
integer, dimension(*) kinet,
integer, dimension(nnpby,*) npby,
integer, dimension(*) lpby,
integer, dimension(nrbe2l,*) irbe2,
integer, dimension(*) lrbe2,
integer, dimension(nrbe3l,*) irbe3,
integer, dimension(*) lrbe3,
integer, dimension(lnopt1,*) nom_opt,
integer ptr_nopt_rwall,
integer ptr_nopt_rbe2,
integer ptr_nopt_rbe3,
integer, dimension(*) itagcyc )

Definition at line 34 of file kinchk.F.

38 USE message_mod
39 USE names_and_titles_mod , ONLY : nchartitle
40 USE format_mod, ONLY : fmw_a_i_a, fmw_10i
41C-----------------------------------------------
42C I m p l i c i t T y p e s
43C-----------------------------------------------
44#include "implicit_f.inc"
45C-----------------------------------------------
46C C o m m o n B l o c k s
47C-----------------------------------------------
48#include "com04_c.inc"
49#include "kincod_c.inc"
50#include "lagmult.inc"
51#include "param_c.inc"
52#include "scr17_c.inc"
53#include "scr03_c.inc"
54#include "units_c.inc"
55C-----------------------------------------------------------------
56C D u m m y A r g u m e n t s
57C-----------------------------------------------
58 INTEGER NOM_OPT(LNOPT1,*),PTR_NOPT_RWALL,PTR_NOPT_RBE2,
59 . PTR_NOPT_RBE3
60 INTEGER IKINE(*),NPRW(*), LPRW(*),ITAB(*),KINET(*),
61 . NPBY(NNPBY,*), LPBY(*),IRBE2(NRBE2L,*),LRBE2(*),
62 . IRBE3(NRBE3L,*),LRBE3(*),
63 . INOPT_RWALL,INOPT_RBE2,INOPT_RBE3,ITAGCYC(*)
64 my_real
65 . rwl(nrwlp,*)
66C-----------------------------------------------
67C L o c a l V a r i a b l e s
68C-----------------------------------------------
69 INTEGER I, J, K, L, N, KK, IKK, IKK2, NK, JWARN, ITYP, NE, NSL,
70 . IK(10), RBWARN, RB2WARN, KRB, NSLRB,
71 . MARQUEUR(8192),
72 . MARQUEURDOUBLE(13),J1,FLAG_IKCOND,MARQ2,MARQM2,
73 . NS,NM,M,IAD,NUN,JJ,NIKRW,IPEN
74 INTEGER, DIMENSION(:), ALLOCATABLE :: NKINDOUBLE,NKIN,IKRW
75 INTEGER ID
76 CHARACTER(LEN=NCHARTITLE) :: TITR
77C-----------------------------------------------------------------
78 ALLOCATE(nkindouble(numnod),nkin(numnod),ikrw(numnod))
79 marq2 = 0
80 marqm2 = 0
81C=======================================================================
82C CORRECTIONS AUTOMATIQUES INTERFACE 1,2,9 OU RBODY AVEC RWALL
83C=======================================================================
84 k=0
85 kk=0
86 rbwarn = 0
87 rb2warn = 0
88 DO n=1,nrwall
89
90 jwarn = 0
91 nsl=nprw(n)
92 ityp=nprw(n+3*nrwall)
93 j=0
94 DO l=1,nsl
95 i=lprw(k+l)
96 ikk=iabs(ikine(i))
97 IF(irb(ikk)/=0.OR.itf(ikk)/=0)THEN
98 rbwarn = rbwarn + 1
99 jwarn = jwarn+1
100 IF(irb(ikk)/=0 .AND. marq2 == 0) marq2 = 1
101 IF(itf(ikk)/=0 .AND. marqm2 == 0) marqm2 = 1
102 IF(iwl(ikine(i))==1)ikine(i) = ikine(i) - 4
103
104 ELSE
105 IF (irb2(ikk)/=0) rb2warn = rb2warn + 1
106 j=j+1
107 lprw(kk+j)=lprw(k+l)
108 ENDIF
109 ENDDO
110 k = k+nsl
111 nsl=j
112 kk = kk+nsl
113 nprw(n)=nsl
114 IF(ityp<0)THEN
115 ne=nint(rwl(8,n))
116 DO i=1,ne
117 lprw(kk+i)=lprw(k+i)
118 ENDDO
119 k = k+ne
120 kk = kk+ne
121 ENDIF
122 IF (jwarn>0) THEN
123 id=nom_opt(1,ptr_nopt_rwall+n)
124 CALL fretitl2(titr,
125 . nom_opt(lnopt1-ltitr+1,ptr_nopt_rwall+n),ltitr)
126 CALL ancmsg(msgid=446,
127 . msgtype=msgwarning,
128 . anmode=aninfo_blind_2,
129 . i1=id,
130 . c1=titr,
131 . i2=jwarn)
132 ENDIF
133 ENDDO
134C
135c CALL ANCHECK(71)
136C----------------------------------------------------------
137C - no-autorised hierarchy :Check des noeuds mains des RBE3 sont SECONDARY de RBE2,or INT2
138C----------------------------------------------------------
139! look at compatibility w/ BCS,RBODY and compute nrbe3_gp, ini penealty
140 nun=0
141 DO i=1,nrbe3
142 iad = irbe3(1,i)
143 ipen= irbe3(9,i)
144 IF (ipen>0) cycle
145 nm = irbe3(5,i)
146 DO j =1,nm
147 m = lrbe3(iad+j)
148 id=nom_opt(1,ptr_nopt_rbe3+i)
149 CALL fretitl2(titr,
150 . nom_opt(lnopt1-ltitr+1,ptr_nopt_rbe3+i),ltitr)
151 IF (ikrbe2(ikine(m))==1) THEN
152 IF (ipen<0) THEN !error out
153 CALL ancmsg(msgid=805,
154 . msgtype=msgerror,
155 . anmode=aninfo_blind_1,
156 . i1=id,
157 . c1=titr,
158 . i2=itab(m))
159 RETURN
160 ELSE !switch to penalty
161 CALL ancmsg(msgid=3100,
162 . msgtype=msgwarning,
163 . anmode=aninfo_blind_1,
164 . i1=id,
165 . c1=titr,
166 . i2=itab(m))
167 irbe3(9,i) = 1
168 END IF !(IPEN<0)
169 ENDIF
170 IF (itf(ikine(m))==1) THEN
171 IF (ipen<0) THEN !error out
172 CALL ancmsg(msgid=1035,
173 . msgtype=msgerror,
174 . anmode=aninfo_blind_1,
175 . i1=id,
176 . c1=titr,
177 . i2=itab(m))
178 RETURN
179 ELSE !switch to penalty
180 CALL ancmsg(msgid=3096,
181 . msgtype=msgwarning,
182 . anmode=aninfo_blind_1,
183 . i1=id,
184 . c1=titr,
185 . i2=itab(m))
186 irbe3(9,i) = 1
187 END IF !(IPEN<0)
188 ENDIF
189 ENDDO
190 ENDDO
191C----------------------------------------------------------
192C - no-autorised hierarchy :Check des noeuds mains des RBE2 SECONDARY de INT2
193C----------------------------------------------------------
194 DO i=1,nrbe2
195 m = irbe2(3,i)
196 id=nom_opt(1,ptr_nopt_rbe2+i)
197 CALL fretitl2(titr,
198 . nom_opt(lnopt1-ltitr+1,ptr_nopt_rbe2+i),ltitr)
199 IF (itf(ikine(m))==1) THEN
200 CALL ancmsg(msgid=1036,
201 . msgtype=msgerror,
202 . anmode=aninfo_blind_1,
203 . i1=id,
204 . c1=titr,
205 . i2=itab(m))
206 RETURN
207 ENDIF
208 ENDDO
209C----------------------------------------------------------
210C - no-autorised hierarchy :Check des noeuds mains des RBODY sont SECONDARY de RBE2
211C----------------------------------------------------------
212 DO i=1,nrbody
213 m=npby(1,i)
214 IF (ikrbe2(ikine(m))==1) THEN
215C CALL ANCWARN(806,ANINFO_BLIND_1)
216C NUN=NUN+1
217 id=nom_opt(1,i)
218 CALL fretitl2(titr,
219 . nom_opt(lnopt1-ltitr+1,i),ltitr)
220 CALL ancmsg(msgid=806,
221 . msgtype=msgerror,
222 . anmode=aninfo_blind_1,
223 . i1=id,
224 . c1=titr,
225 . i2=itab(m))
226 RETURN
227 ENDIF
228 ENDDO
229C----------------------------------------------------------
230C - no-autorised hierarchy :Check des noeuds mains des RBODY sont SECONDARY de RBE3
231C----------------------------------------------------------
232 DO i=1,nrbody
233 m=npby(1,i)
234 IF (ikrbe3(ikine(m))==1) THEN ! add here the case of switching to penalty of RBE3
235 DO n=1,nrbe3
236 nsl= irbe3(3,n)
237 ipen= irbe3(9,n)
238 IF (ipen>0) cycle
239 IF (nsl==m) THEN
240 IF (ipen<0) THEN
241 id=nom_opt(1,i)
242 CALL fretitl2(titr,
243 . nom_opt(lnopt1-ltitr+1,i),ltitr)
244 CALL ancmsg(msgid=810,
245 . msgtype=msgerror,
246 . anmode=aninfo_blind_1,
247 . i1=id,
248 . c1=titr,
249 . i2=itab(m))
250 RETURN
251 ELSE ! switch to penalty of RBE3
252 id = irbe3(2,n)
253 CALL fretitl2(titr,
254 . nom_opt(lnopt1-ltitr+1,ptr_nopt_rbe3+n),ltitr)
255 CALL ancmsg(msgid=3104,
256 . msgtype=msgwarning,
257 . anmode=aninfo_blind_1,
258 . i1=id,
259 . c1=titr,
260 . i2=itab(m))
261 irbe3(9,n) = 1
262 END IF ! (IPEN<0) THEN
263 END IF
264 END DO
265 END IF
266 ENDDO
267C----------------------------------------------------------
268C - Check des noeuds mains des RBE2 sont mains de RBODY
269C----------------------------------------------------------
270 DO i=1,nrbe2
271 m = irbe2(3,i)
272 DO j =1,nrbody
273 IF(npby(1,j)==m)THEN
274 id=nom_opt(1,ptr_nopt_rbe2+i)
275 CALL fretitl2(titr,
276 . nom_opt(lnopt1-ltitr+1,ptr_nopt_rbe2+i),ltitr)
277 CALL ancmsg(msgid=807,
278 . msgtype=msgerror,
279 . anmode=aninfo_blind_1,
280 . i1=id,
281 . c1=titr,
282 . i2=itab(m))
283 RETURN
284 ENDIF
285 ENDDO
286 ENDDO
287C----------------------------------------------------------
288C - Check des noeuds mains des Rbody SECONDARY d'autres Rbodies
289C----------------------------------------------------------
290 krb = 0
291 DO n=1,nrbykin
292 nslrb = npby(2,n)
293 krb= krb+nslrb
294 ENDDO
295 DO n=1,nrbylag
296 nslrb = npby(2,n)
297 krb= krb+3*nslrb ! possible zeros in LPBY
298 ENDDO
299 DO n=1,nrbykin
300 id=nom_opt(1,n)
301 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,n),ltitr)
302 DO i=1,krb
303 IF(npby(1,n)==lpby(i))THEN
304 CALL ancmsg(msgid=555,
305 . msgtype=msgwarning,
306 . anmode=aninfo_blind_2,
307 . i1=id,
308 . c1=titr,
309 . i2=itab(npby(1,n)))
310 ENDIF
311 ENDDO
312 ENDDO
313C----------------------------------------------------------
314C - Check incompatibility /BCS/CYCLIC
315C----------------------------------------------------------
316 IF (nbcscyc>0) THEN
317 DO i=1,numnod
318 IF (itagcyc(i)==0 .OR. ikine(i)==0) cycle
319C------- RBODY
320 IF (irb(ikine(i))/=0 ) THEN
321 k=0
322 DO n=1,nrbykin
323 nsl=npby(2,n)
324C------ not w/ Sensor
325 IF(npby(7,n)/=0)THEN
326 id=nom_opt(1,n)
327 DO j=1,nsl
328 IF (lpby(j+k)==i) THEN
329 CALL ancmsg(msgid=1754,anmode=aninfo,msgtype=msgerror,
330 . i1=itagcyc(i),i2=itab(i),i3=id)
331 END IF
332 ENDDO
333 ENDIF
334 k=k+nsl
335 ENDDO
336 END IF !(IRB(IKINE(I))/=0 ) THEN
337C------- RBE2
338 IF (ikrbe2(ikine(i))/=0 ) THEN
339 DO n=1,nrbe2
340 k = irbe2(1,n)
341 nsl= irbe2(5,n)
342 id = irbe2(2,n)
343 DO j=1,nsl
344 IF (lrbe2(j+k)==i) THEN
345 CALL ancmsg(msgid=1755,anmode=aninfo,msgtype=msgerror,
346 . i1=itagcyc(i),i2=itab(i),i3=id)
347 END IF
348 ENDDO
349 ENDDO
350 END IF
351C------- RBE3
352 IF (ikrbe3(ikine(i))/=0 ) THEN ! will be looked after
353 DO n=1,nrbe3
354 nsl= irbe3(3,n)
355 id = irbe3(2,n)
356 IF (nsl==i) THEN
357 CALL ancmsg(msgid=1756,anmode=aninfo,msgtype=msgerror,
358 . i1=itagcyc(i),i2=itab(i),i3=id)
359 END IF
360 ENDDO
361 END IF
362C------- RLINK
363 IF (irlk(ikine(i))/=0 ) THEN
364 CALL ancmsg(msgid=1757,anmode=aninfo,msgtype=msgerror,
365 . i1=itagcyc(i),i2=itab(i))
366 END IF
367 ENDDO
368 END IF !(NBCSCYC>0) THEN
369C=======================================================================
370 IF(ipri>=6)THEN
371 WRITE(iout,*)' NODES WITH KINEMATIC CONDITIONS:'
372 WRITE(iout,*)' --------------------------------'
373 k = 0
374 DO i=1,numnod
375 IF(ikine(i)/=0)THEN
376 k = k + 1
377 ik(k) = itab(i)
378 IF(k==10)THEN
379 WRITE(iout,fmt=fmw_10i)(ik(j),j=1,k)
380 k = 0
381 ENDIF
382 ENDIF
383 ENDDO
384 IF(k/=10) WRITE(iout,fmt=fmw_10i)(ik(j),j=1,k)
385 ENDIF
386C
387C---------------------------------------------------------------
388C LISTE CONDITIONS INCOMPATIBLES PAR TYPE
389C LISTE DES NOEUDS CONCERNES
390C
391C NKIN(I) >= 2 => POSSIBLE CONDITIONS INCOMPATIBLES SUR LE NOEUD I
392C FLAG_IKCOND = 1 => CONDITIONS INCOMPATIBLES DANS LE MODELE
393C MARQUEURDOUBLE(I) = 1 => CONDITIONS INCOMPATIBLES ENTRE CONDITIONS
394C DE MEME TYPE SUR LE NOEUD I
395C MARQUEUR(I) != 0 => CONDITIONS INCOMPATIBLES ENTRE CONDITIONS
396C DE TYPES DIFFERENTS SUR LE NOEUD I
397C MARQUEUR(I) = 2 => CAS RBODY + RWALL
398C MARQUEUR(I) =-2 => CAS INTERFACES TYPE 1,2,9 + RWALL
399C MARQUEUR(I) = 3 => CAS INTERFACES TYPE 1,2,9 + RBODY + RWALL
400C---------------------------------------------------------------
401 DO i=1,numnod
402 nkin(i) = 0
403 nkindouble(i) = 0
404 ENDDO
405 DO i=1,numnod
406 nkin(i) = ibc(ikine(i))+itf(ikine(i))+iwl(ikine(i))+
407 . irb(ikine(i))+irb2(ikine(i))+
408 . ivf(ikine(i))+irv(ikine(i))+ijo(ikine(i))+
409 . irbm(ikine(i))+ilmult(ikine(i))+irlk(ikine(i))+
410 . ikrbe2(ikine(i))+ikrbe3(ikine(i))+
411 . ibc(ikine(i+3*numnod))+itf(ikine(i+3*numnod))+
412 . iwl(ikine(i+3*numnod))+irb(ikine(i+3*numnod))+
413 . irb2(ikine(i+3*numnod))+ivf(ikine(i+3*numnod))+
414 . irv(ikine(i+3*numnod))+ijo(ikine(i+3*numnod))+
415 . irbm(ikine(i+3*numnod))+ilmult(ikine(i+3*numnod))+
416 . irlk(ikine(i+3*numnod))+ikrbe2(ikine(i+3*numnod))+
417 . ikrbe3(ikine(i+3*numnod))
418 ENDDO
419C---------------------------------------------------------------
420 flag_ikcond = 0
421 DO i=1,8192
422 marqueur(i) = 0
423 ENDDO
424 DO i=1,13
425 marqueurdouble(i) = 0
426 ENDDO
427 DO i=1,numnod
428 IF(nkin(i)>=2)THEN
429 IF (ibc(ikine(i))== 1
430 . .AND. ibc(ikine(i+3*numnod))== 1) THEN
431 marqueurdouble(1) = 1
432 flag_ikcond = 1
433 ENDIF
434 IF (itf(ikine(i))== 1
435 . .AND. itf(ikine(i+3*numnod))== 1) THEN
436 marqueurdouble(2) = 1
437 flag_ikcond = 1
438 ENDIF
439 IF (iwl(ikine(i))== 1
440 . .AND. iwl(ikine(i+3*numnod))== 1) THEN
441 marqueurdouble(3) = 1
442 flag_ikcond = 1
443 ENDIF
444 IF (irb(ikine(i))== 1
445 . .AND. irb(ikine(i+3*numnod))== 1) THEN
446 marqueurdouble(4) = 1
447 flag_ikcond = 1
448 ENDIF
449 IF (irb2(ikine(i))== 1
450 . .AND. irb2(ikine(i+3*numnod))== 1) THEN
451 marqueurdouble(5) = 1
452 flag_ikcond = 1
453 ENDIF
454 IF (ivf(ikine(i))== 1
455 . .AND. ivf(ikine(i+3*numnod))== 1) THEN
456 marqueurdouble(6) = 1
457 flag_ikcond = 1
458 ENDIF
459 IF (irv(ikine(i))== 1
460 . .AND. irv(ikine(i+3*numnod))== 1) THEN
461 marqueurdouble(7) = 1
462 flag_ikcond = 1
463 ENDIF
464 IF (ijo(ikine(i))== 1
465 . .AND. ijo(ikine(i+3*numnod))== 1) THEN
466 marqueurdouble(8) = 1
467 flag_ikcond = 1
468 ENDIF
469 IF (irbm(ikine(i))== 1
470 . .AND. irbm(ikine(i+3*numnod))== 1) THEN
471 marqueurdouble(9) = 1
472 flag_ikcond = 1
473 ENDIF
474 IF (ilmult(ikine(i))== 1
475 . .AND. ilmult(ikine(i+3*numnod))== 1) THEN
476 marqueurdouble(10) = 1
477 flag_ikcond = 1
478 ENDIF
479 IF (irlk(ikine(i))== 1
480 . .AND. irlk(ikine(i+3*numnod))== 1) THEN
481 marqueurdouble(11) = 1
482 flag_ikcond = 1
483 ENDIF
484 IF (ikrbe2(ikine(i))== 1
485 . .AND. ikrbe2(ikine(i+3*numnod))== 1) THEN
486 marqueurdouble(12) = 1
487 flag_ikcond = 1
488 ENDIF
489 IF (ikrbe3(ikine(i))== 1
490 . .AND. ikrbe3(ikine(i+3*numnod))== 1) THEN
491 marqueurdouble(13) = 1
492 flag_ikcond = 1
493 ENDIF
494 ENDIF
495 ENDDO
496C---------------------------------------------------------------
497 nikrw = 0
498 DO i = 1,numnod
499 IF ( ikine(i) /= 0 .AND. ikine(i)/=1 .AND. ikine(i)/=2
500 . .AND. ikine(i)/=4 .AND. ikine(i)/=8 .AND. ikine(i)/=16
501 . .AND. ikine(i)/=32 .AND. ikine(i)/=64
502 . .AND. ikine(i)/=128 .AND. ikine(i)/=256
503 . .AND. ikine(i)/=512 .AND. ikine(i)/=1024
504 . .AND. ikine(i)/=2048 .AND. ikine(i)/=4096
505 . .AND. ikine(i+4*numnod) /= 0 ) THEN
506 IF(iwl(ikine(i))== 1 .AND. irb(ikine(i))== 1
507 . .AND. itf(ikine(i))== 1 )THEN
508 IF (ikine(i)>14) THEN
509 marqueur(ikine(i)) = 3
510 flag_ikcond = 1
511 ELSE
512 marqueur(ikine(i)) = 0
513 ENDIF
514 ELSEIF(iwl(ikine(i))== 1 .AND. irb(ikine(i))== 1)THEN
515 IF (ikine(i)>12) THEN
516 marqueur(ikine(i)) = 2
517 flag_ikcond = 1
518 ELSE
519 marqueur(ikine(i)) = 0
520 ENDIF
521 ELSEIF(iwl(ikine(i))== 1 .AND. itf(ikine(i))== 1)THEN
522 IF (ikine(i)>6) THEN
523 marqueur(ikine(i)) = -2
524 flag_ikcond = 1
525 ELSE
526 marqueur(ikine(i)) = 0
527 ENDIF
528 ELSE
529 marqueur(ikine(i)) = 1
530 flag_ikcond = 1
531 nikrw = nikrw + 1
532 ikrw(nikrw) = itab(i)
533 ENDIF
534 ENDIF
535 ENDDO
536C---------------------------------------------------------------
537 IF (ipri>=6 .AND. flag_ikcond==1) THEN
538 WRITE(iout,*)' '
539 WRITE(iout,*)
540 . 'LIST OF POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS :'
541 WRITE(iout,*)'--------------------------------------------------'
542 WRITE(iout,*)' '
543
544 DO i=1,13
545 IF ( marqueurdouble(i) == 1 )THEN
546 IF ( i == 1) THEN
547 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
548 .ETWEEN'
549 WRITE(iout,*)' SEVERAL BOUNDARY CONDITIONS :'
550 WRITE(iout,*)' '
551 WRITE(iout,*)'NODES :'
552 k = 0
553 DO j = 1,numnod
554 IF (ibc(ikine(j))== 1
555 . .AND. ibc(ikine(j+3*numnod))== 1) THEN
556 k = k + 1
557 ik(k) = itab(j)
558 IF(k==10)THEN
559 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
560 k = 0
561 ENDIF
562 ENDIF
563 ENDDO
564 IF(k/=0)THEN
565 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
566 ENDIF
567 WRITE(iout,*)' '
568 ENDIF
569 IF ( i == 2) THEN
570 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
571 .ETWEEN'
572 WRITE(iout,*)' SEVERAL INTERFACES TYPE 1 2 12 OR 9'
573 WRITE(iout,*)' '
574 WRITE(iout,*)'NODES :'
575 k = 0
576 DO j = 1,numnod
577 IF (itf(ikine(j))== 1
578 . .AND. itf(ikine(j+3*numnod))== 1) THEN
579 k = k + 1
580 ik(k) = itab(j)
581 IF(k==10)THEN
582 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
583 k = 0
584 ENDIF
585 ENDIF
586 ENDDO
587 IF(k/=0)THEN
588 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
589 ENDIF
590 WRITE(iout,*)' '
591 ENDIF
592 IF ( i == 3) THEN
593 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
594 .ETWEEN'
595 WRITE(iout,*)' SEVERAL RIGID WALLS'
596 WRITE(iout,*)' '
597 WRITE(iout,*)'NODES :'
598 k = 0
599 DO j = 1,numnod
600 IF (iwl(ikine(j))== 1
601 . .AND. iwl(ikine(j+3*numnod))== 1) THEN
602 k = k + 1
603 ik(k) = itab(j)
604 IF(k==10)THEN
605 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
606 k = 0
607 ENDIF
608 ENDIF
609 ENDDO
610 IF(k/=0)THEN
611 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
612 ENDIF
613 WRITE(iout,*)' '
614 ENDIF
615 IF ( i == 4 .OR. i == 5) THEN
616 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
617 .ETWEEN'
618 WRITE(iout,*)' SEVERAL RIGID BODIES'
619 WRITE(iout,*)' '
620 WRITE(iout,*)'NODES :'
621 k = 0
622 DO j = 1,numnod
623 IF (irb(ikine(j))== 1
624 . .AND. irb(ikine(j+3*numnod))== 1) THEN
625 k = k + 1
626 ik(k) = itab(j)
627 IF(k==10)THEN
628 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
629 k = 0
630 ENDIF
631 ENDIF
632 ENDDO
633 IF(k/=0)THEN
634 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
635 ENDIF
636 WRITE(iout,*)' '
637 ENDIF
638 IF ( i == 6) THEN
639 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
640 .ETWEEN'
641 WRITE(iout,*)' SEVERAL IMPOSED ACCELERATIONS, IMPOSED DEP
642 .LACEMENTS, IMPOSED VELOCITIES'
643 WRITE(iout,*)' '
644 WRITE(iout,*)'NODES :'
645 k = 0
646 DO j = 1,numnod
647 IF (ivf(ikine(j))== 1
648 . .AND. ivf(ikine(j+3*numnod))== 1) THEN
649 k = k + 1
650 ik(k) = itab(j)
651 IF(k==10)THEN
652 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
653 k = 0
654 ENDIF
655 ENDIF
656 ENDDO
657 IF(k/=0)THEN
658 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
659 ENDIF
660 WRITE(iout,*)' '
661 ENDIF
662 IF ( i == 7) THEN
663 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
664 .ETWEEN'
665 WRITE(iout,*)' SEVERAL RIVETS'
666 WRITE(iout,*)' '
667 WRITE(iout,*)'NODES :'
668 k = 0
669 DO j = 1,numnod
670 IF (irv(ikine(j))== 1
671 . .AND. irv(ikine(j+3*numnod))== 1) THEN
672 k = k + 1
673 ik(k) = itab(j)
674 IF(k==10)THEN
675 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
676 k = 0
677 ENDIF
678 ENDIF
679 ENDDO
680 IF(k/=0)THEN
681 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
682 ENDIF
683 WRITE(iout,*)' '
684 ENDIF
685 IF ( i == 8) THEN
686 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
687 .ETWEEN'
688 WRITE(iout,*)' SEVERAL CYLINDRICAL JOINTS'
689 WRITE(iout,*)' '
690 WRITE(iout,*)'NODES :'
691 k = 0
692 DO j = 1,numnod
693 IF (ijo(ikine(j))== 1
694 . .AND. ijo(ikine(j+3*numnod))== 1) THEN
695 k = k + 1
696 ik(k) = itab(j)
697 IF(k==10)THEN
698 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
699 k = 0
700 ENDIF
701 ENDIF
702 ENDDO
703 IF(k/=0)THEN
704 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
705 ENDIF
706 WRITE(iout,*)' '
707 ENDIF
708 IF ( i == 9) THEN
709 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
710 .ETWEEN'
711 WRITE(iout,*)' SEVERAL IMPOSED BODY VELOCITIES'
712 WRITE(iout,*)' '
713 WRITE(iout,*)'NODES :'
714 k = 0
715 DO j = 1,numnod
716 IF (ilmult(ikine(j))== 1
717 . .AND. ilmult(ikine(j+3*numnod))== 1) THEN
718 k = k + 1
719 ik(k) = itab(j)
720 IF(k==10)THEN
721 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
722 k = 0
723 ENDIF
724 ENDIF
725 ENDDO
726 IF(k/=0)THEN
727 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
728 ENDIF
729 WRITE(iout,*)' '
730 ENDIF
731 IF ( i == 10) THEN
732 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
733 .ETWEEN'
734 WRITE(iout,*)' SEVERAL LAGRANGE MULTIPLIERS'
735 WRITE(iout,*)' '
736 WRITE(iout,*)'NODES :'
737 k = 0
738 DO j = 1,numnod
739 IF (ibc(ikine(j))== 1
740 . .AND. ibc(ikine(j+3*numnod))== 1) THEN
741 k = k + 1
742 ik(k) = itab(j)
743 IF(k==10)THEN
744 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
745 k = 0
746 ENDIF
747 ENDIF
748 ENDDO
749 IF(k/=0)THEN
750 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
751 ENDIF
752 WRITE(iout,*)' '
753 ENDIF
754 IF ( i == 11) THEN
755 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
756 .ETWEEN'
757 WRITE(iout,*)' SEVERAL RIGID LINKS :'
758 WRITE(iout,*)' '
759 WRITE(iout,*)'NODES :'
760 k = 0
761 DO j = 1,numnod
762 IF (irlk(ikine(j))== 1
763 . .AND. irlk(ikine(j+3*numnod))== 1) THEN
764 k = k + 1
765 ik(k) = itab(j)
766 IF(k==10)THEN
767 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
768 k = 0
769 ENDIF
770 ENDIF
771 ENDDO
772 IF(k/=0)THEN
773 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
774 ENDIF
775 WRITE(iout,*)' '
776 ENDIF
777 IF ( i == 12) THEN
778 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
779 .ETWEEN'
780 WRITE(iout,*)' SEVERAL RBE2 :'
781 WRITE(iout,*)' '
782 WRITE(iout,*)'NODES :'
783 k = 0
784 DO j = 1,numnod
785 IF (ikrbe2(ikine(j))== 1
786 . .AND. ikrbe2(ikine(j+3*numnod))== 1) THEN
787 k = k + 1
788 ik(k) = itab(j)
789 IF(k==10)THEN
790 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
791 k = 0
792 ENDIF
793 ENDIF
794 ENDDO
795 IF(k/=0)THEN
796 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
797 ENDIF
798 WRITE(iout,*)' '
799 ENDIF
800 IF ( i == 13) THEN
801 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
802 .ETWEEN'
803 WRITE(iout,*)' SEVERAL RBE3 :'
804 WRITE(iout,*)' '
805 WRITE(iout,*)'NODES :'
806 k = 0
807 DO j = 1,numnod
808 IF (ikrbe3(ikine(j))== 1
809 . .AND. ikrbe3(ikine(j+3*numnod))== 1) THEN
810 k = k + 1
811 ik(k) = itab(j)
812 IF(k==10)THEN
813 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
814 k = 0
815 ENDIF
816 ENDIF
817 ENDDO
818 IF(k/=0)THEN
819 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
820 ENDIF
821 WRITE(iout,*)' '
822 ENDIF
823 ENDIF
824 ENDDO
825C '
826 DO i=1,8192
827 IF ( marqueur(i) /= 0 )THEN
828 WRITE(iout,*)
829 . '- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS BETWEEN:'
830 DO j=1,abs(marqueur(i))
831C cas RBODY & RWALL, INTER 1_2_9 & RWALL, RBODY & INTER 1_2_9 & RWALL
832 IF (j==1 .AND. abs(marqueur(i)) == 2 ) iwl(i)=iwl(i)-1
833 IF (j==1 .AND. abs(marqueur(i)) == 3 ) THEN
834 iwl(i)=iwl(i)-1
835 itf(i) = itf(i) - 1
836 ENDIF
837 IF (j==2 .AND. marqueur(i) == 2 ) THEN
838 WRITE(iout,*)
839 . '- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS BETWEEN:'
840 iwl(i) = iwl(i) + 1
841 irb(i) = irb(i) - 1
842 ENDIF
843 IF (j==2 .AND. marqueur(i) == -2 ) THEN
844 WRITE(iout,*)
845 . '- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS BETWEEN:'
846 iwl(i) = iwl(i) + 1
847 itf(i) = itf(i) - 1
848 ENDIF
849 IF (j==2 .AND. marqueur(i) == 3 ) THEN
850 WRITE(iout,*)
851 . '- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS BETWEEN:'
852 iwl(i) = iwl(i) + 1
853 irb(i) = irb(i) - 1
854 ENDIF
855 IF (j==3 .AND. marqueur(i) == 3 ) THEN
856 WRITE(iout,*)
857 . '- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS BETWEEN:'
858 iwl(i) = iwl(i) - 1
859 itf(i) = itf(i) +1
860 ENDIF
861C
862 IF (ibc(i)== 1) THEN
863 WRITE(iout,*)' BOUNDARY CONDITION'
864 ENDIF
865 IF (itf(i)== 1) THEN
866 WRITE(iout,*)' INTERFACE TYPE 1 2 12 OR 9'
867 ENDIF
868 IF (iwl(i)== 1) THEN
869 WRITE(iout,*)' RIGID WALL'
870 ENDIF
871 IF (irb(i)== 1) THEN
872 WRITE(iout,*)' RIGID BODY'
873 ENDIF
874 IF (irb2(i)== 1) THEN
875 WRITE(iout,*)' RIGID BODY'
876 ENDIF
877 IF (ivf(i)== 1) THEN
878 WRITE(iout,*)' IMPOSED ACCELERATION, IMPOSED DISPLACEMENT
879 ., IMPOSED VELOCITY'
880 ENDIF
881 IF (irv(i)== 1) THEN
882 WRITE(iout,*)' RIVET'
883 ENDIF
884 IF (ijo(i)== 1) THEN
885 WRITE(iout,*)' CYLINDRICAL JOINT'
886 ENDIF
887 IF (irbm(i)== 1) THEN
888 WRITE(iout,*)' IMPOSED BODY VELOCITY'
889 ENDIF
890 IF (ilmult(i)== 1) THEN
891 WRITE(iout,*)' LAGRANGE MULTIPLIERS'
892 ENDIF
893 IF (irlk(i)== 1) THEN
894 WRITE(iout,*)' RIGID LINK'
895 ENDIF
896 IF (ikrbe2(i)== 1) THEN
897 WRITE(iout,*)' RBE2'
898 ENDIF
899 IF (ikrbe3(i)== 1) THEN
900 WRITE(iout,*)' RBE3'
901 ENDIF
902 WRITE(iout,*)
903 . ' '
904 WRITE(iout,*)'NODES :'
905 k = 0
906 DO j1 = 1,numnod
907 IF (ikine(j1) == i) THEN
908 k = k + 1
909 ik(k) = itab(j1)
910 IF(k==10)THEN
911 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
912 k = 0
913 ENDIF
914 ENDIF
915 ENDDO
916 IF(k/=0)THEN
917 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
918 ENDIF
919 WRITE(iout,*)' '
920 IF (j==2 .AND.marqueur(i) == 2 )irb(i) = irb(i) + 1
921 IF (j==2 .AND.marqueur(i) == -2 )itf(i) = itf(i) + 1
922 IF (j==3 .AND.marqueur(i) == 3 ) THEN
923 irb(i) = irb(i) + 1
924 iwl(i) = iwl(i) + 1
925 ENDIF
926 ENDDO
927 ENDIF
928 ENDDO
929 ENDIF
930C---------------------------------------------------------------
931 IF(kwarn>0)THEN
932 CALL ancmsg(msgid=312,anmode=aninfo,msgtype=msgwarning,
933 . i1=kwarn)
934 WRITE(iout,*)' '
935 WRITE(iout,*)' '
936c WRITE(IOUT,FMT=FMW_10I)(IKRW(L),L=1,KWARN)
937c
938 ENDIF
939C---------------------------------------------------------------
940C RESUME CONDITIONS INCOMPATIBLES PAR TYPE
941C---------------------------------------------------------------
942 WRITE(iout,*)'SUMMARY OF POSSIBLE INCOMPATIBLE KINEMATIC CONDITION
943 .S :'
944 WRITE(iout,*)'--------------------------------------------------
945 .---'
946 WRITE(iout,*)' '
947 IF (flag_ikcond==0) THEN
948 WRITE(iout,*)'NO TRUE INCOMPATIBLE KINEMATIC CONDITION'
949 IF (marq2 == 1) THEN
950 WRITE(iout,*)' - AFTER SECONDARY NODES OF RIGID BODIES WERE SUPPRE
951 .SSED FROM RIGID WALL(S)'
952 ENDIF
953 IF (marqm2 == 1) THEN
954 WRITE(iout,*)' - AFTER SECONDARY NODES OF INTERFACES TYPE 1,2,12 O
955 .R 9 WERE SUPPRESSED'
956 WRITE(iout,*)' FROM RIGID WALL(S)'
957 ENDIF
958 ENDIF
959C---------------------------------------------------------------
960 DO i=1,13
961 IF ( marqueurdouble(i) == 1 )THEN
962 IF ( i == 1) THEN
963 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
964 .ETWEEN'
965 WRITE(iout,*)' SEVERAL BOUNDARY CONDITIONS'
966 WRITE(iout,*)' '
967 WRITE(iout,*)' '
968 ENDIF
969 IF ( i == 2) THEN
970 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
971 .ETWEEN'
972 WRITE(iout,*)' SEVERAL INTERFACES TYPE 1 2 12 OR 9'
973 WRITE(iout,*)' '
974 WRITE(iout,*)' '
975 ENDIF
976 IF ( i == 3) THEN
977 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
978 .ETWEEN'
979 WRITE(iout,*)' SEVERAL RIGID WALLS'
980 WRITE(iout,*)' '
981 WRITE(iout,*)' '
982 ENDIF
983 IF ( i == 4 .OR. i == 5) THEN
984 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
985 .ETWEEN'
986 WRITE(iout,*)' SEVERAL RIGID BODIES'
987 WRITE(iout,*)' '
988 WRITE(iout,*)' '
989 ENDIF
990 IF ( i == 6) THEN
991 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
992 .ETWEEN'
993 WRITE(iout,*)' SEVERAL IMPOSED ACCELERATIONS, IMPOSED DEP
994 .LACEMENTS, IMPOSED VELOCITIES'
995 WRITE(iout,*)' '
996 WRITE(iout,*)' '
997 ENDIF
998 IF ( i == 7) THEN
999 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
1000 .ETWEEN'
1001 WRITE(iout,*)' SEVERAL RIVETS'
1002 WRITE(iout,*)' '
1003 WRITE(iout,*)' '
1004 ENDIF
1005 IF ( i == 8) THEN
1006 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
1007 .ETWEEN'
1008 WRITE(iout,*)' SEVERAL CYLINDRICAL JOINTS'
1009 WRITE(iout,*)' '
1010 WRITE(iout,*)' '
1011 ENDIF
1012 IF ( i == 9) THEN
1013 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
1014 .ETWEEN'
1015 WRITE(iout,*)' SEVERAL IMPOSED BODY VELOCITIES'
1016 WRITE(iout,*)' '
1017 WRITE(iout,*)' '
1018 ENDIF
1019 IF ( i == 10) THEN
1020 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
1021 .ETWEEN'
1022 WRITE(iout,*)' SEVERAL LAGRANGE MULTIPLIERS'
1023 WRITE(iout,*)' '
1024 WRITE(iout,*)' '
1025 ENDIF
1026 IF ( i == 11) THEN
1027 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
1028 .ETWEEN'
1029 WRITE(iout,*)' SEVERAL RIGID LINKS'
1030 WRITE(iout,*)' '
1031 WRITE(iout,*)' '
1032 ENDIF
1033 IF ( i == 12) THEN
1034 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
1035 .ETWEEN'
1036 WRITE(iout,*)' SEVERAL RBE2'
1037 WRITE(iout,*)' '
1038 WRITE(iout,*)' '
1039 ENDIF
1040 IF ( i == 13) THEN
1041 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
1042 .ETWEEN'
1043 WRITE(iout,*)' SEVERAL RBE3'
1044 WRITE(iout,*)' '
1045 WRITE(iout,*)' '
1046 ENDIF
1047 ENDIF
1048 ENDDO
1049C '
1050 DO i=1,8192
1051 IF ( marqueur(i) /= 0 )THEN
1052 WRITE(iout,*)
1053 . '- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS BETWEEN:'
1054 DO j=1,abs(marqueur(i))
1055 IF (j==1 .AND. abs(marqueur(i)) == 2 ) iwl(i)=iwl(i)-1
1056 IF (j==1 .AND. abs(marqueur(i)) == 3 ) THEN
1057 iwl(i )= iwl(i) - 1
1058 itf(i) = itf(i) - 1
1059 ENDIF
1060 IF (j==2 .AND. marqueur(i) == 2 ) THEN
1061 WRITE(iout,*)
1062 . '- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS BETWEEN:'
1063 iwl(i) = iwl(i) + 1
1064 irb(i) = irb(i) - 1
1065 ENDIF
1066 IF (j==2 .AND. marqueur(i) == -2 ) THEN
1067 WRITE(iout,*)
1068 . '- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS BETWEEN:'
1069 iwl(i) = iwl(i) + 1
1070 itf(i) = itf(i) - 1
1071 ENDIF
1072 IF (j==2 .AND. marqueur(i) == 3 ) THEN
1073 WRITE(iout,*)
1074 . '- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS BETWEEN:'
1075 iwl(i) = iwl(i) + 1
1076 irb(i) = irb(i) - 1
1077 ENDIF
1078 IF (j==3 .AND. marqueur(i) == 3 ) THEN
1079 WRITE(iout,*)
1080 . '- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS BETWEEN:'
1081 iwl(i) = iwl(i) - 1
1082 itf(i) = itf(i) + 1
1083 ENDIF
1084C
1085 IF (ibc(i)== 1) THEN
1086 WRITE(iout,*)' BOUNDARY CONDITION'
1087 ENDIF
1088 IF (itf(i)== 1) THEN
1089 WRITE(iout,*)' INTERFACE TYPE 1 2 12 OR 9'
1090 ENDIF
1091 IF (iwl(i)== 1) THEN
1092 WRITE(iout,*)' RIGID WALL'
1093 ENDIF
1094 IF (irb(i)== 1) THEN
1095 WRITE(iout,*)' RIGID BODY'
1096 ENDIF
1097 IF (irb2(i)== 1) THEN
1098 WRITE(iout,*)' RIGID BODY'
1099 ENDIF
1100 IF (ivf(i)== 1) THEN
1101 WRITE(iout,*)' IMPOSED ACCELERATION, IMPOSED DISPLACEMENT
1102 ., IMPOSED VELOCITY'
1103 ENDIF
1104 IF (irv(i)== 1) THEN
1105 WRITE(iout,*)' RIVET'
1106 ENDIF
1107 IF (ijo(i)== 1) THEN
1108 WRITE(iout,*)' CYLINDRICAL JOINT'
1109 ENDIF
1110 IF (irbm(i)== 1) THEN
1111 WRITE(iout,*)' IMPOSED BODY VELOCITY'
1112 ENDIF
1113 IF (ilmult(i)== 1) THEN
1114 WRITE(iout,*)' LAGRANGE MULTIPLIERS'
1115 ENDIF
1116 IF (irlk(i)== 1) THEN
1117 WRITE(iout,*)' RIGID LINK'
1118 ENDIF
1119 IF (ikrbe2(i)== 1) THEN
1120 WRITE(iout,*)' RBE2'
1121 ENDIF
1122 IF (ikrbe3(i)== 1) THEN
1123 WRITE(iout,*)' RBE3'
1124 ENDIF
1125 IF (j==2 .AND.marqueur(i) == 2 )irb(i) = irb(i) + 1
1126 IF (j==2 .AND.marqueur(i) == -2 )itf(i) = itf(i) + 1
1127 IF (j==3 .AND.marqueur(i) == 3 ) THEN
1128 irb(i) = irb(i) + 1
1129 iwl(i) = iwl(i) + 1
1130 ENDIF
1131 IF(kwarn>0.AND.ipri>=3)THEN
1132 WRITE(iout,*)'NODES :'
1133 WRITE(iout,fmt=fmw_10i)(ikrw(l),l=1,nikrw)
1134 ENDIF
1135 WRITE(iout,*)' '
1136 WRITE(iout,*)' '
1137 ENDDO
1138 ENDIF
1139 ENDDO
1140!
1141 nun=0
1142 DO i=1,nrbe3
1143 ipen = irbe3(9,i) ! add warning for added mass+pen
1144 IF (ipen>0) nun = nun + 1
1145 IF (ipen <0) irbe3(9,i) =0
1146 END DO
1147 IF (nun>0) THEN
1148 WRITE(iout,'(/I8,X,A)')nun,'OF RBE3 HAVE BEEN SWITCHED TO PENALTY METHOD'
1149 ENDIF
1150C---------------------------------------------------------------
1151 DO i=1,numnod
1152C reset flag impact / wall
1153ccc IF(IWL(IKINE(I))==1)IKINE(I) = IKINE(I) - 4
1154 kinet(i)=ikine(i)
1155 ENDDO
1156 DEALLOCATE(nkindouble,nkin,ikrw)
1157
1158C
1159Cls
1160Cls
1161Cls WARNING : RETURN HERE !!!
1162Cls
1163 RETURN
1164Cls
1165Cls
1166Cls
1167 jwarn = 0
1168 DO 100 i=1,numnod
1169 nk = ibc(ikine(i))+itf(ikine(i))+iwl(ikine(i))+
1170 . irb(ikine(i))+irb2(ikine(i))+
1171 . ivf(ikine(i))+irv(ikine(i))+ijo(ikine(i))
1172 IF(nk>=2)THEN
1173 jwarn = jwarn+1
1174 WRITE(iout,*)
1175 . ' -',nk,' KINEMATIC CONDITIONS ON NODE',itab(i),':'
1176 IF(ibc(ikine(i))==1) WRITE(iout,*)
1177 . ' - BOUNDARY CONDITION'
1178 IF(itf(ikine(i))==1) WRITE(iout,*)
1179 . ' - INTERFACE TYPE 1 2 12 OR 9'
1180 IF(iwl(ikine(i))==1) WRITE(iout,*)
1181 . ' - RIGID WALL'
1182 IF(irb(ikine(i))==1) WRITE(iout,*)
1183 . ' - RIGID BODY'
1184 IF(irb2(ikine(i))==1) WRITE(iout,*)
1185 . ' - RIGID BODY'
1186 IF(ivf(ikine(i))==1) WRITE(iout,*)
1187 . ' - FIXED VELOCITY'
1188 IF(irv(ikine(i))==1) WRITE(iout,*)
1189 . ' - RIVET'
1190 IF(ijo(ikine(i))==1) WRITE(iout,*)
1191 . ' - CYLINDRICAL JOINT'
1192 IF(irbm(ikine(i))==1) WRITE(iout,*)
1193 . ' - IMPOSED BODY VELOCITY'
1194 IF(ilmult(ikine(i))==1) WRITE(iout,*)
1195 . ' - LAGRANGE MULTIPLIERS'
1196 ENDIF
1197 100 CONTINUE
1198C
1199 iwarn = iwarn + jwarn
1200 IF(jwarn/=0)THEN
1201 WRITE(istdo,'(A,I8,A)') ' ** WARNING',jwarn,
1202 . ' NODES WITH INCOMPATIBLE KINEMATIC CONDITIONS'
1203 WRITE(iout,fmt=fmw_a_i_a) ' ** WARNING',jwarn,
1204 . ' NODES WITH INCOMPATIBLE KINEMATIC CONDITIONS'
1205 ENDIF
1206C
1207 RETURN
id
initmumps id
Definition multiplerhs_example.m:4
message_mod
Definition message_mod.F:1249
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804

◆ kinrem()

subroutine kinrem ( integer, dimension(*) ikine,
integer, dimension(*) ikinew,
rwl,
integer, dimension(*) itab,
integer, dimension(*) nprw,
integer, dimension(*) lprw,
integer, dimension(nnpby,*) npby,
integer, dimension(*) lpby )

Definition at line 1214 of file kinchk.F.

1216C-----------------------------------------------
1217C I m p l i c i t T y p e s
1218C-----------------------------------------------
1219#include "implicit_f.inc"
1220C-----------------------------------------------
1221C C o m m o n B l o c k s
1222C-----------------------------------------------
1223#include "com04_c.inc"
1224#include "kincod_c.inc"
1225#include "param_c.inc"
1226C-----------------------------------------------------------------
1227C D u m m y A r g u m e n t s
1228C-----------------------------------------------
1229 INTEGER IKINE(*), IKINEW(*), NPRW(*), LPRW(*),ITAB(*),
1230 . NPBY(NNPBY,*), LPBY(*)
1231 my_real
1232 . rwl(nrwlp,*)
1233C-----------------------------------------------
1234C L o c a l V a r i a b l e s
1235C-----------------------------------------------
1236 INTEGER I, J, K, L, N, KK, IKK, ITYP, NE, NSL
1237C-----------------------------------------------------------------
1238C Recopie dans tableau de travail
1239 DO n=1,numnod
1240 ikinew(n)=ikine(n)
1241 END DO
1242C=======================================================================
1243C CORRECTIONS AUTOMATIQUES INTERFACE 1,2,9 OU RBODY AVEC RWALL
1244C=======================================================================
1245 k=0
1246 kk=0
1247
1248 DO n=1,nrwall
1249
1250 nsl=nprw(n)
1251 ityp=nprw(n+3*nrwall)
1252 j=0
1253 DO l=1,nsl
1254 i=lprw(k+l)
1255 ikk=iabs(ikinew(i))
1256 IF(irb(ikk)/=0.OR.itf(ikk)/=0)THEN
1257 IF(iwl(ikinew(i))==1)ikinew(i) = ikinew(i) - 4
1258 ELSE
1259 j=j+1
1260 lprw(kk+j)=lprw(k+l)
1261 ENDIF
1262 ENDDO
1263 k = k+nsl
1264 nsl=j
1265 kk = kk+nsl
1266 nprw(n)=nsl
1267 IF(ityp<0)THEN
1268 ne=nint(rwl(8,n))
1269 DO i=1,ne
1270 lprw(kk+i)=lprw(k+i)
1271 ENDDO
1272 k = k+ne
1273 kk = kk+ne
1274 ENDIF
1275 ENDDO
1276C
1277 RETURN

◆ prerbe2()

subroutine prerbe2 ( integer, dimension(nrbe2l,*) irbe2,
integer, dimension(3,*) jt,
integer, dimension(3,*) jr )

Definition at line 1973 of file kinchk.F.

1974C-----------------------------------------------
1975C I m p l i c i t T y p e s
1976C-----------------------------------------------
1977#include "implicit_f.inc"
1978C-----------------------------------------------
1979C C o m m o n B l o c k s
1980C-----------------------------------------------
1981#include "com01_c.inc"
1982#include "com04_c.inc"
1983#include "param_c.inc"
1984C-----------------------------------------------
1985C D u m m y A r g u m e n t s
1986C-----------------------------------------------
1987 INTEGER IRBE2(NRBE2L,*),JT(3,*) ,JR(3,*)
1988C REAL
1989C-----------------------------------------------
1990C L o c a l V a r i a b l e s
1991C-----------------------------------------------
1992 INTEGER I, J, N,NML,IC,ICT,ICR,IROT
1993C======================================================================|
1994 DO n=1,nrbe2
1995 ic=irbe2(4,n)
1996 ict=ic/512
1997 icr=(ic-512*(ict))/64
1998 IF (iroddl==0) icr =0
1999 DO j =1,3
2000 jt(j,n)=0
2001 jr(j,n)=0
2002 ENDDO
2003 SELECT CASE (ict)
2004 CASE(1)
2005 jt(3,n)=1
2006 CASE(2)
2007 jt(2,n)=1
2008 CASE(3)
2009 jt(2,n)=1
2010 jt(3,n)=1
2011 CASE(4)
2012 jt(1,n)=1
2013 CASE(5)
2014 jt(1,n)=1
2015 jt(3,n)=1
2016 CASE(6)
2017 jt(1,n)=1
2018 jt(2,n)=1
2019 CASE(7)
2020 jt(1,n)=1
2021 jt(2,n)=1
2022 jt(3,n)=1
2023 END SELECT
2024 SELECT CASE (icr)
2025 CASE(1)
2026 jr(3,n)=1
2027 CASE(2)
2028 jr(2,n)=1
2029 CASE(3)
2030 jr(2,n)=1
2031 jr(3,n)=1
2032 CASE(4)
2033 jr(1,n)=1
2034 CASE(5)
2035 jr(1,n)=1
2036 jr(3,n)=1
2037 CASE(6)
2038 jr(1,n)=1
2039 jr(2,n)=1
2040 CASE(7)
2041 jr(1,n)=1
2042 jr(2,n)=1
2043 jr(3,n)=1
2044 END SELECT
2045 ENDDO
2046C---
2047 RETURN

◆ prerbe3()

subroutine prerbe3 ( integer, dimension(nrbe3l,*) irbe3,
integer max_m,
integer irotg,
integer, dimension(3,*) jt,
integer, dimension(3,*) jr )

Definition at line 1493 of file kinchk.F.

1494C-----------------------------------------------
1495C I m p l i c i t T y p e s
1496C-----------------------------------------------
1497#include "implicit_f.inc"
1498C-----------------------------------------------
1499C C o m m o n B l o c k s
1500C-----------------------------------------------
1501#include "com04_c.inc"
1502#include "param_c.inc"
1503C-----------------------------------------------
1504C D u m m y A r g u m e n t s
1505C-----------------------------------------------
1506 INTEGER IRBE3(NRBE3L,*),MAX_M , IROTG,JT(3,*) ,JR(3,*)
1507C REAL
1508C-----------------------------------------------
1509C L o c a l V a r i a b l e s
1510C-----------------------------------------------
1511 INTEGER I, J, N,NML,IC,ICT,ICR,IROT
1512C======================================================================|
1513 max_m=0
1514 irotg=0
1515 DO n=1,nrbe3
1516 nml = irbe3(5,n)
1517 irot =irbe3(6,n)
1518 max_m=max(max_m,nml)
1519 irotg=max(irotg,irot)
1520 ic=irbe3(4,n)
1521 ict=ic/512
1522 icr=(ic-512*(ict))/64
1523 DO j =1,3
1524 jt(j,n)=0
1525 jr(j,n)=0
1526 ENDDO
1527 SELECT CASE (ict)
1528 CASE(1)
1529 jt(3,n)=1
1530 CASE(2)
1531 jt(2,n)=1
1532 CASE(3)
1533 jt(2,n)=1
1534 jt(3,n)=1
1535 CASE(4)
1536 jt(1,n)=1
1537 CASE(5)
1538 jt(1,n)=1
1539 jt(3,n)=1
1540 CASE(6)
1541 jt(1,n)=1
1542 jt(2,n)=1
1543 CASE(7)
1544 jt(1,n)=1
1545 jt(2,n)=1
1546 jt(3,n)=1
1547 END SELECT
1548 SELECT CASE (icr)
1549 CASE(1)
1550 jr(3,n)=1
1551 CASE(2)
1552 jr(2,n)=1
1553 CASE(3)
1554 jr(2,n)=1
1555 jr(3,n)=1
1556 CASE(4)
1557 jr(1,n)=1
1558 CASE(5)
1559 jr(1,n)=1
1560 jr(3,n)=1
1561 CASE(6)
1562 jr(1,n)=1
1563 jr(2,n)=1
1564 CASE(7)
1565 jr(1,n)=1
1566 jr(2,n)=1
1567 jr(3,n)=1
1568 END SELECT
1569 ENDDO
1570C---
1571 RETURN
max
#define max(a, b)
Definition macros.h:21

◆ rbe2_impd()

subroutine rbe2_impd ( integer, dimension(nrbe2l,*) irbe2,
integer, dimension(*) lrbe2,
x,
d,
dr,
skew )

Definition at line 1927 of file kinchk.F.

1928C-----------------------------------------------
1929C I m p l i c i t T y p e s
1930C-----------------------------------------------
1931#include "implicit_f.inc"
1932C-----------------------------------------------
1933C C o m m o n B l o c k s
1934C-----------------------------------------------
1935#include "com04_c.inc"
1936#include "param_c.inc"
1937C-----------------------------------------------
1938C D u m m y A r g u m e n t s
1939C-----------------------------------------------
1940 INTEGER IRBE2(NRBE2L,*),LRBE2(*)
1941C REAL
1942 my_real
1943 . x(3,*), d(3,*), dr(3,*),skew(lskew,*)
1944C-----------------------------------------------
1945C L o c a l V a r i a b l e s
1946C-----------------------------------------------
1947 INTEGER I, J, N, M, NS ,NML, IAD,JJ,ISK,
1948 . JT(3,NRBE2),JR(3,NRBE2),NM,NN,K,NSL
1949C REAL
1950C======================================================================|
1951 CALL prerbe2(irbe2 ,jt ,jr )
1952 DO n=nrbe2,1,-1
1953 iad = irbe2(1,n)
1954 m = irbe2(3,n)
1955 nsl = irbe2(5,n)
1956 isk = irbe2(7,n)
1957 IF (isk>1) THEN
1958 CALL rbe2dl(nsl ,lrbe2(iad+1),x ,d ,dr ,
1959 1 jt(1,n),jr(1,n),m ,skew(1,isk))
1960 ELSE
1961 CALL rbe2d0(nsl ,lrbe2(iad+1),x ,d ,dr ,
1962 1 jt(1,n),jr(1,n),m )
1963 END IF
1964 ENDDO
1965C---
1966 RETURN
rbe2dl
subroutine rbe2dl(nsn, isl, x, v, vr, jt, jr, m, skew)
Definition kinchk.F:2113
rbe2d0
subroutine rbe2d0(nsl, isl, x, v, vr, jt, jr, m)
Definition kinchk.F:2056
prerbe2
subroutine prerbe2(irbe2, jt, jr)
Definition kinchk.F:1974

◆ rbe2d0()

subroutine rbe2d0 ( integer nsl,
integer, dimension(*) isl,
x,
v,
vr,
integer, dimension(3) jt,
integer, dimension(3) jr,
integer m )

Definition at line 2054 of file kinchk.F.

2056C-----------------------------------------------
2057C I m p l i c i t T y p e s
2058C-----------------------------------------------
2059#include "implicit_f.inc"
2060C-----------------------------------------------
2061C D u m m y A r g u m e n t s
2062C-----------------------------------------------
2063 INTEGER NSL,ISL(*),JT(3),JR(3),M
2064C REAL
2065 my_real
2066 . x(3,*), v(3,*), vr(3,*)
2067C-----------------------------------------------
2068C L o c a l V a r i a b l e s
2069C-----------------------------------------------
2070 INTEGER I, J, N, NS
2071C REAL
2072 my_real
2073 . xs, ys, zs,vrm(3)
2074C======================================================================|
2075 DO j = 1,3
2076 IF (jt(j)/=0) THEN
2077 DO i=1,nsl
2078 ns = isl(i)
2079 v(j,ns)= v(j,m)
2080 ENDDO
2081 ENDIF
2082 ENDDO
2083 IF ((jr(1)+jr(2)+jr(3))>0) THEN
2084 DO j = 1,3
2085 IF (jr(j)/=0) THEN
2086 DO i=1,nsl
2087 ns = isl(i)
2088 vr(j,ns)= vr(j,m)
2089 ENDDO
2090 ENDIF
2091 vrm(j)= vr(j,m)*jr(j)
2092 ENDDO
2093 DO i=1,nsl
2094 ns = isl(i)
2095 xs=x(1,ns)-x(1,m)
2096 ys=x(2,ns)-x(2,m)
2097 zs=x(3,ns)-x(3,m)
2098 v(1,ns)=v(1,ns)+vrm(2)*zs-vrm(3)*ys
2099 v(2,ns)=v(2,ns)-vrm(1)*zs+vrm(3)*xs
2100 v(3,ns)=v(3,ns)+vrm(1)*ys-vrm(2)*xs
2101 ENDDO
2102 END IF
2103C---
2104 RETURN

◆ rbe2dl()

subroutine rbe2dl ( integer nsn,
integer, dimension(*) isl,
x,
v,
vr,
integer, dimension(3) jt,
integer, dimension(3) jr,
integer m,
skew )

Definition at line 2111 of file kinchk.F.

2113C-----------------------------------------------
2114C I m p l i c i t T y p e s
2115C-----------------------------------------------
2116#include "implicit_f.inc"
2117C-----------------------------------------------
2118C D u m m y A r g u m e n t s
2119C-----------------------------------------------
2120 INTEGER NSN,ISL(*),JT(3),JR(3),M
2121C REAL
2122 my_real
2123 . x(3,*), v(3,*), vr(3,*),skew(*)
2124C-----------------------------------------------
2125C L o c a l V a r i a b l e s
2126C-----------------------------------------------
2127 INTEGER I, NS
2128C REAL
2129 my_real
2130 . xs, ys, zs,rx, ry,rz,lrx, lry,lrz,rvx,rvy,rvz,
2131 . dvx,dvy,dvz,vvx,vvy,vvz,lxs(nsn), lys(nsn), lzs(nsn)
2132C======================================================================|
2133 DO i=1,nsn
2134 ns = isl(i)
2135 dvx =v(1,ns)-v(1,m)
2136 dvy =v(2,ns)-v(2,m)
2137 dvz =v(3,ns)-v(3,m)
2138 vvx =jt(1)*(skew(1)*dvx+skew(2)*dvy+skew(3)*dvz)
2139 vvy =jt(2)*(skew(4)*dvx+skew(5)*dvy+skew(6)*dvz)
2140 vvz =jt(3)*(skew(7)*dvx+skew(8)*dvy+skew(9)*dvz)
2141 v(1,ns) =v(1,ns)-vvx*skew(1)-vvy*skew(4)-vvz*skew(7)
2142 v(2,ns) =v(2,ns)-vvx*skew(2)-vvy*skew(5)-vvz*skew(8)
2143 v(3,ns) =v(3,ns)-vvx*skew(3)-vvy*skew(6)-vvz*skew(9)
2144 ENDDO
2145 IF ((jr(1)+jr(2)+jr(3))>0) THEN
2146 DO i=1,nsn
2147 ns = isl(i)
2148 xs=x(1,ns)-x(1,m)
2149 ys=x(2,ns)-x(2,m)
2150 zs=x(3,ns)-x(3,m)
2151 lxs(i)=skew(1)*xs+skew(2)*ys+skew(3)*zs
2152 lys(i)=skew(4)*xs+skew(5)*ys+skew(6)*zs
2153 lzs(i)=skew(7)*xs+skew(8)*ys+skew(9)*zs
2154 ENDDO
2155 DO i=1,nsn
2156 ns = isl(i)
2157 dvx =vr(1,ns)-vr(1,m)
2158 dvy =vr(2,ns)-vr(2,m)
2159 dvz =vr(3,ns)-vr(3,m)
2160 vvx =jr(1)*(skew(1)*dvx+skew(2)*dvy+skew(3)*dvz)
2161 vvy =jr(2)*(skew(4)*dvx+skew(5)*dvy+skew(6)*dvz)
2162 vvz =jr(3)*(skew(7)*dvx+skew(8)*dvy+skew(9)*dvz)
2163 vr(1,ns) =vr(1,ns)-vvx*skew(1)-vvy*skew(4)-vvz*skew(7)
2164 vr(2,ns) =vr(2,ns)-vvx*skew(2)-vvy*skew(5)-vvz*skew(8)
2165 vr(3,ns) =vr(3,ns)-vvx*skew(3)-vvy*skew(6)-vvz*skew(9)
2166 rx=vr(1,m)
2167 ry=vr(2,m)
2168 rz=vr(3,m)
2169 lrx =jr(1)*(skew(1)*rx+skew(2)*ry+skew(3)*rz)
2170 lry =jr(2)*(skew(4)*rx+skew(5)*ry+skew(6)*rz)
2171 lrz =jr(3)*(skew(7)*rx+skew(8)*ry+skew(9)*rz)
2172 rvx=lry*lzs(i)-lrz*lys(i)
2173 rvy=lrx*lzs(i)+lrz*lxs(i)
2174 rvz=lrx*lys(i)-lry*lxs(i)
2175 v(1,ns) =v(1,ns)+rvx*skew(1)+rvy*skew(4)+rvz*skew(7)
2176 v(2,ns) =v(2,ns)+rvx*skew(2)+rvy*skew(5)+rvz*skew(8)
2177 v(3,ns) =v(3,ns)+rvx*skew(3)+rvy*skew(6)+rvz*skew(9)
2178 ENDDO
2179 END IF
2180C---
2181 RETURN

◆ rbe3_impd()

subroutine rbe3_impd ( integer, dimension(nrbe3l,*) irbe3,
integer, dimension(*) lrbe3,
x,
d,
dr,
frbe3,
skew )

Definition at line 1404 of file kinchk.F.

1406C-----------------------------------------------
1407C I m p l i c i t T y p e s
1408C-----------------------------------------------
1409#include "implicit_f.inc"
1410C-----------------------------------------------
1411C C o m m o n B l o c k s
1412C-----------------------------------------------
1413#include "com01_c.inc"
1414#include "com04_c.inc"
1415#include "param_c.inc"
1416#include "tabsiz_c.inc"
1417C-----------------------------------------------
1418C D u m m y A r g u m e n t s
1419C-----------------------------------------------
1420 INTEGER IRBE3(NRBE3L,*),LRBE3(*)
1421C REAL
1422 my_real
1423 . x(3,*), d(3,*), dr(3,*), frbe3(*),skew(*)
1424C-----------------------------------------------
1425C L o c a l V a r i a b l e s
1426C-----------------------------------------------
1427 INTEGER I, J, N, M, NS ,NML, IAD,JJ,IROT,IADS,MAX_M,IROTG,
1428 . JT(3,NRBE3),JR(3,NRBE3),NM,NN,K
1429C REAL
1430 my_real
1431 . vs(3),vrs(3)
1432 my_real,
1433 . DIMENSION(:,:,:),ALLOCATABLE :: fdstnb ,mdstnb
1434
1435C======================================================================|
1436 iads = slrbe3/2
1437 CALL prerbe3(irbe3 ,max_m , irotg,jt ,jr )
1438 ALLOCATE(fdstnb(3,6,max_m))
1439 IF (irotg>0) ALLOCATE(mdstnb(3,6,max_m))
1440 DO n=1,nrbe3
1441 iad = irbe3(1,n)
1442 ns = irbe3(3,n)
1443 IF (ns==0) cycle
1444 nml = irbe3(5,n)
1445 irot =min(irbe3(6,n),iroddl)
1446 CALL rbe3cl(lrbe3(iad+1),lrbe3(iads+iad+1),ns ,x ,
1447 . frbe3(6*iad+1),skew ,nml ,irot ,fdstnb ,
1448 . mdstnb )
1449 DO j = 1,3
1450 vs(j) = zero
1451 vrs(j) = zero
1452 ENDDO
1453 DO i=1,nml
1454 m = lrbe3(iad+i)
1455 DO j = 1,3
1456 DO k = 1,3
1457 vs(j) = vs(j)+fdstnb(k,j,i)*d(k,m)
1458 vrs(j) = vrs(j)+fdstnb(k,j+3,i)*d(k,m)
1459 ENDDO
1460 ENDDO
1461 ENDDO
1462 IF (irot>0) THEN
1463 DO i=1,nml
1464 m = lrbe3(iad+i)
1465 DO j = 1,3
1466 DO k = 1,3
1467 vs(j) = vs(j)+mdstnb(k,j,i)*dr(k,m)
1468 vrs(j) = vrs(j)+mdstnb(k,j+3,i)*dr(k,m)
1469 ENDDO
1470 ENDDO
1471 ENDDO
1472 ENDIF
1473 DO j = 1,3
1474 d(j,ns) = vs(j) *jt(j,n)
1475 ENDDO
1476 IF ((jr(1,n)+jr(2,n)+jr(3,n))>0) THEN
1477 DO j = 1,3
1478 dr(j,ns) = vrs(j) *jr(j,n)
1479 ENDDO
1480 ENDIF
1481 ENDDO
1482C
1483 DEALLOCATE(fdstnb)
1484 IF (irotg>0) DEALLOCATE(mdstnb)
1485C---
1486 RETURN
rbe3cl
subroutine rbe3cl(inrbe3, ilrbe3, ns, xyz, frbe3, skew, ng, irot, fdstnb, mdstnb)
Definition kinchk.F:1586
prerbe3
subroutine prerbe3(irbe3, max_m, irotg, jt, jr)
Definition kinchk.F:1494
min
#define min(a, b)
Definition macros.h:20

◆ rbe3cl()

subroutine rbe3cl ( integer, dimension(*) inrbe3,
integer, dimension(*) ilrbe3,
integer ns,
xyz,
frbe3,
skew,
integer ng,
integer irot,
fdstnb,
mdstnb )

Definition at line 1584 of file kinchk.F.

1586C-----------------------------------------------
1587C I m p l i c i t T y p e s
1588C-----------------------------------------------
1589#include "implicit_f.inc"
1590C-----------------------------------------------
1591C C o m m o n B l o c k s
1592C-----------------------------------------------
1593#include "units_c.inc"
1594#include "param_c.inc"
1595C-----------------------------------------------
1596C D u m m y A r g u m e n t s
1597C-----------------------------------------------
1598 INTEGER INRBE3(*),ILRBE3(*),NG, NS,IROT
1599C REAL
1600 my_real
1601 . xyz(3,*), frbe3(6,*), skew(lskew,*),fdstnb(3,6,*), mdstnb(3,6,*)
1602C-----------------------------------------------
1603C L o c a l V a r i a b l e s
1604C-----------------------------------------------
1605 INTEGER I, J, K,N, M ,NML, IAD,JJ,KG,NSNGLR,IELSUB,IERR,ng1
1606C REAL
1607 my_real
1608 * tw(3,ng), rw(3,ng),
1609 * fufxlc(3,ng), fufylc(3,ng), fufzlc(3,ng),
1610 * fumxlc(3,ng), fumylc(3,ng), fumzlc(3,ng),
1611 * mxlc(3,ng), mylc(3,ng), mzlc(3,ng),
1612 * fufx(3,ng), fufy(3,ng), fufz(3,ng),
1613 * mufx(3,ng), mufy(3,ng), mufz(3,ng),
1614 * fumx(3,ng), fumy(3,ng), fumz(3,ng),
1615 * mx(3,ng), my(3,ng), mz(3,ng),
1616 * mumx(3,ng), mumy(3,ng), mumz(3,ng),
1617 * el(3,3,ng)
1618 my_real
1619 * denfx, denfy, denfz, denmx, denmy, denmz,
1620 * refpt(3), cgmx(3), cgmy(3), cgmz(3), averef,
1621 * tfufx(3), tfufy(3), tfufz(3),
1622 * tmufx(3), tmufy(3), tmufz(3),
1623 * tfumx(3), tfumy(3), tfumz(3),
1624 * tmumx(3), tmumy(3), tmumz(3),
1625 * a(6,6), c(6,6), t(3,3)
1626C
1627C INITIALIZATION
1628C
1629 CALL zero1(fdstnb,3*ng*6)
1630 IF (irot>0) CALL zero1(mdstnb,3*ng*6)
1631 CALL zero1(a,36)
1632 CALL zero1(c,36)
1633 CALL zero1(cgmx,3)
1634 CALL zero1(cgmy,3)
1635 CALL zero1(cgmz,3)
1636 ierr = 0
1637C
1638 refpt(1) = xyz(1,ns)
1639 refpt(2) = xyz(2,ns)
1640 refpt(3) = xyz(3,ns)
1641 DO k = 1, ng
1642 DO i = 1, 3
1643 tw(i,k) = frbe3(i,k)
1644 rw(i,k) = frbe3(i+3,k)
1645 ENDDO
1646 ENDDO
1647C
1648C ERROR OUT IF RBE3 ELEMENT HAS TWO INDEPENDENT NODES WITH
1649C NO ROTATIONAL WEIGHTS SET (THIS MEANS THE ELEMENT CANNOT
1650C SUPPORT A MOMENT ALONG ITS AXIS)
1651C
1652 IF (ng == 2.AND.irot==0) THEN
1653 ierr = 322
1654 GOTO 999
1655 ENDIF
1656C
1657C CALCULATE DIRECTION COSINES OF LOCAL COORDINATE SYSTEMS, IF ANY
1658C
1659 DO k = 1, ng
1660 ielsub = ilrbe3(k)
1661 IF (ielsub > 0) THEN
1662 DO i = 1, 3
1663 el(i,1,k) = skew(i,ielsub)
1664 el(i,2,k) = skew(i+3,ielsub)
1665 el(i,3,k) = skew(i+6,ielsub)
1666 ENDDO
1667 ENDIF
1668 ENDDO
1669C
1670C DENOMINATORS FOR DISTRIBUTING FORCES (DENFX, DENFY AND DENFZ)
1671C
1672 denfx = zero
1673 denfy = zero
1674 denfz = zero
1675 averef = zero
1676C
1677 DO 70 k = 1, ng
1678 kg = inrbe3(k)
1679 ielsub = ilrbe3(k)
1680 IF (ielsub > 0) THEN
1681C
1682C IF GRID POINT HAS A LOCAL COORDINATE SYSTEM
1683C
1684 DO 60 i = 1, 3
1685 denfx = denfx + tw(i,k)*el(i,1,k)**2
1686 denfy = denfy + tw(i,k)*el(i,2,k)**2
1687 denfz = denfz + tw(i,k)*el(i,3,k)**2
1688 60 CONTINUE
1689 ELSE
1690 denfx = denfx + tw(1,k)
1691 denfy = denfy + tw(2,k)
1692 denfz = denfz + tw(3,k)
1693 END IF
1694C
1695 averef = averef + sqrt( (xyz(1,kg) - refpt(1))**2 +
1696 * (xyz(2,kg) - refpt(2))**2 +
1697 * (xyz(3,kg) - refpt(3))**2 )
1698 70 CONTINUE
1699C
1700 IF (abs(denfx) <= em20) THEN
1701 ierr = 326
1702 ENDIF
1703C
1704 IF (abs(denfy) <= em20) THEN
1705 ierr = 327
1706 ENDIF
1707C
1708 IF (abs(denfz) <= em20) THEN
1709 ierr = 328
1710 ENDIF
1711 IF (ierr /= 0) GOTO 999
1712 averef = averef/ng
1713 IF (averef == zero) averef = one
1714C
1715C CALCULATE 3 CENTERS OF GRAVITY (CGMX, CGMY AND CGMZ) AND
1716C DENOMINATORS FOR DISTRIBUTING MOMENTS (DENMX, DENMY AND DENMZ)
1717C
1718 DO 40 k = 1, ng
1719 kg = inrbe3(k)
1720 ielsub = ilrbe3(k)
1721 IF (ielsub > 0) THEN
1722C
1723C IF THERE IS A LOCAL COORDINATE SYSTEM AT THE GRID POINT
1724C
1725 DO 10 i = 1, 3
1726 cgmx(2) = cgmx(2) + tw(i,k)*el(i,3,k)**2*xyz(2,kg)
1727 cgmx(3) = cgmx(3) + tw(i,k)*el(i,2,k)**2*xyz(3,kg)
1728 10 CONTINUE
1729C
1730 DO 20 i = 1, 3
1731 cgmy(3) = cgmy(3) + tw(i,k)*el(i,1,k)**2*xyz(3,kg)
1732 cgmy(1) = cgmy(1) + tw(i,k)*el(i,3,k)**2*xyz(1,kg)
1733 20 CONTINUE
1734C
1735 DO 30 i = 1, 3
1736 cgmz(1) = cgmz(1) + tw(i,k)*el(i,2,k)**2*xyz(1,kg)
1737 cgmz(2) = cgmz(2) + tw(i,k)*el(i,1,k)**2*xyz(2,kg)
1738 30 CONTINUE
1739C
1740 ELSE
1741 cgmx(2) = cgmx(2) + tw(3,k)*xyz(2,kg)
1742 cgmx(3) = cgmx(3) + tw(2,k)*xyz(3,kg)
1743C
1744 cgmy(3) = cgmy(3) + tw(1,k)*xyz(3,kg)
1745 cgmy(1) = cgmy(1) + tw(3,k)*xyz(1,kg)
1746C
1747 cgmz(1) = cgmz(1) + tw(2,k)*xyz(1,kg)
1748 cgmz(2) = cgmz(2) + tw(1,k)*xyz(2,kg)
1749 END IF
1750 40 CONTINUE
1751 cgmx(2) = cgmx(2)/denfz
1752 cgmx(3) = cgmx(3)/denfy
1753C
1754 cgmy(3) = cgmy(3)/denfx
1755 cgmy(1) = cgmy(1)/denfz
1756C
1757 cgmz(1) = cgmz(1)/denfy
1758 cgmz(2) = cgmz(2)/denfx
1759C
1760 denmx = zero
1761 denmy = zero
1762 denmz = zero
1763C
1764 DO 90 k = 1, ng
1765 kg = inrbe3(k)
1766 ielsub = ilrbe3(k)
1767C
1768C NOTE: AS IMPLEMENTED IN NASTRAN 70.7, WE SCALE THE ROTATIONAL
1769C WEIGHTS WITH THE SQUARE OF THE AVERAGE DISTANCE OF THE
1770C INDEPENDENT GRID POINTS FROM THE REFERENCE POINT TO
1771C RENDER THE RBE3 CALCULATIONS UNIT INDEPENDENT
1772C
1773 IF (ielsub > 0) THEN
1774C
1775C IF GRID POINT HAS A LOCAL COORDINATE SYSTEM
1776C
1777 DO 80 i = 1, 3
1778 denmx = denmx + rw(i,k)*el(i,1,k)**2*averef**2 +
1779 * tw(i,k)*( el(i,3,k)*(xyz(2,kg) - cgmx(2)) -
1780 * el(i,2,k)*(xyz(3,kg) - cgmx(3))
1781 * ) **2
1782 denmy = denmy + rw(i,k)*el(i,2,k)**2*averef**2 +
1783 * tw(i,k)*( el(i,1,k)*(xyz(3,kg) - cgmy(3)) -
1784 * el(i,3,k)*(xyz(1,kg) - cgmy(1))
1785 * ) **2
1786 denmz = denmz + rw(i,k)*el(i,3,k)**2*averef**2 +
1787 * tw(i,k)*( el(i,2,k)*(xyz(1,kg) - cgmz(1)) -
1788 * el(i,1,k)*(xyz(2,kg) - cgmz(2))
1789 * ) **2
1790 80 CONTINUE
1791 ELSE
1792 denmx = denmx + rw(1,k)*averef**2 +
1793 * tw(2,k)*(xyz(3,kg) - cgmx(3))**2 +
1794 * tw(3,k)*(xyz(2,kg) - cgmx(2))**2
1795 denmy = denmy + rw(2,k)*averef**2 +
1796 * tw(1,k)*(xyz(3,kg) - cgmy(3))**2 +
1797 * tw(3,k)*(xyz(1,kg) - cgmy(1))**2
1798 denmz = denmz + rw(3,k)*averef**2 +
1799 * tw(2,k)*(xyz(1,kg) - cgmz(1))**2 +
1800 * tw(1,k)*(xyz(2,kg) - cgmz(2))**2
1801 END IF
1802 90 CONTINUE
1803C
1804C PERFORM SOME CHECKS ON WEIGHTS, TO MAKE SURE THAT THE RBE3
1805C ELEMENT HAS NO UNCONSTRAINED DEGREES OF FREEDOM
1806C
1807C
1808 IF (abs(denmx) <= em20) THEN
1809 ierr = 329
1810 ENDIF
1811C
1812 IF (abs(denmy) <= em20) THEN
1813 ierr = 330
1814 ENDIF
1815C
1816 IF (abs(denmz) <= em20) THEN
1817 ierr = 331
1818 ENDIF
1819C
1820 IF (ierr /= 0) GOTO 999
1821C
1822C CALCULATE 3 FORCE DISTRIBUTIONS THAT CREATE NET X, Y AND Z FORCES
1823C OF 1 (BESIDES OTHER NONZERO FORCES/MOMENTS IN ALL THE DIRECTIONS)
1824C
1825 CALL rbe3uf(inrbe3,ilrbe3,el,tw,xyz,refpt,
1826 * fufxlc,fufylc,fufzlc,fufx,fufy,fufz,mufx,mufy,mufz,
1827 * tfufx,tfufy,tfufz,tmufx,tmufy,tmufz,
1828 * denfx,denfy,denfz,ng)
1829C
1830C CALCULATE 3 MOMENT/FORCE DISTRIBUTIONS THAT CREATE NET X, Y AND Z
1831C MOMENTS OF 1 (BESIDES OTHER NONZERO FORCES/MOMENTS IN ALL THE
1832C DIRECTIONS) AT CGMX, CGMY AND CGMZ RESPECTIVELY
1833C
1834 CALL rbe3um(inrbe3,ilrbe3,el,tw,rw,xyz,refpt,cgmx,cgmy,cgmz,
1835 * fumxlc,fumylc,fumzlc,mxlc,mylc,mzlc,
1836 * fumx,fumy,fumz,mx,my,mz,mumx,mumy,mumz,
1837 * tfumx,tfumy,tfumz,tmumx,tmumy,tmumz,
1838 * averef,denmx,denmy,denmz,ng,irot )
1839C
1840C DETERMINE COMBINATORY COEFFICIENTS FOR THESE 6 DISTRIBUTIONS
1841C (6 COEFFICIENTS FOR EACH OF 6 CASES)
1842C
1843C CASE 1 - RESULTANT OF THE LINEAR COMBINATION OF THESE FORCE/MOMENT
1844C DISTRIBUTIONS IS A UNIT X-FORCE AT REFERENCE POINT
1845C CASE 2 - RESULTANT OF THE LINEAR COMBINATION OF THESE FORCE/MOMENT
1846C DISTRIBUTIONS IS A UNIT Y-FORCE AT REFERENCE POINT
1847C CASE 3 - RESULTANT OF THE LINEAR COMBINATION OF THESE FORCE/MOMENT
1848C DISTRIBUTIONS IS A UNIT Z-FORCE AT REFERENCE POINT
1849C CASE 4 - RESULTANT OF THE LINEAR COMBINATION OF THESE FORCE/MOMENT
1850C DISTRIBUTIONS IS A UNIT X-MOMENT AT REFERENCE POINT
1851C CASE 5 - RESULTANT OF THE LINEAR COMBINATION OF THESE FORCE/MOMENT
1852C DISTRIBUTIONS IS A UNIT Y-MOMENT AT REFERENCE POINT
1853C CASE 6 - RESULTANT OF THE LINEAR COMBINATION OF THESE FORCE/MOMENT
1854C DISTRIBUTIONS IS A UNIT Z-MOMENT AT REFERENCE POINT
1855C
1856C IN ORDER TO DETERMINE THESE COEFFICIENTS, FIRST SET UP A 6X6
1857C MATRIX. THE 6 COLUMNS OF THE INVERSE OF THIS MATRIX ARE THE
1858C DESIRED 6 SETS OF COEFFICIENTS.
1859C
1860 DO 120 i = 1, 3
1861 k = i + 3
1862 a(i,1) = tfufx(i)
1863 a(k,1) = tmufx(i)
1864 a(i,2) = tfufy(i)
1865 a(k,2) = tmufy(i)
1866 a(i,3) = tfufz(i)
1867 a(k,3) = tmufz(i)
1868 a(i,4) = tfumx(i)
1869 a(k,4) = tmumx(i)
1870 a(i,5) = tfumy(i)
1871 a(k,5) = tmumy(i)
1872 a(i,6) = tfumz(i)
1873 a(k,6) = tmumz(i)
1874 120 CONTINUE
1875C
1876C INVERT THE 6X6 MATRIX
1877C
1878 nsnglr = 0
1879 CALL invert(a,c,6,nsnglr)
1880 IF (nsnglr /= 0) THEN
1881 ierr = 332
1882 GOTO 999
1883 ENDIF
1884C
1885 DO i = 1, 3
1886 DO j = 1, 6
1887 DO k = 1, ng
1888 fdstnb(i,j,k) = c(1,j)*fufx(i,k) + c(2,j)*fufy(i,k) +
1889 * c(3,j)*fufz(i,k) + c(4,j)*fumx(i,k) +
1890 * c(5,j)*fumy(i,k) + c(6,j)*fumz(i,k)
1891 ENDDO
1892 ENDDO
1893 ENDDO
1894 IF (irot>0) THEN
1895 DO i = 1, 3
1896 DO j = 1, 6
1897 DO k = 1, ng
1898 mdstnb(i,j,k) = c(4,j)*mx(i,k) + c(5,j)*my(i,k) +
1899 * c(6,j)*mz(i,k)
1900 ENDDO
1901 ENDDO
1902 ENDDO
1903 END IF
1904C
1905 999 CONTINUE
1906 IF (ierr>0) THEN
1907 WRITE(istdo,'(A,I10)')
1908 . ' ** ERROR IN RBE3 CALCULATION ID=',ierr
1909 WRITE(iout,'(A,I10)')
1910 . ' ** ERROR IN RBE3 CALCULATION ID=',ierr
1911 CALL arret(2)
1912 ENDIF
1913C
1914C DIAGNOSTIC INFORMATION
1915C
1916 RETURN
invert
subroutine invert(matrix, inverse, n, errorflag)
Definition hm_read_rbe3.F:1354
zero1
subroutine zero1(r, n)
Definition hm_read_rbe3.F:1481
rbe3um
subroutine rbe3um(inrbe3, ilrbe3, el, tw, rw, xyz, refpt, cgmx, cgmy, cgmz, fumxlc, fumylc, fumzlc, mxlc, mylc, mzlc, fumx, fumy, fumz, mx, my, mz, mumx, mumy, mumz, tfumx, tfumy, tfumz, tmumx, tmumy, tmumz, averef, denmx, denmy, denmz, ng, irot)
Definition hm_read_rbe3.F:1171
rbe3uf
subroutine rbe3uf(inrbe3, ilrbe3, el, tw, xyz, refpt, fufxlc, fufylc, fufzlc, fufx, fufy, fufz, mufx, mufy, mufz, tfufx, tfufy, tfufz, tmufx, tmufy, tmufz, denfx, denfy, denfz, ng)
Definition hm_read_rbe3.F:1052
arret
subroutine arret(nn)
Definition arret.F:87

◆ rby_v0()

subroutine rby_v0 ( x,
integer, dimension(*) nod,
integer m,
integer nsn,
d,
dr )

Definition at line 1361 of file kinchk.F.

1362C-----------------------------------------------
1363C I m p l i c i t T y p e s
1364C-----------------------------------------------
1365#include "implicit_f.inc"
1366C-----------------------------------------------
1367C D u m m y A r g u m e n t s
1368C-----------------------------------------------
1369 INTEGER NOD(*), M,NSN
1370C REAL
1371 my_real
1372 . x(3,*), d(3,*),dr(3,*)
1373C-----------------------------------------------
1374C L o c a l V a r i a b l e s
1375C-----------------------------------------------
1376 INTEGER I, N
1377C REAL
1378 my_real
1379 . xs,ys,zs
1380C-----------------------------------------------
1381 DO i=1,nsn
1382 n = nod(i)
1383 xs=x(1,n)-x(1,m)
1384 ys=x(2,n)-x(2,m)
1385 zs=x(3,n)-x(3,m)
1386 d(1,n)=d(1,m)+dr(2,m)*zs-dr(3,m)*ys
1387 d(2,n)=d(2,m)-dr(1,m)*zs+dr(3,m)*xs
1388 d(3,n)=d(3,m)+dr(1,m)*ys-dr(2,m)*xs
1389 dr(1,n)= dr(1,m)
1390 dr(2,n)= dr(2,m)
1391 dr(3,n)= dr(3,m)
1392 ENDDO
1393C
1394 RETURN