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"
#include "com01_c.inc"
#include "tabsiz_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 1294 of file kinchk.F.

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

◆ 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 AUTOMATIC CORRECTIONS INTERFACE 1,2,9 OR RBODY WITH 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 - unauthorized hierarchy: check that the main nodes of rbe3 are secondary to 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 - unauthorized hierarchy: check that the main nodes of rbe2 are secondary to 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 - unauthorized hierarchy: check that the main nodes of rbody are secondary to 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 - unauthorized hierarchy: check that the main nodes of rbody are secondary to 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 that the main nodes of rbe2 are mains of 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 main nodes of Rbody SECONDARY to other 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
369! remove ik of penalty RBE3
370 DO i=1,nrbe3
371 nsl= irbe3(3,i)
372 ipen = irbe3(9,i)
373 IF (ipen>0) ikrbe3(ikine(nsl)) = 0
374 END DO
375C=======================================================================
376 IF(ipri>=6)THEN
377 WRITE(iout,*)' NODES WITH KINEMATIC CONDITIONS:'
378 WRITE(iout,*)' --------------------------------'
379 k = 0
380 DO i=1,numnod
381 IF(ikine(i)/=0)THEN
382 k = k + 1
383 ik(k) = itab(i)
384 IF(k==10)THEN
385 WRITE(iout,fmt=fmw_10i)(ik(j),j=1,k)
386 k = 0
387 ENDIF
388 ENDIF
389 ENDDO
390 IF(k/=10) WRITE(iout,fmt=fmw_10i)(ik(j),j=1,k)
391 ENDIF
392C
393C---------------------------------------------------------------
394C LIST OF INCOMPATIBLE CONDITIONS BY TYPE
395C LIST OF AFFECTED NODES
396C
397C NKIN(I) >= 2 => POSSIBLE INCOMPATIBLE CONDITIONS ON NODE I
398C FLAG_IKCOND = 1 => INCOMPATIBLE CONDITIONS IN THE MODEL
399C MARQUEURDOUBLE(I) = 1 => INCOMPATIBLE CONDITIONS BETWEEN CONDITIONS
400C OF THE SAME TYPE ON NODE I
401C MARQUEUR(I) != 0 => INCOMPATIBLE CONDITIONS BETWEEN CONDITIONS
402C OF DIFFERENT TYPES ON NODE I
403C MARQUEUR(I) = 2 => CASE RBODY + RWALL
404C MARQUEUR(I) =-2 => CASE INTERFACES TYPE 1,2,9 + RWALL
405C MARQUEUR(I) = 3 => CASE INTERFACES TYPE 1,2,9 + RBODY + RWALL
406C---------------------------------------------------------------
407 DO i=1,numnod
408 nkin(i) = 0
409 nkindouble(i) = 0
410 ENDDO
411 DO i=1,numnod
412 nkin(i) = ibc(ikine(i))+itf(ikine(i))+iwl(ikine(i))+
413 . irb(ikine(i))+irb2(ikine(i))+
414 . ivf(ikine(i))+irv(ikine(i))+ijo(ikine(i))+
415 . irbm(ikine(i))+ilmult(ikine(i))+irlk(ikine(i))+
416 . ikrbe2(ikine(i))+ikrbe3(ikine(i))+
417 . ibc(ikine(i+3*numnod))+itf(ikine(i+3*numnod))+
418 . iwl(ikine(i+3*numnod))+irb(ikine(i+3*numnod))+
419 . irb2(ikine(i+3*numnod))+ivf(ikine(i+3*numnod))+
420 . irv(ikine(i+3*numnod))+ijo(ikine(i+3*numnod))+
421 . irbm(ikine(i+3*numnod))+ilmult(ikine(i+3*numnod))+
422 . irlk(ikine(i+3*numnod))+ikrbe2(ikine(i+3*numnod))+
423 . ikrbe3(ikine(i+3*numnod))
424 ENDDO
425C---------------------------------------------------------------
426 flag_ikcond = 0
427 DO i=1,8192
428 marqueur(i) = 0
429 ENDDO
430 DO i=1,13
431 marqueurdouble(i) = 0
432 ENDDO
433 DO i=1,numnod
434 IF(nkin(i)>=2)THEN
435 IF (ibc(ikine(i))== 1
436 . .AND. ibc(ikine(i+3*numnod))== 1) THEN
437 marqueurdouble(1) = 1
438 flag_ikcond = 1
439 ENDIF
440 IF (itf(ikine(i))== 1
441 . .AND. itf(ikine(i+3*numnod))== 1) THEN
442 marqueurdouble(2) = 1
443 flag_ikcond = 1
444 ENDIF
445 IF (iwl(ikine(i))== 1
446 . .AND. iwl(ikine(i+3*numnod))== 1) THEN
447 marqueurdouble(3) = 1
448 flag_ikcond = 1
449 ENDIF
450 IF (irb(ikine(i))== 1
451 . .AND. irb(ikine(i+3*numnod))== 1) THEN
452 marqueurdouble(4) = 1
453 flag_ikcond = 1
454 ENDIF
455 IF (irb2(ikine(i))== 1
456 . .AND. irb2(ikine(i+3*numnod))== 1) THEN
457 marqueurdouble(5) = 1
458 flag_ikcond = 1
459 ENDIF
460 IF (ivf(ikine(i))== 1
461 . .AND. ivf(ikine(i+3*numnod))== 1) THEN
462 marqueurdouble(6) = 1
463 flag_ikcond = 1
464 ENDIF
465 IF (irv(ikine(i))== 1
466 . .AND. irv(ikine(i+3*numnod))== 1) THEN
467 marqueurdouble(7) = 1
468 flag_ikcond = 1
469 ENDIF
470 IF (ijo(ikine(i))== 1
471 . .AND. ijo(ikine(i+3*numnod))== 1) THEN
472 marqueurdouble(8) = 1
473 flag_ikcond = 1
474 ENDIF
475 IF (irbm(ikine(i))== 1
476 . .AND. irbm(ikine(i+3*numnod))== 1) THEN
477 marqueurdouble(9) = 1
478 flag_ikcond = 1
479 ENDIF
480 IF (ilmult(ikine(i))== 1
481 . .AND. ilmult(ikine(i+3*numnod))== 1) THEN
482 marqueurdouble(10) = 1
483 flag_ikcond = 1
484 ENDIF
485 IF (irlk(ikine(i))== 1
486 . .AND. irlk(ikine(i+3*numnod))== 1) THEN
487 marqueurdouble(11) = 1
488 flag_ikcond = 1
489 ENDIF
490 IF (ikrbe2(ikine(i))== 1
491 . .AND. ikrbe2(ikine(i+3*numnod))== 1) THEN
492 marqueurdouble(12) = 1
493 flag_ikcond = 1
494 ENDIF
495 IF (ikrbe3(ikine(i))== 1
496 . .AND. ikrbe3(ikine(i+3*numnod))== 1) THEN
497 marqueurdouble(13) = 1
498 flag_ikcond = 1
499 ENDIF
500 ENDIF
501 ENDDO
502C---------------------------------------------------------------
503 nikrw = 0
504 DO i = 1,numnod
505 IF ( ikine(i) /= 0 .AND. ikine(i)/=1 .AND. ikine(i)/=2
506 . .AND. ikine(i)/=4 .AND. ikine(i)/=8 .AND. ikine(i)/=16
507 . .AND. ikine(i)/=32 .AND. ikine(i)/=64
508 . .AND. ikine(i)/=128 .AND. ikine(i)/=256
509 . .AND. ikine(i)/=512 .AND. ikine(i)/=1024
510 . .AND. ikine(i)/=2048 .AND. ikine(i)/=4096
511 . .AND. ikine(i+4*numnod) /= 0 ) THEN
512 IF(iwl(ikine(i))== 1 .AND. irb(ikine(i))== 1
513 . .AND. itf(ikine(i))== 1 )THEN
514 IF (ikine(i)>14) THEN
515 marqueur(ikine(i)) = 3
516 flag_ikcond = 1
517 ELSE
518 marqueur(ikine(i)) = 0
519 ENDIF
520 ELSEIF(iwl(ikine(i))== 1 .AND. irb(ikine(i))== 1)THEN
521 IF (ikine(i)>12) THEN
522 marqueur(ikine(i)) = 2
523 flag_ikcond = 1
524 ELSE
525 marqueur(ikine(i)) = 0
526 ENDIF
527 ELSEIF(iwl(ikine(i))== 1 .AND. itf(ikine(i))== 1)THEN
528 IF (ikine(i)>6) THEN
529 marqueur(ikine(i)) = -2
530 flag_ikcond = 1
531 ELSE
532 marqueur(ikine(i)) = 0
533 ENDIF
534 ELSE
535 marqueur(ikine(i)) = 1
536 flag_ikcond = 1
537 nikrw = nikrw + 1
538 ikrw(nikrw) = itab(i)
539 ENDIF
540 ENDIF
541 ENDDO
542C---------------------------------------------------------------
543 IF (ipri>=6 .AND. flag_ikcond==1) THEN
544 WRITE(iout,*)' '
545 WRITE(iout,*)
546 . 'LIST OF POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS :'
547 WRITE(iout,*)'--------------------------------------------------'
548 WRITE(iout,*)' '
549
550 DO i=1,13
551 IF ( marqueurdouble(i) == 1 )THEN
552 IF ( i == 1) THEN
553 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
554 .ETWEEN'
555 WRITE(iout,*)' SEVERAL BOUNDARY CONDITIONS :'
556 WRITE(iout,*)' '
557 WRITE(iout,*)'NODES :'
558 k = 0
559 DO j = 1,numnod
560 IF (ibc(ikine(j))== 1
561 . .AND. ibc(ikine(j+3*numnod))== 1) THEN
562 k = k + 1
563 ik(k) = itab(j)
564 IF(k==10)THEN
565 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
566 k = 0
567 ENDIF
568 ENDIF
569 ENDDO
570 IF(k/=0)THEN
571 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
572 ENDIF
573 WRITE(iout,*)' '
574 ENDIF
575 IF ( i == 2) THEN
576 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
577 .ETWEEN'
578 WRITE(iout,*)' SEVERAL INTERFACES TYPE 1 2 12 OR 9'
579 WRITE(iout,*)' '
580 WRITE(iout,*)'NODES :'
581 k = 0
582 DO j = 1,numnod
583 IF (itf(ikine(j))== 1
584 . .AND. itf(ikine(j+3*numnod))== 1) THEN
585 k = k + 1
586 ik(k) = itab(j)
587 IF(k==10)THEN
588 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
589 k = 0
590 ENDIF
591 ENDIF
592 ENDDO
593 IF(k/=0)THEN
594 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
595 ENDIF
596 WRITE(iout,*)' '
597 ENDIF
598 IF ( i == 3) THEN
599 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
600 .ETWEEN'
601 WRITE(iout,*)' SEVERAL RIGID WALLS'
602 WRITE(iout,*)' '
603 WRITE(iout,*)'NODES :'
604 k = 0
605 DO j = 1,numnod
606 IF (iwl(ikine(j))== 1
607 . .AND. iwl(ikine(j+3*numnod))== 1) THEN
608 k = k + 1
609 ik(k) = itab(j)
610 IF(k==10)THEN
611 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
612 k = 0
613 ENDIF
614 ENDIF
615 ENDDO
616 IF(k/=0)THEN
617 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
618 ENDIF
619 WRITE(iout,*)' '
620 ENDIF
621 IF ( i == 4 .OR. i == 5) THEN
622 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
623 .ETWEEN'
624 WRITE(iout,*)' SEVERAL RIGID BODIES'
625 WRITE(iout,*)' '
626 WRITE(iout,*)'NODES :'
627 k = 0
628 DO j = 1,numnod
629 IF (irb(ikine(j))== 1
630 . .AND. irb(ikine(j+3*numnod))== 1) THEN
631 k = k + 1
632 ik(k) = itab(j)
633 IF(k==10)THEN
634 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
635 k = 0
636 ENDIF
637 ENDIF
638 ENDDO
639 IF(k/=0)THEN
640 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
641 ENDIF
642 WRITE(iout,*)' '
643 ENDIF
644 IF ( i == 6) THEN
645 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
646 .ETWEEN'
647 WRITE(iout,*)' SEVERAL IMPOSED ACCELERATIONS, IMPOSED DEP
648 .LACEMENTS, IMPOSED VELOCITIES'
649 WRITE(iout,*)' '
650 WRITE(iout,*)'NODES :'
651 k = 0
652 DO j = 1,numnod
653 IF (ivf(ikine(j))== 1
654 . .AND. ivf(ikine(j+3*numnod))== 1) THEN
655 k = k + 1
656 ik(k) = itab(j)
657 IF(k==10)THEN
658 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
659 k = 0
660 ENDIF
661 ENDIF
662 ENDDO
663 IF(k/=0)THEN
664 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
665 ENDIF
666 WRITE(iout,*)' '
667 ENDIF
668 IF ( i == 7) THEN
669 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
670 .ETWEEN'
671 WRITE(iout,*)' SEVERAL RIVETS'
672 WRITE(iout,*)' '
673 WRITE(iout,*)'NODES :'
674 k = 0
675 DO j = 1,numnod
676 IF (irv(ikine(j))== 1
677 . .AND. irv(ikine(j+3*numnod))== 1) THEN
678 k = k + 1
679 ik(k) = itab(j)
680 IF(k==10)THEN
681 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
682 k = 0
683 ENDIF
684 ENDIF
685 ENDDO
686 IF(k/=0)THEN
687 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
688 ENDIF
689 WRITE(iout,*)' '
690 ENDIF
691 IF ( i == 8) THEN
692 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
693 .ETWEEN'
694 WRITE(iout,*)' SEVERAL CYLINDRICAL JOINTS'
695 WRITE(iout,*)' '
696 WRITE(iout,*)'NODES :'
697 k = 0
698 DO j = 1,numnod
699 IF (ijo(ikine(j))== 1
700 . .AND. ijo(ikine(j+3*numnod))== 1) THEN
701 k = k + 1
702 ik(k) = itab(j)
703 IF(k==10)THEN
704 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
705 k = 0
706 ENDIF
707 ENDIF
708 ENDDO
709 IF(k/=0)THEN
710 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
711 ENDIF
712 WRITE(iout,*)' '
713 ENDIF
714 IF ( i == 9) THEN
715 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
716 .ETWEEN'
717 WRITE(iout,*)' SEVERAL IMPOSED BODY VELOCITIES'
718 WRITE(iout,*)' '
719 WRITE(iout,*)'NODES :'
720 k = 0
721 DO j = 1,numnod
722 IF (ilmult(ikine(j))== 1
723 . .AND. ilmult(ikine(j+3*numnod))== 1) THEN
724 k = k + 1
725 ik(k) = itab(j)
726 IF(k==10)THEN
727 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
728 k = 0
729 ENDIF
730 ENDIF
731 ENDDO
732 IF(k/=0)THEN
733 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
734 ENDIF
735 WRITE(iout,*)' '
736 ENDIF
737 IF ( i == 10) THEN
738 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
739 .ETWEEN'
740 WRITE(iout,*)' SEVERAL LAGRANGE MULTIPLIERS'
741 WRITE(iout,*)' '
742 WRITE(iout,*)'NODES :'
743 k = 0
744 DO j = 1,numnod
745 IF (ibc(ikine(j))== 1
746 . .AND. ibc(ikine(j+3*numnod))== 1) THEN
747 k = k + 1
748 ik(k) = itab(j)
749 IF(k==10)THEN
750 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
751 k = 0
752 ENDIF
753 ENDIF
754 ENDDO
755 IF(k/=0)THEN
756 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
757 ENDIF
758 WRITE(iout,*)' '
759 ENDIF
760 IF ( i == 11) THEN
761 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
762 .ETWEEN'
763 WRITE(iout,*)' SEVERAL RIGID LINKS :'
764 WRITE(iout,*)' '
765 WRITE(iout,*)'NODES :'
766 k = 0
767 DO j = 1,numnod
768 IF (irlk(ikine(j))== 1
769 . .AND. irlk(ikine(j+3*numnod))== 1) THEN
770 k = k + 1
771 ik(k) = itab(j)
772 IF(k==10)THEN
773 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
774 k = 0
775 ENDIF
776 ENDIF
777 ENDDO
778 IF(k/=0)THEN
779 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
780 ENDIF
781 WRITE(iout,*)' '
782 ENDIF
783 IF ( i == 12) THEN
784 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
785 .ETWEEN'
786 WRITE(iout,*)' SEVERAL RBE2 :'
787 WRITE(iout,*)' '
788 WRITE(iout,*)'NODES :'
789 k = 0
790 DO j = 1,numnod
791 IF (ikrbe2(ikine(j))== 1
792 . .AND. ikrbe2(ikine(j+3*numnod))== 1) THEN
793 k = k + 1
794 ik(k) = itab(j)
795 IF(k==10)THEN
796 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
797 k = 0
798 ENDIF
799 ENDIF
800 ENDDO
801 IF(k/=0)THEN
802 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
803 ENDIF
804 WRITE(iout,*)' '
805 ENDIF
806 IF ( i == 13) THEN
807 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
808 .ETWEEN'
809 WRITE(iout,*)' SEVERAL RBE3 :'
810 WRITE(iout,*)' '
811 WRITE(iout,*)'NODES :'
812 k = 0
813 DO j = 1,numnod
814 IF (ikrbe3(ikine(j))== 1
815 . .AND. ikrbe3(ikine(j+3*numnod))== 1) THEN
816 k = k + 1
817 ik(k) = itab(j)
818 IF(k==10)THEN
819 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
820 k = 0
821 ENDIF
822 ENDIF
823 ENDDO
824 IF(k/=0)THEN
825 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
826 ENDIF
827 WRITE(iout,*)' '
828 ENDIF
829 ENDIF
830 ENDDO
831C '
832 DO i=1,8192
833 IF ( marqueur(i) /= 0 )THEN
834 WRITE(iout,*)
835 . '- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS BETWEEN:'
836 DO j=1,abs(marqueur(i))
837C cas RBODY & RWALL, INTER 1_2_9 & RWALL, RBODY & INTER 1_2_9 & RWALL
838 IF (j==1 .AND. abs(marqueur(i)) == 2 ) iwl(i)=iwl(i)-1
839 IF (j==1 .AND. abs(marqueur(i)) == 3 ) THEN
840 iwl(i)=iwl(i)-1
841 itf(i) = itf(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 irb(i) = irb(i) - 1
848 ENDIF
849 IF (j==2 .AND. marqueur(i) == -2 ) THEN
850 WRITE(iout,*)
851 . '- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS BETWEEN:'
852 iwl(i) = iwl(i) + 1
853 itf(i) = itf(i) - 1
854 ENDIF
855 IF (j==2 .AND. marqueur(i) == 3 ) THEN
856 WRITE(iout,*)
857 . '- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS BETWEEN:'
858 iwl(i) = iwl(i) + 1
859 irb(i) = irb(i) - 1
860 ENDIF
861 IF (j==3 .AND. marqueur(i) == 3 ) THEN
862 WRITE(iout,*)
863 . '- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS BETWEEN:'
864 iwl(i) = iwl(i) - 1
865 itf(i) = itf(i) +1
866 ENDIF
867C
868 IF (ibc(i)== 1) THEN
869 WRITE(iout,*)' BOUNDARY CONDITION'
870 ENDIF
871 IF (itf(i)== 1) THEN
872 WRITE(iout,*)' INTERFACE TYPE 1 2 12 OR 9'
873 ENDIF
874 IF (iwl(i)== 1) THEN
875 WRITE(iout,*)' RIGID WALL'
876 ENDIF
877 IF (irb(i)== 1) THEN
878 WRITE(iout,*)' RIGID BODY'
879 ENDIF
880 IF (irb2(i)== 1) THEN
881 WRITE(iout,*)' RIGID BODY'
882 ENDIF
883 IF (ivf(i)== 1) THEN
884 WRITE(iout,*)' IMPOSED ACCELERATION, IMPOSED DISPLACEMENT
885 ., IMPOSED VELOCITY'
886 ENDIF
887 IF (irv(i)== 1) THEN
888 WRITE(iout,*)' RIVET'
889 ENDIF
890 IF (ijo(i)== 1) THEN
891 WRITE(iout,*)' CYLINDRICAL JOINT'
892 ENDIF
893 IF (irbm(i)== 1) THEN
894 WRITE(iout,*)' IMPOSED BODY VELOCITY'
895 ENDIF
896 IF (ilmult(i)== 1) THEN
897 WRITE(iout,*)' LAGRANGE MULTIPLIERS'
898 ENDIF
899 IF (irlk(i)== 1) THEN
900 WRITE(iout,*)' RIGID LINK'
901 ENDIF
902 IF (ikrbe2(i)== 1) THEN
903 WRITE(iout,*)' RBE2'
904 ENDIF
905 IF (ikrbe3(i)== 1) THEN
906 WRITE(iout,*)' RBE3'
907 ENDIF
908 WRITE(iout,*)
909 . ' '
910 WRITE(iout,*)'NODES :'
911 k = 0
912 DO j1 = 1,numnod
913 IF (ikine(j1) == i) THEN
914 k = k + 1
915 ik(k) = itab(j1)
916 IF(k==10)THEN
917 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
918 k = 0
919 ENDIF
920 ENDIF
921 ENDDO
922 IF(k/=0)THEN
923 WRITE(iout,fmt=fmw_10i)(ik(l),l=1,k)
924 ENDIF
925 WRITE(iout,*)' '
926 IF (j==2 .AND.marqueur(i) == 2 )irb(i) = irb(i) + 1
927 IF (j==2 .AND.marqueur(i) == -2 )itf(i) = itf(i) + 1
928 IF (j==3 .AND.marqueur(i) == 3 ) THEN
929 irb(i) = irb(i) + 1
930 iwl(i) = iwl(i) + 1
931 ENDIF
932 ENDDO
933 ENDIF
934 ENDDO
935 ENDIF
936C---------------------------------------------------------------
937 IF(kwarn>0)THEN
938 CALL ancmsg(msgid=312,anmode=aninfo,msgtype=msgwarning,
939 . i1=kwarn)
940 WRITE(iout,*)' '
941 WRITE(iout,*)' '
942c WRITE(IOUT,FMT=FMW_10I)(IKRW(L),L=1,KWARN)
943c
944 ENDIF
945C---------------------------------------------------------------
946C SUMMARY OF INCOMPATIBLE CONDITIONS BY TYPE
947C---------------------------------------------------------------
948 WRITE(iout,*)'SUMMARY OF POSSIBLE INCOMPATIBLE KINEMATIC CONDITION
949 .S :'
950 WRITE(iout,*)'--------------------------------------------------
951 .---'
952 WRITE(iout,*)' '
953 IF (flag_ikcond==0) THEN
954 WRITE(iout,*)'NO TRUE INCOMPATIBLE KINEMATIC CONDITION'
955 IF (marq2 == 1) THEN
956 WRITE(iout,*)' - AFTER SECONDARY NODES OF RIGID BODIES WERE SUPPRE
957 .SSED FROM RIGID WALL(S)'
958 ENDIF
959 IF (marqm2 == 1) THEN
960 WRITE(iout,*)' - AFTER SECONDARY NODES OF INTERFACES TYPE 1,2,12 O
961 .R 9 WERE SUPPRESSED'
962 WRITE(iout,*)' FROM RIGID WALL(S)'
963 ENDIF
964 ENDIF
965C---------------------------------------------------------------
966 DO i=1,13
967 IF ( marqueurdouble(i) == 1 )THEN
968 IF ( i == 1) THEN
969 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
970 .ETWEEN'
971 WRITE(iout,*)' SEVERAL BOUNDARY CONDITIONS'
972 WRITE(iout,*)' '
973 WRITE(iout,*)' '
974 ENDIF
975 IF ( i == 2) THEN
976 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
977 .ETWEEN'
978 WRITE(iout,*)' SEVERAL INTERFACES TYPE 1 2 12 OR 9'
979 WRITE(iout,*)' '
980 WRITE(iout,*)' '
981 ENDIF
982 IF ( i == 3) THEN
983 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
984 .ETWEEN'
985 WRITE(iout,*)' SEVERAL RIGID WALLS'
986 WRITE(iout,*)' '
987 WRITE(iout,*)' '
988 ENDIF
989 IF ( i == 4 .OR. i == 5) THEN
990 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
991 .ETWEEN'
992 WRITE(iout,*)' SEVERAL RIGID BODIES'
993 WRITE(iout,*)' '
994 WRITE(iout,*)' '
995 ENDIF
996 IF ( i == 6) THEN
997 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
998 .ETWEEN'
999 WRITE(iout,*)' SEVERAL IMPOSED ACCELERATIONS, IMPOSED DEP
1000 .LACEMENTS, IMPOSED VELOCITIES'
1001 WRITE(iout,*)' '
1002 WRITE(iout,*)' '
1003 ENDIF
1004 IF ( i == 7) THEN
1005 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
1006 .ETWEEN'
1007 WRITE(iout,*)' SEVERAL RIVETS'
1008 WRITE(iout,*)' '
1009 WRITE(iout,*)' '
1010 ENDIF
1011 IF ( i == 8) THEN
1012 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
1013 .ETWEEN'
1014 WRITE(iout,*)' SEVERAL CYLINDRICAL JOINTS'
1015 WRITE(iout,*)' '
1016 WRITE(iout,*)' '
1017 ENDIF
1018 IF ( i == 9) THEN
1019 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
1020 .ETWEEN'
1021 WRITE(iout,*)' SEVERAL IMPOSED BODY VELOCITIES'
1022 WRITE(iout,*)' '
1023 WRITE(iout,*)' '
1024 ENDIF
1025 IF ( i == 10) THEN
1026 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
1027 .ETWEEN'
1028 WRITE(iout,*)' SEVERAL LAGRANGE MULTIPLIERS'
1029 WRITE(iout,*)' '
1030 WRITE(iout,*)' '
1031 ENDIF
1032 IF ( i == 11) THEN
1033 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
1034 .ETWEEN'
1035 WRITE(iout,*)' SEVERAL RIGID LINKS'
1036 WRITE(iout,*)' '
1037 WRITE(iout,*)' '
1038 ENDIF
1039 IF ( i == 12) THEN
1040 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
1041 .ETWEEN'
1042 WRITE(iout,*)' SEVERAL RBE2'
1043 WRITE(iout,*)' '
1044 WRITE(iout,*)' '
1045 ENDIF
1046 IF ( i == 13) THEN
1047 WRITE(iout,*)'- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS B
1048 .ETWEEN'
1049 WRITE(iout,*)' SEVERAL RBE3'
1050 WRITE(iout,*)' '
1051 WRITE(iout,*)' '
1052 ENDIF
1053 ENDIF
1054 ENDDO
1055C '
1056 DO i=1,8192
1057 IF ( marqueur(i) /= 0 )THEN
1058 WRITE(iout,*)
1059 . '- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS BETWEEN:'
1060 DO j=1,abs(marqueur(i))
1061 IF (j==1 .AND. abs(marqueur(i)) == 2 ) iwl(i)=iwl(i)-1
1062 IF (j==1 .AND. abs(marqueur(i)) == 3 ) THEN
1063 iwl(i )= iwl(i) - 1
1064 itf(i) = itf(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 irb(i) = irb(i) - 1
1071 ENDIF
1072 IF (j==2 .AND. marqueur(i) == -2 ) THEN
1073 WRITE(iout,*)
1074 . '- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS BETWEEN:'
1075 iwl(i) = iwl(i) + 1
1076 itf(i) = itf(i) - 1
1077 ENDIF
1078 IF (j==2 .AND. marqueur(i) == 3 ) THEN
1079 WRITE(iout,*)
1080 . '- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS BETWEEN:'
1081 iwl(i) = iwl(i) + 1
1082 irb(i) = irb(i) - 1
1083 ENDIF
1084 IF (j==3 .AND. marqueur(i) == 3 ) THEN
1085 WRITE(iout,*)
1086 . '- POSSIBLE INCOMPATIBLE KINEMATIC CONDITIONS BETWEEN:'
1087 iwl(i) = iwl(i) - 1
1088 itf(i) = itf(i) + 1
1089 ENDIF
1090C
1091 IF (ibc(i)== 1) THEN
1092 WRITE(iout,*)' BOUNDARY CONDITION'
1093 ENDIF
1094 IF (itf(i)== 1) THEN
1095 WRITE(iout,*)' INTERFACE TYPE 1 2 12 OR 9'
1096 ENDIF
1097 IF (iwl(i)== 1) THEN
1098 WRITE(iout,*)' RIGID WALL'
1099 ENDIF
1100 IF (irb(i)== 1) THEN
1101 WRITE(iout,*)' RIGID BODY'
1102 ENDIF
1103 IF (irb2(i)== 1) THEN
1104 WRITE(iout,*)' RIGID BODY'
1105 ENDIF
1106 IF (ivf(i)== 1) THEN
1107 WRITE(iout,*)' IMPOSED ACCELERATION, IMPOSED DISPLACEMENT
1108 ., IMPOSED VELOCITY'
1109 ENDIF
1110 IF (irv(i)== 1) THEN
1111 WRITE(iout,*)' RIVET'
1112 ENDIF
1113 IF (ijo(i)== 1) THEN
1114 WRITE(iout,*)' CYLINDRICAL JOINT'
1115 ENDIF
1116 IF (irbm(i)== 1) THEN
1117 WRITE(iout,*)' IMPOSED BODY VELOCITY'
1118 ENDIF
1119 IF (ilmult(i)== 1) THEN
1120 WRITE(iout,*)' LAGRANGE MULTIPLIERS'
1121 ENDIF
1122 IF (irlk(i)== 1) THEN
1123 WRITE(iout,*)' RIGID LINK'
1124 ENDIF
1125 IF (ikrbe2(i)== 1) THEN
1126 WRITE(iout,*)' RBE2'
1127 ENDIF
1128 IF (ikrbe3(i)== 1) THEN
1129 WRITE(iout,*)' RBE3'
1130 ENDIF
1131 IF (j==2 .AND.marqueur(i) == 2 )irb(i) = irb(i) + 1
1132 IF (j==2 .AND.marqueur(i) == -2 )itf(i) = itf(i) + 1
1133 IF (j==3 .AND.marqueur(i) == 3 ) THEN
1134 irb(i) = irb(i) + 1
1135 iwl(i) = iwl(i) + 1
1136 ENDIF
1137 IF(kwarn>0.AND.ipri>=3)THEN
1138 WRITE(iout,*)'NODES :'
1139 WRITE(iout,fmt=fmw_10i)(ikrw(l),l=1,nikrw)
1140 ENDIF
1141 WRITE(iout,*)' '
1142 WRITE(iout,*)' '
1143 ENDDO
1144 ENDIF
1145 ENDDO
1146!
1147 nun=0
1148 DO i=1,nrbe3
1149 ipen = irbe3(9,i) ! add warning for added mass+pen
1150 IF (ipen>0) nun = nun + 1
1151 IF (ipen <0) irbe3(9,i) =0
1152 END DO
1153 IF (nun>0) THEN
1154 WRITE(iout,'(/I8,X,A)')nun,'OF RBE3 HAVE BEEN SWITCHED TO PENALTY METHOD'
1155 ENDIF
1156C---------------------------------------------------------------
1157 DO i=1,numnod
1158C reset flag impact / wall
1159ccc IF(IWL(IKINE(I))==1)IKINE(I) = IKINE(I) - 4
1160 kinet(i)=ikine(i)
1161 ENDDO
1162 DEALLOCATE(nkindouble,nkin,ikrw)
1163
1164C
1165Cls
1166Cls
1167Cls WARNING : RETURN HERE !!!
1168Cls
1169 RETURN
1170Cls
1171Cls
1172Cls
1173 jwarn = 0
1174 DO 100 i=1,numnod
1175 nk = ibc(ikine(i))+itf(ikine(i))+iwl(ikine(i))+
1176 . irb(ikine(i))+irb2(ikine(i))+
1177 . ivf(ikine(i))+irv(ikine(i))+ijo(ikine(i))
1178 IF(nk>=2)THEN
1179 jwarn = jwarn+1
1180 WRITE(iout,*)
1181 . ' -',nk,' KINEMATIC CONDITIONS ON NODE',itab(i),':'
1182 IF(ibc(ikine(i))==1) WRITE(iout,*)
1183 . ' - BOUNDARY CONDITION'
1184 IF(itf(ikine(i))==1) WRITE(iout,*)
1185 . ' - INTERFACE TYPE 1 2 12 OR 9'
1186 IF(iwl(ikine(i))==1) WRITE(iout,*)
1187 . ' - RIGID WALL'
1188 IF(irb(ikine(i))==1) WRITE(iout,*)
1189 . ' - RIGID BODY'
1190 IF(irb2(ikine(i))==1) WRITE(iout,*)
1191 . ' - RIGID BODY'
1192 IF(ivf(ikine(i))==1) WRITE(iout,*)
1193 . ' - FIXED VELOCITY'
1194 IF(irv(ikine(i))==1) WRITE(iout,*)
1195 . ' - RIVET'
1196 IF(ijo(ikine(i))==1) WRITE(iout,*)
1197 . ' - CYLINDRICAL JOINT'
1198 IF(irbm(ikine(i))==1) WRITE(iout,*)
1199 . ' - IMPOSED BODY VELOCITY'
1200 IF(ilmult(ikine(i))==1) WRITE(iout,*)
1201 . ' - LAGRANGE MULTIPLIERS'
1202 ENDIF
1203 100 CONTINUE
1204C
1205 iwarn = iwarn + jwarn
1206 IF(jwarn/=0)THEN
1207 WRITE(istdo,'(A,I8,A)') ' ** WARNING',jwarn,
1208 . ' NODES WITH INCOMPATIBLE KINEMATIC CONDITIONS'
1209 WRITE(iout,fmt=fmw_a_i_a) ' ** WARNING',jwarn,
1210 . ' NODES WITH INCOMPATIBLE KINEMATIC CONDITIONS'
1211 ENDIF
1212C
1213 RETURN
the
end diagonal values have been computed in the(sparse) matrix id.SOL
id
initmumps id
Definition multiplerhs_example.m:4
message_mod
Definition message_mod.F:1257
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1008
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:895
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:799

◆ 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 1220 of file kinchk.F.

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

◆ prerbe2()

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

Definition at line 1979 of file kinchk.F.

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

◆ prerbe3()

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

Definition at line 1499 of file kinchk.F.

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

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

◆ rbe2d0()

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

Definition at line 2060 of file kinchk.F.

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

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

◆ rbe3_impd()

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

Definition at line 1410 of file kinchk.F.

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

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

◆ rby_v0()

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

Definition at line 1367 of file kinchk.F.

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