OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
fv_imp0.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23C ------- only FIXV dans system global sont traites---------
24!||====================================================================
25!|| fv_imp0 ../engine/source/constraints/general/impvel/fv_imp0.F
26!||--- called by ------------------------------------------------------
27!|| upd_glob_k ../engine/source/implicit/upd_glob_k.F
28!||--- calls -----------------------------------------------------
29!|| ancmsg ../engine/source/output/message/message.F
30!|| arret ../engine/source/system/arret.F
31!||--- uses -----------------------------------------------------
32!|| message_mod ../engine/share/message_module/message_mod.F
33!||====================================================================
34 SUBROUTINE fv_imp0(IDDL ,IFIX ,NDOF ,IADK ,JDIK ,
35 1 DIAG_K ,LT_K ,UD ,NBK ,IAB ,
36 2 BK ,NDDL ,RD )
37C-----------------------------------------------
38C M o d u l e s
39C-----------------------------------------------
40 USE message_mod
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 "impl1_c.inc"
50C-----------------------------------------------
51C D u m m y A r g u m e n t s
52C-----------------------------------------------
53 INTEGER MAXC
54 INTEGER
55 . iddl(*),iadk(*),jdik(*),ndof(*),
56 . nbk(*),iab(nfxvel,*) ,nddl ,ifix(*)
57C REAL
58 my_real
59 . ud(3,*), diag_k(*),lt_k(*),bk(nfxvel,*),rd(3,*)
60C-----------------------------------------------
61C L o c a l V a r i a b l e s
62C-----------------------------------------------
63 INTEGER N, I, J, K,I1,J1,ND,ID,IDUD(NFXVEL),
64 . NFV,NF,NT,JD
65 my_real
66 . u(nfxvel)
67C REAL
68C--------extraire kij associe avec Ud (update {b} due to {ud})-----
69 nfv=0
70 DO i = 1,numnod
71 IF (ndof(i)>0) THEN
72 nd = iddl(i)
73 k = ndof(i)
74 DO j =1,k
75 id = nd + j
76 IF (j<=3) THEN
77 IF (ifix(id)==1) THEN
78 ud(j,i)=zero
79 ELSEIF (ifix(id)==2.OR.ifix(id)==9) THEN
80 nfv=nfv+1
81 idud(nfv)=id
82 u(nfv)=ud(j,i)
83 ENDIF
84 ELSE
85 IF (ifix(id)==1) THEN
86 rd(j-3,i)=zero
87 ELSEIF (ifix(id)==2.OR.ifix(id)==9) THEN
88 nfv=nfv+1
89 idud(nfv)=id
90 u(nfv)=rd(j-3,i)
91 ENDIF
92 ENDIF
93 ENDDO
94 ENDIF
95 ENDDO
96C IF (NFV/=NFXVEL) WRITE(*,*)'ERROR IN FV_IMP0',NFV,NFXVEL
97C
98 DO i = 1,nfxvel
99 nbk(i)=0
100 ENDDO
101C
102 DO i1=1,nfv
103 nd=0
104 id=idud(i1)
105C------------Ligne ID-------
106 DO j1 = iadk(id),iadk(id+1)-1
107 jd = jdik(j1)
108 IF (ifix(jd)==0.AND.lt_k(j1)/=zero) THEN
109 nd=nbk(i1)+1
110 iab(i1,nd)=jd
111 bk(i1,nd)=u(i1)*lt_k(j1)
112 nbk(i1)=nd
113 ENDIF
114 ENDDO
115C------------Colonne ID-------
116 IF (ikpat==0) THEN
117 nf=1
118 nt=id-1
119 ELSE
120 nf=id+1
121 nt=nddl
122 ENDIF
123 DO i = nf,nt
124 IF (ifix(i)==0) THEN
125 DO k = iadk(i),iadk(i+1)-1
126 j=jdik(k)
127 IF (id==j.AND.lt_k(k)/=zero) THEN
128 nd=nbk(i1)+1
129 iab(i1,nd)=i
130 bk(i1,nd)=u(i1)*lt_k(k)
131 nbk(i1)=nd
132 ENDIF
133 ENDDO
134 ENDIF
135 ENDDO
136C
137 IF (nd>maxb0) THEN
138 CALL ancmsg(msgid=103,anmode=aninfo,
139 . i1=nd,i2=maxb,i3=i1)
140 CALL arret(2)
141 ENDIF
142 ENDDO
143C
144 RETURN
145 END
146!||====================================================================
147!|| fv_imp1 ../engine/source/constraints/general/impvel/fv_imp0.F
148!||--- called by ------------------------------------------------------
149!|| imp_chkm ../engine/source/implicit/imp_solv.F
150!|| imp_solv ../engine/source/implicit/imp_solv.F
151!||--- uses -----------------------------------------------------
152!|| imp_fvbcl ../engine/share/modules/impbufdef_mod.F
153!||====================================================================
154 SUBROUTINE fv_imp1(NBK ,IAB ,BK ,B )
155C-----------------------------------------------
156C M o d u l e s
157C-----------------------------------------------
158 USE imp_fvbcl
159C-----------------------------------------------
160C I m p l i c i t T y p e s
161C-----------------------------------------------
162#include "implicit_f.inc"
163C-----------------------------------------------
164C C o m m o n B l o c k s
165C-----------------------------------------------
166#include "com04_c.inc"
167C-----------------------------------------------
168C D u m m y A r g u m e n t s
169C-----------------------------------------------
170 integer
171 . nbk(*),iab(nfxvel,*)
172C REAL
173 my_real
174 . bk(nfxvel,*), b(*)
175C-----------------------------------------------
176C L o c a l V a r i a b l e s
177C-----------------------------------------------
178 INTEGER N, I, J, K,I1,J1,K1,ND,ID
179C REAL
180C----------------only imposed global displacement is available---------------
181C--------update {b} due to {ud}-----
182 DO i = 1,nfxvel
183 DO j = 1,nbk(i)
184 id=iab(i,j)
185 b(id)=b(id)-bk(i,j)
186 ENDDO
187 ENDDO
188C------Part of FV-BCS coupling----
189 DO j = 1,nkud_1
190 id=ikud_1(j)
191 b(id)=b(id)-bkud_1(j)
192 ENDDO
193C
194 RETURN
195 END
196!||====================================================================
197!|| fv_imp ../engine/source/constraints/general/impvel/fv_imp0.f
198!||--- called by ------------------------------------------------------
199!|| imp_buck ../engine/source/implicit/imp_buck.f
200!|| imp_chkm ../engine/source/implicit/imp_solv.F
201!|| imp_solv ../engine/source/implicit/imp_solv.F
202!||--- calls -----------------------------------------------------
203!|| dinteri ../engine/source/constraints/general/impvel/fv_imp0.F
204!|| fvl_modif ../engine/source/constraints/general/impvel/fv_imp0.F
205!|| velrot ../engine/source/constraints/general/rbe2/rbe2v.F
206!||--- uses -----------------------------------------------------
207!|| sensor_mod ../common_source/modules/sensor_mod.F90
208!||====================================================================
209 SUBROUTINE fv_imp(IBFV ,NPC ,TF ,VEL ,SENSOR_TAB,
210 1 UD ,RD ,IFIX ,IDDL ,NSENSOR ,
211 2 SKEW ,IFRAME,XFRAME,V ,VR ,
212 3 X ,LJ ,NDOF ,A ,AR )
213C-----------------------------------------------
214C M o d u l e s
215C-----------------------------------------------
216 USE sensor_mod
217C-----------------------------------------------
218C I m p l i c i t T y p e s
219C-----------------------------------------------
220#include "implicit_f.inc"
221#include "mvsiz_p.inc"
222C-----------------------------------------------
223C C o m m o n B l o c k s
224C-----------------------------------------------
225#include "com01_c.inc"
226#include "com04_c.inc"
227#include "com08_c.inc"
228#include "param_c.inc"
229C-----------------------------------------------
230C D u m m y A r g u m e n t s
231C-----------------------------------------------
232 INTEGER ,INTENT(IN) :: NSENSOR
233 INTEGER NPC(*),IBFV(NIFV,*),
234 . IFIX(*),IDDL(*),IFRAME(LISKN,*),LJ(*),NDDL,
235 . NDOF(*)
236C REAL
237 my_real
238 . tf(*), vel(lfxvelr,*), ud(3,*),
239 . skew(lskew,*),rd(3,*),v(3,*),vr(3,*),
240 . x(3,*),xframe(nxframe,*),a(3,*),ar(3,*)
241 TYPE (SENSOR_STR_) ,DIMENSION(NSENSOR) ,INTENT(IN) :: SENSOR_TAB
242C-----------------------------------------------
243C L o c a l V a r i a b l e s
244C-----------------------------------------------
245 INTEGER N, I, ISK, J, L, K1, K2, K3, ISENS,K,
246 . ii, ic, nn, ideb, nr, nsk, nfk, ifm, n0,
247 . ilenc(mvsiz), iposc(mvsiz), iadc(mvsiz),
248 . lc(mvsiz), index(mvsiz),i1,j1,nd,id,j2,j3,
249 . n1,n2,n3,nvl
250C REAL
251 my_real
252 . fac, startt, stopt, ts,dydx,
253 . yc(mvsiz), tsc(mvsiz), dydxc(mvsiz),
254 . rx,ry,rz,vf,vfx,vfy,vfz,vl(nfxvel),
255 . tsc1(mvsiz),facx,a0,lms(3),vs(3),mrv(3),vv
256C IBFV(7,N):1 V;2 D ;0 A ;
257 ideb = 0
258 DO nn=1,nfxvel
259 lj(nn) = 0
260 ENDDO
261 nvl = 0
262C
263 DO nn=1,nfxvel,nvsiz
264 IF (ibfv(8,nn)==1) GOTO 100
265 ic = 0
266 IF (nsensor>0) THEN
267 DO 10 ii = 1, min(nfxvel-ideb,nvsiz)
268 n = ii+ideb
269 startt = vel(2,n)
270 stopt = vel(3,n)
271 IF(tt<startt)GOTO 10
272 IF(tt>stopt) GOTO 10
273 i=iabs(ibfv(1,n))
274 IF(ndof(i)==0) GOTO 10
275 isens=0
276 DO k=1,nsensor
277 IF(ibfv(4,n)== sensor_tab(k)%SENS_ID) isens=k
278 ENDDO
279 IF(isens==0)THEN
280 ts=tt
281 ELSE
282 ts = tt - sensor_tab(isens)%TSTART
283 IF(ts<zero)GOTO 10
284 ENDIF
285 ic = ic + 1
286 index(ic) = n
287 tsc(ic) = ts
288 tsc1(ic) = tsc(ic)-dt2
289 10 CONTINUE
290 ELSE
291 DO 20 ii = 1, min(nfxvel-ideb,nvsiz)
292 n = ii+ideb
293 startt = vel(2,n)
294 stopt = vel(3,n)
295 IF(tt<startt)GOTO 20
296 IF(tt>stopt) GOTO 20
297 i=iabs(ibfv(1,n))
298 IF(ndof(i)==0) GOTO 20
299 ic = ic + 1
300 index(ic) = n
301 tsc(ic) = tt
302 tsc1(ic) = tsc(ic)-dt2
303 20 CONTINUE
304 ENDIF
305C
306 ideb = ideb + min(nfxvel-ideb,nvsiz)
307C
308 DO ii=1,ic
309 n = index(ii)
310 facx = vel(5,n)
311 tsc(ii) = facx*tsc(ii)
312 tsc1(ii) = facx*tsc1(ii)
313 ENDDO
314 IF(ncycle==1)THEN
315 DO ii=1,ic
316 n = index(ii)
317 l = ibfv(3,n)
318 lc(ii) = ibfv(7,n)
319 iposc(ii) = 0
320 iadc(ii) = half * npc(l) + 1
321 ilenc(ii) = half * npc(l+1) - iadc(ii) - iposc(ii)
322 ENDDO
323 ELSE
324 DO ii=1,ic
325 n = index(ii)
326 l = ibfv(3,n)
327 lc(ii) = ibfv(7,n)
328 iposc(ii) = ibfv(5,n)
329 iadc(ii) = half * npc(l) + 1
330 ilenc(ii) = half * npc(l+1) - iadc(ii) - iposc(ii)
331 ENDDO
332 ENDIF
333 CALL dinteri(tf,iadc,iposc,ilenc,ic,tsc1,tsc,yc,lc)
334 DO ii=1,ic
335 n = index(ii)
336 ibfv(5,n) = iposc(ii)
337 fac = vel(1,n)
338 yc(ii) = yc(ii) * fac
339 facx = vel(5,n)
340C IBFV(7,N):1 V;2 D ;0 A ; explicit YC=A;implicit YC=D;
341 IF(ibfv(7,n)<2) yc(ii) = yc(ii) / facx
342 IF(ibfv(7,n)==0) yc(ii) = yc(ii) / facx
343 vl(n) = yc(ii)
344C YC(II) = (YC(II)-YC1(II)) * FAC
345 i=iabs(ibfv(1,n))
346 isk=ibfv(2,n)/10
347 ifm = ibfv(9,n)
348 j=ibfv(2,n)
349 IF (ifm<=1) j=j-10*isk
350 IF (isk>1.OR.ifm>1) THEN
351 nvl = nvl + 1
352 lj(n)=j
353 ENDIF
354 IF(j<=3)THEN
355 IF(isk<=1.AND.ifm<=1)THEN
356 ud(j,i)=yc(ii)
357 k1 = iddl(i)+j
358 ifix(k1)=2
359 a0 = a(j,i)
360 ELSEIF (isk>1) THEN
361 k1=3*j-2
362 k2=3*j-1
363 k3=3*j
364 a0 = skew(k1,isk)*a(1,i) +
365 . skew(k2,isk)*a(2,i) +
366 . skew(k3,isk)*a(3,i)
367 ELSEIF (ifm>1) THEN
368 k1=3*j-2
369 k2=3*j-1
370 k3=3*j
371 rx = x(1,i) - xframe(10,ifm)
372 ry = x(2,i) - xframe(11,ifm)
373 rz = x(3,i) - xframe(12,ifm)
374 lms(1)=rx
375 lms(2)=ry
376 lms(3)=rz
377 mrv(1)=xframe(13,ifm)*dt2
378 mrv(2)=xframe(14,ifm)*dt2
379 mrv(3)=xframe(15,ifm)*dt2
380 CALL velrot(mrv,lms,vs)
381 vfx = xframe(31,ifm)*dt2+vs(1)
382 vfy = xframe(32,ifm)*dt2+vs(2)
383 vfz = xframe(33,ifm)*dt2+vs(3)
384 vf = xframe(k1,ifm)*vfx
385 . + xframe(k2,ifm)*vfy
386 . + xframe(k3,ifm)*vfz
387 vl(n) = vl(n) + vf
388 a0 = xframe(k1,ifm)*a(1,i)
389 . + xframe(k2,ifm)*a(2,i)
390 . + xframe(k3,ifm)*a(3,i)
391 ENDIF
392 ELSEIF(j<=6)THEN
393 j1 = j
394 j = j - 3
395 IF(isk<=1.AND.ifm<=1)THEN
396 rd(j,i)=yc(ii)
397 k1 = iddl(i)+j1
398 ifix(k1)=2
399 a0 = ar(j,i)
400 ELSEIF (isk>1) THEN
401 k1=3*j-2
402 k2=3*j-1
403 k3=3*j
404 a0 = skew(k1,isk)*ar(1,i) +
405 . skew(k2,isk)*ar(2,i) +
406 . skew(k3,isk)*ar(3,i)
407 ELSEIF (ifm>1) THEN
408 k1=3*j-2
409 k2=3*j-1
410 k3=3*j
411 j1 = iframe(1,ifm)
412 vf = xframe(k1,ifm)*xframe(13,ifm)
413 . + xframe(k2,ifm)*xframe(14,ifm)
414 . + xframe(k3,ifm)*xframe(15,ifm)
415 vl(n) = vl(n) + vf*dt2
416 a0 = xframe(k1,ifm)*ar(1,i)
417 . + xframe(k2,ifm)*ar(2,i)
418 . + xframe(k3,ifm)*ar(3,i)
419 ENDIF
420 ENDIF
421C-------------SAVE Fint-----
422 vel(4,n) = a0
423 ENDDO
424 100 CONTINUE
425 ENDDO
426C-------------traitement-pour fxvel dans system local --
427 IF (nvl > 0) THEN
428 CALL fvl_modif(nvl ,ibfv ,ud ,rd ,ifix ,
429 1 iddl ,skew ,xframe,vl ,lj )
430 ENDIF
431C
432 RETURN
433 END
434!||====================================================================
435!|| fv_impi ../engine/source/constraints/general/impvel/fv_imp0.F
436!||--- called by ------------------------------------------------------
437!|| upd_int_k ../engine/source/implicit/upd_glob_k.F
438!||====================================================================
439 SUBROUTINE fv_impi(IDDL ,IFIX ,NDOF ,IADK ,JDIK ,
440 1 DIAG_K ,LT_K ,UD ,B ,NDDL )
441C-----------------------------------------------
442C I m p l i c i t T y p e s
443C-----------------------------------------------
444#include "implicit_f.inc"
445C-----------------------------------------------
446C C o m m o n B l o c k s
447C-----------------------------------------------
448#include "com04_c.inc"
449#include "impl1_c.inc"
450C-----------------------------------------------
451C D u m m y A r g u m e n t s
452C-----------------------------------------------
453 integer
454 . iddl(*),ifix(*),iadk(*),jdik(*),ndof(*),nddl
455C REAL
456 my_real
457 . ud(3,*), diag_k(*),lt_k(*),b(*)
458C-----------------------------------------------
459C L o c a l V a r i a b l e s
460C-----------------------------------------------
461 INTEGER N, I, J, K,I1,J1,K1,ND,ID,NF,NT
462C REAL
463C--------update {b} due to {ud}-----
464 DO i = 1,numnod
465 IF (ndof(i)>0) THEN
466 nd = iddl(i)
467 k = min(3,ndof(i))
468 DO j =1,k
469 id = nd + j
470 IF (ifix(id)==2.OR.ifix(id)==9) THEN
471 IF (ikpat==0) THEN
472 nf=1
473 nt=id-1
474 ELSE
475 nf=id+1
476 nt=nddl
477 ENDIF
478 DO i1=nf,nt
479 DO j1 = iadk(i1),iadk(i1+1)-1
480 k1 =jdik(j1)
481 IF (k1==id ) b(i1)=b(i1)-lt_k(j1)*ud(j,i)
482 ENDDO
483 ENDDO
484 DO j1 = iadk(id),iadk(id+1)-1
485 k1 =jdik(j1)
486 b(k1)=b(k1)-lt_k(j1)*ud(j,i)
487 ENDDO
488 ENDIF
489 ENDDO
490 ENDIF
491 ENDDO
492C
493 RETURN
494 END
495!||====================================================================
496!|| fv_rw ../engine/source/constraints/general/impvel/fv_imp0.F
497!||--- called by ------------------------------------------------------
498!|| imp_buck ../engine/source/implicit/imp_buck.F
499!|| imp_chkm ../engine/source/implicit/imp_solv.f
500!|| imp_solv ../engine/source/implicit/imp_solv.F
501!||====================================================================
502 SUBROUTINE fv_rw(IDDL ,IKC ,NDOF ,UD ,V )
503C-----------------------------------------------
504C I m p l i c i t T y p e s
505C-----------------------------------------------
506#include "implicit_f.inc"
507C-----------------------------------------------
508C C o m m o n B l o c k s
509C-----------------------------------------------
510#include "com04_c.inc"
511#include "com08_c.inc"
512C-----------------------------------------------
513C D u m m y A r g u m e n t s
514C-----------------------------------------------
515 integer
516 . iddl(*),ikc(*),ndof(*)
517C REAL
518 my_real
519 . ud(3,*), v(3,*)
520C-----------------------------------------------
521C L o c a l V a r i a b l e s
522C-----------------------------------------------
523 INTEGER N, I, J, K,I1,J1,K1,ND,ID
524C REAL
525 DO i = 1,numnod
526 nd = iddl(i)
527 k = min(3,ndof(i))
528 DO j =1,k
529 id = nd + j
530 IF (ikc(id)==3) ud(j,i)=v(j,i)*dt2
531 ENDDO
532 ENDDO
533C
534 RETURN
535 END
536!||====================================================================
537!|| fv_rw0 ../engine/source/constraints/general/impvel/fv_imp0.F
538!||--- called by ------------------------------------------------------
539!|| upd_glob_k ../engine/source/implicit/upd_glob_k.F
540!|| upd_int_k ../engine/source/implicit/upd_glob_k.F
541!||--- calls -----------------------------------------------------
542!|| fv_rwl0 ../engine/source/constraints/general/rwall/srw_imp.F
543!||====================================================================
544 SUBROUTINE fv_rw0(IDDL ,IFIX ,NDOF ,IADK ,JDIK ,
545 1 DIAG_K ,LT_K ,UD ,B )
546C-----------------------------------------------
547C I m p l i c i t T y p e s
548C-----------------------------------------------
549#include "implicit_f.inc"
550C-----------------------------------------------
551C C o m m o n B l o c k s
552C-----------------------------------------------
553#include "com04_c.inc"
554C-----------------------------------------------
555C D u m m y A r g u m e n t s
556C-----------------------------------------------
557 integer
558 . iddl(*),ifix(*),iadk(*),jdik(*),ndof(*)
559C REAL
560 my_real
561 . ud(3,*), diag_k(*),lt_k(*),b(*)
562C-----------------------------------------------
563C L o c a l V a r i a b l e s
564C-----------------------------------------------
565 INTEGER N, I, J, K,I1,J1,K1,ND,ID
566C REAL
567 DO i = 1,numnod
568 nd = iddl(i)
569 k = min(3,ndof(i))
570 DO j =1,k
571 id = nd + j
572 IF (ifix(id)==3.OR.ifix(id)==4.OR.
573 . ifix(id)==10.OR.ifix(id)==11) THEN
574 DO i1=1,id-1
575 DO j1 = iadk(i1),iadk(i1+1)-1
576 k1 =jdik(j1)
577 IF (k1==id ) b(i1)=b(i1)-lt_k(j1)*ud(j,i)
578 ENDDO
579 ENDDO
580 DO j1 = iadk(id),iadk(id+1)-1
581 k1 =jdik(j1)
582 b(k1)=b(k1)-lt_k(j1)*ud(j,i)
583 ENDDO
584 ENDIF
585 ENDDO
586 ENDDO
587 CALL fv_rwl0(iddl ,ifix ,ndof ,iadk ,jdik ,
588 1 diag_k ,lt_k ,ud ,b )
589C
590 RETURN
591 END
592!||====================================================================
593!|| fv_dd0 ../engine/source/constraints/general/impvel/fv_imp0.F
594!||--- called by ------------------------------------------------------
595!|| imp_solv ../engine/source/implicit/imp_solv.F
596!||====================================================================
597 SUBROUTINE fv_dd0(IDDL ,IKC ,NDOF ,DD ,DDR ,D )
598C-----------------------------------------------
599C I m p l i c i t T y p e s
600C-----------------------------------------------
601#include "implicit_f.inc"
602C-----------------------------------------------
603C C o m m o n B l o c k s
604C-----------------------------------------------
605#include "com01_c.inc"
606#include "com04_c.inc"
607C-----------------------------------------------
608C D u m m y A r g u m e n t s
609C-----------------------------------------------
610 integer
611 . iddl(*),ikc(*),ndof(*)
612C REAL
613 my_real
614 . dd(3,*), d(3,*),ddr(3,*)
615C-----------------------------------------------
616C L o c a l V a r i a b l e s
617 INTEGER N, I, J, K,I1,J1,K1,ND,ID
618C REAL
619 DO I = 1,numnod
620 nd = iddl(i)
621 k = min(3,ndof(i))
622 DO j =1,k
623 id = nd + j
624 IF (ikc(id)==3.OR.ikc(id)==4.OR.
625 . ikc(id)==10.OR.ikc(id)==11) THEN
626 dd(j,i)=d(j,i)
627c ELSEIF (IKC(ID)==2) THEN
628c DD(J,I)=ZERO
629 ENDIF
630 ENDDO
631 ENDDO
632C
633 IF (iroddl/=0) THEN
634 DO i = 1,numnod
635 IF (ndof(i)>3) THEN
636 DO j=1,3
637 id = iddl(i)+j+3
638 IF (ikc(id)==2) ddr(j,i)=zero
639 ENDDO
640 ENDIF
641 ENDDO
642 ENDIF
643C
644 RETURN
645 END
646!||====================================================================
647!|| dinteri ../engine/source/constraints/general/impvel/fv_imp0.f
648!||--- called by ------------------------------------------------------
649!|| fv_imp ../engine/source/constraints/general/impvel/fv_imp0.F
650!||====================================================================
651 SUBROUTINE dinteri(TF,IAD,IPOS1,ILEN,NEL0,X1,X2,DY,ITY)
652C-----------------------------------------------
653C I m p l i c i t T y p e s
654C-----------------------------------------------
655#include "implicit_f.inc"
656C
657C-----------------------------------------------
658C D u m m y A r g u m e n t s
659C-----------------------------------------------
660 INTEGER NEL0,IAD(*),IPOS1(*),ILEN(*),ITY(*)
661 my_real
662 . X1(*),X2(*),DY(*),TF(2,*)
663C----------------------------------------------
664C L o c a l V a r i a b l e s
665C-----------------------------------------------
666 INTEGER IPOS(NEL0)
667 my_real
668 . y1(nel0),y2(nel0),dydx,x(nel0),y(nel0),
669 . v(nel0)
670 INTEGER I,J1,J,J2,ICONT,J0,L,JJ
671C------postion pour x1-----
672 IF (NEL0==0) return
673 DO i=1,nel0
674 IF (ity(i)<2) dy(i) =zero
675 IF (ity(i)==0) v(i) = zero
676 ENDDO
677 DO i=1,nel0
678 j1 = ipos1(i)+iad(i)+1
679 IF (x1(i)>tf(1,j1)) THEN
680 ipos(i) = ipos1(i)
681C--------due au divergence-----
682 ELSE
683 ipos(i) = 0
684 ilen(i) = ilen(i)+ipos1(i)
685 ENDIF
686 ENDDO
687 j = 0
688 icont = 1
689C
690 DO WHILE(icont==1)
691 j = j+1
692 icont = 0
693 DO i=1,nel0
694 j1 = ipos(i)+iad(i)+1
695 IF(j<=ilen(i)-1.AND.x1(i)>tf(1,j1))THEN
696 ipos(i)=ipos(i)+1
697 icont = 1
698 ENDIF
699 ENDDO
700 ENDDO
701C------interpelation pour y1--------
702 DO i=1,nel0
703 j1 =ipos(i)+iad(i)
704 j2 = j1+1
705 dydx=(tf(2,j2)-tf(2,j1))/(tf(1,j2)-tf(1,j1))
706 y1(i) = tf(2,j1) + dydx*(x1(i)-tf(1,j1))
707 ipos1(i) = ipos(i)
708 IF (ity(i)<2) THEN
709 x(i) = x1(i)
710 y(i) = y1(i)
711 ENDIF
712 ENDDO
713C------ Calcul de V initial quand A est imposee
714 icont = 1
715C
716 jj = 0
717 DO WHILE(icont==1)
718 jj = jj+1
719 icont = 0
720 DO i=1,nel0
721 j1 = iad(i)-1+jj
722 IF (ity(i)==0) THEN
723 IF (x1(i)>tf(1,j1+1)) THEN
724 v(i) = v(i) + half*(tf(2,j1)+tf(2,j1+1))*
725 . (tf(1,j1+1)-tf(1,j1))
726 icont = 1
727 ELSE
728 dydx = (tf(2,j1+1)-tf(2,j1))/(tf(1,j1+1)-tf(1,j1))
729 y2(i) = tf(2,j1) + dydx*(x2(i)-tf(1,j1))
730 v(i) = v(i) + half*(tf(2,j1)+y1(i))*
731 . (x1(i)-tf(1,j1))
732 END IF
733 ELSE
734 END IF
735 ENDDO
736 ENDDO
737C------postion pour x2-----
738 icont = 1
739C
740 DO WHILE(icont==1)
741 j = j+1
742 icont = 0
743 DO i=1,nel0
744 j1 = ipos(i)+iad(i)+1
745 IF(j<=ilen(i).AND.x2(i)>tf(1,j1))THEN
746 ipos(i)=ipos(i)+1
747 icont = 1
748 IF (ity(i)==1) THEN
749 dy(i) = dy(i) + half*(tf(2,j1)+y(i))*
750 . (tf(1,j1)-x(i))
751 x(i) = tf(1,j1)
752 y(i) = tf(2,j1)
753 ELSEIF (ity(i)==0) THEN
754 dy(i) = dy(i) + v(i)*(tf(1,j1)-x(i)) +
755 . one_over_6*(two*y(i)+tf(2,j1))*(tf(1,j1)-x(i))*(tf(1,j1)-x(i))
756 v(i) = v(i) + half*(y(i)+tf(2,j1))*(tf(1,j1)-x(i))
757 x(i) = tf(1,j1)
758 y(i) = tf(2,j1)
759 ENDIF
760 ENDIF
761 ENDDO
762C
763 ENDDO
764C------interpelation pour (d,v,a)--------
765 DO i=1,nel0
766 j1 =ipos(i)+iad(i)
767 j2 = j1+1
768 dydx=(tf(2,j2)-tf(2,j1))/(tf(1,j2)-tf(1,j1))
769 y2(i) = tf(2,j1) + dydx*(x2(i)-tf(1,j1))
770 IF (ity(i)==2) THEN
771 dy(i) = y2(i) - y1(i)
772 ELSEIF (ity(i)==1) THEN
773 dy(i) = dy(i) + half*(y(i)+y2(i))*(x2(i)-x(i))
774 ELSEIF (ity(i)==0) THEN
775 dy(i) = dy(i) + v(i)*(x2(i)-x(i)) +
776 . one_over_6*(two*y(i)+y2(i))*(x2(i)-x(i))*(x2(i)-x(i))
777 ENDIF
778 ENDDO
779C
780 RETURN
781 END
782!||====================================================================
783!|| fv_impl ../engine/source/constraints/general/impvel/fv_imp0.F
784!||--- called by ------------------------------------------------------
785!|| upd_glob_k ../engine/source/implicit/upd_glob_k.F
786!|| upd_int_k ../engine/source/implicit/upd_glob_k.f
787!||--- calls -----------------------------------------------------
788!|| fv_updk ../engine/source/constraints/general/impvel/fv_imp0.F
789!||====================================================================
790 SUBROUTINE fv_impl(IBFV ,SKEW ,XFRAME ,LJ ,IDDL ,
791 1 IFIX ,NDOF ,IADK ,JDIK ,DIAG_K ,
792 2 LT_K ,UD ,RD ,LB )
793C-----------------------------------------------
794C I m p l i c i t T y p e s
795C-----------------------------------------------
796#include "implicit_f.inc"
797C-----------------------------------------------
798C C o m m o n B l o c k s
799C-----------------------------------------------
800#include "com04_c.inc"
801#include "param_c.inc"
802C-----------------------------------------------
803C D u m m y A r g u m e n t s
804C-----------------------------------------------
805 INTEGER IBFV(NIFV,*),LJ(*)
806 INTEGER
807 . IDDL(*),IADK(*),JDIK(*),NDOF(*),IFIX(*)
808C REAL
809 my_real
810 . UD(*),RD(*), DIAG_K(*),LT_K(*),SKEW(LSKEW,*),LB(*),
811 . XFRAME(NXFRAME,*)
812C-----------------------------------------------
813C L o c a l V a r i a b l e s
814C-----------------------------------------------
815 INTEGER N, I, ISK, J, L, K1, K2, K3, K,
816 . IFM, J2,J3,I1,J1,ND,ID,IR,NN
817 my_real
818 . ej(3),s
819C--------
820 DO n = 1,nfxvel
821 j1=lj(n)
822 IF (j1>0) THEN
823 i=iabs(ibfv(1,n))
824 isk=ibfv(2,n)/10
825 ifm = ibfv(9,n)
826 j=ibfv(2,n)
827 IF (ifm<=1) j=j-10*isk
828 k1=3*j-2
829 k2=3*j-1
830 k3=3*j
831 IF (isk>1) THEN
832 ej(1)=skew(k1,isk)
833 ej(2)=skew(k2,isk)
834 ej(3)=skew(k3,isk)
835 ELSE
836 ej(1)=xframe(k1,ifm)
837 ej(2)=xframe(k2,ifm)
838 ej(3)=xframe(k3,ifm)
839 ENDIF
840 IF (j1<=3) THEN
841 ir =0
842 s = one/ej(j1)
843 DO nn =1,3
844 ej(nn) = ej(nn)*s
845 ENDDO
846 CALL fv_updk(i ,iddl ,ej ,j1 ,ir ,
847 1 iadk ,jdik ,diag_k,lt_k ,lb ,ud )
848 ELSE
849 ir =1
850 j1 = j1 -3
851 s = one/ej(j1)
852 DO nn =1,3
853 ej(nn) = ej(nn)*s
854 ENDDO
855 CALL fv_updk(i ,iddl ,ej ,j1 ,ir ,
856 1 iadk ,jdik ,diag_k,lt_k ,lb ,rd )
857 ENDIF
858 ENDIF
859 ENDDO
860C
861 RETURN
862 END
863!||====================================================================
864!|| fv_updk ../engine/source/constraints/general/impvel/fv_imp0.F
865!||--- called by ------------------------------------------------------
866!|| fv_impl ../engine/source/constraints/general/impvel/fv_imp0.F
867!|| fv_rwl0 ../engine/source/constraints/general/rwall/srw_imp.F
868!||--- calls -----------------------------------------------------
869!|| bc_updk ../engine/source/constraints/general/bcs/bc_imp0.F
870!||====================================================================
871 SUBROUTINE fv_updk(N ,IDDL ,EJ ,JJ ,IR ,
872 1 IADK ,JDIK ,DIAG_K,LT_K ,LB ,
873 2 UD )
874C-----------------------------------------------
875C I m p l i c i t T y p e s
876C-----------------------------------------------
877#include "implicit_f.inc"
878C-----------------------------------------------
879C C o m m o n B l o c k s
880C-----------------------------------------------
881#include "impl1_c.inc"
882C-----------------------------------------------
883C D u m m y A r g u m e n t s
884C-----------------------------------------------
885 INTEGER N,JJ,IDDL(*),IR,IADK(*) ,JDIK(*)
886 my_real
887 . EJ(*),DIAG_K(*),LT_K(*),LB(*),UD(3,*)
888C-----------------------------------------------
889C L o c a l V a r i a b l e s
890C-----------------------------------------------
891 INTEGER I,J,ND,K,L,J1,K1,L1,ID,SHF,JFT,KFT,LFT,NL,NJ,
892 . IT(6),KK
893 my_real
894 . S
895C-----------------------------------------------
896 k = jj + 1
897 l = jj + 2
898 IF (k>3) k = k - 3
899 IF (l>3) l = l - 3
900 IF (ej(k)==zero.AND.ej(l)==zero) RETURN
901 CALL bc_updk(n ,iddl ,ej ,jj ,ir ,
902 1 iadk ,jdik ,diag_k,lt_k )
903 IF (ir==0) THEN
904 j1 = jj
905 k1 = k
906 l1 = l
907 ELSE
908 j1 = jj + 3
909 k1 = k + 3
910 l1 = l + 3
911 ENDIF
912 IF (imconv/=1) RETURN
913 id = iddl(n)
914 s = -diag_k(id+j1)*ud(jj,n)
915 lb(id+k1)=lb(id+k1)-ej(k)*s
916 lb(id+l1)=lb(id+l1)-ej(l)*s
917C
918 RETURN
919 END
920!||====================================================================
921!|| fv_impd ../engine/source/constraints/general/impvel/fv_imp0.F
922!||--- called by ------------------------------------------------------
923!|| fr_u2dd ../engine/source/mpi/implicit/imp_fri.f
924!|| imp3_u2x ../engine/source/airbag/monv_imp0.F
925!|| recukin ../engine/source/implicit/recudis.F
926!||--- calls -----------------------------------------------------
927!|| bc_updd ../engine/source/constraints/general/bcs/bc_imp0.F
928!|| bc_updd2 ../engine/source/constraints/general/bcs/bc_imp0.F
929!||====================================================================
930 SUBROUTINE fv_impd(IBFV ,LJ ,SKEW ,XFRAME,UD ,
931 1 RD )
932C-----------------------------------------------
933C I m p l i c i t T y p e s
934C-----------------------------------------------
935#include "implicit_f.inc"
936C-----------------------------------------------
937C C o m m o n B l o c k s
938C-----------------------------------------------
939#include "com04_c.inc"
940#include "param_c.inc"
941C-----------------------------------------------
942C D u m m y A r g u m e n t s
943C-----------------------------------------------
944 INTEGER IBFV(NIFV,*),LJ(*)
945C REAL
946 my_real
947 . UD(3,*),RD(3,*),SKEW(LSKEW,*),XFRAME(NXFRAME,*)
948C-----------------------------------------------
949C L o c a l V a r i a b l e s
950C-----------------------------------------------
951 INTEGER N, I, ISK, J, L, K1, K2, K3, ISENS,K,
952 . II, NN, NR, NSK, NFK, IFM,
953 . I1,J1,ND,ID,ITAG(NFXVEL),N2,J2,N1,NL
954C REAL
955 my_real
956 . ej(3),ej1(3),s,s1,s2
957C---------------------------------------------------------------
958 nl = 0
959 DO n=1,nfxvel
960 itag(n)=0
961 ENDDO
962 DO n=1,nfxvel
963 IF (lj(n)>0.AND.itag(n)>=0) THEN
964 nl = 1
965 itag(n)=n
966 i=iabs(ibfv(1,n))
967 DO n1=n+1,nfxvel
968 IF (lj(n1)>0.AND.iabs(ibfv(1,n1))==i) THEN
969 nn =iabs(lj(n1)-lj(n))
970 IF (nn>0.AND.nn<3) THEN
971 itag(n)=n1
972 itag(n1)=-n
973 ENDIF
974 ENDIF
975 ENDDO
976 ENDIF
977 ENDDO
978C
979 IF (nl==0) RETURN
980C
981 DO n=1,nfxvel
982 IF (itag(n)==n) THEN
983 i=iabs(ibfv(1,n))
984 isk=ibfv(2,n)/10
985 ifm = ibfv(9,n)
986 j=ibfv(2,n)
987 IF (ifm<=1) j=j-10*isk
988 IF(j<=3) THEN
989 nd = 0
990 ELSEIF(j<=6) THEN
991 nd = 3
992 j = j- 3
993 ENDIF
994 k1=3*j-2
995 k2=3*j-1
996 k3=3*j
997 IF (isk>1) THEN
998 ej(1)=skew(k1,isk)
999 ej(2)=skew(k2,isk)
1000 ej(3)=skew(k3,isk)
1001 ELSE
1002 ej(1)=xframe(k1,ifm)
1003 ej(2)=xframe(k2,ifm)
1004 ej(3)=xframe(k3,ifm)
1005 ENDIF
1006 j1 = lj(n)
1007 s = one/ej(j1)
1008 DO nn =1,3
1009 ej(nn) = ej(nn)*s
1010 ENDDO
1011 IF (nd ==0 ) THEN
1012C UD(J1,I)=UD(J1,I)*S*S
1013 CALL bc_updd(i ,ej ,j1 ,ud )
1014 ELSE
1015c RD(J1,I)=RD(J1,I)*S*S
1016 CALL bc_updd(i ,ej ,j1 ,rd )
1017 ENDIF
1018 ELSEIF (itag(n)>0) THEN
1019C-------traite le cas ou il y a deux directions sont imposees-----
1020 n1 = itag(n)
1021 i=iabs(ibfv(1,n))
1022 isk=ibfv(2,n)/10
1023 ifm = ibfv(9,n)
1024 j=ibfv(2,n)
1025 IF (ifm<=1) j=j-10*isk
1026 IF(j<=3) THEN
1027 nd = 0
1028 ELSEIF(j<=6) THEN
1029 nd = 3
1030 j = j- 3
1031 ENDIF
1032 k1=3*j-2
1033 k2=3*j-1
1034 k3=3*j
1035 IF (isk>1) THEN
1036 ej(1)=skew(k1,isk)
1037 ej(2)=skew(k2,isk)
1038 ej(3)=skew(k3,isk)
1039 ELSE
1040 ej(1)=xframe(k1,ifm)
1041 ej(2)=xframe(k2,ifm)
1042 ej(3)=xframe(k3,ifm)
1043 ENDIF
1044 j1 = lj(n)
1045 s1 = one/ej(j1)
1046 DO nn =1,3
1047 ej(nn) = ej(nn)*s1
1048 ENDDO
1049C
1050 isk = ibfv(2,n1)/10
1051 ifm = ibfv(9,n1)
1052 j = ibfv(2,n1)
1053 IF (ifm<=1) j=j-10*isk
1054 IF(j>3) j = j- 3
1055 k1=3*j-2
1056 k2=3*j-1
1057 k3=3*j
1058 IF (isk>1) THEN
1059 ej1(1)=skew(k1,isk)
1060 ej1(2)=skew(k2,isk)
1061 ej1(3)=skew(k3,isk)
1062 ELSE
1063 ej1(1)=xframe(k1,ifm)
1064 ej1(2)=xframe(k2,ifm)
1065 ej1(3)=xframe(k3,ifm)
1066 ENDIF
1067 j2 = lj(n1)
1068 s2 = one/ej1(j2)
1069 DO nn =1,3
1070 ej1(nn) = ej1(nn)*s2
1071 ENDDO
1072 IF (nd==0) THEN
1073C UD(J1,I)=UD(J1,I)*S1*S1
1074C UD(J2,I)=UD(J2,I)*S2*S2
1075 CALL bc_updd2(i ,ej ,j1 ,ej1 ,j2 ,ud )
1076 ELSEIF (nd==3) THEN
1077C RD(J1,I)=RD(J1,I)*S1*S1
1078C RD(J2,I)=RD(J2,I)*S2*S2
1079 CALL bc_updd2(i ,ej ,j1 ,ej1 ,j2 ,rd )
1080 ENDIF
1081 ENDIF
1082 ENDDO
1083C
1084 RETURN
1085 END
1086!||====================================================================
1087!|| fvl_modif ../engine/source/constraints/general/impvel/fv_imp0.f
1088!||--- called by ------------------------------------------------------
1089!|| fv_imp ../engine/source/constraints/general/impvel/fv_imp0.F
1090!||--- calls -----------------------------------------------------
1091!|| l_dir02 ../engine/source/constraints/general/impvel/fv_imp0.F
1092!||====================================================================
1093 SUBROUTINE fvl_modif(NVL ,IBFV ,UD ,RD ,IFIX ,
1094 2 IDDL ,SKEW ,XFRAME,VL ,LJ )
1095C-----------------------------------------------
1096C I m p l i c i t T y p e s
1097C-----------------------------------------------
1098#include "implicit_f.inc"
1099C-----------------------------------------------
1100C C o m m o n B l o c k s
1101C-----------------------------------------------
1102#include "com04_c.inc"
1103#include "param_c.inc"
1104C-----------------------------------------------
1105C D u m m y A r g u m e n t s
1106C-----------------------------------------------
1107 INTEGER NVL,IBFV(NIFV,*),IFIX(*),IDDL(*),LJ(*)
1108C REAL
1109 my_real
1110 . UD(3,*), SKEW(LSKEW,*),RD(3,*),VL(*),XFRAME(NXFRAME,*)
1111C-----------------------------------------------
1112C L o c a l V a r i a b l e s
1113C-----------------------------------------------
1114 INTEGER IVL(NVL),I,J,II,N,ND,JJ,ISK,IFM,
1115 . NN,K,L,J1,K1,K2,K3,L1,N1,N2,N3,NL
1116 INTEGER NLFV(NVL),ITAG(NUMNOD)
1117 my_real
1118 . EJ(3)
1119C-----------------------------------------------
1120 n1 = 0
1121 DO n=1,nfxvel
1122 IF (lj(n)>0) THEN
1123 n1 = n1 + 1
1124 ivl(n1) = n
1125 ENDIF
1126 ENDDO
1127 IF (n1/=nvl) WRITE(*,*)'ERROR IN FVL_MODIF',n1,nvl
1128C
1129C------determine NL (raison for NL=3)save into NLFV
1130C----first translation
1131 DO i=1,numnod
1132 itag(i)=0
1133 END DO
1134 DO i=1,nvl
1135 n = ivl(i)
1136 j = lj(n)
1137 ii=iabs(ibfv(1,n))
1138 IF (j>3) cycle
1139 itag(ii)= itag(ii)+1
1140 ENDDO
1141 DO i=1,nvl
1142 n = ivl(i)
1143 j = lj(n)
1144 ii=iabs(ibfv(1,n))
1145 IF (j>3) cycle
1146 nlfv(i)= itag(ii)
1147 ENDDO
1148C----rotational---------
1149 DO i=1,numnod
1150 itag(i)=0
1151 END DO
1152 DO i=1,nvl
1153 n = ivl(i)
1154 j = lj(n)
1155 ii=iabs(ibfv(1,n))
1156 IF (j<=3) cycle
1157 itag(ii)= itag(ii)+1
1158 ENDDO
1159 DO i=1,nvl
1160 n = ivl(i)
1161 j = lj(n)
1162 ii=iabs(ibfv(1,n))
1163 IF (j<=3) cycle
1164 nlfv(i)= itag(ii)
1165 ENDDO
1166C---------------------------------
1167 n2 = 0
1168 n3 = 0
1169 DO i=1,nvl
1170 n = ivl(i)
1171 j = lj(n)
1172 ii=iabs(ibfv(1,n))
1173 nd = iddl(ii)
1174 IF (j>3) nd = nd +3
1175 nl = nlfv(i)
1176 DO nn =1,3
1177 k1 = nd+nn
1178 IF (ifix(k1)==9) ifix(k1)=0
1179 ENDDO
1180 IF (nl==1) THEN
1181C IFIX(ND+J)=0
1182 isk=ibfv(2,n)/10
1183 ifm = ibfv(9,n)
1184 IF(j<=3)THEN
1185 IF (isk>1) THEN
1186 k1=3*j-2
1187 k2=3*j-1
1188 k3=3*j
1189 ej(1)=skew(k1,isk)
1190 ej(2)=skew(k2,isk)
1191 ej(3)=skew(k3,isk)
1192 ELSEIF (ifm>1) THEN
1193 k1=3*j-2
1194 k2=3*j-1
1195 k3=3*j
1196 ej(1)=xframe(k1,ifm)
1197 ej(2)=xframe(k2,ifm)
1198 ej(3)=xframe(k3,ifm)
1199 ENDIF
1200 CALL l_dir02(ej,j1,j,ifix(nd+1))
1201 ud(j1,ii)=vl(n)/ej(j1)
1202 nd = iddl(ii)+j1
1203 ifix(nd)=9
1204 lj(n) = j1
1205 nd=iddl(ii)
1206 ELSEIF(j<=6)THEN
1207 j = j - 3
1208 IF (isk>1) THEN
1209 k1=3*j-2
1210 k2=3*j-1
1211 k3=3*j
1212 ej(1)=skew(k1,isk)
1213 ej(2)=skew(k2,isk)
1214 ej(3)=skew(k3,isk)
1215 ELSEIF (ifm>1) THEN
1216 k1=3*j-2
1217 k2=3*j-1
1218 k3=3*j
1219 ej(1)=xframe(k1,ifm)
1220 ej(2)=xframe(k2,ifm)
1221 ej(3)=xframe(k3,ifm)
1222 ENDIF
1223 CALL l_dir02(ej,j1,j,ifix(nd+4))
1224 rd(j1,ii)=vl(n)/ej(j1)
1225 nd = iddl(ii)+j1+3
1226 ifix(nd)=9
1227 lj(n) = j1 + 3
1228 ENDIF
1229 ELSEIF (nl==3) THEN
1230 DO nn =1,3
1231 k1 = nd+nn
1232 ifix(k1)=2
1233 ENDDO
1234 IF (j<=3) THEN
1235 DO nn =1,3
1236 ud(nn,ii)=zero
1237 ENDDO
1238 ELSE
1239 DO nn =1,3
1240 rd(nn,ii)=zero
1241 ENDDO
1242 ENDIF
1243 lj(n)=-j
1244 n3 = n3 + 1
1245 ELSE
1246C--------NL=2 to be traited later---------------------
1247 n2 = n2 + 1
1248 ENDIF
1249 ENDDO
1250C--------change to global system ---------------------
1251 IF (n3 >= 3) THEN
1252 DO i=1,nvl
1253 n = ivl(i)
1254 j = -lj(n)
1255 IF (j>0) THEN
1256 ii=iabs(ibfv(1,n))
1257 isk=ibfv(2,n)/10
1258 ifm = ibfv(9,n)
1259 j1=j
1260 IF (j1 > 3) j1=j1-3
1261 k1=3*j1-2
1262 k2=3*j1-1
1263 k3=3*j1
1264 IF (isk>1) THEN
1265 ej(1)=skew(k1,isk)
1266 ej(2)=skew(k2,isk)
1267 ej(3)=skew(k3,isk)
1268 ELSE
1269 ej(1)=xframe(k1,ifm)
1270 ej(2)=xframe(k2,ifm)
1271 ej(3)=xframe(k3,ifm)
1272 ENDIF
1273 IF (j<=3) THEN
1274 DO nn =1,3
1275 ud(nn,ii)=ud(nn,ii)+vl(n)*ej(nn)
1276 ENDDO
1277 ELSE
1278 DO nn =1,3
1279 rd(nn,ii)=rd(nn,ii)+vl(n)*ej(nn)
1280 ENDDO
1281 ENDIF
1282 lj(n)=0
1283 ENDIF
1284 ENDDO
1285 ENDIF
1286C--------VL dans 2 directions--------
1287 IF (n2 == 0) RETURN
1288 n2 =0
1289 DO i=1,nvl
1290 n = ivl(i)
1291 j = lj(n)
1292 IF (j>0) THEN
1293 ii=iabs(ibfv(1,n))
1294 nd = iddl(ii)
1295 IF (j>3) nd = nd +3
1296 nl = nlfv(i)
1297C DO NN =1,3
1298C K1 = ND+NN
1299C IF (IFIX(K1)==9) NL=NL+1
1300C ENDDO
1301 IF (nl==2) THEN
1302C---------premier--------
1303C IFIX(ND+J)=0
1304 isk=ibfv(2,n)/10
1305 ifm = ibfv(9,n)
1306 IF(j<=3)THEN
1307 IF (isk>1) THEN
1308 k1=3*j-2
1309 k2=3*j-1
1310 k3=3*j
1311 ej(1)=skew(k1,isk)
1312 ej(2)=skew(k2,isk)
1313 ej(3)=skew(k3,isk)
1314 ELSEIF (ifm>1) THEN
1315 k1=3*j-2
1316 k2=3*j-1
1317 k3=3*j
1318 ej(1)=xframe(k1,ifm)
1319 ej(2)=xframe(k2,ifm)
1320 ej(3)=xframe(k3,ifm)
1321 ENDIF
1322 CALL l_dir02(ej,j1,j,ifix(nd+1))
1323 ud(j1,ii)=vl(n)/ej(j1)
1324 ifix(iddl(ii)+j1)=9
1325 lj(n) = j1
1326 ELSEIF(j<=6)THEN
1327 j = j - 3
1328 IF (isk>1) THEN
1329 k1=3*j-2
1330 k2=3*j-1
1331 k3=3*j
1332 ej(1)=skew(k1,isk)
1333 ej(2)=skew(k2,isk)
1334 ej(3)=skew(k3,isk)
1335 ELSEIF (ifm>1) THEN
1336 k1=3*j-2
1337 k2=3*j-1
1338 k3=3*j
1339 ej(1)=xframe(k1,ifm)
1340 ej(2)=xframe(k2,ifm)
1341 ej(3)=xframe(k3,ifm)
1342 ENDIF
1343 CALL l_dir02(ej,j1,j,ifix(nd+4))
1344 rd(j1,ii)=vl(n)/ej(j1)
1345 j1 = j1 + 3
1346 ifix(iddl(ii)+j1)=9
1347 lj(n) = j1
1348C----------for the second
1349 j = j - 3
1350 ENDIF
1351C---------seconde--------
1352 DO k=i+1,nvl
1353 n1 = ivl(k)
1354 nn=iabs(ibfv(1,n1))
1355 jj = iabs(lj(n1)-j)
1356 IF (lj(n1)>0.AND.ii==nn.AND.jj<3) GOTO 100
1357 ENDDO
1358 100 CONTINUE
1359 j = lj(n1)
1360 IF (j/=j1) ifix(nd+j)=0
1361 isk=ibfv(2,n1)/10
1362 ifm = ibfv(9,n1)
1363 IF(j<=3)THEN
1364 IF (isk>1) THEN
1365 k1=3*j-2
1366 k2=3*j-1
1367 k3=3*j
1368 ej(1)=skew(k1,isk)
1369 ej(2)=skew(k2,isk)
1370 ej(3)=skew(k3,isk)
1371 ELSEIF (ifm>1) THEN
1372 k1=3*j-2
1373 k2=3*j-1
1374 k3=3*j
1375 ej(1)=xframe(k1,ifm)
1376 ej(2)=xframe(k2,ifm)
1377 ej(3)=xframe(k3,ifm)
1378 ENDIF
1379 CALL l_dir02(ej,jj,j,ifix(nd+1))
1380 ud(jj,nn)=vl(n1)/ej(jj)
1381 ifix(iddl(nn)+jj)=9
1382 lj(n1) = -jj
1383 ELSEIF(j<=6)THEN
1384 j = j - 3
1385 IF (isk>1) THEN
1386 k1=3*j-2
1387 k2=3*j-1
1388 k3=3*j
1389 ej(1)=skew(k1,isk)
1390 ej(2)=skew(k2,isk)
1391 ej(3)=skew(k3,isk)
1392 ELSEIF (ifm>1) THEN
1393 k1=3*j-2
1394 k2=3*j-1
1395 k3=3*j
1396 ej(1)=xframe(k1,ifm)
1397 ej(2)=xframe(k2,ifm)
1398 ej(3)=xframe(k3,ifm)
1399 ENDIF
1400 CALL l_dir02(ej,jj,j,ifix(nd+4))
1401 rd(jj,nn)=vl(n)/ej(jj)
1402 jj = jj + 3
1403 ifix(iddl(nn)+jj)=9
1404 lj(n1) = -jj
1405 ENDIF
1406 ENDIF
1407 ENDIF
1408 ENDDO
1409C
1410 DO i=1,nvl
1411 n = ivl(i)
1412 IF (lj(n)<0) lj(n) = -lj(n)
1413 ENDDO
1414C
1415 RETURN
1416 END
1417!||====================================================================
1418!|| fv_updf ../engine/source/constraints/general/impvel/fv_imp0.F
1419!||--- called by ------------------------------------------------------
1420!|| imp3_a2b ../engine/source/airbag/monv_imp0.F
1421!|| upd_fr ../engine/source/mpi/implicit/imp_fri.F
1422!||--- calls -----------------------------------------------------
1423!|| kin_updf ../engine/source/constraints/general/impvel/fv_imp0.F
1424!||====================================================================
1425 SUBROUTINE fv_updf(NFX ,IFX ,IBFV ,SKEW ,XFRAME,
1426 1 A )
1427C-----------------------------------------------
1428C I m p l i c i t T y p e s
1429C-----------------------------------------------
1430#include "implicit_f.inc"
1431C-----------------------------------------------
1432C C o m m o n B l o c k s
1433C-----------------------------------------------
1434#include "param_c.inc"
1435C-----------------------------------------------
1436C D u m m y A r g u m e n t s
1437C-----------------------------------------------
1438 INTEGER NFX ,IFX(2,*) ,IBFV(NIFV,*)
1439 my_real
1440 . a(3,*),skew(lskew,*),xframe(nxframe,*)
1441C-----------------------------------------------
1442C L o c a l V a r i a b l e s
1443C-----------------------------------------------
1444 INTEGER I,J,N,K,L,J1,K1,L1,K2,K3,II,ISK,IFM,NN
1445 my_real
1446 . EJ(3),S
1447C-----------------------------------------------
1448 DO II=1,nfx
1449 i = ifx(1,ii)
1450 n = iabs(ibfv(1,i))
1451 isk=ibfv(2,i)/10
1452 ifm = ibfv(9,i)
1453 j=ibfv(2,i)
1454 IF (ifm<=1) j=j-10*isk
1455 k1=3*j-2
1456 k2=3*j-1
1457 k3=3*j
1458 IF (isk>1) THEN
1459 ej(1)=skew(k1,isk)
1460 ej(2)=skew(k2,isk)
1461 ej(3)=skew(k3,isk)
1462 ELSE
1463 ej(1)=xframe(k1,ifm)
1464 ej(2)=xframe(k2,ifm)
1465 ej(3)=xframe(k3,ifm)
1466 ENDIF
1467 j1 = ifx(2,ii)
1468 s = one/ej(j1)
1469 DO nn =1,3
1470 ej(nn) = ej(nn)*s
1471 ENDDO
1472 IF(j<=3)THEN
1473 CALL kin_updf(n ,ej ,j1 ,a )
1474 ENDIF
1475 ENDDO
1476C
1477 RETURN
1478 END
1479!||====================================================================
1480!|| kin_updf ../engine/source/constraints/general/impvel/fv_imp0.F
1481!||--- called by ------------------------------------------------------
1482!|| fv_updf ../engine/source/constraints/general/impvel/fv_imp0.F
1483!|| imp3_a2b ../engine/source/airbag/monv_imp0.F
1484!|| upd_fr ../engine/source/mpi/implicit/imp_fri.F
1485!||====================================================================
1486 SUBROUTINE kin_updf(N ,EJ ,J1 ,A )
1487C-----------------------------------------------
1488C I m p l i c i t T y p e s
1489C-----------------------------------------------
1490#include "implicit_f.inc"
1491C-----------------------------------------------
1492C D u m m y A r g u m e n t s
1493C-----------------------------------------------
1494 INTEGER N ,J1
1495 my_real
1496 . EJ(3),A(3,*)
1497C-----------------------------------------------
1498C L o c a l V a r i a b l e s
1499C-----------------------------------------------
1500 INTEGER K,L
1501C-----------------------------------------------
1502 K = j1 + 1
1503 IF (k>3) k = k - 3
1504 l = j1 + 2
1505 IF (l>3) l = l - 3
1506 a(k,n)=a(k,n)-ej(k)*a(j1,n)
1507 a(l,n)=a(l,n)-ej(l)*a(j1,n)
1508C
1509 RETURN
1510 END
1511!||====================================================================
1512!|| fv_updkd ../engine/source/constraints/general/impvel/fv_imp0.F
1513!||--- called by ------------------------------------------------------
1514!|| bcl_impkd ../engine/source/constraints/general/bcs/bc_imp0.F
1515!|| diag_int ../engine/source/mpi/implicit/imp_fri.F
1516!|| updk_mv ../engine/source/airbag/monv_imp0.F
1517!||====================================================================
1518 SUBROUTINE fv_updkd(EJ ,J ,KDD ,DIAG_K)
1519C-----------------------------------------------
1520C I m p l i c i t T y p e s
1521C-----------------------------------------------
1522#include "implicit_f.inc"
1523C-----------------------------------------------
1524C D u m m y A r g u m e n t s
1525C-----------------------------------------------
1526 INTEGER J
1527 my_real
1528 . EJ(3),DIAG_K(3)
1529C-----------------------------------------------
1530C L o c a l V a r i a b l e s
1531C-----------------------------------------------
1532 INTEGER I,ND,K,L,J1,K1,L1
1533 my_real
1534 . KDD(3,3)
1535C-----------------------------------------------
1536 K = j + 1
1537 l = j + 2
1538 IF (k>3) k = k - 3
1539 IF (l>3) l = l - 3
1540 diag_k(k)=diag_k(k)-(two*kdd(k,j)-kdd(j,j)*ej(k))*ej(k)
1541 diag_k(l)=diag_k(l)-(two*kdd(l,j)-kdd(j,j)*ej(l))*ej(l)
1542C
1543 RETURN
1544 END
1545!||====================================================================
1546!|| fv_imprl ../engine/source/constraints/general/impvel/fv_imp0.F
1547!||--- called by ------------------------------------------------------
1548!|| ext_rhs ../engine/source/implicit/upd_glob_k.F
1549!|| upd_rhs ../engine/source/implicit/upd_glob_k.F
1550!||--- calls -----------------------------------------------------
1551!|| bc_updb ../engine/source/constraints/general/bcs/bc_imp0.F
1552!||====================================================================
1553 SUBROUTINE fv_imprl(IBFV ,SKEW ,XFRAME ,LJ ,IDDL ,
1554 1 NDOF ,LB )
1555C-----------------------------------------------
1556C I m p l i c i t T y p e s
1557C-----------------------------------------------
1558#include "implicit_f.inc"
1559C-----------------------------------------------
1560C C o m m o n B l o c k s
1561C-----------------------------------------------
1562#include "com04_c.inc"
1563#include "param_c.inc"
1564C-----------------------------------------------
1565C D u m m y A r g u m e n t s
1566C-----------------------------------------------
1567 INTEGER IBFV(NIFV,*),LJ(*),IDDL(*),NDOF(*)
1568C REAL
1569 my_real
1570 . skew(lskew,*),lb(*),xframe(nxframe,*)
1571C-----------------------------------------------
1572C L o c a l V a r i a b l e s
1573C-----------------------------------------------
1574 INTEGER N, I, ISK, J, L, K1, K2, K3, K,
1575 . IFM, J2,J3,I1,J1,ND,ID,IR,NN
1576 my_real
1577 . EJ(3),S
1578C--------
1579 DO N = 1,nfxvel
1580 j1=lj(n)
1581 IF (j1>0) THEN
1582 i=iabs(ibfv(1,n))
1583 isk=ibfv(2,n)/10
1584 ifm = ibfv(9,n)
1585 j=ibfv(2,n)
1586 IF (ifm<=1) j=j-10*isk
1587 k1=3*j-2
1588 k2=3*j-1
1589 k3=3*j
1590 id=iddl(i)
1591 IF (isk>1) THEN
1592 ej(1)=skew(k1,isk)
1593 ej(2)=skew(k2,isk)
1594 ej(3)=skew(k3,isk)
1595 ELSE
1596 ej(1)=xframe(k1,ifm)
1597 ej(2)=xframe(k2,ifm)
1598 ej(3)=xframe(k3,ifm)
1599 ENDIF
1600 IF (j1<=3) THEN
1601 ir =0
1602 s = one/ej(j1)
1603 DO nn =1,3
1604 ej(nn) = ej(nn)*s
1605 ENDDO
1606 CALL bc_updb(id ,ej ,j1 ,ir ,lb )
1607 ELSE
1608 ir =1
1609 j1 = j1 -3
1610 s = one/ej(j1)
1611 DO nn =1,3
1612 ej(nn) = ej(nn)*s
1613 ENDDO
1614 CALL bc_updb(id ,ej ,j1 ,ir ,lb )
1615 ENDIF
1616 ENDIF
1617 ENDDO
1618C
1619 RETURN
1620 END
1621!||====================================================================
1622!|| fvl_frk ../engine/source/constraints/general/impvel/fv_imp0.F
1623!||--- called by ------------------------------------------------------
1624!|| upd_kml ../engine/source/mpi/implicit/imp_fri.F
1625!|| upd_ksl ../engine/source/mpi/implicit/imp_fri.f
1626!||--- calls -----------------------------------------------------
1627!|| fv_updfr ../engine/source/constraints/general/impvel/fv_imp0.F
1628!||====================================================================
1629 SUBROUTINE fvl_frk(J1 ,N ,IBFV ,SKEW ,XFRAME ,
1630 1 IDDL ,IDDLM ,IKC ,IADK ,JDIK ,
1631 2 DIAG_K ,LT_K ,UD ,LB ,A ,
1632 3 KSS ,KSM ,IDLM ,IFSS ,IFSM )
1633C-----------------------------------------------
1634C I m p l i c i t T y p e s
1635C-----------------------------------------------
1636#include "implicit_f.inc"
1637C-----------------------------------------------
1638C C o m m o n B l o c k s
1639C-----------------------------------------------
1640#include "param_c.inc"
1641C-----------------------------------------------
1642C D u m m y A r g u m e n t s
1643C-----------------------------------------------
1644 INTEGER N,IBFV(NIFV,*),J1,IDLM ,IFSS ,IFSM
1645 INTEGER
1646 . IDDL(*),IDDLM(*),IADK(*),JDIK(*),IKC(*)
1647C REAL
1648 my_real
1649 . ud(3,*),diag_k(*),lt_k(*),skew(lskew,*),lb(*),
1650 . xframe(nxframe,*),a(3,*),kss(6),ksm(9)
1651C-----------------------------------------------
1652C L o c a l V a r i a b l e s
1653C-----------------------------------------------
1654 INTEGER I, ISK, J, L, K1, K2, K3, K,
1655 . IFM, J2,J3,I1,ND,ID,IR,NN
1656 my_real
1657 . EJ(3),S
1658C--------
1659 I=iabs(ibfv(1,n))
1660 isk=ibfv(2,n)/10
1661 ifm = ibfv(9,n)
1662 j=ibfv(2,n)
1663 IF (ifm<=1) j=j-10*isk
1664 k1=3*j-2
1665 k2=3*j-1
1666 k3=3*j
1667 IF (isk>1) THEN
1668 ej(1)=skew(k1,isk)
1669 ej(2)=skew(k2,isk)
1670 ej(3)=skew(k3,isk)
1671 ELSE
1672 ej(1)=xframe(k1,ifm)
1673 ej(2)=xframe(k2,ifm)
1674 ej(3)=xframe(k3,ifm)
1675 ENDIF
1676 s = one/ej(j1)
1677 DO nn =1,3
1678 ej(nn) = ej(nn)*s
1679 ENDDO
1680 CALL fv_updfr(i ,ej ,j1 ,iddl ,iddlm ,
1681 1 ikc ,iadk ,jdik ,diag_k,lt_k ,
1682 2 ud ,lb ,a ,kss ,ksm ,
1683 3 idlm ,ifss ,ifsm )
1684C
1685 RETURN
1686 END
1687!||====================================================================
1688!|| fv_updfr ../engine/source/constraints/general/impvel/fv_imp0.f
1689!||--- called by ------------------------------------------------------
1690!|| fvl_frk ../engine/source/constraints/general/impvel/fv_imp0.F
1691!|| upd_kml ../engine/source/mpi/implicit/imp_fri.F
1692!|| upd_ksl ../engine/source/mpi/implicit/imp_fri.F
1693!||--- calls -----------------------------------------------------
1694!|| bc_updfr ../engine/source/constraints/general/bcs/bc_imp0.f
1695!||====================================================================
1696 SUBROUTINE fv_updfr(N ,EJ ,J1 ,IDDL ,IDDLM ,
1697 1 IKC ,IADK ,JDIK ,DIAG_K ,LT_K ,
1698 2 UD ,LB ,A ,KSS ,KSM ,
1699 3 IDLM ,IFSS ,IFSM)
1700C-----------------------------------------------
1701C I m p l i c i t T y p e s
1702C-----------------------------------------------
1703#include "implicit_f.inc"
1704C-----------------------------------------------
1705C D u m m y A r g u m e n t s
1706C-----------------------------------------------
1707 INTEGER N,J1,IDLM ,IFSS ,IFSM
1708 INTEGER
1709 . IDDL(*),IDDLM(*),IADK(*),JDIK(*),IKC(*)
1710C REAL
1711 my_real
1712 . UD(3,*),DIAG_K(*),LT_K(*),LB(*),EJ(3),
1713 . A(3,*),KSS(6),KSM(9)
1714C-----------------------------------------------
1715C L o c a l V a r i a b l e s
1716C-----------------------------------------------
1717 INTEGER L, K,ID,IDM
1718 my_real
1719 . S
1720C--------
1721 CALL BC_UPDFR(N ,IDDL ,EJ ,J1 ,IDDLM ,
1722 1 IKC ,IADK ,JDIK ,DIAG_K,LT_K ,
1723 2 LB ,A ,KSS ,KSM ,IDLM ,
1724 3 IFSS ,IFSM )
1725 IF (IFSS>0) THEN
1726 S = -kss(j1)*ud(j1,n)
1727 id = iddl(n)
1728 idm = iddlm(n)
1729 k = j1 + 1
1730 l = j1 + 2
1731 IF (k>3) k = k - 3
1732 IF (l>3) l = l - 3
1733 IF(ikc(id+k)==0) lb(idm+k)=lb(idm+k)-ej(k)*s
1734 IF(ikc(id+l)==0) lb(idm+l)=lb(idm+l)-ej(l)*s
1735 ENDIF
1736C
1737 RETURN
1738 END
1739!||====================================================================
1740!|| wfv_imp ../engine/source/constraints/general/impvel/fv_imp0.F
1741!||--- called by ------------------------------------------------------
1742!|| dyna_wex ../engine/source/implicit/imp_dyna.F
1743!||--- calls -----------------------------------------------------
1744!|| dintera ../engine/source/constraints/general/impvel/fv_imp0.F
1745!||--- uses -----------------------------------------------------
1746!|| imp_dyna ../engine/share/modules/impbufdef_mod.F
1747!|| sensor_mod ../common_source/modules/sensor_mod.f90
1748!||====================================================================
1749 SUBROUTINE wfv_imp(IBFV ,NPC ,TF ,VEL ,SENSOR_TAB,
1750 1 UD ,RD ,IFIX ,IDDL ,NSENSOR ,
1751 2 SKEW ,IFRAME ,XFRAME,A ,AR ,
1752 3 X ,NDOF ,MS ,IN ,WEIGHT ,
1753 4 RBY ,DW )
1754C-----------------------------------------------
1755C M o d u l e s
1756C-----------------------------------------------
1757 USE imp_dyna
1758 USE sensor_mod
1759C-----------------------------------------------
1760C I m p l i c i t T y p e s
1761C-----------------------------------------------
1762#include "implicit_f.inc"
1763#include "mvsiz_p.inc"
1764C-----------------------------------------------
1765C C o m m o n B l o c k s
1766C-----------------------------------------------
1767#include "com04_c.inc"
1768#include "com08_c.inc"
1769#include "param_c.inc"
1770Ctmp+1
1771C-----------------------------------------------
1772C D u m m y A r g u m e n t s
1773C-----------------------------------------------
1774 INTEGER ,INTENT(IN) :: NSENSOR
1775 INTEGER NPC(*),IBFV(NIFV,*),
1776 . IFIX(*),IDDL(*),IFRAME(LISKN,*),NDOF(*),WEIGHT(*)
1777C REAL
1778 my_real
1779 . TF(*), VEL(LFXVELR,*), UD(3,*),
1780 . SKEW(LSKEW,*),RD(3,*),A(3,*),AR(3,*),IN(*),
1781 . X(3,*),XFRAME(NXFRAME,*),DW,MS(*),RBY(NRBY,*)
1782 TYPE (SENSOR_STR_) ,DIMENSION(NSENSOR) ,INTENT(IN) :: SENSOR_TAB
1783C-----------------------------------------------
1784C L o c a l V a r i a b l e s
1785C-----------------------------------------------
1786 INTEGER N, I, ISK, J, L, K1, K2, K3, ISENS,K,
1787 . II, IC, NN, IDEB, NR, NSK, NFK, IFM, N0,
1788 . INDEX(MVSIZ),I1,J1,ND,ID,J2,J3,
1789 . N1,N2,N3,NVL
1790C REAL
1791 my_real
1792 . FAC, STARTT, STOPT, TS,
1793 . RX,RY,RZ,VF,VFX,VFY,VFZ,
1794 . FACX,FINT,A0,IN0,DD
1795 INTEGER ILENC(MVSIZ), IPOSC(MVSIZ), IADC(MVSIZ),
1796 . LC(MVSIZ)
1797 my_real
1798 . YC(MVSIZ), TSC(MVSIZ), DYDXC(MVSIZ),
1799 . tsc1(mvsiz)
1800C IBFV(7,N):1 V;2 D ;0 A ;
1801C-------------------------------
1802C--A =DY_AR, AR=DY_AR as input ;
1803C---DY_A is not precise w/ imposed (u,v,a) Correction for DY_V,DY_D, DY_A
1804 ideb = 0
1805C
1806 dw = 0
1807 DO nn=1,nfxvel,nvsiz
1808 IF (ibfv(8,nn)==1) GOTO 100
1809 ic = 0
1810 IF (nsensor>0) THEN
1811 DO 10 ii = 1, min(nfxvel-ideb,nvsiz)
1812 n = ii+ideb
1813 startt = vel(2,n)
1814 stopt = vel(3,n)
1815 IF(tt<startt)GOTO 10
1816 IF(tt>stopt) GOTO 10
1817 i=iabs(ibfv(1,n))
1818 IF(ndof(i)==0) GOTO 10
1819 isens=0
1820 DO k=1,nsensor
1821 IF(ibfv(4,n)==sensor_tab(k)%SENS_ID) isens=k
1822 ENDDO
1823 IF(isens==0)THEN
1824 ts=tt
1825 ELSE
1826 ts = tt-sensor_tab(isens)%TSTART
1827 IF(ts<zero)GOTO 10
1828 ENDIF
1829 ic = ic + 1
1830 index(ic) = n
1831 tsc(ic) = ts
1832 tsc1(ic) = tsc(ic)-dt2
1833 10 CONTINUE
1834 ELSE
1835 DO 20 ii = 1, min(nfxvel-ideb,nvsiz)
1836 n = ii+ideb
1837 startt = vel(2,n)
1838 stopt = vel(3,n)
1839 IF(tt<startt)GOTO 20
1840 IF(tt>stopt) GOTO 20
1841 i=iabs(ibfv(1,n))
1842 IF(ndof(i)==0) GOTO 20
1843 ic = ic + 1
1844 index(ic) = n
1845 tsc(ic) = tt
1846 tsc1(ic) = tsc(ic)-dt2
1847 20 CONTINUE
1848 ENDIF
1849C
1850 ideb = ideb + min(nfxvel-ideb,nvsiz)
1851C
1852 DO ii=1,ic
1853 n = index(ii)
1854 facx = vel(5,n)
1855 tsc(ii) = facx*tsc(ii)
1856 tsc1(ii) = facx*tsc1(ii)
1857 ENDDO
1858C
1859 DO ii=1,ic
1860 n = index(ii)
1861 l = ibfv(3,n)
1862 lc(ii) = ibfv(7,n)
1863C
1864 iposc(ii) = ibfv(5,n)
1865 iadc(ii) = half * npc(l) + 1
1866 ilenc(ii) = half * npc(l+1) - iadc(ii) - iposc(ii)
1867 ENDDO
1868C
1869 CALL dintera(tf,iadc,iposc,ilenc,ic,tsc1,tsc,yc,lc)
1870 DO ii=1,ic
1871 n = index(ii)
1872 fac = vel(1,n)
1873 yc(ii) = yc(ii) * fac
1874 facx = vel(5,n)
1875 IF(ibfv(7,n)<2) yc(ii) = yc(ii) / facx
1876 IF(ibfv(7,n)==0) yc(ii) = yc(ii) / facx
1877 i=iabs(ibfv(1,n))
1878 isk=ibfv(2,n)/10
1879 ifm = ibfv(9,n)
1880 j=ibfv(2,n)
1881 IF (ifm<=1) j=j-10*isk
1882 fint = vel(4,n)
1883 IF(j<=3)THEN
1884 IF(isk<=1.AND.ifm<=1)THEN
1885 ELSEIF (isk>1) THEN
1886 ELSEIF (ifm>1) THEN
1887 ENDIF
1888C---Correction for DY_V,DY_D
1889 dy_v(j,i) = dy_v(j,i)+(yc(ii)-a(j,i))*dt2
1890 dy_d(j,i) =dt2*(dy_v(j,i)+(dy_g-dy_b-half)*yc(ii)*dt2)
1891 a(j,i) = yc(ii)
1892 IF (tt<=dt2) THEN
1893 dy_v(j,i) = ud(j,i)/dt2
1894 dy_d(j,i) = ud(j,i)
1895 yc(ii) = half*dy_v(j,i)/dt2
1896 END IF
1897 dw = dw + ud(j,i)*(ms(i)*weight(i)*yc(ii)-fint)
1898 ELSEIF(j<=6)THEN
1899 j1 = j
1900 j = j - 3
1901c
1902 IF(isk<=1.AND.ifm<=1)THEN
1903 IF(ibfv(6,n)==0)THEN
1904 in0=in(i)*weight(i)
1905 ELSE
1906 nr = ibfv(6,n)
1907 in0= weight(i)*
1908 . (rby(16+j,nr) + rby(19+j,nr) + rby(22+j,nr))
1909 ENDIF
1910 ELSEIF (isk>1) THEN
1911 IF(ibfv(6,n)==0)THEN
1912 in0=in(i)*weight(i)
1913 ELSE
1914 nr = ibfv(6,n)
1915 k1=3*j-2
1916 k2=3*j-1
1917 k3=3*j
1918 in0=weight(i)*
1919 . ((rby(17,nr)*skew(k1,isk)
1920 . +rby(18,nr)*skew(k2,isk)
1921 . +rby(19,nr)*skew(k3,isk))*skew(k1,isk) +
1922 . (rby(20,nr)*skew(k1,isk)
1923 . +rby(21,nr)*skew(k2,isk)
1924 . +rby(22,nr)*skew(k3,isk))*skew(k2,isk) +
1925 . (rby(23,nr)*skew(k1,isk)
1926 . +rby(24,nr)*skew(k2,isk)
1927 . +rby(25,nr)*skew(k3,isk))*skew(k3,isk))
1928 ENDIF
1929 ELSEIF (ifm>1) THEN
1930 IF(ibfv(6,n)==0)THEN
1931 in0=in(i)*weight(i)
1932 ELSE
1933 nr = ibfv(6,n)
1934 k1=3*j-2
1935 k2=3*j-1
1936 k3=3*j
1937 in0= weight(i)*
1938 . ((rby(17,nr)*xframe(k1,ifm)
1939 . +rby(18,nr)*xframe(k2,ifm)
1940 . +rby(19,nr)*xframe(k3,ifm))*xframe(k1,ifm) +
1941 . (rby(20,nr)*xframe(k1,ifm)
1942 . +rby(21,nr)*xframe(k2,ifm)
1943 . +rby(22,nr)*xframe(k3,ifm))*xframe(k2,ifm) +
1944 . (rby(23,nr)*xframe(k1,ifm)
1945 . +rby(24,nr)*xframe(k2,ifm)
1946 . +rby(25,nr)*xframe(k3,ifm))*xframe(k3,ifm))
1947 ENDIF
1948 ENDIF
1949C---Correction for DY_VR,DY_DR, DY_AR
1950 dy_vr(j,i) = dy_vr(j,i)+(yc(ii)-ar(j,i))*dt2
1951 dy_dr(j,i) =dt2*(dy_vr(j,i)+(dy_g-dy_b-half)*yc(ii)*dt2)
1952 ar(j,i) = yc(ii)
1953 IF (tt<=dt2) THEN
1954 dy_vr(j,i) = rd(j,i)/dt2
1955 dy_dr(j,i) = rd(j,i)
1956 yc(ii) = half*dy_vr(j,i)/dt2
1957 END IF
1958 dw = dw + rd(j,i)*(in0*yc(ii)-fint)
1959 ENDIF
1960 ENDDO
1961 100 CONTINUE
1962 ENDDO
1963C
1964 RETURN
1965 END
1966C------- choice of codensated direction with prefer direction j0--
1967!||====================================================================
1968!|| l_dir02 ../engine/source/constraints/general/impvel/fv_imp0.F
1969!||--- called by ------------------------------------------------------
1970!|| fvl_modif ../engine/source/constraints/general/impvel/fv_imp0.F
1971!||--- calls -----------------------------------------------------
1972!|| ancmsg ../engine/source/output/message/message.F
1973!|| arret ../engine/source/system/arret.F
1974!|| l_dir0 ../engine/source/constraints/general/bcs/bc_imp0.F
1975!||--- uses -----------------------------------------------------
1976!|| message_mod ../engine/share/message_module/message_mod.F
1977!||====================================================================
1978 SUBROUTINE l_dir02(EJ ,J ,J0 ,IKC )
1979C-----------------------------------------------
1980C M o d u l e s
1981C-----------------------------------------------
1982 USE message_mod
1983C-----------------------------------------------
1984C I m p l i c i t T y p e s
1985C-----------------------------------------------
1986#include "implicit_f.inc"
1987C-----------------------------------------------
1988C D u m m y A r g u m e n t s
1989C-----------------------------------------------
1990 INTEGER J,J0,IKC(3)
1991 my_real
1992 . EJ(*)
1993C-----------------------------------------------
1994C L o c a l V a r i a b l e s
1995C-----------------------------------------------
1996 INTEGER I
1997 my_real
1998 . EJ1(3)
1999C------------EJ is not modified-----------------------
2000 DO I=1,3
2001 ej1(i)= ej(i)
2002C-----becomes obsolet
2003C IF (IKC(I)>0) EJ1(I)=ZERO
2004 END DO
2005C------add user's id
2006 IF ((abs(ej1(1))+abs(ej1(2))+abs(ej1(3)))==zero) THEN
2007 CALL ancmsg(msgid=104,anmode=aninfo)
2008 CALL arret(2)
2009 ENDIF
2010C---using J0 creat numerical error when EJ1(J0) is small---
2011c IF (J0>0 )THEN
2012c IF (ABS(EJ1(J0))>EM6) THEN
2013c J=J0
2014c ELSE
2015c CALL L_DIR0(EJ1 ,J)
2016c ENDIF
2017c ELSE
2018 CALL l_dir0(ej1 ,j)
2019c ENDIF
2020C
2021 RETURN
2022 END
2023!||====================================================================
2024!|| dintera ../engine/source/constraints/general/impvel/fv_imp0.F
2025!||--- called by ------------------------------------------------------
2026!|| wfv_imp ../engine/source/constraints/general/impvel/fv_imp0.F
2027!||====================================================================
2028 SUBROUTINE dintera(TF,IAD,IPOS1,ILEN,NEL0,X1,X2,AY,ITY)
2029C-----------------------------------------------
2030C I m p l i c i t T y p e s
2031C-----------------------------------------------
2032#include "implicit_f.inc"
2033C
2034C-----------------------------------------------
2035C D u m m y A r g u m e n t s
2036C-----------------------------------------------
2037 INTEGER NEL0,IAD(*),IPOS1(*),ILEN(*),ITY(*)
2038 my_real
2039 . X1(*),X2(*),AY(*),TF(2,*)
2040C----------------------------------------------
2041C L o c a l V a r i a b l e s
2042C-----------------------------------------------
2043C-----calculate acceleration at (a(X1)+a(X2))/2
2044 INTEGER IPOS(NEL0)
2045 my_real
2046 . y1(nel0),y2(nel0),dydx,x(nel0),y(nel0),
2047 . vy1(nel0),vy2(nel0)
2048 INTEGER I,J1,J,J2,ICONT,J0,L
2049C------postion pour x1-----
2050 IF (NEL0==0) return
2051 DO i=1,nel0
2052 j1 = ipos1(i)+iad(i)+1
2053 IF (x1(i)>tf(1,j1)) THEN
2054 ipos(i) = ipos1(i)
2055C--------due au divergence-----
2056 ELSE
2057 ipos(i) = 0
2058 ilen(i) = ilen(i)+ipos1(i)
2059 ENDIF
2060 ENDDO
2061 j = 0
2062 icont = 1
2063C
2064 DO WHILE(icont==1)
2065 j = j+1
2066 icont = 0
2067 DO i=1,nel0
2068 j1 = ipos(i)+iad(i)+1
2069 IF(j<=ilen(i)-1.AND.x1(i)>tf(1,j1))THEN
2070 ipos(i)=ipos(i)+1
2071 icont = 1
2072 ENDIF
2073 ENDDO
2074 ENDDO
2075C------interpelation pour y1--------
2076 DO i=1,nel0
2077 j1 =ipos(i)+iad(i)
2078 j2 = j1+1
2079 dydx=(tf(2,j2)-tf(2,j1))/(tf(1,j2)-tf(1,j1))
2080 y1(i) = tf(2,j1) + dydx*(x1(i)-tf(1,j1))
2081C IPOS1(I) = IPOS(I)
2082 IF (ity(i)==2) vy1(i) = dydx
2083C--------to be consisting w/ explicit--
2084c IF (X1(I)<=ZERO) Y1(I) =ZERO
2085 ENDDO
2086C------postion pour x2-----
2087 icont = 1
2088C
2089 DO WHILE(icont==1)
2090 j = j+1
2091 icont = 0
2092 DO i=1,nel0
2093 j1 = ipos(i)+iad(i)+1
2094 IF(j<=ilen(i).AND.x2(i)>tf(1,j1))THEN
2095 ipos(i)=ipos(i)+1
2096 icont = 1
2097 ENDIF
2098 ENDDO
2099 ENDDO
2100C------interpelation pour y2--------
2101 DO i=1,nel0
2102 j1 =ipos(i)+iad(i)
2103 j2 = j1+1
2104 dydx=(tf(2,j2)-tf(2,j1))/(tf(1,j2)-tf(1,j1))
2105 y2(i) = tf(2,j1) + dydx*(x2(i)-tf(1,j1))
2106C IPOS1(I) = IPOS(I)
2107 IF (ity(i)==2) vy2(i) = dydx
2108 ENDDO
2109C------interpelation in function of (d,v,a)--------
2110 DO i=1,nel0
2111 IF (ity(i)==2) THEN
2112 ay(i) = (vy2(i) - vy1(i))/(x2(i)-x1(i))
2113 ELSEIF (ity(i)==1) THEN
2114 ay(i) = (y2(i)-y1(i))/(x2(i)-x1(i))
2115 ELSEIF (ity(i)==0) THEN
2116C----------------takes average value since it's used only for energy compute
2117 ay(i) = (y2(i)+y1(i))*half
2118 ENDIF
2119 ENDDO
2120 i=1
2121C
2122 RETURN
2123 END
2124!||====================================================================
2125!|| fv_fint0 ../engine/source/constraints/general/impvel/fv_imp0.F
2126!||--- called by ------------------------------------------------------
2127!|| imp_solv ../engine/source/implicit/imp_solv.F
2128!||--- uses -----------------------------------------------------
2129!|| imp_dyna ../engine/share/modules/impbufdef_mod.F
2130!|| sensor_mod ../common_source/modules/sensor_mod.F90
2131!||====================================================================
2132 SUBROUTINE fv_fint0(IBFV ,NPC ,TF ,VEL ,SENSOR_TAB,
2133 1 UD ,RD ,IFIX ,IDDL ,NSENSOR ,
2134 2 SKEW ,IFRAME ,XFRAME,A ,AR ,
2135 3 X ,NDOF ,MS ,IN ,WEIGHT ,
2136 4 RBY )
2137C-----------------------------------------------
2138C M o d u l e s
2139C-----------------------------------------------
2140 USE imp_dyna
2141 USE sensor_mod
2142C-----------------------------------------------
2143C I m p l i c i t T y p e s
2144C-----------------------------------------------
2145#include "implicit_f.inc"
2146#include "mvsiz_p.inc"
2147C-----------------------------------------------
2148C C o m m o n B l o c k s
2149C-----------------------------------------------
2150#include "com04_c.inc"
2151#include "com08_c.inc"
2152#include "param_c.inc"
2153C-----------------------------------------------
2154C D u m m y A r g u m e n t s
2155C-----------------------------------------------
2156 INTEGER ,INTENT(IN) :: NSENSOR
2157 INTEGER NPC(*),IBFV(NIFV,*),
2158 . IFIX(*),IDDL(*),IFRAME(LISKN,*),NDOF(*),WEIGHT(*)
2159C REAL
2160 my_real
2161 . tf(*), vel(lfxvelr,*), ud(3,*),
2162 . skew(lskew,*),rd(3,*),a(3,*),ar(3,*),in(*),
2163 . x(3,*),xframe(nxframe,*),dw,ms(*),rby(nrby,*)
2164 TYPE (SENSOR_STR_) ,DIMENSION(NSENSOR) ,INTENT(IN) :: SENSOR_TAB
2165C-----------------------------------------------
2166C L o c a l V a r i a b l e s
2167C-----------------------------------------------
2168 INTEGER N, I, ISK, J, L, K1, K2, K3, ISENS,K,
2169 . ii, ic, nn, ideb, nr, nsk, nfk, ifm, n0,
2170 . index(mvsiz),i1,j1,nd,id,j2,j3,
2171 . n1,n2,n3,nvl
2172C REAL
2173 my_real
2174 . fac, startt, stopt, ts,
2175 . rx,ry,rz,vf,vfx,vfy,vfz,
2176 . facx,fold,a0,in0,dd,ms0,dvr
2177C IBFV(7,N):1 V;2 D ;0 A ;
2178C-------------------------------
2179C calculate average value (Fint(t+dt)+Fint(t)) for W_ext compute stored at VEL(4,N)
2180C---Fint(t) has been calculated and stored at beginning of imp_solv(even t+dt) ; input A,AR : residual
2181C-----------------------------------------------
2182 ideb = 0
2183C
2184 DO nn=1,nfxvel,nvsiz
2185 IF (ibfv(8,nn)==1) GOTO 100
2186 ic = 0
2187 IF (nsensor>0) THEN
2188 DO 10 ii = 1, min(nfxvel-ideb,nvsiz)
2189 n = ii+ideb
2190 startt = vel(2,n)
2191 stopt = vel(3,n)
2192 IF(tt<startt)GOTO 10
2193 IF(tt>stopt) GOTO 10
2194 i=iabs(ibfv(1,n))
2195 IF(ndof(i)==0) GOTO 10
2196 isens=0
2197 DO k=1,nsensor
2198 IF(ibfv(4,n)==sensor_tab(k)%SENS_ID) isens=k
2199 ENDDO
2200 IF(isens==0)THEN
2201 ts=tt
2202 ELSE
2203 ts = tt-sensor_tab(isens)%TSTART
2204 IF(ts<zero)GOTO 10
2205 ENDIF
2206 ic = ic + 1
2207 index(ic) = n
2208 10 CONTINUE
2209 ELSE
2210 DO 20 ii = 1, min(nfxvel-ideb,nvsiz)
2211 n = ii+ideb
2212 startt = vel(2,n)
2213 stopt = vel(3,n)
2214 IF(tt<startt)GOTO 20
2215 IF(tt>stopt) GOTO 20
2216 i=iabs(ibfv(1,n))
2217 IF(ndof(i)==0) GOTO 20
2218 ic = ic + 1
2219 index(ic) = n
2220 20 CONTINUE
2221 ENDIF
2222C
2223 ideb = ideb + min(nfxvel-ideb,nvsiz)
2224 DO ii=1,ic
2225 n = index(ii)
2226 fac = vel(1,n)
2227 i=iabs(ibfv(1,n))
2228 isk=ibfv(2,n)/10
2229 ifm = ibfv(9,n)
2230 j=ibfv(2,n)
2231 IF (ifm<=1) j=j-10*isk
2232 ms0=abs(ms(i))*weight(i)
2233 IF(j<=3)THEN
2234 IF(isk<=1.AND.ifm<=1)THEN
2235 a0 = a(j,i)+ms0*dy_a(j,i)
2236 ELSEIF (isk>1) THEN
2237 k1=3*j-2
2238 k2=3*j-1
2239 k3=3*j
2240 a0 = skew(k1,isk)*(a(1,i)+ms0*dy_a(1,i)) +
2241 . skew(k2,isk)*(a(2,i)+ms0*dy_a(2,i)) +
2242 . skew(k3,isk)*(a(3,i)+ms0*dy_a(3,i))
2243 ELSEIF (ifm>1) THEN
2244 k1=3*j-2
2245 k2=3*j-1
2246 k3=3*j
2247 dd = xframe(k1,ifm)*ud(1,i)
2248 . + xframe(k2,ifm)*ud(2,i)
2249 . + xframe(k3,ifm)*ud(3,i)
2250 a0 = xframe(k1,ifm)*(a(1,i)+ms0*dy_a(1,i))
2251 . + xframe(k2,ifm)*(a(2,i)+ms0*dy_a(2,i))
2252 . + xframe(k3,ifm)*(a(3,i)+ms0*dy_a(3,i))
2253 ENDIF
2254 ELSEIF(j<=6)THEN
2255 j1 = j
2256 j = j - 3
2257 in0=in(i)*weight(i)
2258 IF(isk<=1.AND.ifm<=1)THEN
2259 a0 = ar(j,i)+in0*dy_ar(j,i)
2260 ELSEIF (isk>1) THEN
2261 k1=3*j-2
2262 k2=3*j-1
2263 k3=3*j
2264 a0 = skew(k1,isk)*(ar(1,i)+in0*dy_ar(1,i))+
2265 . skew(k2,isk)*(ar(2,i)+in0*dy_ar(2,i))+
2266 . skew(k3,isk)*(ar(3,i)+in0*dy_ar(3,i))
2267C
2268 ELSEIF (ifm>1) THEN
2269 k1=3*j-2
2270 k2=3*j-1
2271 k3=3*j
2272 a0 = xframe(k1,ifm)*(ar(1,i)+in0*dy_ar(1,i))+
2273 . xframe(k2,ifm)*(ar(2,i)+in0*dy_ar(2,i))+
2274 . xframe(k3,ifm)*(ar(3,i)+in0*dy_ar(3,i))
2275 ENDIF
2276 ENDIF
2277 vel(4,n) = half*(vel(4,n)+a0)
2278 ENDDO
2279 100 CONTINUE
2280 ENDDO
2281C
2282 RETURN
2283 END
2284!||====================================================================
2285!|| dim_fvbcl ../engine/source/constraints/general/impvel/fv_imp0.F
2286!||--- called by ------------------------------------------------------
2287!|| upd_glob_k ../engine/source/implicit/upd_glob_k.F
2288!||--- calls -----------------------------------------------------
2289!|| dir_fvbc ../engine/source/constraints/general/impvel/fv_imp0.F
2290!|| fvbc_compa0 ../engine/source/constraints/general/impvel/fv_imp0.f
2291!|| fvbc_compa1 ../engine/source/constraints/general/impvel/fv_imp0.F
2292!|| fvbc_compa2 ../engine/source/constraints/general/impvel/fv_imp0.F
2293!|| getbcl_j ../engine/source/constraints/general/impvel/fv_imp0.F
2294!|| gfvbc2_ind ../engine/source/constraints/general/impvel/fv_imp0.F
2295!|| updfvbc_l ../engine/source/constraints/general/impvel/fv_imp0.F
2296!||====================================================================
2297 SUBROUTINE dim_fvbcl(IBFV ,LJ ,ISKEW ,ICODT ,ICODR ,
2298 1 NDDL ,IDDL ,IFIX ,IADK ,JDIK ,
2299 2 SKEW ,NFVBCL ,NBKUD )
2300C-----------------------------------------------
2301C I m p l i c i t T y p e s
2302C-----------------------------------------------
2303#include "implicit_f.inc"
2304C-----------------------------------------------
2305C C o m m o n B l o c k s
2306C-----------------------------------------------
2307#include "com04_c.inc"
2308#include "param_c.inc"
2309C-----------------------------------------------
2310C D u m m y A r g u m e n t s
2311C-----------------------------------------------
2312 INTEGER IBFV(NIFV,*),LJ(*),ISKEW(*),ICODT(*),ICODR(*),NFVBCL,
2313 . nbkud,nddl ,iadk(*) ,jdik(*),iddl(*),ifix(*)
2314C REAL
2315 my_real
2316 . skew(lskew,*)
2317C-----------------------------------------------
2318C L o c a l V a r i a b l e s
2319C-----------------------------------------------
2320 INTEGER N, I, ISK, J, L, K1, K2, K3, K,II,N1,
2321 . IFM, J2,J3,I1,J1,ND,NUD,ITAG(NFXVEL),ICTR,
2322 . JBC,JJ,J11,J1_1,ISKBC
2323 my_real
2324 . EJ(3),S
2325C--------LJ()=1,6----- LJ<0
2326C-1) impose disp in global system
2327C-2) change CDT,CDR and call BC1 for [K] update
2328C-3) when there is conflict, change FV or BCS global dir(UD will be updated in FVBC_IMPL)
2329C-4) adding FVBC_IMPD in RECUKIN as FV_IMP is called several times
2330C if treated before
2331 DO n = 1,nfxvel
2332 j1=-lj(n)
2333 IF (j1>0) lj(n)=j1
2334 END DO
2335C
2336 DO n = 1,nfxvel
2337 j1=lj(n)
2338 itag(n)=0
2339 IF (j1>0) THEN
2340 i=iabs(ibfv(1,n))
2341 isk=ibfv(2,n)/10
2342 ifm = ibfv(9,n)
2343 j=ibfv(2,n)
2344 IF (ifm<=1) j=j-10*isk
2345 iskbc=iskew(i)
2346 IF (isk==iskbc) THEN
2347 IF (j>3) THEN
2348 IF (icodr(i)>0) THEN
2349 nfvbcl=nfvbcl+1
2350 lj(n)=-j1
2351 END IF
2352 ELSE
2353 IF (icodt(i)>0) THEN
2354 nfvbcl=nfvbcl+1
2355 lj(n)=-j1
2356 END IF
2357 END IF !IF (J>3) THEN
2358 ELSE
2359 IF (iskbc>0) THEN
2360C----------error out---
2361 END IF
2362 END IF
2363 ENDIF
2364 ENDDO
2365C--------------NBKUD compter----
2366 nbkud =0
2367 DO n = 1,nfxvel
2368 j1=-lj(n)
2369 IF (j1>0.AND.itag(n)>=0) THEN
2370 i=iabs(ibfv(1,n))
2371 isk=ibfv(2,n)/10
2372 ifm = ibfv(9,n)
2373 j=ibfv(2,n)
2374 IF (ifm<=1) j=j-10*isk
2375 nud=0
2376 nd =iddl(i)
2377 IF (j>3) THEN
2378 ictr=icodr(i)
2379 nd = nd +3
2380 ELSE
2381 ictr=icodt(i)
2382 END IF
2383 DO k=1,3
2384 IF (ifix(nd+k)==9) nud = nud + 1
2385 END DO
2386C case 2 Ud ---search only ICT 1,2,4
2387 IF (nud > 1) THEN
2388C---------look for another Ud in LJ()<0
2389 DO n1=n+1,nfxvel
2390 jj = iabs(lj(n1)-j1)
2391 ii = iabs(ibfv(1,n1))
2392 IF (lj(n1) < 0.AND.jj < 3.AND.ii==i) THEN
2393 itag(n)=n1
2394 itag(n1)=-n
2395 ENDIF
2396 ENDDO
2397 n1 = itag(n)
2398 j11 = ibfv(2,n1)
2399 j1_1 = -lj(n1)
2400C-----suppose ICT =(1,2,4) otherwise starter does not pass
2401 CALL getbcl_j(ictr ,isk ,skew ,jbc ,j )
2402 CALL fvbc_compa2(j1 ,j1_1 ,jbc ,ifix(iddl(i)+1) )
2403C---------
2404 CALL dir_fvbc(j1 ,j1_1 ,k )
2405 nd=iddl(i)+k
2406 CALL updfvbc_l(nd ,ifix ,nddl ,iadk ,jdik ,
2407 1 nbkud )
2408 ELSEIF (nud == 1) THEN
2409C-----case 1 Ud ---search first ICT 3,5,6 +2BCS=3global UD-> no change for BCS--
2410 IF (ictr==3 .OR.ictr==5.OR.ictr==6) THEN
2411 CALL getbcl_j(ictr ,isk ,skew ,k ,j)
2412C--------check compatibility--
2413 CALL fvbc_compa1(j1 ,k ,ifix(nd+1))
2414C---------
2415 j1_1 = 0
2416 CALL dir_fvbc(j1 ,j1_1 ,k )
2417 nd=iddl(i)+j1_1
2418 CALL updfvbc_l(nd ,ifix ,nddl ,iadk ,jdik ,
2419 1 nbkud )
2420 nd=iddl(i)+k
2421 CALL updfvbc_l(nd ,ifix ,nddl ,iadk ,jdik ,
2422 1 nbkud )
2423C-----case 1 Ud ---search first ICT 1,2,4 -> 2d ud, change for BCS--
2424 ELSEIF (ictr==1 .OR.ictr==2.OR.ictr==4) THEN
2425C--------termine independent dof K w/ fixing j1
2426 CALL gfvbc2_ind(j,ictr,skew(1,isk),k ,l )
2427 CALL getbcl_j(ictr ,isk ,skew ,j1_1 ,j )
2428 CALL fvbc_compa0(j1 ,j1_1 ,ifix(nd+1) ,k )
2429C---------
2430 nd=iddl(i)+j1_1
2431 CALL updfvbc_l(nd ,ifix ,nddl ,iadk ,jdik ,
2432 1 nbkud )
2433C---------change of IFIX, update {B} is done also with NKUD1
2434 END IF !(ICTR==3 .OR.ICTR==5.OR.ICTR==6)
2435 END IF !IF (NUD > 1) THEN
2436 ENDIF
2437 ENDDO
2438 RETURN
2439 END
2440!||====================================================================
2441!|| fvbc_impl ../engine/source/constraints/general/impvel/fv_imp0.F
2442!||--- called by ------------------------------------------------------
2443!|| upd_glob_k ../engine/source/implicit/upd_glob_k.F
2444!||--- calls -----------------------------------------------------
2445!|| dir_fvbc ../engine/source/constraints/general/impvel/fv_imp0.F
2446!|| fvbc2_bup ../engine/source/constraints/general/impvel/fv_imp0.F
2447!|| fvbc_compa0 ../engine/source/constraints/general/impvel/fv_imp0.F
2448!|| fvbc_compa1 ../engine/source/constraints/general/impvel/fv_imp0.F
2449!|| fvbc_compa2 ../engine/source/constraints/general/impvel/fv_imp0.F
2450!|| getbcl_j ../engine/source/constraints/general/impvel/fv_imp0.F
2451!|| gfvbc2_ind ../engine/source/constraints/general/impvel/fv_imp0.F
2452!|| recu_ul ../engine/source/constraints/general/impvel/fv_imp0.F
2453!|| udl2_ug ../engine/source/constraints/general/impvel/fv_imp0.F
2454!|| udl2_ug2 ../engine/source/constraints/general/impvel/fv_imp0.F
2455!|| updfvbc_b ../engine/source/constraints/general/impvel/fv_imp0.F
2456!||====================================================================
2457 SUBROUTINE fvbc_impl(IBFV ,SKEW ,XFRAME ,LJ ,IDDL ,
2458 1 IFIX ,NDOF ,IADK ,JDIK ,DIAG_K ,
2459 2 LT_K ,UD ,RD ,LB ,NDDL ,
2460 3 ICODT ,ICODR ,ICODT1 ,ICODR1,NKUD1 ,
2461 4 IKUD ,BKUD )
2462C-----------------------------------------------
2463C I m p l i c i t T y p e s
2464C-----------------------------------------------
2465#include "implicit_f.inc"
2466C-----------------------------------------------
2467C C o m m o n B l o c k s
2468C-----------------------------------------------
2469#include "com01_c.inc"
2470#include "com04_c.inc"
2471#include "param_c.inc"
2472#include "units_c.inc"
2473C-----------------------------------------------
2474C D u m m y A r g u m e n t s
2475C-----------------------------------------------
2476 INTEGER IBFV(NIFV,*),LJ(*),NFVBCL,NDDL,
2477 . NKUD1,IKUD(*)
2478 INTEGER
2479 . IDDL(*),IADK(*),JDIK(*),NDOF(*),IFIX(*),
2480 . ICODT(*),ICODR(*),ICODT1(*),ICODR1(*)
2481C REAL
2482 my_real
2483 . UD(3,*),RD(3,*), DIAG_K(*),LT_K(*),SKEW(LSKEW,*),LB(*),
2484 . XFRAME(NXFRAME,*),BKUD(*)
2485C-----------------------------------------------
2486C L o c a l V a r i a b l e s
2487C-----------------------------------------------
2488C-1) impose disp in global system
2489C-2) change CDT,CDR and call BC1 for [K] update
2490C-3) when there is conflict, change FV or BCS global dir
2491C-4) adding FVBC_IMPD in RECUKIN as FV_IMP is called several times
2492 INTEGER N, I, ISK, J, L, K1, K2, K3, K,II,N1,
2493 . IFM, J2,J3,I1,J1,ND,NUD,ITAG(NFXVEL),ICTR,
2494 . JBC,JJ,J11,J1_1,ICTR1
2495 my_real
2496 . EJ(3),S,UDL(3),UDG(3)
2497C--------
2498 NKUD1=0
2499 do n = 1,numnod
2500 icodt1(n) = icodt(n)
2501 END DO
2502 IF (iroddl/=0) THEN
2503 DO n = 1,numnod
2504 icodr1(n) = icodr(n)
2505 END DO
2506 END IF !(IRODDL/=0) THEN
2507 DO n = 1,nfxvel
2508 itag(n)=0
2509 END DO
2510 DO n = 1,nfxvel
2511 j1=-lj(n)
2512 IF (j1>0.AND.itag(n)>=0) THEN
2513 i=iabs(ibfv(1,n))
2514 isk=ibfv(2,n)/10
2515 ifm = ibfv(9,n)
2516 j=ibfv(2,n)
2517 IF (ifm<=1) j=j-10*isk
2518 nud=0
2519 nd =iddl(i)
2520 IF (j>3) THEN
2521 ictr=icodr(i)
2522 nd = nd +3
2523 ELSE
2524 ictr=icodt(i)
2525 END IF
2526 DO k=1,3
2527 IF (ifix(nd+k)==9) nud = nud + 1
2528 udl(k)=zero
2529 END DO
2530C case 2 Ud ---search only ICT 1,2,4
2531 IF (nud > 1) THEN
2532C---------look for another Ud in LJ()<0
2533 DO n1=n+1,nfxvel
2534 jj = iabs(-lj(n1)-j1)
2535 ii = iabs(ibfv(1,n1))
2536 IF (lj(n1) < 0.AND.jj < 3.AND.ii==i) THEN
2537 itag(n)=n1
2538 itag(n1)=-n
2539 ENDIF
2540 ENDDO
2541 n1 = itag(n)
2542 j11 = ibfv(2,n1)
2543 j1_1 = -lj(n1)
2544 IF (n1==0) THEN
2545C -------error out
2546 WRITE(istdo,'(A,I4)')
2547 + ' ** ERROR IN IMPVEL(OR IMPDISP) IN SKEW:',isk
2548 END IF
2549C--------starter done already CALL FVBC_COMP1(J,J11,ICTR)
2550 IF (j>3) THEN
2551 CALL recu_ul(isk,ifm,skew,xframe,j,j1,udl,rd(1,i),n)
2552 CALL recu_ul(isk,ifm,skew,xframe,j11,j1_1,udl,rd(1,i),n1)
2553 ELSE
2554 CALL recu_ul(isk,ifm,skew,xframe,j,j1,udl,ud(1,i),n)
2555 CALL recu_ul(isk,ifm,skew,xframe,j11,j1_1,udl,ud(1,i),n1)
2556 END IF
2557C--------calculate Ud in global system (only SKEW is available w/ BCS
2558 CALL udl2_ug(skew(1,isk),udl,udg)
2559C----------compatibility FV-BCS-(condensation components)----- ;
2560C-----suppose ICT =(1,2,4) otherwise starter does not pass
2561 CALL getbcl_j(ictr ,isk ,skew ,jbc ,j )
2562 CALL fvbc_compa2(j1 ,j1_1 ,jbc ,ifix(iddl(i)+1) )
2563C----------update 2 ud J1,J1_1 first ;
2564 IF (j>3) THEN
2565 rd(j1-3,i)=udg(j1)
2566 rd(j1_1-3,i)=udg(j1_1)
2567 ELSE
2568 ud(j1,i)=udg(j1)
2569 ud(j1_1,i)=udg(j1_1)
2570 END IF
2571C---------update {B} manually for the last ud
2572 CALL dir_fvbc(j1 ,j1_1 ,k )
2573 nd=iddl(i)+k
2574 IF (k >3 ) k = k -3
2575 CALL updfvbc_b(nd ,ifix ,nddl ,iadk ,jdik ,
2576 1 lt_k ,udg(k),nkud1 ,ikud ,bkud )
2577 ELSEIF (nud == 1) THEN
2578 IF (j>3) THEN
2579 CALL recu_ul(isk,ifm,skew,xframe,j,j1,udl,rd(1,i),n)
2580 ELSE
2581 CALL recu_ul(isk,ifm,skew,xframe,j,j1,udl,ud(1,i),n)
2582 END IF
2583C-----case 1 Ud ---search first ICT 3,5,6 -> no change for BCS--
2584 IF (ictr==3 .OR.ictr==5.OR.ictr==6) THEN
2585C--------calculate Ud in global system (only SKEW is available w/ BCS
2586 CALL udl2_ug(skew(1,isk),udl,udg)
2587 CALL getbcl_j(ictr ,isk ,skew ,k ,j)
2588C--------check compatibility--
2589 CALL fvbc_compa1(j1 ,k ,ifix(iddl(i)+1))
2590C----------update ud first
2591 IF (j>3) THEN
2592 DO k1=1,3
2593 rd(k1,i)=udg(k1)
2594 END DO
2595 icodr1(i) = 0
2596 ELSE
2597 DO k1=1,3
2598 ud(k1,i)=udg(k1)
2599 END DO
2600C--------no need for update [K] w/ BCL
2601 icodt1(i) = 0
2602 END IF
2603C---------update {B} of manually for the 2 other ud
2604 j1_1 = 0
2605 CALL dir_fvbc(j1 ,j1_1 ,k )
2606 nd=iddl(i)+j1_1
2607 ifix(nd)=8
2608 IF (j1_1 >3 ) j1_1 = j1_1 -3
2609 CALL updfvbc_b(nd ,ifix ,nddl ,iadk ,jdik ,
2610 1 lt_k ,udg(j1_1),nkud1 ,ikud ,bkud )
2611 nd=iddl(i)+k
2612 ifix(nd)=8
2613 IF (k >3 ) k = k -3
2614 CALL updfvbc_b(nd ,ifix ,nddl ,iadk ,jdik ,
2615 1 lt_k ,udg(k),nkud1 ,ikud ,bkud )
2616C-----case 1 Ud ---search first ICT 1,2,4 -> 2d ud, change for BCS--
2617 ELSEIF (ictr==1 .OR.ictr==2.OR.ictr==4) THEN
2618C--------termine independent dof K w/ so that DET=DET_max
2619 CALL gfvbc2_ind(j,ictr,skew(1,isk),k ,ictr1)
2620 CALL getbcl_j(ictr ,isk ,skew ,j1_1 ,j )
2621 nd = iddl(i)+j1_1
2622 ifix(nd)=8
2623 nd = iddl(i)+1
2624 CALL fvbc_compa0(j1 ,j1_1 ,ifix(nd) ,k )
2625C--------calculate Ud() free of K in global system update ud_i
2626 CALL udl2_ug2(j,ictr,skew(1,isk),udl,udg,k)
2627C---------and update {B} of term diag_k
2628 CALL fvbc2_bup(j ,ictr ,skew(1,isk),j1 ,j1_1 ,
2629 1 udg ,diag_k ,lb ,iddl(i))
2630C----------update ud first
2631 IF (j>3) THEN
2632 rd(j1-1,i)=udg(j1-1)
2633 rd(j1_1-1,i)=udg(j1_1-1)
2634 ELSE
2635 ud(j1,i)=udg(j1)
2636 ud(j1_1,i)=udg(j1_1)
2637 END IF
2638C---------update {B} of manually for the ud_j1
2639 nd=iddl(i)+j1_1
2640 IF (j1_1 >3 ) j1_1 = j1_1 -3
2641 CALL updfvbc_b(nd ,ifix ,nddl ,iadk ,jdik ,
2642 1 lt_k ,udg(j1_1),nkud1 ,ikud ,bkud )
2643C---------attention IFIX is changed also in BC_IMP1([K] update)
2644C---------due to this, update {B} of manually for the ud_j1
2645C---------update ICODT1,ICODR1 for dof j1,j1_1-> [K] update (consisting w/ BC_IMP1
2646C-------------negative value (taged) to avoid the change of IFIX by BC_IMP1
2647 IF (j>3) THEN
2648 icodr1(i) = -ictr1
2649 ELSE
2650 icodt1(i) = -ictr1
2651 END IF
2652 END IF !(ICTR==3 .OR.ICTR==5.OR.ICTR==6)
2653 END IF !IF (NUD > 1) THEN
2654 ENDIF
2655 ENDDO
2656C
2657 RETURN
2658 END
2659!||====================================================================
2660!|| recu_ul ../engine/source/constraints/general/impvel/fv_imp0.F
2661!||--- called by ------------------------------------------------------
2662!|| fvbc_impd ../engine/source/constraints/general/impvel/fv_imp0.F
2663!|| fvbc_impl ../engine/source/constraints/general/impvel/fv_imp0.F
2664!|| fvbc_impl1 ../engine/source/constraints/general/impvel/fv_imp0.F
2665!||--- uses -----------------------------------------------------
2666!|| imp_fvbcl ../engine/share/modules/impbufdef_mod.F
2667!||====================================================================
2668 SUBROUTINE recu_ul(ISK,IFM,SKEW,XFRAME,J,J1,UDL,UD,N)
2669C-----------------------------------------------
2670C M o d u l e s
2671C-----------------------------------------------
2672 USE imp_fvbcl
2673C-----------------------------------------------
2674C I m p l i c i t T y p e s
2675C-----------------------------------------------
2676#include "implicit_f.inc"
2677C-----------------------------------------------
2678C C o m m o n B l o c k s
2679C-----------------------------------------------
2680#include "param_c.inc"
2681#include "impl1_c.inc"
2682C-----------------------------------------------
2683C D u m m y A r g u m e n t s
2684C-----------------------------------------------
2685 INTEGER ISK,IFM,J,J1,N
2686C REAL
2687 my_real
2688 . ud(*),udl(*), skew(lskew,*),xframe(nxframe,*)
2689C-----------------------------------------------
2690C L o c a l V a r i a b l e s
2691C-----------------------------------------------
2692C-----reget Ud initialized in FVL_MODIF
2693 INTEGER J0,J01,K1,K2,K3
2694 my_real
2695 . EJ(3)
2696C
2697 J0=j
2698 j01=j1
2699 IF (j > 3) j0 = j0-3
2700 IF (j1> 3) j01 = j01-3
2701C
2702 IF (imconv == 1) THEN
2703 IF (isk>1) THEN
2704 k1=3*j0-2
2705 k2=3*j0-1
2706 k3=3*j0
2707 ej(1)=skew(k1,isk)
2708 ej(2)=skew(k2,isk)
2709 ej(3)=skew(k3,isk)
2710 ELSEIF (ifm>1) THEN
2711 k1=3*j0-2
2712 k2=3*j0-1
2713 k3=3*j0
2714 ej(1)=xframe(k1,ifm)
2715 ej(2)=xframe(k2,ifm)
2716 ej(3)=xframe(k3,ifm)
2717 ENDIF
2718 udl(j0)=ud(j01)*ej(j01)
2719 fvbcudl(n) = udl(j0)
2720 ELSE
2721 udl(j0)=fvbcudl(n)
2722 END IF !(IMCONV == 1) THEN
2723C
2724 RETURN
2725 END
2726!||====================================================================
2727!|| udl2_ug ../engine/source/constraints/general/impvel/fv_imp0.F
2728!||--- called by ------------------------------------------------------
2729!|| fvbc_impd ../engine/source/constraints/general/impvel/fv_imp0.F
2730!|| fvbc_impl ../engine/source/constraints/general/impvel/fv_imp0.F
2731!|| fvbc_impl1 ../engine/source/constraints/general/impvel/fv_imp0.F
2732!||====================================================================
2733 SUBROUTINE udl2_ug(SKEW,UDL,UDG)
2734C-----------------------------------------------
2735C I m p l i c i t T y p e s
2736C-----------------------------------------------
2737#include "implicit_f.inc"
2738C-----------------------------------------------
2739C D u m m y A r g u m e n t s
2740C-----------------------------------------------
2741 my_real
2742 . udl(3),udg(3), skew(3,3)
2743C-----------------------------------------------
2744C L o c a l V a r i a b l e s
2745C-----------------------------------------------
2746C-----Ud_g=[SKEW]Ud_l
2747 INTEGER I,J
2748 udg(1)=skew(1,1)*udl(1)+skew(1,2)*udl(2)+skew(1,3)*udl(3)
2749 udg(2)=skew(2,1)*udl(1)+skew(2,2)*udl(2)+skew(2,3)*udl(3)
2750 udg(3)=skew(3,1)*udl(1)+skew(3,2)*udl(2)+skew(3,3)*udl(3)
2751C
2752 RETURN
2753 END
2754!||====================================================================
2755!|| dir_fvbc ../engine/source/constraints/general/impvel/fv_imp0.F
2756!||--- called by ------------------------------------------------------
2757!|| dim_fvbcl ../engine/source/constraints/general/impvel/fv_imp0.F
2758!|| fvbc_compa2 ../engine/source/constraints/general/impvel/fv_imp0.F
2759!|| fvbc_impl ../engine/source/constraints/general/impvel/fv_imp0.F
2760!||====================================================================
2761 SUBROUTINE dir_fvbc(J ,J1 ,K )
2762C-----------------------------------------------
2763C I m p l i c i t T y p e s
2764C-----------------------------------------------
2765#include "implicit_f.inc"
2766C-----------------------------------------------
2767C D u m m y A r g u m e n t s
2768C-----------------------------------------------
2769 INTEGER K,J,J1
2770C-----------------------------------------------
2771C L o c a l V a r i a b l e s
2772C-----------------------------------------------
2773 INTEGER J0,J01
2774C------J,J1 (1-3).or.(4-6)
2775 J0=j
2776 j01=j1
2777 IF (j > 3) j0 = j0-3
2778 IF (j1> 3) j01 = j01-3
2779 k = j0 + 1
2780 IF (k>3) k = k - 3
2781 IF (j1==0) THEN
2782 j1 = j0 + 2
2783 IF (j1>3) j1 = j1 - 3
2784 ELSEIF (k==j01) THEN
2785 k = j0 + 2
2786 IF (k>3) k = k - 3
2787 ENDIF
2788 IF (j > 3) THEN
2789 k = k + 3
2790 IF (j01==0) j1 = j1 + 3
2791 END IF
2792C
2793 RETURN
2794 END
2795!||====================================================================
2796!|| updfvbc_l ../engine/source/constraints/general/impvel/fv_imp0.F
2797!||--- called by ------------------------------------------------------
2798!|| dim_fvbcl ../engine/source/constraints/general/impvel/fv_imp0.F
2799!||====================================================================
2800 SUBROUTINE updfvbc_l(ID ,IFIX ,NDDL ,IADK ,JDIK ,
2801 1 NB )
2802C-----------------------------------------------
2803C I m p l i c i t T y p e s
2804C-----------------------------------------------
2805#include "implicit_f.inc"
2806C-----------------------------------------------
2807C C o m m o n B l o c k s
2808C-----------------------------------------------
2809#include "impl1_c.inc"
2810C-----------------------------------------------
2811C D u m m y A r g u m e n t s
2812C-----------------------------------------------
2813 integer
2814 . id,iadk(*),jdik(*),nddl,ifix(*) ,nb
2815C REAL
2816C-----------------------------------------------
2817C L o c a l V a r i a b l e s
2818C-----------------------------------------------
2819 INTEGER N, I, J, K,I1,J1,ND,NFV,NF,NT,JD
2820C REAL
2821C------------Ligne ID-------
2822 DO j1 = iadk(id),iadk(id+1)-1
2823 jd = jdik(j1)
2824 IF (ifix(jd)==0)nb = nb+1
2825 ENDDO
2826C------------Colonne ID-------
2827 IF (ikpat==0) THEN
2828 nf=1
2829 nt=id-1
2830 ELSE
2831 nf=id+1
2832 nt=nddl
2833 ENDIF
2834 DO i = nf,nt
2835 IF (ifix(i)==0) THEN
2836 DO k = iadk(i),iadk(i+1)-1
2837 j=jdik(k)
2838 IF (id==j) nb = nb+1
2839 ENDDO
2840 ENDIF
2841 ENDDO
2842C
2843 RETURN
2844 END
2845!||====================================================================
2846!|| updfvbc_b ../engine/source/constraints/general/impvel/fv_imp0.F
2847!||--- called by ------------------------------------------------------
2848!|| fvbc_impl ../engine/source/constraints/general/impvel/fv_imp0.F
2849!||====================================================================
2850 SUBROUTINE updfvbc_b(ID ,IFIX ,NDDL ,IADK ,JDIK ,
2851 1 LT_K ,UD ,NB ,IB ,KB )
2852C-----------------------------------------------
2853C I m p l i c i t T y p e s
2854C-----------------------------------------------
2855#include "implicit_f.inc"
2856C-----------------------------------------------
2857C C o m m o n B l o c k s
2858C-----------------------------------------------
2859#include "impl1_c.inc"
2860C-----------------------------------------------
2861C D u m m y A r g u m e n t s
2862C-----------------------------------------------
2863 integer
2864 . id,iadk(*),jdik(*),nddl,ifix(*) ,nb ,ib(*)
2865C REAL
2866 my_real
2867 . ud,lt_k(*),kb(*)
2868C-----------------------------------------------
2869C L o c a l V a r i a b l e s
2870C-----------------------------------------------
2871 INTEGER N, I, J, K,I1,J1,ND,NFV,NF,NT,JD
2872C REAL
2873C------------Ligne ID-------
2874 DO j1 = iadk(id),iadk(id+1)-1
2875 jd = jdik(j1)
2876 IF (ifix(jd)==0.AND.lt_k(j1)/=zero) THEN
2877 nb = nb+1
2878 ib(nb)=jd
2879 kb(nb)=ud*lt_k(j1)
2880 ENDIF
2881 ENDDO
2882C------------Colonne ID-------
2883 IF (ikpat==0) THEN
2884 nf=1
2885 nt=id-1
2886 ELSE
2887 nf=id+1
2888 nt=nddl
2889 ENDIF
2890 DO i = nf,nt
2891 IF (ifix(i)==0) THEN
2892 DO k = iadk(i),iadk(i+1)-1
2893 j=jdik(k)
2894 IF (id==j.AND.lt_k(k)/=zero) THEN
2895 nb = nb+1
2896 ib(nb)=i
2897 kb(nb)=ud*lt_k(k)
2898 ENDIF
2899 ENDDO
2900 ENDIF
2901 ENDDO
2902C
2903 RETURN
2904 END
2905!||====================================================================
2906!|| getbcl_j ../engine/source/constraints/general/impvel/fv_imp0.F
2907!||--- called by ------------------------------------------------------
2908!|| dim_fvbcl ../engine/source/constraints/general/impvel/fv_imp0.F
2909!|| fvbc_impd ../engine/source/constraints/general/impvel/fv_imp0.F
2910!|| fvbc_impl ../engine/source/constraints/general/impvel/fv_imp0.F
2911!|| fvbc_impl1 ../engine/source/constraints/general/impvel/fv_imp0.F
2912!||--- calls -----------------------------------------------------
2913!|| bc_c2d ../engine/source/constraints/general/bcs/bc_imp0.F
2914!|| dir_rbe2 ../engine/source/constraints/general/rbe2/rbe2v.F
2915!|| l_dir2 ../engine/source/constraints/general/bcs/bc_imp0.F
2916!||====================================================================
2917 SUBROUTINE getbcl_j(ICT ,ISK ,SKEW ,J ,IR )
2918C-----------------------------------------------
2919C I m p l i c i t T y p e s
2920C-----------------------------------------------
2921#include "implicit_f.inc"
2922C-----------------------------------------------
2923C C o m m o n B l o c k s
2924C-----------------------------------------------
2925#include "param_c.inc"
2926C-----------------------------------------------
2927C D u m m y A r g u m e n t s
2928C-----------------------------------------------
2929 INTEGER ICT,ISK,J,IR
2930 my_real
2931 . skew(lskew,*)
2932C-----------------------------------------------
2933C L o c a l V a r i a b l e s
2934C-----------------------------------------------
2935 INTEGER K,J1,L,KC
2936 my_real
2937 . ej(3),ej1(3),s,ea,eb
2938C-----GET BCS w/ local skew condensation component(global) info----
2939C----For ICT=1,2,4-: return to depedent component j
2940C----For ICT=3,5,6-: return to indepedent component j=k
2941 IF (ict == 4 ) THEN
2942 ej(1)=skew(1,isk)
2943 ej(2)=skew(2,isk)
2944 ej(3)=skew(3,isk)
2945 CALL l_dir2(ej,j,1)
2946 ELSEIF (ict == 2) THEN
2947 ej(1)=skew(4,isk)
2948 ej(2)=skew(5,isk)
2949 ej(3)=skew(6,isk)
2950 CALL l_dir2(ej,j,2)
2951 ELSEIF (ict == 1) THEN
2952 ej(1)=skew(7,isk)
2953 ej(2)=skew(8,isk)
2954 ej(3)=skew(9,isk)
2955 CALL l_dir2(ej,j,3)
2956 ELSEIF (ict == 3) THEN
2957 ej(1)=skew(7,isk)
2958 ej(2)=skew(8,isk)
2959 ej(3)=skew(9,isk)
2960c CALL L_DIR(EJ,J)
2961 ej1(1)=skew(4,isk)
2962 ej1(2)=skew(5,isk)
2963 ej1(3)=skew(6,isk)
2964 CALL bc_c2d(ej,ej1, j, j1 ,ea, eb )
2965 CALL dir_rbe2(j ,j1 ,k )
2966 j = k
2967 ELSEIF (ict == 5) THEN
2968 ej(1)=skew(7,isk)
2969 ej(2)=skew(8,isk)
2970 ej(3)=skew(9,isk)
2971c CALL L_DIR(EJ,J)
2972 ej1(1)=skew(1,isk)
2973 ej1(2)=skew(2,isk)
2974 ej1(3)=skew(3,isk)
2975 CALL bc_c2d(ej,ej1, j, j1 ,ea, eb )
2976 CALL dir_rbe2(j ,j1 ,k )
2977 j = k
2978 ELSEIF (ict == 6) THEN
2979C
2980 ej(1)=skew(4,isk)
2981 ej(2)=skew(5,isk)
2982 ej(3)=skew(6,isk)
2983c CALL L_DIR(EJ,J)
2984 ej1(1)=skew(1,isk)
2985 ej1(2)=skew(2,isk)
2986 ej1(3)=skew(3,isk)
2987 CALL bc_c2d(ej,ej1, j, j1 ,ea, eb )
2988 CALL dir_rbe2(j ,j1 ,k )
2989 j = k
2990 ELSEIF (ict == 7) THEN
2991 j=0
2992 ENDIF
2993C---------rotational id----------
2994 IF (ir > 3) j = j + 3
2995C
2996 RETURN
2997 END
2998!||====================================================================
2999!|| fvbc_compa0 ../engine/source/constraints/general/impvel/fv_imp0.F
3000!||--- called by ------------------------------------------------------
3001!|| dim_fvbcl ../engine/source/constraints/general/impvel/fv_imp0.F
3002!|| fvbc_impd ../engine/source/constraints/general/impvel/fv_imp0.F
3003!|| fvbc_impl ../engine/source/constraints/general/impvel/fv_imp0.F
3004!|| fvbc_impl1 ../engine/source/constraints/general/impvel/fv_imp0.F
3005!||--- calls -----------------------------------------------------
3006!|| dir_rbe2 ../engine/source/constraints/general/rbe2/rbe2v.F
3007!||====================================================================
3008 SUBROUTINE fvbc_compa0(J1 ,JBC ,IFIX ,K )
3009C-----------------------------------------------
3010C I m p l i c i t T y p e s
3011C-----------------------------------------------
3012#include "implicit_f.inc"
3013C-----------------------------------------------
3014C D u m m y A r g u m e n t s
3015C-----------------------------------------------
3016 INTEGER J1 ,JBC ,IFIX(*),K
3017C-----------------------------------------------
3018C L o c a l V a r i a b l e s
3019C-----------------------------------------------
3020 INTEGER I,IKC(3),J01,J,J02
3021C---------JBC is the fix component of BCS
3022 j01 = j1
3023 IF (j01>3) j01 = j01 -3
3024 j02 = jbc
3025 IF (j02>3) j02 = j02 -3
3026C
3027 IF (j02==k) THEN
3028 IF (j01==k) THEN
3029C change JBC,J1 to -->
3030 j02=k+1
3031 IF (j02>3) j02 = j02 -3
3032 IF (jbc>3) j02 = j02 +3
3033 ifix(j02)=8
3034 ifix(jbc)=0
3035 jbc = j02
3036C
3037 j01=k+2
3038 IF (j01>3) j01 = j01 -3
3039 IF (j1>3) j01 = j01 +3
3040 ifix(j01)=9
3041 ifix(j1)=0
3042 j1 = j01
3043 ELSE
3044C change JBC to -->
3045 CALL dir_rbe2(j01 ,k ,j02 )
3046 IF (jbc>3) j02 = j02 +3
3047 ifix(j02)=8
3048 ifix(jbc)=0
3049 jbc = j02
3050 END IF
3051 ELSEIF (j01==k) THEN
3052C change J1 to -->
3053 CALL dir_rbe2(j02 ,k ,j01 )
3054 IF (j1>3) j01 = j01 +3
3055 ifix(j01)=9
3056 ifix(j1)=0
3057 j1 = j01
3058 END IF !(J02==K) THEN
3059 RETURN
3060 END
3061!||====================================================================
3062!|| fvbc_compa1 ../engine/source/constraints/general/impvel/fv_imp0.F
3063!||--- called by ------------------------------------------------------
3064!|| dim_fvbcl ../engine/source/constraints/general/impvel/fv_imp0.F
3065!|| fvbc_impd ../engine/source/constraints/general/impvel/fv_imp0.F
3066!|| fvbc_impl ../engine/source/constraints/general/impvel/fv_imp0.F
3067!|| fvbc_impl1 ../engine/source/constraints/general/impvel/fv_imp0.f
3068!||====================================================================
3069 SUBROUTINE fvbc_compa1(J1 ,K ,IFIX )
3070C-----------------------------------------------
3071C I m p l i c i t T y p e s
3072C-----------------------------------------------
3073#include "implicit_f.inc"
3074C-----------------------------------------------
3075C D u m m y A r g u m e n t s
3076C-----------------------------------------------
3077 INTEGER J1 ,K ,IFIX(*)
3078C-----------------------------------------------
3079C L o c a l V a r i a b l e s
3080C-----------------------------------------------
3081 INTEGER I
3082C---------K is the free component of BCS
3083 IF (j1 /= k) THEN
3084C---------change J1
3085c print *,'change FV condensation component', J1,'to',k
3086C------should change only one times
3087 ifix(k)=9
3088 ifix(j1)=0
3089 j1 = k
3090 END IF
3091C
3092 RETURN
3093 END
3094!||====================================================================
3095!|| fvbc_compa2 ../engine/source/constraints/general/impvel/fv_imp0.F
3096!||--- called by ------------------------------------------------------
3097!|| dim_fvbcl ../engine/source/constraints/general/impvel/fv_imp0.F
3098!|| fvbc_impd ../engine/source/constraints/general/impvel/fv_imp0.F
3099!|| fvbc_impl ../engine/source/constraints/general/impvel/fv_imp0.F
3100!|| fvbc_impl1 ../engine/source/constraints/general/impvel/fv_imp0.F
3101!||--- calls -----------------------------------------------------
3102!|| dir_fvbc ../engine/source/constraints/general/impvel/fv_imp0.F
3103!||====================================================================
3104 SUBROUTINE fvbc_compa2(J1 ,J2 ,JBC ,IFIX )
3105C-----------------------------------------------
3106C I m p l i c i t T y p e s
3107C-----------------------------------------------
3108#include "implicit_f.inc"
3109C-----------------------------------------------
3110C D u m m y A r g u m e n t s
3111C-----------------------------------------------
3112 INTEGER J1 ,J2 ,JBC ,IFIX(*)
3113C-----------------------------------------------
3114C L o c a l V a r i a b l e s
3115C-----------------------------------------------
3116 INTEGER I,K
3117C---------change J1
3118 IF (jbc == j1) THEN
3119C---------change J1
3120 CALL dir_fvbc(jbc ,j2 ,k )
3121c print *,'change FV condensation component', J1,'to',k
3122 ifix(k)=9
3123 ifix(j1)=0
3124 j1 = k
3125 ELSEIF (jbc == j2) THEN
3126 CALL dir_fvbc(jbc ,j1 ,k )
3127c print *,'change FV condensation component', J2,'to',k
3128 ifix(k)=9
3129 ifix(j2)=0
3130 j2 =k
3131 END IF
3132C
3133 RETURN
3134 END
3135!||====================================================================
3136!|| udl2_ug2 ../engine/source/constraints/general/impvel/fv_imp0.F
3137!||--- called by ------------------------------------------------------
3138!|| fvbc_impd ../engine/source/constraints/general/impvel/fv_imp0.F
3139!|| fvbc_impl ../engine/source/constraints/general/impvel/fv_imp0.F
3140!|| fvbc_impl1 ../engine/source/constraints/general/impvel/fv_imp0.F
3141!||====================================================================
3142 SUBROUTINE udl2_ug2(FVJ,ICT,SKEW,UDL,UDG,K)
3143C-----------------------------------------------
3144C I m p l i c i t T y p e s
3145C-----------------------------------------------
3146#include "implicit_f.inc"
3147C-----------------------------------------------
3148C D u m m y A r g u m e n t s
3149C-----------------------------------------------
3150 INTEGER FVJ,ICT,K
3151C REAL
3152 my_real
3153 . udl(3),udg(3), skew(3,3)
3154C-----------------------------------------------
3155C L o c a l V a r i a b l e s
3156C-----------------------------------------------
3157 INTEGER I,J,L
3158 my_real
3159 . det,udi,udj,ei(3),ej(3)
3160C-----Ud_g=[A(2,2)]Ud_l, [A] =reduced (condense k) [SKEW]^-t
3161 j = fvj
3162 IF (j>3) j=j-3
3163 DO l=1,3
3164 ei(l)=skew(l,j)
3165 END DO
3166 udi=udl(j)
3167 IF (ict==4) THEN
3168 i=1
3169 ELSEIF(ict==2) THEN
3170 i=2
3171 ELSEIF(ict==1) THEN
3172 i=3
3173 END IF
3174 DO j=1,3
3175 ej(j)=skew(j,i)
3176 END DO
3177 udj=udl(i)
3178C
3179 IF (k == 1) THEN
3180 det = ei(2)*ej(3)-ei(3)*ej(2)
3181 udg(2)=(ej(3)*udi-ei(3)*udj)/det
3182 udg(3)=(-ej(2)*udi+ei(2)*udj)/det
3183 ELSEIF (k == 2) THEN
3184 det = ei(1)*ej(3)-ei(3)*ej(1)
3185 udg(1)=(ej(3)*udi-ei(3)*udj)/det
3186 udg(3)=(-ej(1)*udi+ei(1)*udj)/det
3187 ELSEIF (k == 3) THEN
3188 det = ei(1)*ej(2)-ei(2)*ej(1)
3189 udg(1)=(ej(2)*udi-ei(2)*udj)/det
3190 udg(2)=(-ej(1)*udi+ei(1)*udj)/det
3191 END IF
3192C
3193 RETURN
3194 END
3195!||====================================================================
3196!|| fvbc_allo ../engine/source/constraints/general/impvel/fv_imp0.F
3197!||--- called by ------------------------------------------------------
3198!|| upd_glob_k ../engine/source/implicit/upd_glob_k.F
3199!||--- uses -----------------------------------------------------
3200!|| imp_fvbcl ../engine/share/modules/impbufdef_mod.F
3201!||====================================================================
3202 SUBROUTINE fvbc_allo
3203C-----------------------------------------------
3204C M o d u l e s
3205C-----------------------------------------------
3206 USE imp_fvbcl
3207C-----------------------------------------------
3208C I m p l i c i t T y p e s
3209C-----------------------------------------------
3210#include "implicit_f.inc"
3211C-----------------------------------------------
3212C C o m m o n B l o c k s
3213C-----------------------------------------------
3214#include "com01_c.inc"
3215#include "com04_c.inc"
3216#include "impl1_c.inc"
3217C-----------------------------------------------
3218C D u m m y A r g u m e n t s
3219C-----------------------------------------------
3220 INTEGER K
3221C REAL
3222C-----------------------------------------------
3223C L o c a l V a r i a b l e s
3224C-----------------------------------------------
3225 my_real
3226 . det
3227 INTEGER I,J
3228C-----
3229 IF (ncycle /= 1 .OR.inconv /=1) RETURN
3230
3231 ALLOCATE(ict_1(numnod))
3232 IF (iroddl >0 ) ALLOCATE(icr_1(numnod))
3233 ALLOCATE(fvbcudl(nfxvel))
3234 IF (nkud_l>0) THEN
3235 ALLOCATE(ikud_1(nkud_l),bkud_1(nkud_l))
3236 ENDIF
3237C
3238 RETURN
3239 END
3240!||====================================================================
3241!|| fvbc_deallo ../engine/source/constraints/general/impvel/fv_imp0.F
3242!||--- called by ------------------------------------------------------
3243!|| deallocm_imp ../engine/source/implicit/imp_solv.F
3244!||--- uses -----------------------------------------------------
3245!|| imp_fvbcl ../engine/share/modules/impbufdef_mod.F
3246!||====================================================================
3247 SUBROUTINE fvbc_deallo
3248C-----------------------------------------------
3249C M o d u l e s
3250C-----------------------------------------------
3251 USE imp_fvbcl
3252C-----------------------------------------------
3253C I m p l i c i t T y p e s
3254C-----------------------------------------------
3255#include "implicit_f.inc"
3256C-----------------------------------------------
3257C C o m m o n B l o c k s
3258C-----------------------------------------------
3259#include "com01_c.inc"
3260C-----------------------------------------------
3261C D u m m y A r g u m e n t s
3262C-----------------------------------------------
3263 INTEGER K
3264C REAL
3265C-----------------------------------------------
3266C L o c a l V a r i a b l e s
3267C-----------------------------------------------
3268 my_real
3269 . det
3270 INTEGER I,J
3271C-----
3272 IF (nfvbcl > 0) THEN
3273
3274 DEALLOCATE(ict_1)
3275 IF (iroddl >0 ) DEALLOCATE(icr_1)
3276 DEALLOCATE(fvbcudl)
3277 IF (nkud_l>0) THEN
3278 DEALLOCATE(ikud_1)
3279 DEALLOCATE(bkud_1)
3280 ENDIF
3281 END IF !(NFVBCL > 0) THEN
3282C
3283 RETURN
3284 END
3285!||====================================================================
3286!|| fvbc_impl1 ../engine/source/constraints/general/impvel/fv_imp0.F
3287!||--- called by ------------------------------------------------------
3288!|| imp_solv ../engine/source/implicit/imp_solv.F
3289!||--- calls -----------------------------------------------------
3290!|| fvbc_compa0 ../engine/source/constraints/general/impvel/fv_imp0.F
3291!|| fvbc_compa1 ../engine/source/constraints/general/impvel/fv_imp0.F
3292!|| fvbc_compa2 ../engine/source/constraints/general/impvel/fv_imp0.F
3293!|| getbcl_j ../engine/source/constraints/general/impvel/fv_imp0.F
3294!|| gfvbc2_ind ../engine/source/constraints/general/impvel/fv_imp0.F
3295!|| recu_ul ../engine/source/constraints/general/impvel/fv_imp0.F
3296!|| udl2_ug ../engine/source/constraints/general/impvel/fv_imp0.F
3297!|| udl2_ug2 ../engine/source/constraints/general/impvel/fv_imp0.F
3298!||====================================================================
3299 SUBROUTINE fvbc_impl1(IBFV ,SKEW ,XFRAME ,LJ ,IDDL ,
3300 1 IFIX ,NDOF ,UD ,RD ,ICODT ,
3301 3 ICODR ,ISKEW )
3302C-----------------------------------------------
3303C I m p l i c i t T y p e s
3304C-----------------------------------------------
3305#include "implicit_f.inc"
3306C-----------------------------------------------
3307C C o m m o n B l o c k s
3308C-----------------------------------------------
3309#include "com04_c.inc"
3310#include "param_c.inc"
3311#include "units_c.inc"
3312C-----------------------------------------------
3313C D u m m y A r g u m e n t s
3314C-----------------------------------------------
3315 INTEGER IBFV(NIFV,*),LJ(*)
3316 integer
3317 . iddl(*),ndof(*),ifix(*),icodt(*),icodr(*),iskew(*)
3318C REAL
3319 my_real
3320 . ud(3,*),rd(3,*), skew(lskew,*), xframe(nxframe,*)
3321C-----------------------------------------------
3322C L o c a l V a r i a b l e s
3323C-----------------------------------------------
3324C-1) impose disp in global system
3325C-2) change CDT,CDR and call BC1
3326 INTEGER N, I, ISK, J, L, K1, K2, K3, K,II,N1,
3327 . IFM, J2,J3,I1,J1,ND,NUD,ITAG(NFXVEL),ICTR,
3328 . JBC,JJ,J11,J1_1,ICTR1,ISKBC,IDONE
3329 my_real
3330 . EJ(3),S,UDL(3),UDG(3)
3331C--------
3332C if treated before, skip
3333 IDONE=0
3334 do n = 1,nfxvel
3335 j1=-lj(n)
3336 IF (j1>0) idone=1
3337 END DO
3338 IF (idone == 1) RETURN
3339C Tag coulping FV-BCS
3340 DO n = 1,nfxvel
3341 itag(n)=0
3342 END DO
3343 DO n = 1,nfxvel
3344 j1=lj(n)
3345 IF (j1>0) THEN
3346 i=iabs(ibfv(1,n))
3347 isk=ibfv(2,n)/10
3348 ifm = ibfv(9,n)
3349 j=ibfv(2,n)
3350 IF (ifm<=1) j=j-10*isk
3351 iskbc=iskew(i)
3352 IF (isk==iskbc) THEN
3353 IF (j>3) THEN
3354 IF (icodr(i)>0) lj(n)=-j1
3355 ELSE
3356 IF (icodt(i)>0) lj(n)=-j1
3357 END IF !IF (J>3) THEN
3358
3359 END IF
3360 ENDIF
3361 ENDDO
3362C
3363 DO n = 1,nfxvel
3364 j1= -lj(n)
3365 IF (j1>0.AND.itag(n)>=0) THEN
3366 i=iabs(ibfv(1,n))
3367 isk=ibfv(2,n)/10
3368 ifm = ibfv(9,n)
3369 j=ibfv(2,n)
3370 IF (ifm<=1) j=j-10*isk
3371 nud=0
3372 nd =iddl(i)
3373 IF (j>3) THEN
3374 ictr=icodr(i)
3375 nd = nd +3
3376 ELSE
3377 ictr=icodt(i)
3378 END IF
3379 DO k=1,3
3380 IF (ifix(nd+k)==9) nud = nud + 1
3381 udl(k)=zero
3382 END DO
3383C-----case 2 Ud ---search only ICT 1,2,4
3384 IF (nud > 1) THEN
3385C---------look for another Ud in LJ()>0
3386 DO n1=n+1,nfxvel
3387 jj = iabs(-lj(n1)-j1)
3388 ii = iabs(ibfv(1,n1))
3389 IF (lj(n1) < 0.AND.jj < 3.AND.ii==i) THEN
3390 itag(n)=n1
3391 itag(n1)=-n
3392 ENDIF
3393 ENDDO
3394 n1 = itag(n)
3395 j11 = ibfv(2,n1)
3396 j1_1 = -lj(n1)
3397 IF (n1==0) THEN
3398C--------------error out
3399 WRITE(istdo,'(A,I4)')
3400 . ' ** ERROR IN IMPVEL(OR IMPDISP) IN SKEW:',isk
3401 END IF
3402C--------starter done already CALL FVBC_COMP1(J,J11,ICTR)
3403 IF (j>3) THEN
3404 CALL recu_ul(isk,ifm,skew,xframe,j,j1,udl,rd(1,i),n)
3405 CALL recu_ul(isk,ifm,skew,xframe,j11,j1_1,udl,rd(1,i),n1)
3406 ELSE
3407 CALL recu_ul(isk,ifm,skew,xframe,j,j1,udl,ud(1,i),n)
3408 CALL recu_ul(isk,ifm,skew,xframe,j11,j1_1,udl,ud(1,i),n1)
3409 END IF
3410C--------calculate Ud in global system (only SKEW is available w/ BCS
3411 CALL udl2_ug(skew(1,isk),udl,udg)
3412C----------compatibility FV-BCS-(condensation components)----- ;
3413C-----suppose ICT =(1,2,4) otherwise starter does not pass
3414 CALL getbcl_j(ictr ,isk ,skew ,jbc ,j )
3415 CALL fvbc_compa2(j1 ,j1_1 ,jbc ,ifix(iddl(i)+1) )
3416C----------update 2 ud J1,J1_1 ;
3417 IF (j>3) THEN
3418 rd(j1,i)=udg(j1)
3419 rd(j1_1,i)=udg(j1_1)
3420 ELSE
3421 ud(j1,i)=udg(j1)
3422 ud(j1_1,i)=udg(j1_1)
3423 END IF
3424 ELSEIF (nud == 1) THEN
3425C-----case 1 Ud ---search first ICT 3,5,6 -> no change for BCS--
3426 IF (j>3) THEN
3427 CALL recu_ul(isk,ifm,skew,xframe,j,j1,udl,rd(1,i),n)
3428 ELSE
3429 CALL recu_ul(isk,ifm,skew,xframe,j,j1,udl,ud(1,i),n)
3430 END IF
3431 IF (ictr==3 .OR.ictr==5.OR.ictr==6) THEN
3432C--------calculate Ud in global system (only SKEW is available w/ BCS
3433 CALL udl2_ug(skew(1,isk),udl,udg)
3434 CALL getbcl_j(ictr ,isk ,skew ,k ,j)
3435C--------check compatibility--
3436 CALL fvbc_compa1(j1 ,k ,ifix(iddl(i)+1))
3437C----------update ud
3438 IF (j>3) THEN
3439 rd(j1,i)=udg(j1)
3440 ELSE
3441 ud(j1,i)=udg(j1)
3442 END IF
3443C-----case 1 Ud ---search first ICT 1,2,4 -> 2d ud, change for BCS--
3444 ELSEIF (ictr==1 .OR.ictr==2.OR.ictr==4) THEN
3445C--------termine independent dof K w/ fixing j1
3446 CALL gfvbc2_ind(j,ictr,skew(1,isk),k ,l )
3447 CALL getbcl_j(ictr ,isk ,skew ,j1_1 ,j )
3448 nd = iddl(i)+1
3449 CALL fvbc_compa0(j1 ,j1_1 ,ifix(nd) ,k )
3450C--------calculate Ud() free of K in global system update ud_i
3451c IF (K >3 ) K = K -3
3452 CALL udl2_ug2(j,ictr,skew(1,isk),udl,udg,k)
3453C----------update ud
3454 IF (j>3) THEN
3455 rd(j1-1,i)=udg(j1-1)
3456 rd(j1_1-1,i)=udg(j1_1-1)
3457 ELSE
3458 ud(j1,i)=udg(j1)
3459 ud(j1_1,i)=udg(j1_1)
3460 END IF
3461 END IF !(ICTR==3 .OR.ICTR==5.OR.ICTR==6)
3462 END IF !IF (NUD > 1) THEN
3463 ENDIF
3464 ENDDO
3465C
3466 RETURN
3467 END
3468C-------definitively, using different system (nodal) setting [K] makes coding more simple
3469C-----will do in V12, should:
3470C-1). create ITSKEW(inode),IRSKEW(inode)
3471C-2). change [K] to each nodal system once assemblage elementary
3472C-3). if secnd,main node has not the same system:
3473C condensation getKij -> change to global system
3474C change to system of main node -> putKij
3475C do all kinematic constraints w/o exception.
3476C-4) once resolved change U to global system for all local nodal one
3477!||====================================================================
3478!|| gdir2_ind ../engine/source/constraints/general/impvel/fv_imp0.F
3479!||--- called by ------------------------------------------------------
3480!|| bc_c2d ../engine/source/constraints/general/bcs/bc_imp0.F
3481!|| fvbc2_bup ../engine/source/constraints/general/impvel/fv_imp0.F
3482!|| gfvbc2_ind ../engine/source/constraints/general/impvel/fv_imp0.F
3483!||====================================================================
3484 SUBROUTINE gdir2_ind(EI,EJ,K)
3485C-----------------------------------------------
3486C I m p l i c i t T y p e s
3487C-----------------------------------------------
3488#include "implicit_f.inc"
3489C-----------------------------------------------
3490C D u m m y A r g u m e n t s
3491C-----------------------------------------------
3492 INTEGER K
3493C REAL
3494 my_real
3495 . ei(3),ej(3)
3496C-----------------------------------------------
3497C L o c a l V a r i a b l e s
3498C-----------------------------------------------
3499 INTEGER I
3500 my_real
3501 . det(3),detmax
3502C-----determine independent direction (global) with two local constraints
3503 det(1) = abs(ei(2)*ej(3)-ei(3)*ej(2))
3504 det(2) = abs(ei(1)*ej(3)-ei(3)*ej(1))
3505 det(3) = abs(ei(1)*ej(2)-ei(2)*ej(1))
3506 detmax =zero
3507 k= 1
3508 DO i= 1,3
3509 IF (det(i)>detmax) THEN
3510 detmax = det(i)
3511 k = i
3512 END IF
3513 END DO
3514C
3515 RETURN
3516 END
3517!||====================================================================
3518!|| gfvbc2_ind ../engine/source/constraints/general/impvel/fv_imp0.F
3519!||--- called by ------------------------------------------------------
3520!|| dim_fvbcl ../engine/source/constraints/general/impvel/fv_imp0.F
3521!|| fvbc_impd ../engine/source/constraints/general/impvel/fv_imp0.F
3522!|| fvbc_impl ../engine/source/constraints/general/impvel/fv_imp0.F
3523!|| fvbc_impl1 ../engine/source/constraints/general/impvel/fv_imp0.F
3524!||--- calls -----------------------------------------------------
3525!|| dir_rbe2 ../engine/source/constraints/general/rbe2/rbe2v.F
3526!|| gdir2_ind ../engine/source/constraints/general/impvel/fv_imp0.F
3527!||====================================================================
3528 SUBROUTINE gfvbc2_ind(FVJ,ICT,SKEW,K ,ICT1)
3529C-----------------------------------------------
3530C I m p l i c i t T y p e s
3531C-----------------------------------------------
3532#include "implicit_f.inc"
3533C-----------------------------------------------
3534C D u m m y A r g u m e n t s
3535C-----------------------------------------------
3536 INTEGER FVJ,K,ICT,ICT1
3537C REAL
3538 my_real
3539 . skew(3,3)
3540C-----------------------------------------------
3541C L o c a l V a r i a b l e s
3542C-----------------------------------------------
3543 INTEGER I,J,L
3544 my_real
3545 . ei(3),ej(3)
3546C-----determine independent direction (global) K, ICT1 is used to call BC_IMP1
3547 IF (ict==4) THEN
3548 i=1
3549 ELSEIF(ict==2) THEN
3550 i=2
3551 ELSEIF(ict==1) THEN
3552 i=3
3553 END IF
3554 DO j=1,3
3555 ei(j)=skew(j,i)
3556 END DO
3557 j = fvj
3558 IF (j>3) j=j-3
3559 DO l=1,3
3560 ej(l)=skew(l,j)
3561 END DO
3562 CALL dir_rbe2(i,j,l)
3563 IF (l==1) THEN
3564 ict1=3
3565 ELSEIF(l==2) THEN
3566 ict1=5
3567 ELSEIF(l==3) THEN
3568 ict1=6
3569 END IF
3570 CALL gdir2_ind(ei,ej,k)
3571C
3572 RETURN
3573 END
3574!||====================================================================
3575!|| fvbc_impd ../engine/source/constraints/general/impvel/fv_imp0.F
3576!||--- called by ------------------------------------------------------
3577!|| recukin ../engine/source/implicit/recudis.F
3578!||--- calls -----------------------------------------------------
3579!|| fvbc_compa0 ../engine/source/constraints/general/impvel/fv_imp0.F
3580!|| fvbc_compa1 ../engine/source/constraints/general/impvel/fv_imp0.F
3581!|| fvbc_compa2 ../engine/source/constraints/general/impvel/fv_imp0.F
3582!|| getbcl_j ../engine/source/constraints/general/impvel/fv_imp0.F
3583!|| gfvbc2_ind ../engine/source/constraints/general/impvel/fv_imp0.F
3584!|| recu_ul ../engine/source/constraints/general/impvel/fv_imp0.F
3585!|| udl2_ug ../engine/source/constraints/general/impvel/fv_imp0.F
3586!|| udl2_ug2 ../engine/source/constraints/general/impvel/fv_imp0.F
3587!||====================================================================
3588 SUBROUTINE fvbc_impd(IBFV ,SKEW ,XFRAME ,LJ ,NDOF ,
3589 1 UD ,RD ,ICODT ,ICODR,ISKEW ,
3590 2 ICODT1 ,ICODR1)
3591C-----------------------------------------------
3592C I m p l i c i t T y p e s
3593C-----------------------------------------------
3594#include "implicit_f.inc"
3595C-----------------------------------------------
3596C C o m m o n B l o c k s
3597C-----------------------------------------------
3598#include "com01_c.inc"
3599#include "com04_c.inc"
3600#include "param_c.inc"
3601#include "units_c.inc"
3602C-----------------------------------------------
3603C D u m m y A r g u m e n t s
3604C-----------------------------------------------
3605 INTEGER IBFV(NIFV,*),LJ(*)
3606 integer
3607 . ndof(*),icodt(*),icodr(*),iskew(*),
3608 . icodt1(*),icodr1(*)
3609C REAL
3610 my_real
3611 . ud(3,*),rd(3,*), skew(lskew,*), xframe(nxframe,*)
3612C-----------------------------------------------
3613C L o c a l V a r i a b l e s
3614C-----------------------------------------------
3615C-1) impose disp in global system
3616C-2) change CDT,CDR and call BC1
3617 INTEGER N, I, ISK, J, L, K1, K2, K3, K,II,N1,
3618 . IFM, J2,J3,I1,J1,ND,NUD,ITAG(NFXVEL),ICTR,
3619 . JBC,JJ,J11,J1_1,ICTR1,ISKBC,IDONE,
3620 . ITAG1(numnod),NLFV(NFXVEL),IFIX(9)
3621 my_real
3622 . EJ(3),S,UDL(3),UDG(3)
3623C----LJ()>0 ->IDONE=1 ->FV_IMP (FVL_MODIF) has been called
3624 IDONE = 1
3625 do n=1,nfxvel
3626 j = lj(n)
3627 IF (j < 0) THEN
3628 lj(n) =-j
3629 idone = 0
3630 END IF
3631 END DO
3632C------determine Num of FVL of the same node
3633C----first translation
3634 DO i=1,numnod
3635 itag1(i)=0
3636 END DO
3637 DO n=1,nfxvel
3638 j = lj(n)
3639 ii=iabs(ibfv(1,n))
3640 nlfv(n)= 0
3641 IF (j==0.OR.j > 3) cycle
3642 itag1(ii)= itag1(ii)+1
3643 ENDDO
3644 DO n=1,nfxvel
3645 j = lj(n)
3646 ii=iabs(ibfv(1,n))
3647 IF (j==0.OR.j > 3) cycle
3648 nlfv(n)= itag1(ii)
3649C------if ITAG1(II)>1, the second one will not be traited
3650 itag1(ii)=0
3651 ENDDO
3652C----rotational---can use the same NLFV as FV is defined per dir------
3653c DO I=1,NUMNOD
3654c ITAG1(I)=0
3655c END DO
3656 DO n=1,nfxvel
3657 j = lj(n)
3658 ii=iabs(ibfv(1,n))
3659 IF (j < 3) cycle
3660 itag1(ii)= itag1(ii)+1
3661 ENDDO
3662 DO n=1,nfxvel
3663 j = lj(n)
3664 ii=iabs(ibfv(1,n))
3665 IF (j < 3) cycle
3666 nlfv(n)= itag1(ii)
3667C------if ITAG1(II)>1, the second one will not be traited
3668 itag1(ii)=0
3669 ENDDO
3670C
3671 DO n = 1,numnod
3672 icodt1(n) = icodt(n)
3673 END DO
3674 IF (iroddl/=0) THEN
3675 DO n = 1,numnod
3676 icodr1(n) = icodr(n)
3677 END DO
3678 END IF !(IRODDL/=0) THEN
3679C-----put ICODT,R 0 for coupling bcs
3680C Tag coulping FV-BCS
3681 DO n = 1,nfxvel
3682 itag(n)=0
3683 END DO
3684 DO n = 1,nfxvel
3685 j1=lj(n)
3686 IF (j1/=0) THEN
3687 i=iabs(ibfv(1,n))
3688 isk=ibfv(2,n)/10
3689 ifm = ibfv(9,n)
3690 j=ibfv(2,n)
3691 IF (ifm<=1) j=j-10*isk
3692 iskbc=iskew(i)
3693 IF (isk==iskbc) THEN
3694 IF (j>3) THEN
3695 IF (icodr(i)>0) lj(n)=-j1
3696 ELSE
3697 IF (icodt(i)>0) lj(n)=-j1
3698 END IF !IF (J>3) THEN
3699 END IF
3700 ENDIF
3701 ENDDO
3702C
3703 DO n = 1,nfxvel
3704 j1= -lj(n)
3705 IF (j1>0.AND.itag(n)>=0) THEN
3706 i=iabs(ibfv(1,n))
3707 isk=ibfv(2,n)/10
3708 ifm = ibfv(9,n)
3709 j=ibfv(2,n)
3710 IF (ifm<=1) j=j-10*isk
3711 nud=0
3712 IF (j>3) THEN
3713 ictr=icodr(i)
3714 nd = nd +3
3715 ELSE
3716 ictr=icodt(i)
3717 END IF
3718 nud = nlfv(n)
3719 DO k=1,3
3720c IF (IFIX(ND+K)==9) NUD = NUD + 1
3721 udl(k)=zero
3722 END DO
3723C-----case 2 Ud ---search only ICT 1,2,4
3724 IF (nud > 1 .AND. idone ==1) THEN
3725C---------look for another Ud in LJ()>0
3726 DO n1=n+1,nfxvel
3727 jj = iabs(-lj(n1)-j1)
3728 ii = iabs(ibfv(1,n1))
3729 IF (lj(n1) < 0.AND.jj < 3.AND.ii==i) THEN
3730 itag(n)=n1
3731 itag(n1)=-n
3732 ENDIF
3733 ENDDO
3734 n1 = itag(n)
3735 j11 = ibfv(2,n1)
3736 j1_1 = -lj(n1)
3737 IF (n1==0) THEN
3738C--------------error out
3739 WRITE(istdo,'(A,I4)')
3740 . ' ** ERROR IN IMPVEL(OR IMPDISP) IN SKEW:',isk
3741 END IF
3742C--------starter done already CALL FVBC_COMP1(J,J11,ICTR)
3743 IF (j>3) THEN
3744 CALL recu_ul(isk,ifm,skew,xframe,j,j1,udl,rd(1,i),n)
3745 CALL recu_ul(isk,ifm,skew,xframe,j11,j1_1,udl,rd(1,i),n1)
3746 ELSE
3747 CALL recu_ul(isk,ifm,skew,xframe,j,j1,udl,ud(1,i),n)
3748 CALL recu_ul(isk,ifm,skew,xframe,j11,j1_1,udl,ud(1,i),n1)
3749 END IF
3750C--------calculate Ud in global system (only SKEW is available w/ BCS
3751 CALL udl2_ug(skew(1,isk),udl,udg)
3752C----------compatibility FV-BCS-(condensation components)----- ;
3753C-----suppose ICT =(1,2,4) otherwise starter does not pass
3754 CALL getbcl_j(ictr ,isk ,skew ,jbc ,j )
3755 CALL fvbc_compa2(j1 ,j1_1 ,jbc ,ifix )
3756C----------update 2 ud J1,J1_1 ;
3757 IF (j>3) THEN
3758 rd(j1,i)=udg(j1)
3759 rd(j1_1,i)=udg(j1_1)
3760 ELSE
3761 ud(j1,i)=udg(j1)
3762 ud(j1_1,i)=udg(j1_1)
3763 END IF
3764 ELSEIF (nud == 1) THEN
3765C-----case 1 Ud ---search first ICT 3,5,6 -> no change for BCS--
3766 IF (j>3) THEN
3767 CALL recu_ul(isk,ifm,skew,xframe,j,j1,udl,rd(1,i),n)
3768 ELSE
3769 CALL recu_ul(isk,ifm,skew,xframe,j,j1,udl,ud(1,i),n)
3770 END IF
3771 IF (ictr==3 .OR.ictr==5.OR.ictr==6) THEN
3772 IF (idone == 1) THEN
3773C--------calculate Ud in global system (only SKEW is available w/ BCS
3774 CALL udl2_ug(skew(1,isk),udl,udg)
3775 CALL getbcl_j(ictr ,isk ,skew ,k ,j)
3776C--------check compatibility--
3777 CALL fvbc_compa1(j1 ,k ,ifix)
3778C----------update ud
3779 IF (j>3) THEN
3780 DO k1=1,3
3781 rd(k1,i)=udg(k1)
3782 END DO
3783 ELSE
3784 DO k1=1,3
3785 ud(k1,i)=udg(k1)
3786 END DO
3787 END IF
3788 END IF
3789 IF (j>3) THEN
3790 icodr1(i) = 0
3791 ELSE
3792 icodt1(i) = 0
3793 END IF
3794C-----case 1 Ud ---search first ICT 1,2,4 -> 2d ud, change for BCS--
3795 ELSEIF (ictr==1 .OR.ictr==2.OR.ictr==4) THEN
3796C--------termine independent dof K w/ fixing j1
3797 CALL gfvbc2_ind(j,ictr,skew(1,isk),k ,ictr1 )
3798 CALL getbcl_j(ictr ,isk ,skew ,j1_1 ,j )
3799 CALL fvbc_compa0(j1 ,j1_1 ,ifix ,k )
3800C--------calculate Ud() free of K in global system update ud_i
3801 IF (idone == 1) THEN
3802 CALL udl2_ug2(j,ictr,skew(1,isk),udl,udg,k)
3803C----------update ud
3804 IF (j>3) THEN
3805 rd(j1-1,i)=udg(j1-1)
3806 rd(j1_1-1,i)=udg(j1_1-1)
3807 ELSE
3808 ud(j1,i)=udg(j1)
3809 ud(j1_1,i)=udg(j1_1)
3810 END IF
3811 END IF
3812C-----------different than real BCS _local
3813 IF (j>3) THEN
3814 icodr1(i) = -ictr1
3815 ELSE
3816 icodt1(i) = -ictr1
3817 END IF
3818 END IF !(ICTR==3 .OR.ICTR==5.OR.ICTR==6)
3819 END IF !IF (NUD > 1) THEN
3820 ENDIF
3821 ENDDO
3822C
3823 RETURN
3824 END
3825!||====================================================================
3826!|| fvbc2_bup ../engine/source/constraints/general/impvel/fv_imp0.F
3827!||--- called by ------------------------------------------------------
3828!|| fvbc_impl ../engine/source/constraints/general/impvel/fv_imp0.F
3829!||--- calls -----------------------------------------------------
3830!|| gdir2_ind ../engine/source/constraints/general/impvel/fv_imp0.F
3831!||====================================================================
3832 SUBROUTINE fvbc2_bup(FVJ ,ICT ,SKEW ,J1 ,J1_1 ,
3833 1 UD ,DIAG_K,LB ,ND )
3834C-----------------------------------------------
3835C I m p l i c i t T y p e s
3836C-----------------------------------------------
3837#include "implicit_f.inc"
3838C-----------------------------------------------
3839C C o m m o n B l o c k s
3840C-----------------------------------------------
3841#include "impl1_c.inc"
3842C-----------------------------------------------
3843C D u m m y A r g u m e n t s
3844C-----------------------------------------------
3845 INTEGER FVJ ,ICT ,J1 ,J1_1 ,ND
3846C REAL
3847 my_real
3848 . skew(3,3),ud(3),diag_k(*),lb(*)
3849C-----------------------------------------------
3850C L o c a l V a r i a b l e s
3851C-----------------------------------------------
3852 INTEGER I,J,L,K,J2
3853 my_real
3854 . ej(3),ej1(3),det,ea,eb
3855C-----update LB of terme diag()*ud
3856 IF (imconv/=1) RETURN
3857C
3858 IF (ict==4) THEN
3859 i=1
3860 ELSEIF(ict==2) THEN
3861 i=2
3862 ELSEIF(ict==1) THEN
3863 i=3
3864 END IF
3865 DO j=1,3
3866 ej1(j)=skew(j,i)
3867 END DO
3868 j = fvj
3869 IF (j>3) j=j-3
3870 DO l=1,3
3871 ej(l)=skew(l,j)
3872 END DO
3873 CALL gdir2_ind(ej,ej1,k)
3874 j = j1
3875 IF (j >3) j= j-3
3876 j2 = j1_1
3877 IF (j2 >3) j2= j2-3
3878 det = one/(ej(j)*ej1(j2)-ej(j2)*ej1(j))
3879 ea = -det*(ej1(j2)*ej(k)-ej(j2)*ej1(k))
3880 eb = -det*(ej(j)*ej1(k)-ej1(j)*ej(k))
3881C
3882 lb(nd+k)=lb(nd+k)-ea*diag_k(nd+j)*ud(j)
3883 lb(nd+k)=lb(nd+k)-eb*diag_k(nd+j2)*ud(j2)
3884C
3885 RETURN
3886 END
bc_updk
subroutine bc_updk(n, iddl, ej, jj, ir, iadk, jdik, diag_k, lt_k)
Definition bc_imp0.F:491
bc_updfr
subroutine bc_updfr(n, iddl, ej, jj, iddlm, ikc, iadk, jdik, diag_k, lt_k, lb, a, kss, ksm, idlm, ifss, ifsm)
Definition bc_imp0.F:1332
bc_updd
subroutine bc_updd(n, ej, j, d)
Definition bc_imp0.F:843
bc_c2d
subroutine bc_c2d(ej, ej1, j, j1, ea, eb)
Definition bc_imp0.F:2740
bc_updd2
subroutine bc_updd2(n, ej, j, ej1, j1, d)
Definition bc_imp0.F:872
l_dir0
subroutine l_dir0(ej, j)
Definition bc_imp0.F:346
bc_updb
subroutine bc_updb(id, ej, jj, ir, lb)
Definition bc_imp0.F:1069
l_dir2
subroutine l_dir2(ej, j, j0)
Definition bc_imp0.F:444
bc_imp0
subroutine bc_imp0(icodt, icodr, iskew, ifix, ndof, iadn)
Definition bc_imp0.F:31
my_real
#define my_real
Definition cppsort.cpp:32
fv_imp0
subroutine fv_imp0(iddl, ifix, ndof, iadk, jdik, diag_k, lt_k, ud, nbk, iab, bk, nddl, rd)
Definition fv_imp0.F:37
dim_fvbcl
subroutine dim_fvbcl(ibfv, lj, iskew, icodt, icodr, nddl, iddl, ifix, iadk, jdik, skew, nfvbcl, nbkud)
Definition fv_imp0.F:2300
fv_fint0
subroutine fv_fint0(ibfv, npc, tf, vel, sensor_tab, ud, rd, ifix, iddl, nsensor, skew, iframe, xframe, a, ar, x, ndof, ms, in, weight, rby)
Definition fv_imp0.F:2137
fv_rw0
subroutine fv_rw0(iddl, ifix, ndof, iadk, jdik, diag_k, lt_k, ud, b)
Definition fv_imp0.F:546
fvbc2_bup
subroutine fvbc2_bup(fvj, ict, skew, j1, j1_1, ud, diag_k, lb, nd)
Definition fv_imp0.F:3834
udl2_ug
subroutine udl2_ug(skew, udl, udg)
Definition fv_imp0.F:2734
fv_imprl
subroutine fv_imprl(ibfv, skew, xframe, lj, iddl, ndof, lb)
Definition fv_imp0.F:1555
fvbc_impl1
subroutine fvbc_impl1(ibfv, skew, xframe, lj, iddl, ifix, ndof, ud, rd, icodt, icodr, iskew)
Definition fv_imp0.F:3302
fvl_frk
subroutine fvl_frk(j1, n, ibfv, skew, xframe, iddl, iddlm, ikc, iadk, jdik, diag_k, lt_k, ud, lb, a, kss, ksm, idlm, ifss, ifsm)
Definition fv_imp0.F:1633
fv_updfr
subroutine fv_updfr(n, ej, j1, iddl, iddlm, ikc, iadk, jdik, diag_k, lt_k, ud, lb, a, kss, ksm, idlm, ifss, ifsm)
Definition fv_imp0.F:1700
getbcl_j
subroutine getbcl_j(ict, isk, skew, j, ir)
Definition fv_imp0.F:2918
updfvbc_l
subroutine updfvbc_l(id, ifix, nddl, iadk, jdik, nb)
Definition fv_imp0.F:2802
fv_updf
subroutine fv_updf(nfx, ifx, ibfv, skew, xframe, a)
Definition fv_imp0.F:1427
fv_updkd
subroutine fv_updkd(ej, j, kdd, diag_k)
Definition fv_imp0.F:1519
udl2_ug2
subroutine udl2_ug2(fvj, ict, skew, udl, udg, k)
Definition fv_imp0.F:3143
fvbc_allo
subroutine fvbc_allo
Definition fv_imp0.F:3203
dintera
subroutine dintera(tf, iad, ipos1, ilen, nel0, x1, x2, ay, ity)
Definition fv_imp0.F:2029
fvbc_compa0
subroutine fvbc_compa0(j1, jbc, ifix, k)
Definition fv_imp0.F:3009
l_dir02
subroutine l_dir02(ej, j, j0, ikc)
Definition fv_imp0.F:1979
fvbc_compa1
subroutine fvbc_compa1(j1, k, ifix)
Definition fv_imp0.F:3070
gfvbc2_ind
subroutine gfvbc2_ind(fvj, ict, skew, k, ict1)
Definition fv_imp0.F:3529
fv_rw
subroutine fv_rw(iddl, ikc, ndof, ud, v)
Definition fv_imp0.F:503
updfvbc_b
subroutine updfvbc_b(id, ifix, nddl, iadk, jdik, lt_k, ud, nb, ib, kb)
Definition fv_imp0.F:2852
fv_impi
subroutine fv_impi(iddl, ifix, ndof, iadk, jdik, diag_k, lt_k, ud, b, nddl)
Definition fv_imp0.F:441
fv_impd
subroutine fv_impd(ibfv, lj, skew, xframe, ud, rd)
Definition fv_imp0.F:932
fv_updk
subroutine fv_updk(n, iddl, ej, jj, ir, iadk, jdik, diag_k, lt_k, lb, ud)
Definition fv_imp0.F:874
fvbc_deallo
subroutine fvbc_deallo
Definition fv_imp0.F:3248
wfv_imp
subroutine wfv_imp(ibfv, npc, tf, vel, sensor_tab, ud, rd, ifix, iddl, nsensor, skew, iframe, xframe, a, ar, x, ndof, ms, in, weight, rby, dw)
Definition fv_imp0.F:1754
fvl_modif
subroutine fvl_modif(nvl, ibfv, ud, rd, ifix, iddl, skew, xframe, vl, lj)
Definition fv_imp0.F:1095
recu_ul
subroutine recu_ul(isk, ifm, skew, xframe, j, j1, udl, ud, n)
Definition fv_imp0.F:2669
gdir2_ind
subroutine gdir2_ind(ei, ej, k)
Definition fv_imp0.F:3485
fvbc_impl
subroutine fvbc_impl(ibfv, skew, xframe, lj, iddl, ifix, ndof, iadk, jdik, diag_k, lt_k, ud, rd, lb, nddl, icodt, icodr, icodt1, icodr1, nkud1, ikud, bkud)
Definition fv_imp0.F:2462
fv_imp1
subroutine fv_imp1(nbk, iab, bk, b)
Definition fv_imp0.F:155
fvbc_impd
subroutine fvbc_impd(ibfv, skew, xframe, lj, ndof, ud, rd, icodt, icodr, iskew, icodt1, icodr1)
Definition fv_imp0.F:3591
dinteri
subroutine dinteri(tf, iad, ipos1, ilen, nel0, x1, x2, dy, ity)
Definition fv_imp0.F:652
fvbc_compa2
subroutine fvbc_compa2(j1, j2, jbc, ifix)
Definition fv_imp0.F:3105
fv_impl
subroutine fv_impl(ibfv, skew, xframe, lj, iddl, ifix, ndof, iadk, jdik, diag_k, lt_k, ud, rd, lb)
Definition fv_imp0.F:793
fv_dd0
subroutine fv_dd0(iddl, ikc, ndof, dd, ddr, d)
Definition fv_imp0.F:598
dir_fvbc
subroutine dir_fvbc(j, j1, k)
Definition fv_imp0.F:2762
kin_updf
subroutine kin_updf(n, ej, j1, a)
Definition fv_imp0.F:1487
fv_imp
subroutine fv_imp(ibfv, npc, tf, vel, sensor_tab, ud, rd, ifix, iddl, nsensor, skew, iframe, xframe, v, vr, x, lj, ndof, a, ar)
Definition fv_imp0.F:213
imp_buck
subroutine imp_buck(pm, geo, ipm, igeo, elbuf, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, ixtg1, iparg, tf, npc, fr_wave, w16, bufmat, thke, bufgeo, nsensor, sensor_tab, rby, skew, wa, icodt, icodr, iskew, ibfv, vel, lpby, npby, itab, weight, ms, in, ipari, intbuf_tab, x, itask, cont, icut, xcut, fint, fext, fopt, anin, nstrf, rwbuf, nprw, tani, dd_iad, eani, ipart, nom_opt, igrsurf, bufsf, idata, rdata, kxx, ixx, kxsp, ixsp, nod2sp, spbuf, ixs10, ixs20, ixs16, vr, monvol, volmon, nodglob, iad_elem, fr_elem, fr_sec, fr_rby2, iad_rby2, fr_wall, v, a, graphe, partsav, xframe, dirul, fncont, ftcont, temp, sh4tree, sh3tree, err_thk_sh4, err_thk_sh3, iframe, lprw, elbuf_tab, fsav, fsavd, rwsav, ar, irbe3, lrbe3, frbe3, fr_i2m, iad_i2m, fr_rbe3m, iad_rbe3m, frwl6, ibcl, forc, irbe2, lrbe2, iad_rbe2, fr_rbe2, weight_md, cluster, fcluster, mcluster, xfem_tab, ale_connect, w, nv46, nercvois, nesdvois, lercvois, lesdvois, crkedge, stack, dimfb, fbsav6, stabsen, tabsensor, indx_crk, xedge4n, xedge3n, sph2sol, stifn, stifr, drape_sh4n, drape_sh3n, h3d_data, subset, igrnod, fcont_max, fncontp2, ftcontp2, nddl0, nnzk0, impbuf_tab, drapeg, matparam_tab, glob_therm, output)
Definition imp_buck.F:106
upd_ksl
subroutine upd_ksl(ipari, intbuf_tab, nint2, iint2, npby, lpby, itab, nrbyac, irbyac, x, ibfv, lj, skew, xframe, iskew, icodt, inloc, nsl, iad_m, iddl, ikc, ndof, iddlm, ud, a, b, kss, ksl_fr, ksi_fr, irbe3, lrbe3, frbe3, irbe2, lrbe2)
Definition imp_fri.F:5749
imp_fri
subroutine imp_fri(num_imp, ns_imp, ne_imp, ipari, intbuf_tab, npby, lpby, itab, nrbyac, irbyac, nint2, iint2, iddl, ikc, ndof, inloc, nsrem, nsl, nbintc, intlist, x, ibfv, lj, skew, xframe, iskew, icodt, a, ud, lb, ifdis, nddl, urd, iddli, irbe3, lrbe3, frbe3, irbe2, lrbe2)
Definition imp_fri.F:45
fr_u2dd
subroutine fr_u2dd(d, dr, x, ipari, intbuf_tab, ndof, a, ar, lx, ibfv, skew, xframe, irbe3, lrbe3, irbe2, lrbe2)
Definition imp_fri.F:2607
imp_solv
subroutine imp_solv(timers, python, icode, iskew, iskwn, ipart, ixtg, ixs, ixq, ixc, ixt, ixp, ixr, ixtg1, itab, itabm1, npc, ibcl, ibfv, sensor_tab, nnlink, lnlink, iparg, igrv, ipari, intbuf_tab, nprw, iconx, npby, lpby, lrivet, nstrf, ljoint, icodt, icodr, isky, adsky, iads_f, ilink, llink, weight, itask, ibvel, lbvel, fbvel, x, d, v, vr, dr, thke, damp, ms, in, pm, skews, geo, eani, bufmat, bufgeo, bufsf, tf, forc, vel, fsav, agrv, fr_wave, parts0, elbuf, rby, rivet, fr_elem, iad_elem, wa, a, ar, stifn, stifr, partsav, fsky, fskyi, iframe, xframe, w16, iactiv, fskym, igeo, ipm, wfext, nodft, nodlt, nint7, num_imp, ns_imp, ne_imp, ind_imp, it, rwbuf, lprw, fr_wall, nbintc, intlist, fopt, rwsav, fsavd, graphe, fac_k, ipiv_k, nkcond, nsensor, monvol, igrsurf, fr_mv, volmon, dirul, nodglob, mumps_par, cddlp, isendto, irecvfrom, newfront, imsch, i2msch, isizxv, ilenxv, islen7, irlen7, islen11, irlen11, islen17, irlen17, irlen7t, islen7t, kinet, num_imp1, temp, dt2prev, waint, lgrav, sh4tree, sh3tree, irlen20, islen20, irlen20t, islen20t, irlen20e, islen20e, irbe3, lrbe3, frbe3, fr_i2m, iad_i2m, fr_rbe3m, iad_rbe3m, frwl6, irbe2, lrbe2, intbuf_tab_c, ikine, diag_sms, icfield, lcfield, cfield, count_remslv, count_remslve, elbuf_tab, elbuf_imp, xdp, weight_md, stack, dimfb, fbsav6, stabsen, tabsensor, drape_sh4n, drape_sh3n, h3d_data, multi_fvm, igrbric, igrsh4n, igrsh3n, igrbeam, forneqs, maxdgap, nddl0, nnzk0, it_t, impbuf_tab, cptreac, fthreac, nodreac, drapeg, interfaces, th_surf, dpl0cld, vel0cld, snpc, stf, glob_therm, wfext_md)
Definition imp_solv.F:173
imp_chkm
subroutine imp_chkm(timers, python, icode, iskew, iskwn, ipart, ixtg, ixs, ixq, ixc, ixt, ixp, ixr, ixtg1, itab, itabm1, npc, ibcl, ibfv, sensor_tab, nnlink, lnlink, iparg, igrv, ipari, intbuf_tab, nprw, iconx, npby, lpby, lrivet, nstrf, ljoint, icodt, icodr, isky, adsky, iads_f, ilink, llink, weight, itask, ibvel, lbvel, fbvel, x, d, v, vr, dr, thke, damp, ms, in, pm, skews, geo, eani, bufmat, bufgeo, bufsf, tf, forc, vel, fsav, agrv, fr_wave, parts0, elbuf, rby, rivet, fr_elem, iad_elem, nsensor, wa, a, ar, stifn, stifr, partsav, fsky, fskyi, iframe, xframe, w16, iactiv, fskym, igeo, ipm, wfext, nodft, nodlt, nint7, num_imp, ns_imp, ne_imp, ind_imp, it, rwbuf, lprw, fr_wall, nbintc, intlist, fopt, rwsav, fsavd, dirul, lgrav, irbe3, lrbe3, frbe3, frwl6, irbe2, lrbe2, icfield, lcfield, cfield, elbuf_tab, weight_md, stack, dimfb, fbsav6, stabsen, tabsensor, drape_sh4n, drape_sh3n, h3d_data, nddl0, nnzk0, impbuf_tab, cptreac, fthreac, nodreac, drapeg, th_surf, dpl0cld, vel0cld, snpc, stf, wfext_md, igrsurf)
Definition imp_solv.F:3132
min
#define min(a, b)
Definition macros.h:20
id
initmumps id
Definition multiplerhs_example.m:4
imp_dyna
Definition impbufdef_mod.F:314
imp_fvbcl
Definition impbufdef_mod.F:621
imp_fvbcl::nfvbcl
integer nfvbcl
Definition impbufdef_mod.F:623
imp_fvbcl::icr_1
integer, dimension(:), allocatable icr_1
Definition impbufdef_mod.F:624
imp_fvbcl::nkud_l
integer nkud_l
Definition impbufdef_mod.F:623
imp_fvbcl::ikud_1
integer, dimension(:), allocatable ikud_1
Definition impbufdef_mod.F:624
imp_fvbcl::ict_1
integer, dimension(:), allocatable ict_1
Definition impbufdef_mod.F:624
imp_fvbcl::nkud_1
integer nkud_1
Definition impbufdef_mod.F:623
message_mod
Definition message_mod.F:1249
velrot
subroutine velrot(vrm, lsm, vs)
Definition rbe2v.F:1119
dir_rbe2
subroutine dir_rbe2(j, j1, k)
Definition rbe2v.F:714
fv_rwl0
subroutine fv_rwl0(iddl, ifix, ndof, iadk, jdik, diag_k, lt_k, ud, b)
Definition srw_imp.F:104
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
arret
subroutine arret(nn)
Definition arret.F:87
upd_int_k
subroutine upd_int_k(icodt, icodr, iskew, ibfv, npc, tf, vel, xframe, rby, x, skew, lpby, npby, itab, weight, ms, in, nrbyac, irbyac, nss, iss, ipari, intbuf_tab, nint2, iint2, iaint2, nss2, iss2, nddli, nnzi, iadi, jdii, diag_i, lt_i, iddli, nddl, iadk, jdik, ikc, diag_k, lt_k, iddl, ndofi, itok, ud, lb, luj, nt_rw, irbe3, lrbe3, frbe3, nss3, iss3, irbe2, lrbe2, nsb2, isb2)
Definition upd_glob_k.F:465
upd_glob_k
subroutine upd_glob_k(icodt, icodr, iskew, ibfv, npc, tf, vel, xframe, rby, x, skew, lpby, npby, itab, weight, ms, in, nrbyac, irbyac, nsc, isij, nmc, imij, nss, iss, nint2, iint2, nsc2, isij2, nss2, iss2, ipari, intbuf_tab, nddl, nnz, iadk, jdik, diag_k, lt_k, ndof, iddl, ikc, ud, b, nkud, ikud, bkud, nmc2, imij2, nt_rw, rd, lj, irbe3, lrbe3, frbe3, iss3, irbe2, lrbe2, isb2, nsrb2)
Definition upd_glob_k.F:66