OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
imp_dyna.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| dyna_ini ../engine/source/implicit/imp_dyna.F
25!||--- called by ------------------------------------------------------
26!|| imp_init ../engine/source/implicit/imp_init.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../engine/source/output/message/message.F
29!|| arret ../engine/source/system/arret.F
30!||--- uses -----------------------------------------------------
31!|| imp_dyna ../engine/share/modules/impbufdef_mod.F
32!|| message_mod ../engine/share/message_module/message_mod.F
33!||====================================================================
34 SUBROUTINE dyna_ini(NODFT ,NODLT ,D_AL ,NM_A ,NM_B ,
35 1 V ,VR )
36C-----------------------------------------------
37C M o d u l e s
38C-----------------------------------------------
39 USE imp_dyna
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 "com01_c.inc"
49#include "com04_c.inc"
50#include "impl1_c.inc"
51C-----------------------------------------------
52C D u m m y A r g u m e n t s
53C-----------------------------------------------
54C REAL
55 INTEGER NODFT,NODLT
56 my_real
57 . d_al,nm_a ,nm_b,v(3,*),vr(3,*)
58C-----------------------------------------------
59C L o c a l V a r i a b l e s
60C-----------------------------------------------
61 INTEGER N, IER1,IER2,IER3,IER4
62C------------------------------------------
63C---DY_DAM0(t) Rayleigh damping force; used for energy compute
64 IF (idy_damp>0) THEN
65 ALLOCATE(dy_dam(3,numnod),dy_dam0(3,numnod),stat=ier1)
66 dy_dam=zero
67 dy_dam0=zero
68 ENDIF
69 IF(ALLOCATED(dy_d)) DEALLOCATE(dy_d)
70 ALLOCATE(dy_d(3,numnod),stat=ier1)
71 IF(ALLOCATED(dy_v)) DEALLOCATE(dy_v)
72 ALLOCATE(dy_v(3,numnod),stat=ier2)
73 IF(ALLOCATED(dy_a)) THEN
74 ier3=0
75 ELSE
76 ALLOCATE(dy_a(3,numnod),stat=ier3)
77 dy_a=zero
78 ENDIF
79 IF ((ier1+ier2+ier3)/=0) THEN
80 CALL ancmsg(msgid=19,anmode=aninfo,
81 . c1='FOR IMPLICIT DYNAMIC')
82 CALL arret(2)
83 ENDIF
84C-------------for sortie at T=0----
85 DO n=nodft,nodlt
86 dy_v(1,n) = v(1,n)
87 dy_v(2,n) = v(2,n)
88 dy_v(3,n) = v(3,n)
89 dy_d(1,n) = zero
90 dy_d(2,n) = zero
91 dy_d(3,n) = zero
92 ENDDO
93C
94 IF (iroddl/=0) THEN
95 IF (idy_damp>0) THEN
96 ALLOCATE(dy_damr(3,numnod),dy_damr0(3,numnod),stat=ier4)
97 dy_damr=zero
98 dy_damr0=zero
99 ENDIF
100 IF(ALLOCATED(dy_dr)) DEALLOCATE(dy_dr)
101 ALLOCATE(dy_dr(3,numnod),stat=ier1)
102 IF(ALLOCATED(dy_vr)) DEALLOCATE(dy_vr)
103 ALLOCATE(dy_vr(3,numnod),stat=ier2)
104 IF(ALLOCATED(dy_ar)) THEN
105 ier3=0
106 ELSE
107 ALLOCATE(dy_ar(3,numnod),stat=ier3)
108 dy_ar=zero
109 ENDIF
110C
111 IF ((ier1+ier2+ier3)/=0) THEN
112 CALL ancmsg(msgid=19,anmode=aninfo,
113 . c1='FOR IMPLICIT DYNAMIC')
114 CALL arret(2)
115 ENDIF
116C
117 DO n=nodft,nodlt
118 dy_vr(1,n) = vr(1,n)
119 dy_vr(2,n) = vr(2,n)
120 dy_vr(3,n) = vr(3,n)
121 dy_dr(1,n) = zero
122 dy_dr(2,n) = zero
123 dy_dr(3,n) = zero
124 ENDDO
125 ENDIF
126C------gama,beta----
127 IF (idyna==2) THEN
128 dy_g = nm_a
129 dy_b = nm_b
130 d_al = zero
131 ELSE
132 dy_g = half-d_al
133 dy_b = fourth*(one-d_al)*(one-d_al)
134 ENDIF
135 dy_edamp = zero
136C
137 RETURN
138 END
139!||====================================================================
140!|| dyna_in0 ../engine/source/implicit/imp_dyna.F
141!||--- uses -----------------------------------------------------
142!|| imp_dyna ../engine/share/modules/impbufdef_mod.F
143!||====================================================================
144 SUBROUTINE dyna_in0(NODFT ,NODLT )
145C-----------------------------------------------
146C M o d u l e s
147C-----------------------------------------------
148 USE imp_dyna
149C-----------------------------------------------
150C I m p l i c i t T y p e s
151C-----------------------------------------------
152#include "implicit_f.inc"
153C-----------------------------------------------
154C C o m m o n B l o c k s
155C-----------------------------------------------
156#include "com01_c.inc"
157C-----------------------------------------------
158C D u m m y A r g u m e n t s
159C-----------------------------------------------
160C REAL
161 INTEGER NODFT,NODLT
162C-----------------------------------------------
163C L o c a l V a r i a b l e s
164C-----------------------------------------------
165 INTEGER N
166C------------------------------------------
167 IF (iroddl/=0) THEN
168 DO n=nodft,nodlt
169 dy_in(1,n) = zero
170 dy_in(2,n) = zero
171 dy_in(3,n) = zero
172 ENDDO
173 ENDIF
174C
175 RETURN
176 END
177!||====================================================================
178!|| inte_dyna ../engine/source/implicit/imp_dyna.F
179!||--- called by ------------------------------------------------------
180!|| integrator ../engine/source/implicit/integrator.f
181!|| integrator_hp ../engine/source/implicit/integrator.F
182!||--- uses -----------------------------------------------------
183!|| imp_dyna ../engine/share/modules/impbufdef_mod.F
184!||====================================================================
185 SUBROUTINE inte_dyna(NODFT,NODLT ,D ,DR ,V ,VR )
186C-----------------------------------------------
187C M o d u l e s
188C-----------------------------------------------
189 USE imp_dyna
190C-----------------------------------------------
191C I m p l i c i t T y p e s
192C-----------------------------------------------
193#include "implicit_f.inc"
194C-----------------------------------------------
195C C o m m o n B l o c k s
196C-----------------------------------------------
197#include "com01_c.inc"
198#include "com08_c.inc"
199#include "impl1_c.inc"
200#include "impl2_c.inc"
201#include "com04_c.inc"
202C-----------------------------------------------
203C D u m m y A r g u m e n t s
204C-----------------------------------------------
205 INTEGER NODFT,NODLT,NDT
206C REAL
207 my_real
208 . d(3,*),dr(3,*),v(3,*),vr(3,*)
209C-----------------------------------------------
210C L o c a l V a r i a b l e s
211C-----------------------------------------------
212 INTEGER I,K
213 my_real
214 . adt,adt1,bdt,bdti,dt3
215C------- integrateur ----------
216 IF (imconv<=-2.AND..NOT.(ninvel>0.AND.ncycle==0)) THEN
217C------- ->a(t) --add something there for initial velocity at t=0--------
218 dt3 = dt1_imp
219 bdt = one/(half-dy_g+dy_b)/dt3
220 bdti = bdt/dt3
221 DO i=nodft,nodlt
222 dy_a(1,i)=bdt*dy_v(1,i)-bdti*dy_d(1,i)
223 dy_a(2,i)=bdt*dy_v(2,i)-bdti*dy_d(2,i)
224 dy_a(3,i)=bdt*dy_v(3,i)-bdti*dy_d(3,i)
225 ENDDO
226 IF (iroddl/=0) THEN
227 DO i=nodft,nodlt
228 dy_ar(1,i)=bdt*dy_vr(1,i)-bdti*dy_dr(1,i)
229 dy_ar(2,i)=bdt*dy_vr(2,i)-bdti*dy_dr(2,i)
230 dy_ar(3,i)=bdt*dy_vr(3,i)-bdti*dy_dr(3,i)
231 ENDDO
232 ENDIF
233 ELSE
234 bdti = one/dt2/dt2/dy_b
235 DO i=nodft,nodlt
236 dy_a(1,i)=bdti*(d(1,i)-dy_d(1,i))
237 dy_a(2,i)=bdti*(d(2,i)-dy_d(2,i))
238 dy_a(3,i)=bdti*(d(3,i)-dy_d(3,i))
239 ENDDO
240 IF (iroddl/=0) THEN
241 DO i=nodft,nodlt
242 dy_ar(1,i)=bdti*(dr(1,i)-dy_dr(1,i))
243 dy_ar(2,i)=bdti*(dr(2,i)-dy_dr(2,i))
244 dy_ar(3,i)=bdti*(dr(3,i)-dy_dr(3,i))
245 ENDDO
246 ENDIF
247 ENDIF
248C------- actualise V',D',(t) --V->v(t+dt)-------
249 IF (imconv==1) THEN
250 adt1 = dy_g*dt2
251c CALL IMP_DT2(DT3)
252 dt1_imp = dt_imp
253 dt3 = dt2
254 adt = (one-dy_g)*dt3
255 bdt = (half-dy_b)*dt3*dt3
256 DO i=nodft,nodlt
257 v(1,i)=dy_v(1,i)+adt1*dy_a(1,i)
258 v(2,i)=dy_v(2,i)+adt1*dy_a(2,i)
259 v(3,i)=dy_v(3,i)+adt1*dy_a(3,i)
260C
261 dy_v(1,i)=v(1,i)+adt*dy_a(1,i)
262 dy_v(2,i)=v(2,i)+adt*dy_a(2,i)
263 dy_v(3,i)=v(3,i)+adt*dy_a(3,i)
264C
265 dy_d(1,i)=dt3*v(1,i)+bdt*dy_a(1,i)
266 dy_d(2,i)=dt3*v(2,i)+bdt*dy_a(2,i)
267 dy_d(3,i)=dt3*v(3,i)+bdt*dy_a(3,i)
268 ENDDO
269 IF (iroddl/=0) THEN
270 DO i=nodft,nodlt
271 vr(1,i)=dy_vr(1,i)+adt1*dy_ar(1,i)
272 vr(2,i)=dy_vr(2,i)+adt1*dy_ar(2,i)
273 vr(3,i)=dy_vr(3,i)+adt1*dy_ar(3,i)
274C
275 dy_vr(1,i)=vr(1,i)+adt*dy_ar(1,i)
276 dy_vr(2,i)=vr(2,i)+adt*dy_ar(2,i)
277 dy_vr(3,i)=vr(3,i)+adt*dy_ar(3,i)
278C
279 dy_dr(1,i)=dt3*vr(1,i)+bdt*dy_ar(1,i)
280 dy_dr(2,i)=dt3*vr(2,i)+bdt*dy_ar(2,i)
281 dy_dr(3,i)=dt3*vr(3,i)+bdt*dy_ar(3,i)
282 ENDDO
283 ENDIF
284 ENDIF
285c I = 2
286c print *,'V=',IDYNA
287c print *,V(1,I),V(2,I),V(3,I)
288C--------------------------------------------
289 RETURN
290 END
291!||====================================================================
292!|| imp_dynam ../engine/source/implicit/imp_dyna.F
293!||--- called by ------------------------------------------------------
294!|| imp_chkm ../engine/source/implicit/imp_solv.F
295!|| imp_solv ../engine/source/implicit/imp_solv.F
296!||--- uses -----------------------------------------------------
297!|| imp_dyna ../engine/share/modules/impbufdef_mod.F
298!||====================================================================
299 SUBROUTINE imp_dynam(NODFT ,NODLT ,IDDL ,NDOF ,
300 . DIAG_K ,MS ,IN ,D_AL ,WEIGHT,
301 . IADK ,LT_K )
302C-----------------------------------------------
303C M o d u l e s
304C-----------------------------------------------
305 USE imp_dyna
306C-----------------------------------------------
307C I m p l i c i t T y p e s
308C-----------------------------------------------
309#include "implicit_f.inc"
310C-----------------------------------------------
311C C o m m o n B l o c k s
312C-----------------------------------------------
313#include "com01_c.inc"
314#include "com08_c.inc"
315#include "impl1_c.inc"
316#include "impl2_c.inc"
317C-----------------------------------------------
318C D u m m y A r g u m e n t s
319C-----------------------------------------------
320 INTEGER NODFT,NODLT,IDDL(*) ,NDOF(*),WEIGHT(*),IADK(*)
321C REAL
322 my_real
323 . diag_k(*),ms(*),in(*),d_al,lt_k(*)
324C-----------------------------------------------
325C L o c a l V a r i a b l e s
326C-----------------------------------------------
327 INTEGER I,J,ND
328 my_real
329 . BDT, MKF,MKM,S,S0
330C------- add to diag_[k] ----------
331 IF (iqstat>0) THEN
332 d_al = -zep05
333 dy_g = half-d_al
334 dy_b = fourth*(one-d_al)*(one-d_al)
335 ENDIF
336 s0 = zero
337 IF (idy_damp>0) THEN
338 s = (one+d_al)*dy_b*dt2
339 bdt = (one/dt2+(one+d_al)*dampa_imp*dy_g)/s
340 nd = iadk(nddl_l+1)-iadk(1)
341 s0 = (one+d_al)*dampb_imp*dy_g/s
342 IF (s0/=zero) THEN
343 DO i = 1,nddl_l
344 diag_k(i)=diag_k(i)+s0*diag_k(i)
345 ENDDO
346 DO i = 1,nd
347 lt_k(i) = lt_k(i)+s0*lt_k(i)
348 ENDDO
349 ENDIF
350 ELSE
351 s = (one+d_al)*dy_b*dt2*dt2
352 IF (iqstat>0.AND.(ilintf==0.OR.ilintf==ncycle)) THEN
353 s = s *scal_dtq*scal_dtq
354 ENDIF
355 bdt = one/s
356Cq52d4+1
357 ENDIF
358C
359 IF (iroddl==0) THEN
360 DO i = nodft,nodlt
361 mkf = abs(ms(i))*bdt*weight(i)
362 DO j=1,ndof(i)
363 nd = iddl(i)+j
364 diag_k(nd)=diag_k(nd)+mkf
365 ENDDO
366 ENDDO
367 ELSE
368 DO i = nodft,nodlt
369 mkf = abs(ms(i))*bdt*weight(i)
370 mkm = abs(in(i))*bdt*weight(i)
371 DO j=1,ndof(i)
372 nd = iddl(i)+j
373 IF (j<=3) THEN
374 diag_k(nd)=diag_k(nd)+mkf
375 ELSE
376 diag_k(nd)=diag_k(nd)+mkm
377 ENDIF
378 ENDDO
379 ENDDO
380 END IF !(IRODDL==0) THEN
381C--------------------------------------------
382 RETURN
383 END
384!||====================================================================
385!|| imp_dynar ../engine/source/implicit/imp_dyna.F
386!||--- called by ------------------------------------------------------
387!|| upd_rhs ../engine/source/implicit/upd_glob_k.F
388!||--- uses -----------------------------------------------------
389!|| imp_dyna ../engine/share/modules/impbufdef_mod.F
390!||====================================================================
391 SUBROUTINE imp_dynar(DY_AC,DY_ACR,MS ,IN ,FINT ,MINT ,
392 . V ,VR )
393C-----------------------------------------------
394C M o d u l e s
395C-----------------------------------------------
396 USE imp_dyna
397C-----------------------------------------------
398C I m p l i c i t T y p e s
399C-----------------------------------------------
400#include "implicit_f.inc"
401C-----------------------------------------------
402C C o m m o n B l o c k s
403C-----------------------------------------------
404#include "com01_c.inc"
405#include "com04_c.inc"
406#include "impl1_c.inc"
407C-----------------------------------------------
408C D u m m y A r g u m e n t s
409C-----------------------------------------------
410C REAL
411 my_real
412 . dy_ac(3,*),dy_acr(3,*),ms(*),in(*),fint(3,*),mint(3,*),
413 . v(3,*),vr(3,*)
414C-----------------------------------------------
415C L o c a l V a r i a b l e s
416C-----------------------------------------------
417 INTEGER I,J,K
418 my_real
419 . BETASDT
420C------- ----------
421 DO i=1,numnod
422 dy_ac(1,i)=-abs(ms(i))*dy_a(1,i)
423 dy_ac(2,i)=-abs(ms(i))*dy_a(2,i)
424 dy_ac(3,i)=-abs(ms(i))*dy_a(3,i)
425 ENDDO
426 IF (iroddl/=0) THEN
427 DO i=1,numnod
428 dy_acr(1,i)=-abs(in(i))*dy_ar(1,i)
429 dy_acr(2,i)=-abs(in(i))*dy_ar(2,i)
430 dy_acr(3,i)=-abs(in(i))*dy_ar(3,i)
431 ENDDO
432 ENDIF
433C---add Cv in Fint---------------
434 IF (idy_damp>0) THEN
435 DO i=1,numnod
436 fint(1,i)=fint(1,i)-dy_dam(1,i)
437 fint(2,i)=fint(2,i)-dy_dam(2,i)
438 fint(3,i)=fint(3,i)-dy_dam(3,i)
439 ENDDO
440 IF (iroddl/=0) THEN
441 DO i=1,numnod
442 mint(1,i)=mint(1,i)-dy_damr(1,i)
443 mint(2,i)=mint(2,i)-dy_damr(2,i)
444 mint(3,i)=mint(3,i)-dy_damr(3,i)
445 ENDDO
446 ENDIF
447 ENDIF
448C--------------------------------------------
449 RETURN
450 END
451!||====================================================================
452!|| imp_fhht ../engine/source/implicit/imp_dyna.F
453!||--- called by ------------------------------------------------------
454!|| upd_rhs ../engine/source/implicit/upd_glob_k.F
455!||--- uses -----------------------------------------------------
456!|| imp_dyna ../engine/share/modules/impbufdef_mod.F
457!||====================================================================
458 SUBROUTINE imp_fhht(NDDL ,LB )
459C-----------------------------------------------
460C M o d u l e s
461C-----------------------------------------------
462 USE imp_dyna
463C-----------------------------------------------
464C I m p l i c i t T y p e s
465C-----------------------------------------------
466#include "implicit_f.inc"
467C-----------------------------------------------
468C C o m m o n B l o c k s
469C-----------------------------------------------
470#include "impl2_c.inc"
471C-----------------------------------------------
472C D u m m y A r g u m e n t s
473C-----------------------------------------------
474 INTEGER NDDL,IFLAG
475C REAL
476 my_real
477 . LB(*)
478C-----------------------------------------------
479C L o c a l V a r i a b l e s
480C-----------------------------------------------
481 INTEGER I,J,K
482 my_real
483 . A,B
484C-------LB() =((ONE+HHT_A)LB(t+dt)-HHT_A*LB(t))/(ONE+HHT_A)
485C--------/(ONE+HHT_A) is due to the Jacobien [K]'=[K]/(ONE+HHT_A) used to reduce [K] modifications
486C----- store db in DY_R0; add db in lb in IMP_FHHT; this is du to SPMD version---------
487 IF (hht_a==zero) RETURN
488 a = one+hht_a
489 b = -hht_a/a
490 DO i=1,nddl
491 dy_r1(i) = lb(i)
492 dy_r0(i) = b*dy_r0(i)
493 ENDDO
494C--------------------------------------------
495 RETURN
496 END
497!||====================================================================
498!|| dyna_cpr0 ../engine/source/implicit/imp_dyna.F
499!||--- called by ------------------------------------------------------
500!|| imp_solv ../engine/source/implicit/imp_solv.F
501!||--- calls -----------------------------------------------------
502!|| cp_real ../engine/source/implicit/produt_v.F
503!||--- uses -----------------------------------------------------
504!|| imp_dyna ../engine/share/modules/impbufdef_mod.F
505!||====================================================================
506 SUBROUTINE dyna_cpr0(NDDL )
507C-----------------------------------------------
508C M o d u l e s
509C-----------------------------------------------
510 USE imp_dyna
511C-----------------------------------------------
512C I m p l i c i t T y p e s
513C-----------------------------------------------
514#include "implicit_f.inc"
515C-----------------------------------------------
516C C o m m o n B l o c k s
517C-----------------------------------------------
518#include "impl2_c.inc"
519C-----------------------------------------------
520C D u m m y A r g u m e n t s
521C-----------------------------------------------
522C REAL
523 INTEGER NDDL
524C-----------------------------------------------
525C L o c a l V a r i a b l e s
526C-----------------------------------------------
527 INTEGER I
528C------------------------------------------
529 IF (HHT_A==zero) RETURN
530 CALL cp_real(nddl,dy_r1,dy_r0)
531C--------------------------------------------
532 RETURN
533 END
534
535!||====================================================================
536!|| qstat_ini ../engine/source/implicit/imp_dyna.F
537!||--- called by ------------------------------------------------------
538!|| imp_solv ../engine/source/implicit/imp_solv.F
539!||--- calls -----------------------------------------------------
540!|| ancmsg ../engine/source/output/message/message.F
541!|| arret ../engine/source/system/arret.F
542!||--- uses -----------------------------------------------------
543!|| imp_qstat ../engine/share/modules/impbufdef_mod.F
544!|| message_mod ../engine/share/message_module/message_mod.F
545!||====================================================================
546 SUBROUTINE qstat_ini(NDDL ,INLOC ,IDDL ,NDOF ,IKC ,
547 . MS ,IN )
548C-----------------------------------------------
549C M o d u l e s
550C-----------------------------------------------
551 USE imp_qstat
552 USE message_mod
553C-----------------------------------------------
554C I m p l i c i t T y p e s
555C-----------------------------------------------
556#include "implicit_f.inc"
557C-----------------------------------------------
558C C o m m o n B l o c k s
559C-----------------------------------------------
560#include "com01_c.inc"
561#include "com04_c.inc"
562#include "com08_c.inc"
563#include "impl1_c.inc"
564C-----------------------------------------------
565C D u m m y A r g u m e n t s
566C-----------------------------------------------
567 INTEGER NDDL,INLOC(*) ,IDDL(*) ,NDOF(*),IKC(*)
568C REAL
569 my_real
570 . MS(*),IN(*)
571C-----------------------------------------------
572C L o c a l V a r i a b l e s
573C-----------------------------------------------
574 INTEGER I,J,N,ID,ND,NKC,IER1
575 my_real
576 . BDT, MKF,MKM,S,B
577C-----------------
578 IF(ILINE==0) then
579 IF(ncycle==1.AND.inconv==1) THEN
580 ALLOCATE(d_n_1(3*numnod),stat=ier1)
581 IF (iroddl/=0) ALLOCATE(dr_n_1(3*numnod),stat=ier1)
582 IF (ier1/=0) THEN
583 CALL ancmsg(msgid=19,anmode=aninfo,
584 . c1='FOR IMPLICIT QUASI-STATIC')
585 CALL arret(2)
586 ENDIF
587 END IF
588C
589 ELSE
590C
591 IF(ncycle == 1)ALLOCATE(qs_d(nddl),qs_u(nddl),stat=ier1)
592 IF (ier1/=0) THEN
593 CALL ancmsg(msgid=19,anmode=aninfo,
594 . c1='FOR IMPLICIT QUASI-STATIC')
595 CALL arret(2)
596 ENDIF
597 DO i=1,nddl
598 qs_u(i)=zero
599 ENDDO
600 b = fourth*(one+zep05)*(one+zep05)
601 s = (one-zep05)*b*dt2*dt2
602 bdt = one/s
603 nkc = 0
604 IF (iroddl == 0) THEN
605 DO n = 1,numnod
606 i=inloc(n)
607 mkf = abs(ms(i))*bdt
608 DO j=1,ndof(i)
609 nd = iddl(i)+j
610 id = nd-nkc
611 IF (ikc(nd)<1) THEN
612 qs_d(id)=mkf
613 ELSE
614 nkc=nkc+1
615 ENDIF
616 ENDDO
617 ENDDO
618 ELSE
619 DO n = 1,numnod
620 i=inloc(n)
621 mkf = abs(ms(i))*bdt
622 mkm = abs(in(i))*bdt
623 DO j=1,ndof(i)
624 nd = iddl(i)+j
625 id = nd-nkc
626 IF (ikc(nd)<1) THEN
627 IF (j<=3) THEN
628 qs_d(id)=mkf
629 ELSE
630 qs_d(id)=mkm
631 ENDIF
632 ELSE
633 nkc=nkc+1
634 ENDIF
635 ENDDO
636 ENDDO
637 END IF !(IRODDL == 0) THEN
638C
639 END IF !(ILINE==0) THEN
640C--------------------------------------------
641 RETURN
642 END
643!||====================================================================
644!|| qstat_it ../engine/source/implicit/imp_dyna.F
645!||--- called by ------------------------------------------------------
646!|| lin_solv ../engine/source/implicit/lin_solv.F
647!||--- uses -----------------------------------------------------
648!|| imp_qstat ../engine/share/modules/impbufdef_mod.F
649!||====================================================================
650 SUBROUTINE qstat_it(NDDL ,F ,U )
651C-----------------------------------------------
652C M o d u l e s
653C-----------------------------------------------
654 USE imp_qstat
655C-----------------------------------------------
656C I m p l i c i t T y p e s
657C-----------------------------------------------
658#include "implicit_f.inc"
659C-----------------------------------------------
660C D u m m y A r g u m e n t s
661C-----------------------------------------------
662 INTEGER NDDL
663C REAL
664 my_real
665 . F(*),U(*)
666C-----------------------------------------------
667C L o c a l V a r i a b l e s
668C-----------------------------------------------
669 INTEGER I
670C-----------------
671 DO I=1,nddl
672 f(i) = qs_d(i)*u(i)
673 qs_u(i) = qs_u(i)+u(i)
674 ENDDO
675C--------------------------------------------
676 RETURN
677 END
678!||====================================================================
679!|| qstat_end ../engine/source/implicit/imp_dyna.F
680!||--- called by ------------------------------------------------------
681!|| lin_solv ../engine/source/implicit/lin_solv.F
682!||--- uses -----------------------------------------------------
683!|| imp_qstat ../engine/share/modules/impbufdef_mod.F
684!||====================================================================
685 SUBROUTINE qstat_end(NDDL ,U )
686C-----------------------------------------------
687C M o d u l e s
688C-----------------------------------------------
689 USE imp_qstat
690C-----------------------------------------------
691C I m p l i c i t T y p e s
692C-----------------------------------------------
693#include "implicit_f.inc"
694C-----------------------------------------------
695C D u m m y A r g u m e n t s
696C-----------------------------------------------
697 INTEGER NDDL
698C REAL
699 my_real
700 . U(*)
701C-----------------------------------------------
702C L o c a l V a r i a b l e s
703C-----------------------------------------------
704 INTEGER I
705C-----------------
706 DO I=1,nddl
707 u(i) = qs_u(i)
708 ENDDO
709 DEALLOCATE(qs_u,qs_d)
710C--------------------------------------------
711 RETURN
712 END
713!||====================================================================
714!|| dyna_ina ../engine/source/implicit/imp_dyna.F
715!||--- called by ------------------------------------------------------
716!|| imp_solv ../engine/source/implicit/imp_solv.F
717!||--- calls -----------------------------------------------------
718!|| ancmsg ../engine/source/output/message/message.F
719!|| arret ../engine/source/system/arret.F
720!|| force_imp ../engine/source/loads/general/force_imp.F
721!|| gravit_imp ../engine/source/loads/general/grav/gravit_imp.F
722!|| spmd_max_i ../engine/source/mpi/implicit/imp_spmd.F
723!|| spmd_sumf_a ../engine/source/mpi/implicit/imp_spmd.F
724!||--- uses -----------------------------------------------------
725!|| h3d_mod ../engine/share/modules/h3d_mod.F
726!|| imp_dyna ../engine/share/modules/impbufdef_mod.F
727!|| message_mod ../engine/share/message_module/message_mod.F
728!|| python_funct_mod ../common_source/modules/python_mod.F90
729!|| sensor_mod ../common_source/modules/sensor_mod.F90
730!|| skew_mod ../common_source/modules/skew_mod.F90
731!|| th_surf_mod ../common_source/modules/interfaces/th_surf_mod.F
732!||====================================================================
733 SUBROUTINE dyna_ina(IBCL ,FORC ,SNPC ,NPC ,TF ,A ,
734 2 V ,X ,SKEWS ,AR ,VR ,
735 3 SENSOR_TAB,WEIGHT ,WFEXC ,IADS_F ,
736 4 FSKY ,IGRV ,AGRV ,MS ,IN ,
737 5 LGRAV ,ITASK ,NRBYAC ,IRBYAC ,NPBY ,
738 6 RBY ,FR_ELEM ,IAD_ELEM,NDDL ,NNZK ,
739 7 IDIV ,H3D_DATA,CPTREAC ,FTHREAC,NODREAC,
740 8 NSENSOR ,TH_SURF ,DPL0CLD,
741 9 VEL0CLD ,D ,DR ,NUMNOD ,NSURF ,
742 A NFUNCT ,NCONLD ,NGRAV ,NINVEL ,STF ,NUMSKW ,
743 B WFEXT, PYTHON)
744C-----------------------------------------------
745C M o d u l e s
746C-----------------------------------------------
747 USE imp_dyna
748 use python_funct_mod, only: python_
749 USE message_mod
750 USE h3d_mod
751 USE sensor_mod
752 USE th_surf_mod , ONLY : th_surf_, th_surf_num_channel
753 USE skew_mod
754C-----------------------------------------------
755C I m p l i c i t T y p e s
756C-----------------------------------------------
757#include "implicit_f.inc"
758C-----------------------------------------------
759C C o m m o n B l o c k s
760C-----------------------------------------------
761#include "com01_c.inc"
762#include "com08_c.inc"
763#include "impl1_c.inc"
764#include "param_c.inc"
765#include "timeri_c.inc"
766#include "impl2_c.inc"
767C-----------------------------------------------
768C D u m m y A r g u m e n t s
769C-----------------------------------------------
770 type(python_), intent(inout) :: python
771 INTEGER ,INTENT(IN) :: NSENSOR,NUMNOD,NSURF,NFUNCT,NCONLD,NGRAV,NINVEL
772 INTEGER, INTENT(IN) :: STF
773 INTEGER, INTENT(IN) :: SNPC
774 INTEGER, INTENT(IN) :: NUMSKW
775 INTEGER ITASK,NPC(SNPC), IBCL(*), NPBY(NNPBY,*), IADS_F(*),
776 . IGRV(*),WEIGHT(*),LGRAV(*),IDIV,
777 . CPTREAC,NODREAC(*)
778 INTEGER FR_ELEM(*),IAD_ELEM(2,*),NRBYAC,IRBYAC(*),NDDL ,NNZK
779 my_real
780 . X(3,*) ,V(3,*) ,VR(3,*),MS(*) ,AGRV(*),
781 . TF(*) ,FORC(*) ,RBY(NRBY,*),IN(*),
782 . A(3,*) ,AR(3,*),WFEXC,FSKY(*),FTHREAC(6,*)
783 TYPE(H3D_DATABASE) :: H3D_DATA
784 TYPE (SENSOR_STR_) ,DIMENSION(NSENSOR) :: SENSOR_TAB
785 TYPE (TH_SURF_) , INTENT(INOUT) :: TH_SURF
786 TYPE (SKEW_),INTENT(INOUT) :: SKEWS
787 my_real, INTENT(IN) ::
788 . dpl0cld(6,nconld),vel0cld(6,nconld),
789 . d(3,numnod),dr(3,numnod)
790 DOUBLE PRECISION,INTENT(INOUT) :: WFEXT
791C-----------------------------------------------
792C L o c a l V a r i a b l e s
793C-----------------------------------------------
794 INTEGER I,J,N, NCL_MAX,LBAND,NTMP,NODFT,NODLT,IER1,IER2
795 my_real
796 . TMP,ADT,BDT,BDTI,DUMMY_FEXT(3,1)
797C--------------------------------
798 dummy_fext = zero
799 nodft = 1
800 nodlt = numnod
801C-----allocation supp----
802 IF (idiv ==0) THEN
803 IF (idy_damp>0) THEN
804 ALLOCATE(dy_diak0(nddl),dy_ltk0(nnzk),stat=ier1)
805 dy_diak0=zero
806 dy_ltk0=zero
807 ALLOCATE(dy_iadk0(nddl+1),dy_jdik0(nnzk),stat=ier2)
808 IF ((ier1+ier2)/=0) THEN
809 CALL ancmsg(msgid=19,anmode=aninfo,
810 . c1='FOR IMPLICIT DYNAMIC')
811 CALL arret(2)
812 ENDIF
813 ENDIF
814 IF (hht_a/=zero) THEN
815 ALLOCATE(dy_r0(nddl),dy_r1(nddl),stat=ier1)
816 dy_r0=zero
817 IF (ier1/=0) THEN
818 CALL ancmsg(msgid=19,anmode=aninfo,
819 . c1='FOR IMPLICIT DYNAMIC')
820 CALL arret(2)
821 ENDIF
822 ENDIF
823C-----------divergence at first step--------
824 ELSE
825 adt = (one-dy_g)
826 bdt = (half-dy_b)*dt0_imp
827 bdti =one/(bdt-adt*dt0_imp)
828 DO n=nodft,nodlt
829 dy_a(1,n) = zero
830 dy_a(2,n) = zero
831 dy_a(3,n) = zero
832C
833 v(1,n) = bdti*(dy_v(1,n)*bdt-dy_d(1,n)*adt)
834 v(2,n) = bdti*(dy_v(2,n)*bdt-dy_d(2,n)*adt)
835 v(3,n) = bdti*(dy_v(3,n)*bdt-dy_d(3,n)*adt)
836 ENDDO
837 IF (iroddl/=0) THEN
838 DO n=nodft,nodlt
839 dy_ar(1,n) = zero
840 dy_ar(2,n) = zero
841 dy_ar(3,n) = zero
842C
843 vr(1,n) = bdti*(dy_vr(1,n)*bdt-dy_dr(1,n)*adt)
844 vr(2,n) = bdti*(dy_vr(2,n)*bdt-dy_dr(2,n)*adt)
845 vr(3,n) = bdti*(dy_vr(3,n)*bdt-dy_dr(3,n)*adt)
846 ENDDO
847 ENDIF
848 END IF !(IDIV ==0) THEN
849C
850 IF (tt==dt2.OR.impl_s0==0) THEN
851C--- Estimate A (t = 0) ----
852 ncl_max = 0
853 IF (tt==dt2) tt = zero
854 IF(nconld/=0) THEN
855! IF (IMON>0 .AND. ITASK == 0) CALL STARTIME(TIMERS,4)
856 CALL force_imp(ibcl ,forc ,snpc ,npc ,tf ,
857 2 dy_a ,v ,x ,skews ,
858 3 dy_ar ,vr ,nsensor ,sensor_tab ,wfexc ,
859 4 iads_f ,fsky ,dummy_fext ,h3d_data ,cptreac ,
860 5 fthreac ,nodreac ,th_surf ,
861 6 dpl0cld ,vel0cld ,d ,dr ,nconld ,
862 7 numnod ,nfunct ,stf ,wfext)
863 IF (nspmd>1) THEN
864 DO i=iad_elem(1,1),iad_elem(1,nspmd+1)-1
865 j = fr_elem(i)
866 tmp = abs(dy_a(1,j))+abs(dy_a(2,j))+abs(dy_a(3,j))+
867 . abs(dy_ar(1,j))+abs(dy_ar(2,j))+abs(dy_ar(3,j))
868 IF (tmp>zero) ncl_max = ncl_max + 1
869 ENDDO
870 ENDIF
871! IF (IMON>0 .AND. ITASK == 0) CALL STOPTIME(TIMERS,4)
872 ENDIF
873 IF (nspmd>1) THEN
874 CALL spmd_max_i(ncl_max)
875 IF (ncl_max>0) THEN
876 lband = iad_elem(1,nspmd+1)-iad_elem(1,1)
877 IF (iroddl/=0) THEN
878 ntmp = 6
879 ELSE
880 ntmp = 3
881 ENDIF
882 CALL spmd_sumf_a(dy_a,dy_ar,iad_elem,fr_elem,ntmp,lband)
883 ENDIF
884 ENDIF
885 IF(ngrav/=0) THEN
886! IF (IMON>0 .AND. ITASK == 0) CALL STARTIME(TIMERS,4)
887 CALL gravit_imp(igrv ,agrv ,npc ,tf ,dy_a,
888 2 v ,x ,skews%SKEW ,ms,wfexc,
889 3 nsensor,sensor_tab,weight,lgrav,itask,
890 4 nrbyac,irbyac,npby ,rby, python)
891! IF (IMON>0 .AND. ITASK == 0) CALL STOPTIME(TIMERS,4)
892 ENDIF
893 DO n=nodft,nodlt
894 IF(ms(n)>0.) THEN
895 tmp = one / ms(n)
896 dy_a(1,n) = (dy_a(1,n) + a(1,n))* tmp
897 dy_a(2,n) = (dy_a(2,n) + a(2,n))* tmp
898 dy_a(3,n) = (dy_a(3,n) + a(3,n))* tmp
899 ENDIF
900 ENDDO
901 IF (iroddl/=0) THEN
902 DO n=nodft,nodlt
903 IF(in(n)>0.) THEN
904 tmp = one / in(n)
905 dy_ar(1,n) = (dy_ar(1,n) + ar(1,n))* tmp
906 dy_ar(2,n) = (dy_ar(2,n) + ar(2,n))* tmp
907 dy_ar(3,n) = (dy_ar(3,n) + ar(3,n))* tmp
908 ENDIF
909 ENDDO
910 ENDIF
911 IF (tt==zero) tt = dt2
912 ELSE !restart
913 ENDIF ! (TT==0) THEN
914C
915 adt = (one-dy_g)*dt2
916 bdt = (half-dy_b)*dt2*dt2
917 DO n=nodft,nodlt
918 dy_v(1,n)=v(1,n)+adt*dy_a(1,n)
919 dy_v(2,n)=v(2,n)+adt*dy_a(2,n)
920 dy_v(3,n)=v(3,n)+adt*dy_a(3,n)
921C
922 dy_d(1,n)=dt2*v(1,n)+bdt*dy_a(1,n)
923 dy_d(2,n)=dt2*v(2,n)+bdt*dy_a(2,n)
924 dy_d(3,n)=dt2*v(3,n)+bdt*dy_a(3,n)
925 ENDDO
926 IF (iroddl/=0) THEN
927 DO n=nodft,nodlt
928 dy_vr(1,n)=vr(1,n)+adt*dy_ar(1,n)
929 dy_vr(2,n)=vr(2,n)+adt*dy_ar(2,n)
930 dy_vr(3,n)=vr(3,n)+adt*dy_ar(3,n)
931C
932 dy_dr(1,n)=dt2*vr(1,n)+bdt*dy_ar(1,n)
933 dy_dr(2,n)=dt2*vr(2,n)+bdt*dy_ar(2,n)
934 dy_dr(3,n)=dt2*vr(3,n)+bdt*dy_ar(3,n)
935 ENDDO
936 ENDIF
937 IF (tt==dt2) THEN
938C----predictor for a(t+dt)-------
939c keep continuity with GM validation: -initialize later-
940 IF (ninvel>0) THEN
941 bdti = one/dt2/dt2/dy_b
942 bdti = zero
943 DO n=nodft,nodlt
944 dy_a(1,n) = -bdti*dy_d(1,n)
945 dy_a(2,n) = -bdti*dy_d(2,n)
946 dy_a(3,n) = -bdti*dy_d(3,n)
947 ENDDO
948 IF (iroddl/=0) THEN
949 DO n=nodft,nodlt
950 dy_ar(1,n) = -bdti*dy_dr(1,n)
951 dy_ar(2,n) = -bdti*dy_dr(2,n)
952 dy_ar(3,n) = -bdti*dy_dr(3,n)
953 ENDDO
954 END IF
955 ELSE
956 bdti = one/dt2/dy_b
957 DO n=nodft,nodlt
958 dy_a(1,n) = -bdti*v(1,n)
959 dy_a(2,n) = -bdti*v(2,n)
960 dy_a(3,n) = -bdti*v(3,n)
961 ENDDO
962 IF (iroddl/=0) THEN
963 DO n=nodft,nodlt
964 dy_ar(1,n) = -bdti*vr(1,n)
965 dy_ar(2,n) = -bdti*vr(2,n)
966 dy_ar(3,n) = -bdti*vr(3,n)
967 ENDDO
968 ENDIF
969 END IF !IF (NINVEL>0)
970 ENDIF
971C
972 RETURN
973 END
974!||====================================================================
975!|| dyna_wex ../engine/source/implicit/imp_dyna.F
976!||--- called by ------------------------------------------------------
977!|| imp_solv ../engine/source/implicit/imp_solv.F
978!||--- calls -----------------------------------------------------
979!|| force_imp ../engine/source/loads/general/force_imp.F
980!|| gravit_imp ../engine/source/loads/general/grav/gravit_imp.F
981!|| wfv_imp ../engine/source/constraints/general/impvel/fv_imp0.F
982!||--- uses -----------------------------------------------------
983!|| h3d_mod ../engine/share/modules/h3d_mod.F
984!|| imp_dyna ../engine/share/modules/impbufdef_mod.F
985!|| python_funct_mod ../common_source/modules/python_mod.F90
986!|| sensor_mod ../common_source/modules/sensor_mod.F90
987!|| skew_mod ../common_source/modules/skew_mod.F90
988!|| th_surf_mod ../common_source/modules/interfaces/th_surf_mod.F
989!||====================================================================
990 SUBROUTINE dyna_wex(IBCL ,FORC ,SNPC,NPC ,TF ,A ,
991 2 V ,X ,SKEWS ,AR ,VR ,
992 3 SENSOR_TAB,WEIGHT,WFEXT ,IADS_F ,
993 4 FSKY ,IGRV ,AGRV ,MS ,IN ,
994 5 LGRAV ,ITASK ,NRBYAC,IRBYAC ,NPBY ,
995 6 RBY ,IBFV ,VEL ,D ,DR ,
996 7 IKC ,IDDL ,IFRAME,XFRAME ,NDOF ,
997 8 H3D_DATA,CPTREAC,FTHREAC,NODREAC,NSENSOR,
998 9 TH_SURF ,DPL0CLD,
999 A VEL0CLD, NUMNOD,NSURF,NFUNCT,NCONLD,
1000 B NGRAV,NFXVEL,STF,NUMSKW,python)
1001C-----------------------------------------------
1002C M o d u l e s
1003C-----------------------------------------------
1004 USE imp_dyna
1005 USE h3d_mod
1006 USE sensor_mod
1007 USE th_surf_mod , ONLY : th_surf_, th_surf_num_channel
1008 USE skew_mod
1009 use python_funct_mod, only: python_
1010C-----------------------------------------------
1011C I m p l i c i t T y p e s
1012C-----------------------------------------------
1013#include "implicit_f.inc"
1014C-----------------------------------------------
1015C C o m m o n B l o c k s
1016C-----------------------------------------------
1017#include "com01_c.inc"
1018#include "com08_c.inc"
1019#include "param_c.inc"
1020#include "timeri_c.inc"
1021#include "impl1_c.inc"
1022C-----------------------------------------------
1023C D u m m y A r g u m e n t s
1024C-----------------------------------------------
1025 type(python_), intent(inout) :: python
1026 INTEGER ,INTENT(IN) :: NSENSOR,NUMNOD,NSURF,NFUNCT,NCONLD,NGRAV,NFXVEL
1027 INTEGER ,INTENT(IN) :: STF
1028 INTEGER ,INTENT(IN) :: SNPC
1029 INTEGER ,INTENT(IN) :: NUMSKW
1030 INTEGER ITASK,NPC(SNPC), IBCL(*), NPBY(NNPBY,*), IADS_F(*),
1031 . igrv(*),weight(*),lgrav(*),
1032 . iframe(liskn,*),ibfv(*),ikc(*) ,iddl(*),ndof(*),
1033 . cptreac,nodreac(*)
1034 INTEGER NRBYAC,IRBYAC(*)
1035 my_real X(3,*) ,V(3,*) ,VR(3,*),MS(*) ,AGRV(*),
1036 . TF(*) ,FORC(*) ,RBY(NRBY,*),IN(*),
1037 . A(3,*) ,AR(3,*),FSKY(*),
1038 . VEL(LFXVELR,*), D(3,*), DR(3,*),XFRAME(NXFRAME,*),
1039 . FTHREAC(6,*)
1040 TYPE(H3D_DATABASE) :: H3D_DATA
1041 TYPE (SENSOR_STR_) ,DIMENSION(NSENSOR) :: SENSOR_TAB
1042 TYPE (TH_SURF_) , INTENT(INOUT) :: TH_SURF
1043 TYPE(SKEW_),INTENT(INOUT) :: SKEWS
1044 my_real, INTENT(IN) :: DPL0CLD(6,NCONLD),VEL0CLD(6,NCONLD)
1045 DOUBLE PRECISION,INTENt(INOUT) :: WFEXT
1046C-----------------------------------------------
1047C L o c a l V a r i a b l e s
1048C-----------------------------------------------
1049 INTEGER N,IBID,IW ,I,J,ND,J1
1050 my_real wfexc,dummy_fext(3,1)
1051C--------------------------------
1052 dummy_fext=zero
1053C--------------------------------
1054! IF (IMON>0 .AND. ITASK ==0) CALL STARTIME(TIMERS,4)
1055 IF(nconld/=0) THEN
1056 CALL force_imp( ibcl ,forc ,snpc ,npc ,tf ,
1057 2 a ,v ,x ,skews ,
1058 3 ar ,vr ,nsensor ,sensor_tab ,wfexc ,
1059 4 iads_f ,fsky ,dummy_fext ,h3d_data ,cptreac ,
1060 5 fthreac ,nodreac ,th_surf ,
1061 6 dpl0cld ,vel0cld ,d ,dr ,nconld ,
1062 7 numnod ,nfunct ,stf ,wfext)
1063
1064 wfext = wfext + wfexc*dt2
1065 ENDIF
1066 IF(ngrav/=0) THEN
1067 CALL gravit_imp(igrv ,agrv ,npc ,tf ,a ,
1068 2 v ,x ,skews%SKEW ,ms,wfexc,
1069 3 nsensor,sensor_tab,weight,lgrav,itask,
1070 5 nrbyac,irbyac,npby ,rby , python)
1071 wfext = wfext + wfexc*dt2
1072 ENDIF
1073 IF(nfxvel/=0) THEN
1074 CALL wfv_imp(ibfv ,npc ,tf ,vel ,sensor_tab,
1075 1 d ,dr ,ikc ,iddl ,nsensor ,
1076 2 skews%SKEW ,iframe ,xframe ,dy_a ,dy_ar ,
1077 3 x ,ndof ,ms ,in ,weight,
1078 4 rby ,wfexc )
1079 wfext = wfext + wfexc
1080 ENDIF
1081 IF(idy_damp>0) THEN
1082 wfexc = zero
1083C----------DY_DAM has been already condensed---
1084 DO i = 1 ,numnod
1085 DO j=1,3
1086 nd = iddl(i)+j
1087 IF (ikc(nd) == 0 )
1088 . wfexc = wfexc +d(j,i)*(dy_dam(j,i)+dy_dam0(j,i))*half
1089 END DO
1090 ENDDO
1091 DO i = 1 ,numnod
1092 dy_dam0(1,i) = dy_dam(1,i)
1093 dy_dam0(2,i) = dy_dam(2,i)
1094 dy_dam0(3,i) = dy_dam(3,i)
1095 ENDDO
1096 IF (iroddl/=0) THEN
1097 DO i = 1 ,numnod
1098 DO j=4,ndof(i)
1099 nd = iddl(i)+j
1100 j1=j-3
1101 IF (ikc(nd) == 0 )
1102 . wfexc = wfexc +dr(j,i)*(dy_damr(j,i)+dy_damr0(j,i))*half
1103 ENDDO
1104 ENDDO
1105 DO i = 1 ,numnod
1106 dy_damr0(1,i) = dy_damr(1,i)
1107 dy_damr0(2,i) = dy_damr(2,i)
1108 dy_damr0(3,i) = dy_damr(3,i)
1109 ENDDO
1110 END IF
1111 dy_edamp = dy_edamp + wfexc
1112C DY_EDAMP will added in Eint instead of W_ext (as explicit)
1113C which makes high error (energy) in case of high Rayleigh damping
1114 ENDIF
1115! IF (IMON>0 .AND. ITASK == 0) CALL STOPTIME(TIMERS,4)
1116C
1117 RETURN
1118 END
1119!||====================================================================
1120!|| imp_qifam ../engine/source/implicit/imp_dyna.F
1121!||--- called by ------------------------------------------------------
1122!|| imp_solv ../engine/source/implicit/imp_solv.F
1123!||====================================================================
1124 SUBROUTINE imp_qifam(NODFT ,NODLT ,IDDL ,NDOF ,INLOC ,
1125 . IKC ,DIAG_K ,MS ,IN ,WEIGHT)
1126C-----------------------------------------------
1127C I m p l i c i t T y p e s
1128C-----------------------------------------------
1129#include "implicit_f.inc"
1130C-----------------------------------------------
1131C C o m m o n B l o c k s
1132C-----------------------------------------------
1133#include "com01_c.inc"
1134#include "com08_c.inc"
1135#include "impl2_c.inc"
1136C-----------------------------------------------
1137C D u m m y A r g u m e n t s
1138C-----------------------------------------------
1139 INTEGER NODFT,NODLT,IDDL(*) ,NDOF(*),WEIGHT(*),INLOC(*),IKC(*)
1140 my_real diag_k(*),ms(*),in(*)
1141C-----------------------------------------------
1142C L o c a l V a r i a b l e s
1143C-----------------------------------------------
1144 INTEGER I,J,ND,N,NKC,ID
1145 my_real
1146 . BDT, MKF,MKM,S,S0,D_AL,DY_G,DY_B,FAC,MM
1147C------- IQSTAT >0 add to diag_[k] condens e----------
1148 IF (SCAL_DTQ==one) RETURN
1149C
1150 d_al = -zep05
1151 dy_b = fourth*(one-d_al)*(one-d_al)
1152 s = (one+d_al)*dy_b*dt2*dt2
1153 fac = one/scal_dtq/scal_dtq
1154 bdt = -one/s + fac/s
1155 nkc=0
1156 IF (nspmd>1) THEN
1157 DO n = nodft,nodlt
1158 i=inloc(n)
1159 mkf = abs(ms(i))*bdt*weight(i)
1160 mkm = abs(in(i))*bdt*weight(i)
1161 DO j=1,ndof(i)
1162 nd = iddl(i)+j
1163 id = nd-nkc
1164 IF (j<=3) THEN
1165 mm = mkf
1166 ELSE
1167 mm = mkm
1168 ENDIF
1169 IF (ikc(nd)<1) THEN
1170 diag_k(id)=diag_k(id)+mm
1171 ELSE
1172 nkc=nkc+1
1173 ENDIF
1174 ENDDO
1175 ENDDO
1176 ELSE
1177 DO n = nodft,nodlt
1178 i=inloc(n)
1179 mkf = abs(ms(i))*bdt
1180 mkm = abs(in(i))*bdt
1181 DO j=1,ndof(i)
1182 nd = iddl(i)+j
1183 id = nd-nkc
1184 IF (j<=3) THEN
1185 mm = mkf
1186 ELSE
1187 mm = mkm
1188 ENDIF
1189 IF (ikc(nd)<1) THEN
1190 diag_k(id)=diag_k(id)+mm
1191 ELSE
1192 nkc=nkc+1
1193 ENDIF
1194 ENDDO
1195 ENDDO
1196 ENDIF
1197C--------------------------------------------
1198 RETURN
1199 END
1200!||====================================================================
1201!|| imp_dycrb ../engine/source/implicit/imp_dyna.F
1202!||--- called by ------------------------------------------------------
1203!|| upd_rhs ../engine/source/implicit/upd_glob_k.F
1204!||--- calls -----------------------------------------------------
1205!|| rotbmr ../engine/source/tools/skew/rotbmr.F
1206!||--- uses -----------------------------------------------------
1207!|| imp_dyna ../engine/share/modules/impbufdef_mod.F
1208!||====================================================================
1209 SUBROUTINE imp_dycrb(AM ,IN ,VR ,NBY ,RBY0 ,
1210 . WEIGHT,ICODR ,ISKEW ,SKEW )
1211C-----------------------------------------------
1212C M o d u l e s
1213C-----------------------------------------------
1214 USE imp_dyna
1215C-----------------------------------------------
1216C I m p l i c i t T y p e s
1217C-----------------------------------------------
1218#include "implicit_f.inc"
1219C-----------------------------------------------
1220C C o m m o n B l o c k s
1221C-----------------------------------------------
1222#include "com01_c.inc"
1223#include "com08_c.inc"
1224#include "param_c.inc"
1225C-----------------------------------------------
1226C D u m m y A r g u m e n t s
1227C-----------------------------------------------
1228 INTEGER NBY(*), WEIGHT(*),ICODR(*),ISKEW(*)
1229 my_real
1230 . AM(3,*),IN(*),VR(3,*),RBY0(*),SKEW(LSKEW,*)
1231C-----------------------------------------------
1232C L o c a l V a r i a b l e s
1233C-----------------------------------------------
1234 INTEGER M, NSN, I, N, J, K, LCOD, ISK
1235 my_real WA1, WA2, WA3, DD, VI(3),II1,II2,II3,II4,II5,II6,II7,II8,II9,
1236 . vid(3),rbyd(9),vj(3),rbz(9),
1237 . det, il1,il2,il3,il4,il5,il6,il7,il8,il9,
1238 . rby(25)
1239C-----------------
1240 m=nby(1)
1241 IF(m<0) RETURN
1242 nsn=nby(2)
1243C small treatment for spmd where M is replicated on processors
1244 IF (nspmd>1) THEN
1245 am(1,m) = am(1,m) * weight(m)
1246 am(2,m) = am(2,m) * weight(m)
1247 am(3,m) = am(3,m) * weight(m)
1248 ENDIF
1249C------annule in const-----
1250 am(1,m) = am(1,m) + abs(in(m))*dy_ar(1,m)
1251 am(2,m) = am(2,m) + abs(in(m))*dy_ar(2,m)
1252 am(3,m) = am(3,m) + abs(in(m))*dy_ar(3,m)
1253 DO i = 1, 25
1254 rby(i) = rby0(i)
1255 ENDDO
1256C CORRECTION OF THE INERTIA OF THE RIGID BODY FOR NODAL DT
1257 rby(10) = max(rby(10),in(m))
1258 rby(11) = max(rby(11),in(m))
1259 rby(12) = max(rby(12),in(m))
1260C
1261 isk =iskew(m)
1262 lcod=icodr(m)
1263 IF(lcod/=0)THEN
1264C rotation of the orientation matrix (principal directions)
1265 vi(1)=rby(1)*vr(1,m)+rby(2)*vr(2,m)+rby(3)*vr(3,m)
1266 vi(2)=rby(4)*vr(1,m)+rby(5)*vr(2,m)+rby(6)*vr(3,m)
1267 vi(3)=rby(7)*vr(1,m)+rby(8)*vr(2,m)+rby(9)*vr(3,m)
1268 CALL rotbmr(vi,rby,dt1)
1269C
1270C matrice d'inertie en frame global
1271 ii1=rby(10)*rby(1)
1272 ii2=rby(10)*rby(2)
1273 ii3=rby(10)*rby(3)
1274 ii4=rby(11)*rby(4)
1275 ii5=rby(11)*rby(5)
1276 ii6=rby(11)*rby(6)
1277 ii7=rby(12)*rby(7)
1278 ii8=rby(12)*rby(8)
1279 ii9=rby(12)*rby(9)
1280C
1281 rby(17)=rby(1)*ii1 + rby(4)*ii4 + rby(7)*ii7
1282 rby(18)=rby(1)*ii2 + rby(4)*ii5 + rby(7)*ii8
1283 rby(19)=rby(1)*ii3 + rby(4)*ii6 + rby(7)*ii9
1284 rby(20)=rby(2)*ii1 + rby(5)*ii4 + rby(8)*ii7
1285 rby(21)=rby(2)*ii2 + rby(5)*ii5 + rby(8)*ii8
1286 rby(22)=rby(2)*ii3 + rby(5)*ii6 + rby(8)*ii9
1287 rby(23)=rby(3)*ii1 + rby(6)*ii4 + rby(9)*ii7
1288 rby(24)=rby(3)*ii2 + rby(6)*ii5 + rby(9)*ii8
1289 rby(25)=rby(3)*ii3 + rby(6)*ii6 + rby(9)*ii9
1290C Addition of terms [iglobal] vr ^ vr
1291 wa1=rby(17)*vr(1,m)+rby(18)*vr(2,m)+rby(19)*vr(3,m)
1292 wa2=rby(20)*vr(1,m)+rby(21)*vr(2,m)+rby(22)*vr(3,m)
1293 wa3=rby(23)*vr(1,m)+rby(24)*vr(2,m)+rby(25)*vr(3,m)
1294C
1295 am(1,m)=am(1,m)-(wa2*vr(3,m)-wa3*vr(2,m))*weight(m)
1296 am(2,m)=am(2,m)-(wa3*vr(1,m)-wa1*vr(3,m))*weight(m)
1297 am(3,m)=am(3,m)-(wa1*vr(2,m)-wa2*vr(1,m))*weight(m)
1298C
1299 IF(isk==1)THEN
1300C------------------
1301C GLOBAL REFERENCE FRAME :
1302C Resolution [iglobal] gama = m, given the limits
1303C Ex : gamaz=0
1304C | Ixx Ixy Ixz | { gamax } { Mx }
1305C | Iyx Iyy Iyz | { gamay } = { My }
1306C | Izx Izy Izz | { 0 } { Mz + DMz } DMz inconnue
1307C Equivaut A
1308C | Ixx Ixy | { gamax } { Mx }
1309C | Iyx Iyy | { gamay } = { My }
1310C and gamaz=0
1311C------------------
1312 IF(lcod==1)THEN
1313 det=one/(rby(17)*rby(21)-rby(18)*rby(20))
1314 wa1=-dy_ar(1,m)
1315 wa2=-dy_ar(2,m)
1316 am(1,m)=( rby(21)*wa1-rby(20)*wa2)*det
1317 am(2,m)=(-rby(18)*wa1+rby(17)*wa2)*det
1318 am(3,m)=zero
1319 ELSEIF(lcod==2)THEN
1320 det=one/(rby(17)*rby(25)-rby(19)*rby(23))
1321 wa1=-dy_ar(1,m)
1322 wa2=-dy_ar(3,m)
1323 am(1,m)=( rby(25)*wa1-rby(23)*wa2)*det
1324 am(2,m)=zero
1325 am(3,m)=(-rby(19)*wa1+rby(17)*wa2)*det
1326 ELSEIF(lcod==3)THEN
1327 am(1,m)=-dy_ar(1,m)/rby(17)
1328 am(2,m)=zero
1329 am(3,m)=zero
1330 ELSEIF(lcod==4)THEN
1331 det=one/(rby(21)*rby(25)-rby(22)*rby(24))
1332 wa1=-dy_ar(2,m)
1333 wa2=-dy_ar(3,m)
1334 am(1,m)=zero
1335 am(2,m)=( rby(25)*wa1-rby(24)*wa2)*det
1336 am(3,m)=(-rby(22)*wa1+rby(21)*wa2)*det
1337 ELSEIF(lcod==5)THEN
1338 am(1,m)=zero
1339 am(2,m)=-dy_ar(2,m)/rby(21)
1340 am(3,m)=zero
1341 ELSEIF(lcod==6)THEN
1342 am(1,m)=zero
1343 am(2,m)=zero
1344 am(3,m)=-dy_ar(3,m)/rby(25)
1345 ELSEIF(lcod==7)THEN
1346 am(1,m)=zero
1347 am(2,m)=zero
1348 am(3,m)=zero
1349 ENDIF
1350 ELSE
1351C-------------------
1352C frame OBLIQUE
1353C------------------
1354C
1355C Passage into the skew: (velocity), moments, inertia matrix.
1356C
1357C
1358 wa1=-dy_ar(1,m)
1359 wa2=-dy_ar(2,m)
1360 wa3=-dy_ar(3,m)
1361C
1362 am(1,m)=skew(1,isk)*wa1+skew(2,isk)*wa2+skew(3,isk)*wa3
1363 am(2,m)=skew(4,isk)*wa1+skew(5,isk)*wa2+skew(6,isk)*wa3
1364 am(3,m)=skew(7,isk)*wa1+skew(8,isk)*wa2+skew(9,isk)*wa3
1365C
1366C Resolution in the local frame, given the limits
1367C Ex : v3+gama3*dt12=0
1368C | IL1 IL2 IL3 | { gama1 } { M1 }
1369C | IL4 IL5 IL6 | { gama2 } = { M2 }
1370C |IL7 IL8 IL9 |{-v3/dt12} {m3 + dm3} dm3 unknown
1371C Equivaut A
1372C | IL1 IL2 IL3 | { gama1 } { M1 } | IL1 IL2 IL3 | { 0 }
1373C | IL4 IL5 IL6 | { gama2 } = { M2 } + | IL4 IL5 IL6 | { 0 }
1374C | IL7 IL8 IL9 | { 0 } { M3 + DM3 } | IL7 IL8 IL9 | { v3/dt12 }
1375C
1376C no solution => gama3=0, v'3=0 (reimposed in the boundary condition)
1377C
1378C | IL1 IL2 IL3 | { gama1 } { M1 } | IL1 IL2 IL3 | { gama1 } { M1 }
1379C | IL4 IL5 IL6 | { gama2 } = { M2 } <==> | IL4 IL5 IL6 | { gama2 } = { M2 }
1380C | IL7 IL8 IL9 | { 0 } { M3 + DM3 }
1381C
1382 IF(lcod==1)THEN
1383C
1384 ii1=rby(17)*skew(1,isk)+rby(18)*skew(2,isk)+rby(19)*skew(3,isk)
1385 ii2=rby(17)*skew(4,isk)+rby(18)*skew(5,isk)+rby(19)*skew(6,isk)
1386 ii4=rby(20)*skew(1,isk)+rby(21)*skew(2,isk)+rby(22)*skew(3,isk)
1387 ii5=rby(20)*skew(4,isk)+rby(21)*skew(5,isk)+rby(22)*skew(6,isk)
1388 ii7=rby(23)*skew(1,isk)+rby(24)*skew(2,isk)+rby(25)*skew(3,isk)
1389 ii8=rby(23)*skew(4,isk)+rby(24)*skew(5,isk)+rby(25)*skew(6,isk)
1390 il1=skew(1,isk)*ii1+skew(2,isk)*ii4+skew(3,isk)*ii7
1391 il2=skew(1,isk)*ii2+skew(2,isk)*ii5+skew(3,isk)*ii8
1392 il4=skew(4,isk)*ii1+skew(5,isk)*ii4+skew(6,isk)*ii7
1393 il5=skew(4,isk)*ii2+skew(5,isk)*ii5+skew(6,isk)*ii8
1394C
1395 det=one/(il1*il5-il2*il4)
1396 wa1=-dy_ar(1,m)
1397 wa2=-dy_ar(2,m)
1398 am(1,m)=( il5*wa1-il4*wa2)*det
1399 am(2,m)=(-il2*wa1+il1*wa2)*det
1400 am(3,m)=zero
1401 ELSEIF(lcod==2)THEN
1402 ii1=rby(17)*skew(1,isk)+rby(18)*skew(2,isk)+rby(19)*skew(3,isk)
1403 ii3=rby(17)*skew(7,isk)+rby(18)*skew(8,isk)+rby(19)*skew(9,isk)
1404 ii4=rby(20)*skew(1,isk)+rby(21)*skew(2,isk)+rby(22)*skew(3,isk)
1405 ii6=rby(20)*skew(7,isk)+rby(21)*skew(8,isk)+rby(22)*skew(9,isk)
1406 ii7=rby(23)*skew(1,isk)+rby(24)*skew(2,isk)+rby(25)*skew(3,isk)
1407 ii9=rby(23)*skew(7,isk)+rby(24)*skew(8,isk)+rby(25)*skew(9,isk)
1408 il1=skew(1,isk)*ii1+skew(2,isk)*ii4+skew(3,isk)*ii7
1409 il3=skew(1,isk)*ii3+skew(2,isk)*ii6+skew(3,isk)*ii9
1410 il7=skew(7,isk)*ii1+skew(8,isk)*ii4+skew(9,isk)*ii7
1411 il9=skew(7,isk)*ii3+skew(8,isk)*ii6+skew(9,isk)*ii9
1412C
1413 det=one/(il1*il9-il3*il7)
1414 wa1=-dy_ar(1,m)
1415 wa2=-dy_ar(3,m)
1416 am(1,m)=( il9*wa1-il7*wa2)*det
1417 am(2,m)=zero
1418 am(3,m)=(-il3*wa1+il1*wa2)*det
1419 ELSEIF(lcod==3)THEN
1420 ii1=rby(17)*skew(1,isk)+rby(18)*skew(2,isk)+rby(19)*skew(3,isk)
1421 ii4=rby(20)*skew(1,isk)+rby(21)*skew(2,isk)+rby(22)*skew(3,isk)
1422 ii7=rby(23)*skew(1,isk)+rby(24)*skew(2,isk)+rby(25)*skew(3,isk)
1423 il1=skew(1,isk)*ii1+skew(2,isk)*ii4+skew(3,isk)*ii7
1424C
1425 am(1,m)=-dy_ar(1,m)/il1
1426 am(2,m)=zero
1427 am(3,m)=zero
1428 ELSEIF(lcod==4)THEN
1429 ii2=rby(17)*skew(4,isk)+rby(18)*skew(5,isk)+rby(19)*skew(6,isk)
1430 ii3=rby(17)*skew(7,isk)+rby(18)*skew(8,isk)+rby(19)*skew(9,isk)
1431 ii5=rby(20)*skew(4,isk)+rby(21)*skew(5,isk)+rby(22)*skew(6,isk)
1432 ii6=rby(20)*skew(7,isk)+rby(21)*skew(8,isk)+rby(22)*skew(9,isk)
1433 ii8=rby(23)*skew(4,isk)+rby(24)*skew(5,isk)+rby(25)*skew(6,isk)
1434 ii9=rby(23)*skew(7,isk)+rby(24)*skew(8,isk)+rby(25)*skew(9,isk)
1435 il5=skew(4,isk)*ii2+skew(5,isk)*ii5+skew(6,isk)*ii8
1436 il6=skew(4,isk)*ii3+skew(5,isk)*ii6+skew(6,isk)*ii9
1437 il8=skew(7,isk)*ii2+skew(8,isk)*ii5+skew(9,isk)*ii8
1438 il9=skew(7,isk)*ii3+skew(8,isk)*ii6+skew(9,isk)*ii9
1439C
1440 det=one/(il5*il9-il6*il8)
1441 wa1=-dy_ar(2,m)
1442 wa2=-dy_ar(3,m)
1443 am(1,m)=zero
1444 am(2,m)=( il9*wa1-il8*wa2)*det
1445 am(3,m)=(-il6*wa1+il5*wa2)*det
1446 ELSEIF(lcod==5)THEN
1447 ii2=rby(17)*skew(4,isk)+rby(18)*skew(5,isk)+rby(19)*skew(6,isk)
1448 ii5=rby(20)*skew(4,isk)+rby(21)*skew(5,isk)+rby(22)*skew(6,isk)
1449 ii8=rby(23)*skew(4,isk)+rby(24)*skew(5,isk)+rby(25)*skew(6,isk)
1450 il5=skew(4,isk)*ii2+skew(5,isk)*ii5+skew(6,isk)*ii8
1451C
1452 am(1,m)=zero
1453 am(2,m)=-dy_ar(2,m)/il5
1454 am(3,m)=zero
1455 ELSEIF(lcod==6)THEN
1456 ii3=rby(17)*skew(7,isk)+rby(18)*skew(8,isk)+rby(19)*skew(9,isk)
1457 ii6=rby(20)*skew(7,isk)+rby(21)*skew(8,isk)+rby(22)*skew(9,isk)
1458 ii9=rby(23)*skew(7,isk)+rby(24)*skew(8,isk)+rby(25)*skew(9,isk)
1459 il9=skew(7,isk)*ii3+skew(8,isk)*ii6+skew(9,isk)*ii9
1460C
1461 am(1,m)=zero
1462 am(2,m)=zero
1463 am(3,m)=-dy_ar(3,m)/il9
1464 ELSEIF(lcod==7)THEN
1465 am(1,m)=zero
1466 am(2,m)=zero
1467 am(3,m)=zero
1468 ENDIF
1469 wa1=am(1,m)
1470 wa2=am(2,m)
1471 wa3=am(3,m)
1472C
1473 am(1,m)=skew(1,isk)*wa1+skew(4,isk)*wa2+skew(7,isk)*wa3
1474 am(2,m)=skew(2,isk)*wa1+skew(5,isk)*wa2+skew(8,isk)*wa3
1475 am(3,m)=skew(3,isk)*wa1+skew(6,isk)*wa2+skew(9,isk)*wa3
1476 ENDIF ! IF(ISK==1)THEN
1477C
1478 ELSE
1479C
1480 wa1=-dy_ar(1,m)
1481 wa2=-dy_ar(2,m)
1482 wa3=-dy_ar(3,m)
1483C frame globale -> frame d'inertie principale
1484 am(1,m)=rby(1)*wa1+rby(2)*wa2+rby(3)*wa3
1485 am(2,m)=rby(4)*wa1+rby(5)*wa2+rby(6)*wa3
1486 am(3,m)=rby(7)*wa1+rby(8)*wa2+rby(9)*wa3
1487C vr contributions are only added on the main processor
1488 vi(1)=rby(1)*vr(1,m)+rby(2)*vr(2,m)+rby(3)*vr(3,m)
1489 vi(2)=rby(4)*vr(1,m)+rby(5)*vr(2,m)+rby(6)*vr(3,m)
1490 vi(3)=rby(7)*vr(1,m)+rby(8)*vr(2,m)+rby(9)*vr(3,m)
1491 DO k=1,9
1492 rbz(k)=rby(k)
1493 ENDDO
1494 CALL rotbmr(vi,rby,dt1)
1495C
1496 am(1,m) = am(1,m) - (rby(11)-rby(12))*vi(2)*vi(3)*weight(m)
1497 am(2,m) = am(2,m) - (rby(12)-rby(10))*vi(3)*vi(1)*weight(m)
1498 am(3,m) = am(3,m) - (rby(10)-rby(11))*vi(1)*vi(2)*weight(m)
1499C
1500C CALCULATION D'ONE PSEUDO MOMENT:
1501C IN FACT THE ROTATION ACCELERATION * INERTIA OF THE MAIN NODE (IMIN OF THE RB)
1502C--------
1503 wa1 = am(1,m)*rby(10)
1504 wa2 = am(2,m)*rby(11)
1505 wa3 = am(3,m)*rby(12)
1506C frame d'inertie principale -> frame globale
1507 am(1,m)=rby(1)*wa1+rby(4)*wa2+rby(7)*wa3
1508 am(2,m)=rby(2)*wa1+rby(5)*wa2+rby(8)*wa3
1509 am(3,m)=rby(3)*wa1+rby(6)*wa2+rby(9)*wa3
1510 ENDIF
1511C--------------------------------------------
1512 RETURN
1513 END
1514!||====================================================================
1515!|| dyna_iniv ../engine/source/implicit/imp_dyna.F
1516!||--- uses -----------------------------------------------------
1517!|| imp_dyna ../engine/share/modules/impbufdef_mod.F
1518!||====================================================================
1519 SUBROUTINE dyna_iniv(NODFT ,NODLT ,MS ,IN ,D ,DR )
1520C-----------------------------------------------
1521C M o d u l e s
1522C-----------------------------------------------
1523 USE imp_dyna
1524C-----------------------------------------------
1525C I m p l i c i t T y p e s
1526C-----------------------------------------------
1527#include "implicit_f.inc"
1528C-----------------------------------------------
1529C C o m m o n B l o c k s
1530C-----------------------------------------------
1531#include "com01_c.inc"
1532#include "com08_c.inc"
1533#include "impl1_c.inc"
1534C-----------------------------------------------
1535C D u m m y A r g u m e n t s
1536C-----------------------------------------------
1537C REAL
1538 INTEGER NODFT,NODLT,IDIV
1539 my_real
1540 . d(3,*),dr(3,*),ms(*) ,in(*)
1541C-----------------------------------------------
1542C L o c a l V a r i a b l e s
1543C-----------------------------------------------
1544 INTEGER N,I
1545 my_real
1546 . adt,bdt,tmp,tmp1
1547C------------------------------------------
1548C-------------seems more stable with predictor d=0 when there is DY_DAM
1549 IF (idy_damp==0) THEN
1550 DO i=nodft,nodlt
1551 d(1,i)=dy_d(1,i)
1552 d(2,i)=dy_d(2,i)
1553 d(3,i)=dy_d(3,i)
1554 ENDDO
1555 IF (iroddl/=0) THEN
1556 DO i=nodft,nodlt
1557 dr(1,i)=dy_dr(1,i)
1558 dr(2,i)=dy_dr(2,i)
1559 dr(3,i)=dy_dr(3,i)
1560 ENDDO
1561 ENDIF
1562C
1563 ELSE
1564 DO i=nodft,nodlt
1565 d(1,i)=dy_d(1,i)*em3
1566 d(2,i)=dy_d(2,i)*em3
1567 d(3,i)=dy_d(3,i)*em3
1568 ENDDO
1569 IF (iroddl/=0) THEN
1570 DO i=nodft,nodlt
1571 dr(1,i)=dy_dr(1,i)*em3
1572 dr(2,i)=dy_dr(2,i)*em3
1573 dr(3,i)=dy_dr(3,i)*em3
1574 ENDDO
1575 ENDIF
1576 adt = (one-dy_g)*dt2
1577 bdt = (half-dy_b)*dt2*dt2
1578 DO i=nodft,nodlt
1579 IF(ms(i)>0.) THEN
1580 tmp = adt / ms(i)
1581 dy_v(1,i)=dy_v(1,i)-tmp*dy_dam(1,i)
1582 dy_v(2,i)=dy_v(2,i)-tmp*dy_dam(2,i)
1583 dy_v(3,i)=dy_v(3,i)-tmp*dy_dam(3,i)
1584C
1585 tmp1 = bdt / ms(i)
1586 dy_d(1,i)=dy_d(1,i)-tmp1*dy_dam(1,i)
1587 dy_d(2,i)=dy_d(2,i)-tmp1*dy_dam(2,i)
1588 dy_d(3,i)=dy_d(3,i)-tmp1*dy_dam(3,i)
1589 ENDIF
1590 ENDDO
1591 IF (iroddl/=0) THEN
1592 DO i=nodft,nodlt
1593 IF(in(i)>0.) THEN
1594 tmp = adt / in(i)
1595 dy_vr(1,i)=dy_vr(1,i)-tmp*dy_damr(1,i)
1596 dy_vr(2,i)=dy_vr(2,i)-tmp*dy_damr(2,i)
1597 dy_vr(3,i)=dy_vr(3,i)-tmp*dy_damr(3,i)
1598C
1599 tmp1 = bdt / in(i)
1600 dy_dr(1,i)=dy_dr(1,i)-tmp1*dy_damr(1,i)
1601 dy_dr(2,i)=dy_dr(2,i)-tmp1*dy_damr(2,i)
1602 dy_dr(3,i)=dy_dr(3,i)-tmp1*dy_damr(3,i)
1603 ENDIF
1604 ENDDO
1605 ENDIF
1606 END IF !IF (IDY_DAMP==0)
1607C--------------------------------------------
1608 RETURN
1609 END
1610!||====================================================================
1611!|| dyna_ivfac ../engine/source/implicit/imp_dyna.F
1612!||--- calls -----------------------------------------------------
1613!|| my_barrier ../engine/source/system/machine.F
1614!|| spmd_sum_s ../engine/source/mpi/implicit/imp_spmd.F
1615!||--- uses -----------------------------------------------------
1616!|| imp_dyna ../engine/share/modules/impbufdef_mod.F
1617!||====================================================================
1618 SUBROUTINE dyna_ivfac(NODFT ,NODLT ,MS ,IN ,WEIGHT,
1619 . EN_I ,EFAC ,ITASK)
1620C-----------------------------------------------
1621C M o d u l e s
1622C-----------------------------------------------
1623 USE imp_dyna
1624C-----------------------------------------------
1625C I m p l i c i t T y p e s
1626C-----------------------------------------------
1627#include "implicit_f.inc"
1628#include "comlock.inc"
1629C-----------------------------------------------
1630C C o m m o n B l o c k s
1631C-----------------------------------------------
1632#include "com01_c.inc"
1633#include "impl2_c.inc"
1634C-----------------------------------------------
1635C D u m m y A r g u m e n t s
1636C-----------------------------------------------
1637C REAL
1638 INTEGER NODFT,NODLT,WEIGHT(*),ITASK
1639 my_real
1640 . MS(*) ,IN(*),EFAC,EN_I
1641C-----------------------------------------------
1642C L o c a l V a r i a b l e s
1643C-----------------------------------------------
1644 INTEGER I
1645 my_real
1646 . dt05,vx,vy,vz,mas,en_k
1647C------------------------------------------
1648 IF (itask==0) r_n2 = zero
1649C----------------------
1650 CALL my_barrier
1651C---------------------
1652 dt05=zero
1653 en_k=zero
1654 DO i = nodft ,nodlt
1655 mas=ms(i)*weight(i)
1656 vx = dy_v(1,i) - dt05*dy_a(1,i)
1657 vy = dy_v(2,i) - dt05*dy_a(2,i)
1658 vz = dy_v(3,i) - dt05*dy_a(3,i)
1659 en_k= en_k+ ( vx*vx + vy*vy + vz*vz)*half*mas
1660 ENDDO
1661 IF(iroddl/=0)THEN
1662 DO i = nodft ,nodlt
1663 mas=in(i)*weight(i)
1664 vx = dy_vr(1,i) - dt05*dy_ar(1,i)
1665 vy = dy_vr(2,i) - dt05*dy_ar(2,i)
1666 vz = dy_vr(3,i) - dt05*dy_ar(3,i)
1667 en_k=en_k + (vx*vx + vy*vy + vz*vz)*half*mas
1668
1669 ENDDO
1670 ENDIF
1671#include "lockon.inc"
1672 r_n2= r_n2 + en_k
1673#include "lockoff.inc"
1674C----------------------
1675 CALL my_barrier
1676C---------------------
1677 IF (itask==0) CALL spmd_sum_s(r_n2)
1678C----------------------
1679 CALL my_barrier
1680C---------------------
1681 efac = r_n2/max(em20,en_i)
1682 efac = min(one,efac)
1683C--------------------------------------------
1684 RETURN
1685 END
1686!||====================================================================
1687!|| dyna_cpk0 ../engine/source/implicit/imp_dyna.F
1688!||--- called by ------------------------------------------------------
1689!|| imp_solv ../engine/source/implicit/imp_solv.F
1690!||--- calls -----------------------------------------------------
1691!|| cp_int ../engine/source/implicit/produt_v.F
1692!|| cp_real ../engine/source/implicit/produt_v.F
1693!||--- uses -----------------------------------------------------
1694!|| imp_dyna ../engine/share/modules/impbufdef_mod.F
1695!||====================================================================
1696 SUBROUTINE dyna_cpk0(NDDL ,NNZK ,IADK ,JDIK ,DIAG_K ,
1697 . LT_K )
1698C-----------------------------------------------
1699C M o d u l e s
1700C-----------------------------------------------
1701 USE imp_dyna
1702C-----------------------------------------------
1703C I m p l i c i t T y p e s
1704C-----------------------------------------------
1705#include "implicit_f.inc"
1706C-----------------------------------------------
1707C C o m m o n B l o c k s
1708C-----------------------------------------------
1709#include "impl1_c.inc"
1710#include "com01_c.inc"
1711C-----------------------------------------------
1712C D u m m y A r g u m e n t s
1713C-----------------------------------------------
1714C REAL
1715 INTEGER NDDL ,NNZK ,IADK(*) ,JDIK(*)
1716 my_real
1717 . DIAG_K(*) ,LT_K(*)
1718C-----------------------------------------------
1719C L o c a l V a r i a b l e s
1720C-----------------------------------------------
1721 INTEGER I
1722C------------------------------------------
1723 IF (ISMDISP>0.AND.(NCYCLE>1.OR.INCONV/=1)) return
1724C
1725 CALL cp_int(nddl+1,iadk,dy_iadk0)
1726 CALL cp_int(nnzk,jdik,dy_jdik0)
1727 CALL cp_real(nddl,diag_k,dy_diak0)
1728 CALL cp_real(nnzk,lt_k,dy_ltk0)
1729C--------------------------------------------
1730 RETURN
1731 END
1732!||====================================================================
1733!|| imp_dykv ../engine/source/implicit/imp_dyna.F
1734!||--- called by ------------------------------------------------------
1735!|| imp_solv ../engine/source/implicit/imp_solv.F
1736!||--- calls -----------------------------------------------------
1737!|| i2_impr1 ../engine/source/interfaces/interf/i2_imp1.F
1738!|| i2_impr2 ../engine/source/interfaces/interf/i2_imp1.F
1739!|| imp_setb ../engine/source/implicit/imp_setb.F
1740!|| mav_lt ../engine/source/implicit/produt_v.F
1741!|| rbe2_impr1 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
1742!|| rbe3_impr1 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
1743!|| rbe3_impr2 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
1744!|| rby_impr1 ../engine/source/constraints/general/rbody/rby_imp0.F
1745!|| rby_impr2 ../engine/source/constraints/general/rbody/rby_imp0.F
1746!|| spmd_sumf_a ../engine/source/mpi/implicit/imp_spmd.F
1747!||--- uses -----------------------------------------------------
1748!|| imp_dyna ../engine/share/modules/impbufdef_mod.F
1749!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
1750!||====================================================================
1751 SUBROUTINE imp_dykv(NODFT ,NODLT ,IDDL ,NDOF ,IKC ,
1752 . DIAG_K ,IADK ,JDIK ,LT_K ,WEIGHT ,
1753 1 RBY ,X ,SKEW ,LPBY ,NPBY ,
1754 2 NRBYAC ,IRBYAC ,NINT2 ,IINT2 ,IPARI ,
1755 3 INTBUF_TAB ,IRBE3 ,LRBE3 ,FRBE3 ,
1756 4 IRBE2 ,LRBE2 ,V ,VR ,NDDL ,
1757 5 FR_ELEM,IAD_ELEM,MS ,IN )
1758C-----------------------------------------------
1759C M o d u l e s
1760C-----------------------------------------------
1761 USE imp_dyna
1762 USE intbufdef_mod
1763C-----------------------------------------------
1764C I m p l i c i t T y p e s
1765C-----------------------------------------------
1766#include "implicit_f.inc"
1767C-----------------------------------------------
1768C C o m m o n B l o c k s
1769C-----------------------------------------------
1770#include "com01_c.inc"
1771#include "com04_c.inc"
1772#include "param_c.inc"
1773#include "impl2_c.inc"
1774C-----------------------------------------------
1775C D u m m y A r g u m e n t s
1776C-----------------------------------------------
1777 INTEGER NODFT,NODLT,IDDL(*) ,NDOF(*),IADK(*),
1778 . IKC(*),JDIK(*),NDDL ,FR_ELEM(*),IAD_ELEM(2,*)
1779 INTEGER NINT2 ,IINT2(*),LPBY(*),NPBY(NNPBY,*),
1780 . IPARI(NPARI,*), NRBYAC,IRBYAC(*)
1781 INTEGER WEIGHT(*),IRBE3(*),LRBE3(*),IRBE2(*),LRBE2(*)
1782C REAL
1783 my_real
1784 . DIAG_K(*),V(3,*),VR(3,*),LT_K(*),FRBE3(*),
1785 . RBY(NRBY,*) ,X(3,*) ,SKEW(*),MS(*),IN(*)
1786 TYPE(intbuf_struct_) INTBUF_TAB(*)
1787C-----------------------------------------------
1788C L o c a l V a r i a b l e s
1789C-----------------------------------------------
1790 INTEGER I,J,ND,NNZ,NKC,N,ID,JR,JI,JB,K1
1791 my_real
1792 . U(NDDL),W(NDDL),ADT1,MKF,MKM,TMP
1793C------- using v,than v(t+dt) is more stable-especially at beginning-----
1794 CALL IMP_SETB(V ,VR ,IDDL ,NDOF ,U )
1795c CALL IMP_SETB(DY_V ,DY_VR ,IDDL ,NDOF ,U )
1796 nnz=dy_iadk0(nddl+1)-dy_iadk0(1)
1797 DO i=1,nddl
1798 w(i)=zero
1799 ENDDO
1800 CALL mav_lt(
1801 1 nddl ,nnz ,dy_iadk0,dy_jdik0 ,dy_diak0,
1802 2 dy_ltk0,u ,w )
1803C----add aM ------
1804 IF (iroddl==0) THEN
1805 DO i = nodft ,nodlt
1806 nd = iddl(i)
1807 mkf = abs(ms(i))*weight(i)
1808 DO j =1,ndof(i)
1809 id = nd + j
1810 tmp=dampa_imp*mkf*v(j,i)+dampb_imp*w(id)
1811 dy_dam(j,i)=tmp
1812 w(id) = tmp
1813 ENDDO
1814 ENDDO
1815 ELSE
1816 DO i = nodft ,nodlt
1817 nd = iddl(i)
1818 mkf = abs(ms(i))*weight(i)
1819 mkm = abs(in(i))*weight(i)
1820 DO j =1,ndof(i)
1821 id = nd + j
1822 IF (j>3) THEN
1823 jr=j-3
1824 tmp=dampa_imp*mkm*vr(jr,i)+dampb_imp*w(id)
1825 dy_damr(jr,i)=tmp
1826 w(id) = tmp
1827 ELSE
1828 tmp=dampa_imp*mkf*v(j,i)+dampb_imp*w(id)
1829 dy_dam(j,i)=tmp
1830 w(id) = tmp
1831 ENDIF
1832 ENDDO
1833 ENDDO
1834 END IF
1835C-------int2,RBE3,rby condense----------
1836 DO i=1,nint2
1837 n=iint2(i)
1838 CALL i2_impr1(ipari(1,n),intbuf_tab(n) ,
1839 . x ,ndof ,iddl ,w )
1840 ENDDO
1841 IF (nrbe2>0) THEN
1842 CALL rbe2_impr1(
1843 1 irbe2 ,lrbe2 ,x ,skew ,ndof ,
1844 2 iddl ,w ,weight)
1845 ENDIF
1846 IF (nrbe3>0) THEN
1847 CALL rbe3_impr1(
1848 1 irbe3 ,lrbe3 ,frbe3 ,x ,skew ,
1849 2 ndof ,iddl ,w ,weight)
1850 ENDIF
1851 DO i=1,nrbyac
1852 n=irbyac(i)
1853 k1=irbyac(i+nrbykin)+1
1854 CALL rby_impr1(x, rby(1,n),lpby(k1),npby(1,n),
1855 1 ndof ,iddl ,w )
1856 ENDDO
1857C-------int2,rby speciale (elements deleted)----------
1858 DO i=1,nint2
1859 n=iint2(i)
1860 CALL i2_impr2(ipari(1,n),intbuf_tab(n) ,dy_dam ,dy_damr,
1861 . x ,ndof ,iddl ,w )
1862 ENDDO
1863 IF (nrbe3>0) THEN
1864 CALL rbe3_impr2(
1865 1 irbe3 ,lrbe3 ,frbe3 ,x ,skew ,
1866 2 ndof ,iddl ,w ,weight,dy_dam ,
1867 3 dy_damr)
1868 ENDIF
1869 DO i=1,nrbyac
1870 n=irbyac(i)
1871 k1=irbyac(i+nrbykin)+1
1872 CALL rby_impr2(x, rby(1,n),lpby(k1),npby(1,n),
1873 1 ndof ,iddl ,w ,dy_dam ,dy_damr)
1874 ENDDO
1875C
1876 DO i = nodft ,nodlt
1877 nd = iddl(i)
1878 DO j =1,ndof(i)
1879 id = nd + j
1880 IF (j>3) THEN
1881 jr=j-3
1882 dy_damr(jr,i)=w(id)
1883 ELSE
1884 dy_dam(j,i)=w(id)
1885 ENDIF
1886 ENDDO
1887 ENDDO
1888C
1889 IF (nspmd>1) THEN
1890 nd = iad_elem(1,nspmd+1)-iad_elem(1,1)
1891 IF (iroddl/=0) THEN
1892 jr = 6
1893 ELSE
1894 jr = 3
1895 ENDIF
1896 CALL spmd_sumf_a(dy_dam,dy_damr,iad_elem,fr_elem,jr,nd)
1897 ENDIF
1898C--------------------------------------------
1899 RETURN
1900 END
1901!||====================================================================
1902!|| getdyna_a ../engine/source/implicit/imp_dyna.F
1903!||--- called by ------------------------------------------------------
1904!|| rgwal0_imp ../engine/source/constraints/general/rwall/rgwal0.F
1905!||--- uses -----------------------------------------------------
1906!|| imp_dyna ../engine/share/modules/impbufdef_mod.F
1907!||====================================================================
1908 SUBROUTINE getdyna_a(NODFT,NODLT,A )
1909C-----------------------------------------------
1910C M o d u l e s
1911C-----------------------------------------------
1912 USE imp_dyna
1913C-----------------------------------------------
1914C I m p l i c i t T y p e s
1915C-----------------------------------------------
1916#include "implicit_f.inc"
1917C-----------------------------------------------
1918C D u m m y A r g u m e n t s
1919C-----------------------------------------------
1920C REAL
1921 INTEGER NODFT,NODLT
1922 my_real
1923 . a(3,*)
1924C-----------------------------------------------
1925C L o c a l V a r i a b l e s
1926C-----------------------------------------------
1927 INTEGER I
1928C------------------------------------------
1929 DO i=nodft,nodlt
1930 a(1,i)=dy_a(1,i)
1931 a(2,i)=dy_a(2,i)
1932 a(3,i)=dy_a(3,i)
1933 ENDDO
1934C--------------------------------------------
1935 RETURN
1936 END
1937!||====================================================================
1938!|| imp_dykv0 ../engine/source/implicit/imp_dyna.F
1939!||--- called by ------------------------------------------------------
1940!|| imp_solv ../engine/source/implicit/imp_solv.F
1941!||--- calls -----------------------------------------------------
1942!|| i2_impr1 ../engine/source/interfaces/interf/i2_imp1.F
1943!|| i2_impr2 ../engine/source/interfaces/interf/i2_imp1.F
1944!|| imp_setb ../engine/source/implicit/imp_setb.F
1945!|| mav_lt ../engine/source/implicit/produt_v.F
1946!|| rbe2_impr1 ../engine/source/constraints/general/rbe2/rbe2_imp0.F
1947!|| rbe3_impr1 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
1948!|| rbe3_impr2 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
1949!|| rby_impr1 ../engine/source/constraints/general/rbody/rby_imp0.F
1950!|| rby_impr2 ../engine/source/constraints/general/rbody/rby_imp0.F
1951!|| spmd_sumf_a ../engine/source/mpi/implicit/imp_spmd.F
1952!||--- uses -----------------------------------------------------
1953!|| imp_dyna ../engine/share/modules/impbufdef_mod.F
1954!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
1955!||====================================================================
1956 SUBROUTINE imp_dykv0(NODFT ,NODLT ,IDDL ,NDOF ,IKC ,
1957 . DIAG_K ,IADK ,JDIK ,LT_K ,WEIGHT ,
1958 1 RBY ,X ,SKEW ,LPBY ,NPBY ,
1959 2 NRBYAC ,IRBYAC ,NINT2 ,IINT2 ,IPARI ,
1960 3 INTBUF_TAB ,IRBE3 ,LRBE3 ,FRBE3 ,
1961 4 IRBE2 ,LRBE2 ,V ,VR ,NDDL ,
1962 5 FR_ELEM,IAD_ELEM,MS ,IN )
1963C-----------------------------------------------
1964C M o d u l e s
1965C-----------------------------------------------
1966 USE imp_dyna
1967 USE intbufdef_mod
1968C-----------------------------------------------
1969C I m p l i c i t T y p e s
1970C-----------------------------------------------
1971#include "implicit_f.inc"
1972C-----------------------------------------------
1973C C o m m o n B l o c k s
1974C-----------------------------------------------
1975#include "com01_c.inc"
1976#include "com04_c.inc"
1977#include "param_c.inc"
1978C-----------------------------------------------
1979C D u m m y A r g u m e n t s
1980C-----------------------------------------------
1981 INTEGER NODFT,NODLT,IDDL(*) ,NDOF(*),IADK(*),
1982 . IKC(*),JDIK(*),NDDL ,FR_ELEM(*),IAD_ELEM(2,*)
1983 INTEGER NINT2 ,IINT2(*),LPBY(*),NPBY(NNPBY,*),
1984 . IPARI(NPARI,*), NRBYAC,IRBYAC(*)
1985 INTEGER WEIGHT(*),IRBE3(*),LRBE3(*),IRBE2(*),LRBE2(*)
1986C REAL
1987 my_real
1988 . DIAG_K(*),V(3,*),VR(3,*),LT_K(*),FRBE3(*),
1989 . RBY(NRBY,*) ,X(3,*) ,SKEW(*),MS(*),IN(*)
1990
1991 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
1992C-----------------------------------------------
1993C L o c a l V a r i a b l e s
1994C-----------------------------------------------
1995 INTEGER I,J,ND,NNZ,NKC,N,ID,JR,JI,JB,K1
1996 my_real
1997 . u(nddl),w(nddl),adt1,mkf,mkm,tmp
1998C------- estimation of A(t+dt) w/ initial velocity------
1999 CALL imp_setb(dy_d ,dy_dr ,iddl ,ndof ,u )
2000 DO i=1,nddl
2001 w(i)=zero
2002 ENDDO
2003 nnz=iadk(nddl+1)-iadk(1)
2004 CALL mav_lt(
2005 1 nddl ,nnz ,iadk,jdik ,diag_k,
2006 2 lt_k ,u ,w )
2007C-------int2,RBE3,rby condense----------
2008 DO i=1,nint2
2009 n=iint2(i)
2010 ji=ipari(1,n)
2011 jb=ipari(2,n)
2012 CALL i2_impr1(ipari(1,n),intbuf_tab(n) ,
2013 . x ,ndof ,iddl ,w )
2014 ENDDO
2015 IF (nrbe2>0) THEN
2016 CALL rbe2_impr1(
2017 1 irbe2 ,lrbe2 ,x ,skew ,ndof ,
2018 2 iddl ,w ,weight)
2019 ENDIF
2020 IF (nrbe3>0) THEN
2021 CALL rbe3_impr1(
2022 1 irbe3 ,lrbe3 ,frbe3 ,x ,skew ,
2023 2 ndof ,iddl ,w ,weight)
2024 ENDIF
2025 DO i=1,nrbyac
2026 n=irbyac(i)
2027 k1=irbyac(i+nrbykin)+1
2028 CALL rby_impr1(x, rby(1,n),lpby(k1),npby(1,n),
2029 1 ndof ,iddl ,w )
2030 ENDDO
2031C-------int2,rby speciale (elements deleted)----------
2032 DO i=1,nint2
2033 n=iint2(i)
2034 CALL i2_impr2(ipari(1,n),intbuf_tab(n) ,dy_a ,dy_ar,
2035 . x ,ndof ,iddl ,w )
2036 ENDDO
2037 IF (nrbe3>0) THEN
2038 CALL rbe3_impr2(
2039 1 irbe3 ,lrbe3 ,frbe3 ,x ,skew ,
2040 2 ndof ,iddl ,w ,weight,dy_a ,
2041 3 dy_ar )
2042 ENDIF
2043 DO i=1,nrbyac
2044 n=irbyac(i)
2045 k1=irbyac(i+nrbykin)+1
2046 CALL rby_impr2(x, rby(1,n),lpby(k1),npby(1,n),
2047 1 ndof ,iddl ,w ,dy_a ,dy_ar)
2048 ENDDO
2049C---- ------
2050 IF (iroddl==0) THEN
2051 DO i = nodft ,nodlt
2052 IF(ms(i)>0.) THEN
2053 tmp = one / ms(i)
2054 nd = iddl(i)
2055 DO j =1,ndof(i)
2056 id = nd + j
2057 dy_a(j,i)=-tmp*w(id)
2058 ENDDO
2059 END IF !(MS(I)>0.) THEN
2060 ENDDO
2061 ELSE
2062 DO i = nodft ,nodlt
2063 nd = iddl(i)
2064 IF(ms(i)>0.) THEN
2065 tmp = one / ms(i)
2066 DO j =1,min(3,ndof(i))
2067 id = nd + j
2068 dy_a(j,i)=-tmp*w(id)
2069 ENDDO
2070 END IF !(MS(I)>0.) THEN
2071C
2072 IF(in(i)>0.) THEN
2073 tmp = one / in(i)
2074 DO j =4,ndof(i)
2075 id = nd + j
2076 dy_ar(j-3,i)=-tmp*w(id)
2077 ENDDO
2078 END IF !(IN(I)>0.) THEN
2079 ENDDO
2080 END IF
2081C
2082 IF (nspmd>1) THEN
2083 nd = iad_elem(1,nspmd+1)-iad_elem(1,1)
2084 IF (iroddl/=0) THEN
2085 jr = 6
2086 ELSE
2087 jr = 3
2088 ENDIF
2089 CALL spmd_sumf_a(dy_a,dy_ar,iad_elem,fr_elem,jr,nd)
2090 ENDIF
2091C--------------------------------------------
2092 RETURN
2093 END
2094!||====================================================================
2095!|| imp_fhht1 ../engine/source/implicit/imp_dyna.F
2096!||--- called by ------------------------------------------------------
2097!|| upd_rhs ../engine/source/implicit/upd_glob_k.F
2098!||--- calls -----------------------------------------------------
2099!|| condens_b ../engine/source/implicit/upd_glob_k.F
2100!||--- uses -----------------------------------------------------
2101!|| imp_dyna ../engine/share/modules/impbufdef_mod.F
2102!||====================================================================
2103 SUBROUTINE imp_fhht1(NDDL0 ,NDDL ,LB ,IKC )
2104C-----------------------------------------------
2105C M o d u l e s
2106C-----------------------------------------------
2107 USE imp_dyna
2108C-----------------------------------------------
2109C I m p l i c i t T y p e s
2110C-----------------------------------------------
2111#include "implicit_f.inc"
2112C-----------------------------------------------
2113C C o m m o n B l o c k s
2114C-----------------------------------------------
2115#include "impl2_c.inc"
2116C-----------------------------------------------
2117C D u m m y A r g u m e n t s
2118C-----------------------------------------------
2119 INTEGER NDDL0 ,NDDL,IKC(*)
2120C REAL
2121 my_real
2122 . lb(*)
2123C-----------------------------------------------
2124C L o c a l V a r i a b l e s
2125C-----------------------------------------------
2126 INTEGER I,J,K
2127 my_real
2128 . db(nddl0)
2129C----- db in lb-;du to SPMD version---------
2130 IF (hht_a==zero) RETURN
2131C
2132 DO i=1,nddl0
2133 db(i) = dy_r0(i)
2134 ENDDO
2135 CALL condens_b(nddl0 ,ikc ,db )
2136 DO i=1,nddl
2137 lb(i) = lb(i)+ db(i)
2138 ENDDO
2139C--------------------------------------------
2140 RETURN
2141 END
2142
my_real
#define my_real
Definition cppsort.cpp:32
force_imp
subroutine force_imp(ib, fac, snpc, npc, tf, a, v, x, skews, ar, vr, nsensor, sensor_tab, wfexc, iadc, fsky, fext, h3d_data, cptreac, fthreac, nodreac, th_surf, dpl0cld, vel0cld, d, dr, nconld, numnod, nfunct, stf, wfext)
Definition force_imp.F:50
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
gravit_imp
subroutine gravit_imp(igrv, agrv, npc, tf, a, v, x, skew, ms, wfextt, nsensor, sensor_tab, weight, ib, itask, nrbyac, irbyac, npby, rby, python)
Definition gravit_imp.F:42
i2_impr1
subroutine i2_impr1(ipari, intbuf_tab, x, ndof, iddl, b)
Definition i2_imp1.F:1901
i2_impr2
subroutine i2_impr2(ipari, intbuf_tab, a, ar, x, ndof, iddl, b)
Definition i2_imp1.F:2183
dyna_ina
subroutine dyna_ina(ibcl, forc, snpc, npc, tf, a, v, x, skews, ar, vr, sensor_tab, weight, wfexc, iads_f, fsky, igrv, agrv, ms, in, lgrav, itask, nrbyac, irbyac, npby, rby, fr_elem, iad_elem, nddl, nnzk, idiv, h3d_data, cptreac, fthreac, nodreac, nsensor, th_surf, dpl0cld, vel0cld, d, dr, numnod, nsurf, nfunct, nconld, ngrav, ninvel, stf, numskw, wfext, python)
Definition imp_dyna.F:744
imp_fhht1
subroutine imp_fhht1(nddl0, nddl, lb, ikc)
Definition imp_dyna.F:2104
dyna_cpk0
subroutine dyna_cpk0(nddl, nnzk, iadk, jdik, diag_k, lt_k)
Definition imp_dyna.F:1698
qstat_ini
subroutine qstat_ini(nddl, inloc, iddl, ndof, ikc, ms, in)
Definition imp_dyna.F:548
imp_qifam
subroutine imp_qifam(nodft, nodlt, iddl, ndof, inloc, ikc, diag_k, ms, in, weight)
Definition imp_dyna.F:1126
dyna_ini
subroutine dyna_ini(nodft, nodlt, d_al, nm_a, nm_b, v, vr)
Definition imp_dyna.F:36
dyna_ivfac
subroutine dyna_ivfac(nodft, nodlt, ms, in, weight, en_i, efac, itask)
Definition imp_dyna.F:1620
qstat_end
subroutine qstat_end(nddl, u)
Definition imp_dyna.F:686
imp_dykv
subroutine imp_dykv(nodft, nodlt, iddl, ndof, ikc, diag_k, iadk, jdik, lt_k, weight, rby, x, skew, lpby, npby, nrbyac, irbyac, nint2, iint2, ipari, intbuf_tab, irbe3, lrbe3, frbe3, irbe2, lrbe2, v, vr, nddl, fr_elem, iad_elem, ms, in)
Definition imp_dyna.F:1758
dyna_in0
subroutine dyna_in0(nodft, nodlt)
Definition imp_dyna.F:145
inte_dyna
subroutine inte_dyna(nodft, nodlt, d, dr, v, vr)
Definition imp_dyna.F:186
dyna_wex
subroutine dyna_wex(ibcl, forc, snpc, npc, tf, a, v, x, skews, ar, vr, sensor_tab, weight, wfext, iads_f, fsky, igrv, agrv, ms, in, lgrav, itask, nrbyac, irbyac, npby, rby, ibfv, vel, d, dr, ikc, iddl, iframe, xframe, ndof, h3d_data, cptreac, fthreac, nodreac, nsensor, th_surf, dpl0cld, vel0cld, numnod, nsurf, nfunct, nconld, ngrav, nfxvel, stf, numskw, python)
Definition imp_dyna.F:1001
imp_dykv0
subroutine imp_dykv0(nodft, nodlt, iddl, ndof, ikc, diag_k, iadk, jdik, lt_k, weight, rby, x, skew, lpby, npby, nrbyac, irbyac, nint2, iint2, ipari, intbuf_tab, irbe3, lrbe3, frbe3, irbe2, lrbe2, v, vr, nddl, fr_elem, iad_elem, ms, in)
Definition imp_dyna.F:1963
dyna_iniv
subroutine dyna_iniv(nodft, nodlt, ms, in, d, dr)
Definition imp_dyna.F:1520
getdyna_a
subroutine getdyna_a(nodft, nodlt, a)
Definition imp_dyna.F:1909
imp_dynam
subroutine imp_dynam(nodft, nodlt, iddl, ndof, diag_k, ms, in, d_al, weight, iadk, lt_k)
Definition imp_dyna.F:302
qstat_it
subroutine qstat_it(nddl, f, u)
Definition imp_dyna.F:651
dyna_cpr0
subroutine dyna_cpr0(nddl)
Definition imp_dyna.F:507
imp_fhht
subroutine imp_fhht(nddl, lb)
Definition imp_dyna.F:459
imp_dycrb
subroutine imp_dycrb(am, in, vr, nby, rby0, weight, icodr, iskew, skew)
Definition imp_dyna.F:1211
imp_dynar
subroutine imp_dynar(dy_ac, dy_acr, ms, in, fint, mint, v, vr)
Definition imp_dyna.F:393
imp_setb
subroutine imp_setb(f, m, iddl, ndof, b)
Definition imp_setb.F:40
spmd_sumf_a
subroutine spmd_sumf_a(a, ar, iad_elem, fr_elem, size, lr)
Definition imp_spmd.F:2897
spmd_sum_s
subroutine spmd_sum_s(s)
Definition imp_spmd.F:1037
spmd_max_i
subroutine spmd_max_i(n)
Definition imp_spmd.F:1362
integrator
subroutine integrator(nodft, nodlt, ndt, d, dr, x, v, vr, a, ar)
Definition integrator.F:81
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
h3d_mod
Definition h3d_mod.F:311
imp_dyna
Definition impbufdef_mod.F:314
imp_dyna::dy_iadk0
integer, dimension(:), allocatable dy_iadk0
Definition impbufdef_mod.F:327
imp_dyna::dy_jdik0
integer, dimension(:), allocatable dy_jdik0
Definition impbufdef_mod.F:327
imp_qstat
Definition impbufdef_mod.F:451
message_mod
Definition message_mod.F:1257
th_surf_mod
OPTION /TH/SURF outputs of Pressure and Area needed Tabs.
Definition th_surf_mod.F:61
th_surf_mod::th_surf_num_channel
integer, parameter th_surf_num_channel
number of /TH/SURF channels : AREA, VELOCITY, MASSFLOW, P A, MASS
Definition th_surf_mod.F:100
cp_real
subroutine cp_real(n, x, xc)
Definition produt_v.F:871
mav_lt
subroutine mav_lt(nddl, nnz, iadl, jdil, diag_k, lt_k, v, w)
Definition produt_v.F:340
cp_int
subroutine cp_int(n, x, xc)
Definition produt_v.F:916
rbe2_impr1
subroutine rbe2_impr1(irbe2, lrbe2, x, skew, ndof, iddl, b, weight)
Definition rbe2_imp0.F:464
rbe3_impr2
subroutine rbe3_impr2(irbe3, lrbe3, frbe3, x, skew, ndof, iddl, b, weight, a, ar)
Definition rbe3_imp0.F:445
rbe3_impr1
subroutine rbe3_impr1(irbe3, lrbe3, frbe3, x, skew, ndof, iddl, b, weight)
Definition rbe3_imp0.F:318
rby_impr1
subroutine rby_impr1(x, rby, nod, nby, ndof, iddl, b)
Definition rby_imp0.F:707
rby_impr2
subroutine rby_impr2(x, rby, nod, nby, ndof, iddl, b, ac, acr)
Definition rby_imp0.F:820
rotbmr
subroutine rotbmr(vr, rby, dt)
Definition rotbmr.F:35
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:895
arret
subroutine arret(nn)
Definition arret.F:86
my_barrier
subroutine my_barrier
Definition machine.F:31
th_surf_mod::th_surf_
Definition th_surf_mod.F:76
condens_b
subroutine condens_b(nddl, ikc, b)
Definition upd_glob_k.F:400