OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
sms_mass_scale_2.F File Reference
#include "implicit_f.inc"
#include "comlock.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "com06_c.inc"
#include "com08_c.inc"
#include "param_c.inc"
#include "parit_c.inc"
#include "remesh_c.inc"
#include "scr03_c.inc"
#include "sms_c.inc"
#include "tabsiz_c.inc"
#include "task_c.inc"
#include "timeri_c.inc"
#include "units_c.inc"
#include "warn_c.inc"
#include "stati_c.inc"
#include "vectorize.inc"
#include "lockon.inc"
#include "lockoff.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine sms_mass_scale_2 (timers, python, itask, nodft, nodlt, nodii_sms, indx2_sms, nodxi_sms, ms, ms0, a, icodt, icodr, iskew, skew, jad_sms, jdi_sms, lt_sms, x_sms, p_sms, z_sms, y_sms, prec_sms, indx1_sms, diag_sms, iad_elem, fr_elem, weight, npby, lpby, tagslv_rby_sms, lad_sms, kad_sms, jrb_sms, ibfv, vel, npc, tf, v, x, d, sensor_tab, nsensor, iframe, xframe, jadi_sms, jdii_sms, lti_sms, fr_sms, fr_rms, iskyi_sms, mskyi_sms, res_sms, igrv, agrv, lgrav, ilink, rlink, fr_rl, frl6, nnlink, lnlink, fr_ll, fnl6, tag_lnk_sms, itab, fsav, ljoint, iadcj, fr_cj, am, vr, in, frl, fnl, nprw, lprw, rwbuf, rwsav, fopt, fr_wall, nrwl_sms, intstamp, kinet, ixc, ixtg, sh4tree, sh3tree, cptreac, nodreac, fthreac, frwl6, dim, tagslv_rby, dampr, damp, igrnod, dr, rby, tagmsr_rby_sms, jsm_sms, irbe2, lrbe2, iad_rbe2, fr_rbe2m, nmrbe2, r2size, irbe3, lrbe3, frbe3, iad_rbe3m, fr_rbe3m, fr_rbe3mp, rrbe3, rrbe3_pon, prec_sms3, diag_sms3, iad_rby, fr_rby6, rby6, r3size, betate, ibcscyc, lbcscyc, mskyi_fi_sms, list_sms, list_rms, cjwork, frea, irwl_work, vfi, sz_mw6, mw6, wfext, ams_work)

Function/Subroutine Documentation

◆ sms_mass_scale_2()

subroutine sms_mass_scale_2 ( type(timer_), intent(inout) timers,
type(python_), intent(inout) python,
integer itask,
integer nodft,
integer nodlt,
integer, dimension(*) nodii_sms,
integer, dimension(*) indx2_sms,
integer, dimension(*) nodxi_sms,
ms,
ms0,
a,
integer, dimension(*) icodt,
integer, dimension(*) icodr,
integer, dimension(*) iskew,
skew,
integer, dimension(*) jad_sms,
integer, dimension(*) jdi_sms,
lt_sms,
x_sms,
p_sms,
z_sms,
y_sms,
prec_sms,
integer, dimension(*) indx1_sms,
diag_sms,
integer, dimension(2,nspmd+1) iad_elem,
integer, dimension(*) fr_elem,
integer, dimension(*) weight,
integer, dimension(nnpby,*) npby,
integer, dimension(*) lpby,
integer, dimension(*) tagslv_rby_sms,
integer, dimension(*) lad_sms,
integer, dimension(*) kad_sms,
integer, dimension(*) jrb_sms,
integer, dimension(nifv,*) ibfv,
vel,
integer, dimension(*) npc,
tf,
v,
x,
d,
type (sensor_str_), dimension(nsensor), intent(in) sensor_tab,
integer nsensor,
integer, dimension(liskn,*) iframe,
xframe,
integer, dimension(*) jadi_sms,
integer, dimension(*) jdii_sms,
lti_sms,
integer, dimension(nspmd+1) fr_sms,
integer, dimension(nspmd+1) fr_rms,
integer, dimension(lskyi_sms,*) iskyi_sms,
mskyi_sms,
res_sms,
integer, dimension(*) igrv,
agrv,
lgrav,
integer, dimension(*) ilink,
integer, dimension(*) rlink,
integer, dimension(nspmd+2,*) fr_rl,
double precision, dimension(*) frl6,
integer, dimension(10,*) nnlink,
integer, dimension(*) lnlink,
integer, dimension(nspmd+2,*) fr_ll,
double precision, dimension(*) fnl6,
integer, dimension(*) tag_lnk_sms,
integer, dimension(*) itab,
fsav,
integer, dimension(*) ljoint,
integer, dimension(*) iadcj,
integer, dimension(*) fr_cj,
am,
vr,
in,
frl,
fnl,
integer, dimension(*) nprw,
integer, dimension(*) lprw,
rwbuf,
rwsav,
fopt,
integer, dimension(*) fr_wall,
integer, dimension(*) nrwl_sms,
type(intstamp_data), dimension(*) intstamp,
integer, dimension(*) kinet,
integer, dimension(nixc,*) ixc,
integer, dimension(nixtg,*) ixtg,
integer, dimension(ksh4tree,*) sh4tree,
integer, dimension(ksh3tree,*) sh3tree,
integer cptreac,
integer, dimension(*) nodreac,
fthreac,
double precision, dimension(*) frwl6,
integer dim,
integer, dimension(*) tagslv_rby,
dampr,
damp,
type (group_), dimension(ngrnod) igrnod,
dr,
rby,
integer, dimension(*) tagmsr_rby_sms,
integer, dimension(*) jsm_sms,
integer, dimension(nrbe2l,*) irbe2,
integer, dimension(*) lrbe2,
integer, dimension(*) iad_rbe2,
integer, dimension(*) fr_rbe2m,
integer nmrbe2,
integer r2size,
integer, dimension(nrbe3l,*) irbe3,
integer, dimension(*) lrbe3,
frbe3,
integer, dimension(*) iad_rbe3m,
integer, dimension(*) fr_rbe3m,
integer, dimension(*) fr_rbe3mp,
rrbe3,
double precision, dimension(*) rrbe3_pon,
prec_sms3,
diag_sms3,
integer, dimension(*) iad_rby,
integer, dimension(*) fr_rby6,
double precision, dimension(8,6,nrbykin) rby6,
integer r3size,
betate,
integer, dimension(*) ibcscyc,
integer, dimension(*) lbcscyc,
intent(inout) mskyi_fi_sms,
integer, dimension(fr_sms(nspmd+1)), intent(inout) list_sms,
integer, dimension(fr_rms(nspmd+1)), intent(inout) list_rms,
intent(inout) cjwork,
intent(inout) frea,
integer, dimension(slprw), intent(inout) irwl_work,
intent(inout) vfi,
integer, intent(in) sz_mw6,
double precision, dimension(6,sz_mw6), intent(inout) mw6,
double precision, intent(inout) wfext,
type (ams_work_), intent(inout) ams_work )

Definition at line 60 of file sms_mass_scale_2.F.

88C-----------------------------------------------
89C M o d u l e s
90C-----------------------------------------------
91 USE timer_mod
92 USE intstamp_mod
93 USE message_mod
94 USE groupdef_mod
95 USE sensor_mod
96 USE ams_work_mod
97 USE my_alloc_mod
98 use python_funct_mod, only : python_
99C-----------------------------------------------
100C I m p l i c i t T y p e s
101C-----------------------------------------------
102#include "implicit_f.inc"
103#include "comlock.inc"
104C-----------------------------------------------
105C C o m m o n B l o c k s
106C-----------------------------------------------
107#include "com01_c.inc"
108#include "com04_c.inc"
109#include "com06_c.inc"
110#include "com08_c.inc"
111#include "param_c.inc"
112#include "parit_c.inc"
113#include "remesh_c.inc"
114#include "scr03_c.inc"
115#include "sms_c.inc"
116#include "tabsiz_c.inc"
117#include "task_c.inc"
118#include "timeri_c.inc"
119#include "units_c.inc"
120#include "warn_c.inc"
121#include "stati_c.inc"
122C-----------------------------------------------
123C D u m m y A r g u m e n t s
124C-----------------------------------------------
125 TYPE(TIMER_), INTENT(INOUT) :: TIMERS
126 TYPE(python_), INTENT(INOUT) :: PYTHON
127 INTEGER ITASK, NODFT,NSENSOR,NODLT, NODII_SMS(*), INDX2_SMS(*),
128 . NODXI_SMS(*), ICODT(*), ICODR(*),
129 . ISKEW(*), JAD_SMS(*), JDI_SMS(*), INDX1_SMS(*),
130 . IAD_ELEM(2,NSPMD+1) ,FR_ELEM(*), WEIGHT(*),
131 . NPBY(NNPBY,*), LPBY(*), TAGSLV_RBY_SMS(*), TAGSLV_RBY(*),
132 . LAD_SMS(*), KAD_SMS(*), JRB_SMS(*),
133 . NPC(*), IBFV(NIFV,*),IFRAME(LISKN,*),
134 . JADI_SMS(*), JDII_SMS(*),
135 . FR_RMS(NSPMD+1), FR_SMS(NSPMD+1), ISKYI_SMS(LSKYI_SMS,*),
136 . IGRV(*),CPTREAC,NODREAC(*),
137 . ILINK(*),RLINK(*), FR_RL(NSPMD+2,*), NNLINK(10,*),
138 . LNLINK(*), FR_LL(NSPMD+2,*), TAG_LNK_SMS(*), ITAB(*),
139 . LJOINT(*), FR_CJ(*), IADCJ(*),
140 . NPRW(*), LPRW(*), FR_WALL(*), NRWL_SMS(*),
141 . KK, MAIN, KINET(*),
142 . IXC(NIXC,*), IXTG(NIXTG,*),
143 . SH4TREE(KSH4TREE,*), SH3TREE(KSH3TREE,*), DIM,
144 . TAGMSR_RBY_SMS(*), JSM_SMS(*),
145 . IRBE2(NRBE2L,*), LRBE2(*), IAD_RBE2(*),
146 . FR_RBE2M(*), NMRBE2, R2SIZE, IRBE3(NRBE3L,*), LRBE3(*),
147 . IAD_RBE3M(*) ,FR_RBE3M(*) ,FR_RBE3MP(*),
148 . FR_RBY6(*),IAD_RBY(*),R3SIZE,IBCSCYC(*),LBCSCYC(*)
149 my_real
150 . ms(*), ms0(*), a(3,*), diag_sms(*),
151 . skew(lskew,*), lt_sms(*),
152 . x_sms(3,*), p_sms(3,*), y_sms(3,*), z_sms(3,*), prec_sms(*),
153 . v(3,*), x(3,*), d(3,*), tf(*), vel(lfxvelr,*),
154 . xframe(nxframe,*), lti_sms(*), mskyi_sms(*),
155 . res_sms(3,*), agrv(*),lgrav(*),
156 . fsav(nthvki,*), am(3,*), vr(3,*), in(*), frl(*), fnl(*),
157 . rwbuf(*), rwsav(*), fopt(*),fthreac(6,*),
158 . dampr(nrdamp,*), damp(dim,*), dr(3,*), rby(nrby,*),
159 . frbe3(*), rrbe3(*), prec_sms3(3,*), diag_sms3(3,*),betate
160 DOUBLE PRECISION FRL6(*), FNL6(*), FRWL6(*), RRBE3_PON(*)
161 DOUBLE PRECISION RBY6(8,6,NRBYKIN)
162 my_real,dimension(fr_rms(nspmd+1)),intent(inout) :: mskyi_fi_sms
163 integer,dimension(fr_sms(nspmd+1)),intent(inout) :: LIST_SMS
164 integer,dimension(fr_rms(nspmd+1)),intent(inout) :: LIST_RMS
165 my_real, DIMENSION(18,NJOINT),intent(inout):: cjwork
166 my_real, DIMENSION(3,NUMNOD),intent(inout):: frea
167 integer, dimension(SLPRW),intent(inout):: IRWL_WORK
168 my_real, DIMENSION(3,FR_RMS(NSPMD+1)+FR_SMS(NSPMD+1) ), intent(inout):: vfi
169 integer, intent(in) :: sz_mw6
170 DOUBLE PRECISION,dimension(6,sz_mw6),intent(inout) :: MW6
171 DOUBLE PRECISION,INTENT(INOUT) :: WFEXT
172
173 TYPE(INTSTAMP_DATA) INTSTAMP(*)
174 TYPE (SENSOR_STR_) ,DIMENSION(NSENSOR) ,INTENT(IN) :: SENSOR_TAB
175C-----------------------------------------------
176 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
177 TYPE (AMS_WORK_) , INTENT(INOUT) :: AMS_WORK
178C-----------------------------------------------
179C L o c a l V a r i a b l e s
180C-----------------------------------------------
181 INTEGER I, N, ISP, IT, IX, IERROR
182 INTEGER ICOUNT, J, K, L, NSN, IMOV, ITYP, ILAGM, IFLAG,
183 . N2, N3, N4, N5, N6, N7, ND, IGR, ISK,
184 . M, IAD, MSR, KAD, KI, KJ, JI, NSR,
185 . LOC_PROC, P, NN, LENR, SIZE, NRBDIM
186 INTEGER NODFT1_SMS, NODLT1_SMS
187 INTEGER NODFT2_SMS, NODLT2_SMS,NGR2USR
188 my_real
189 . vx,vy,vz, mvx, mvy, mvz,
190 . vxj, vyj, vzj, mas,wfextt, errtet, dw, dt15, dt25, rbid,
191 . omega, betasdt, dampt, factb, d_tstart, d_tstop, da, adt,
192 . p1, p2, p3, uomega, domega
193C-----
194 INTEGER, DIMENSION(:), ALLOCATABLE :: IMV
195 my_real
196 . , DIMENSION(:), ALLOCATABLE :: mv
197 my_real, DIMENSION(:,:), ALLOCATABLE :: mvskw
198 my_real, DIMENSION(:,:), ALLOCATABLE :: vskw
199 my_real, DIMENSION(:,:), ALLOCATABLE :: rskw
200 my_real, DIMENSION(:,:), ALLOCATABLE :: dampskw
201 double precision
202 . , DIMENSION(:,:), ALLOCATABLE :: mv6
203 EXTERNAL ngr2usr
204C-----------------------------------------------
205 CALL my_alloc(mvskw,3,numnod)
206 CALL my_alloc(vskw,3,numnod)
207 CALL my_alloc(rskw,3,numnod)
208 CALL my_alloc(dampskw,3,numnod)
209C-----------------------------------------------
210 frea(1:3,nodft:nodlt)=zero
211C
212 IF(iparit/=0)THEN
213 IF(debug(9)==0)THEN
214 ALLOCATE(imv(2*nisky_sms+fr_rms(nspmd+1)),
215 . mv(3*(2*nisky_sms+fr_rms(nspmd+1))),
216 . mv6(6,3*(2*nisky_sms+fr_rms(nspmd+1))),stat=ierror)
217 ELSE
218 ALLOCATE(imv(numnod+nnz_sms+2*nisky_sms+fr_rms(nspmd+1)),
219 . mv(3*(numnod+nnz_sms+2*nisky_sms+fr_rms(nspmd+1))),
220 . mv6(6,3*(numnod+nnz_sms+2*nisky_sms+fr_rms(nspmd+1))),
221 . stat=ierror)
222 END IF
223 IF(ierror/=0) THEN
224 WRITE(istdo,*)
225 CALL ancmsg(msgid=19,anmode=aninfo,
226 . c1='(/DT/.../AMS)')
227 CALL arret(2)
228 ENDIF
229 END IF
230C
231 IF(nspmd > 1)THEN
232 IF(itask==0)THEN
233 CALL spmd_list_sms(iskyi_sms,fr_sms,fr_rms,list_sms,list_rms,
234 . npby ,tagslv_rby_sms)
235 END IF
236C
237 CALL my_barrier
238C
239 END IF
240C
241C----
242C
243 IF(nspmd > 1)THEN
244C
245 CALL my_barrier()
246C
247 IF(itask==0) THEN ! comm sur 1er thread
248 CALL spmd_mij_sms(
249 1 iskyi_sms,fr_sms,fr_rms,list_rms,mskyi_sms,
250 2 mskyi_fi_sms)
251 END IF
252 END IF
253C----
254C
255 CALL sms_gravit(igrv ,agrv ,npc ,tf ,a ,
256 2 v ,x ,skew ,ms ,sensor_tab,
257 3 weight,lgrav ,itask,tagslv_rby_sms,nsensor,wfext, python)
258C
259 CALL my_barrier
260C
261 nodft1_sms=1+itask*nindx1_sms/nthread
262 nodlt1_sms=(itask+1)*nindx1_sms/nthread
263C
264 nodft2_sms=1+itask*nindx2_sms/nthread
265 nodlt2_sms=(itask+1)*nindx2_sms/nthread
266C----
267C
268 DO n=nodft,nodlt
269
270 a(1,n)=a(1,n)+res_sms(1,n)
271 a(2,n)=a(2,n)+res_sms(2,n)
272 a(3,n)=a(3,n)+res_sms(3,n)
273
274 res_sms(1,n)=zero
275 res_sms(2,n)=zero
276 res_sms(3,n)=zero
277
278 END DO
279C
280 CALL my_barrier
281C
282C--------------------------------------------
283C RAILEIGH DAMPING
284C--------------------------------------------
285 IF(ndamp/=0.OR.istat==1.OR.istat==3)THEN
286C
287 DO n=nodft,nodlt
288 IF(nodxi_sms(n)==0)THEN
289 z_sms(1,n)=ms(n)*v(1,n)
290 z_sms(2,n)=ms(n)*v(2,n)
291 z_sms(3,n)=ms(n)*v(3,n)
292 ELSE
293 x_sms(1,n)=v(1,n)
294 x_sms(2,n)=v(2,n)
295 x_sms(3,n)=v(3,n)
296 END IF
297 ENDDO
298C-----------------------------------
299 IF(nrbody/=0)THEN
300C
301 CALL my_barrier()
302C
303 DO n=nodft1_sms,nodlt1_sms
304 i=indx1_sms(n)
305 m=tagslv_rby_sms(i)
306 IF(m /= 0)THEN
307 msr=npby(1,m)
308 x_sms(1,i)=x_sms(1,msr)
309 x_sms(2,i)=x_sms(2,msr)
310 x_sms(3,i)=x_sms(3,msr)
311 END IF
312 END DO
313C
314 END IF
315C
316 CALL my_barrier
317C
318C Z_SMS utilise temporairement pour [M]V
319 CALL sms_mav_lt(timers,
320 1 nodft ,nodlt ,numnod ,jad_sms ,jdi_sms ,
321 2 itask ,diag_sms,lt_sms,x_sms ,z_sms ,
322 3 nodft1_sms,nodlt1_sms,indx1_sms,nodxi_sms,iad_elem ,
323 4 fr_elem ,weight ,jadi_sms ,jdii_sms ,lti_sms ,
324 5 iskyi_sms ,mskyi_sms ,fr_sms ,fr_rms ,list_sms ,
325 6 list_rms ,mskyi_fi_sms ,vfi ,imv ,mv ,
326 7 mv6 ,mw6 ,nodft2_sms,nodlt2_sms,indx2_sms,
327 8 nodii_sms )
328C
329 CALL my_barrier
330C
331C-----------------------------------
332C remontee Yi => Ym
333C-----------------------------------
334 IF(nrbody/=0)THEN
335C
336!$OMP DO SCHEDULE(DYNAMIC,1)
337 DO m =1,nrbody
338 DO k = 1, 6
339 rby6(1,k,m) = zero
340 rby6(2,k,m) = zero
341 rby6(3,k,m) = zero
342 END DO
343C
344 msr=npby(1,m)
345 IF(msr < 0) cycle
346C
347 IF(tagmsr_rby_sms(msr) /= 0) THEN
348 rby6(1,1,m)=z_sms(1,msr)*weight(msr)
349 rby6(2,1,m)=z_sms(2,msr)*weight(msr)
350 rby6(3,1,m)=z_sms(3,msr)*weight(msr)
351 END IF
352C
353 END DO
354!$OMP END DO
355
356!$OMP SINGLE
357 DO n=1,nindx1_sms
358 i=indx1_sms(n)
359 m=tagslv_rby_sms(i)
360 IF(m /= 0)THEN
361 IF(weight(i) /= 0)THEN
362 rby6(1,1,m)=rby6(1,1,m)+z_sms(1,i)
363 rby6(2,1,m)=rby6(2,1,m)+z_sms(2,i)
364 rby6(3,1,m)=rby6(3,1,m)+z_sms(3,i)
365 END IF
366 z_sms(1,i)=zero
367 z_sms(2,i)=zero
368 z_sms(3,i)=zero
369 END IF
370 END DO
371!$OMP END SINGLE
372
373 IF (nspmd > 1) THEN
374!$OMP SINGLE
375 nrbdim=3
376 CALL spmd_exch_a_rb6(
377 1 nrbdim,iad_rby,fr_rby6,iad_rby(nspmd+1),rby6)
378!$OMP END SINGLE
379 END IF
380
381!$OMP DO SCHEDULE(DYNAMIC,1)
382 DO m =1,nrbody
383 msr=npby(1,m)
384 IF(msr < 0) cycle
385 IF(tagmsr_rby_sms(msr) /= 0) THEN
386 z_sms(1,msr)=rby6(1,1,m)
387 z_sms(2,msr)=rby6(2,1,m)
388 z_sms(3,msr)=rby6(3,1,m)
389 END IF
390 END DO
391!$OMP END DO
392C
393 END IF
394C
395 CALL my_barrier
396C
397C-----------------------------------
398 IF(itask==0)THEN
399 IF (imon>0) CALL startime(timers,5)
400 dw = zero
401 DO nd=1,ndamp
402 igr = nint(dampr(2,nd))
403 isk = nint(dampr(15,nd))
404 factb = dampr(16,nd)
405 dampt = min(dt1,dt2)*factb
406 d_tstart = dampr(17,nd)
407 d_tstop = dampr(18,nd)
408 IF (tt>=d_tstart .AND. tt<=d_tstop) THEN
409 IF(isk<=1)THEN
410C----- Damping sur dof rotation et seulement -----
411 IF (dampr(19,nd)>0) cycle
412 dampa = dampr(3,nd)
413 dampb = dampr(4,nd)
414 betasdt= -min(dampb,dampt)*dt1/max(dt1*dt1,em30)
415 omega = one/ (one + half * dampa * dt1)
416 DO n=1,igrnod(igr)%NENTITY
417 i=igrnod(igr)%ENTITY(n)
418 IF(tagslv_rby(i)/=0) cycle
419 da=a(1,i)-dampa*z_sms(1,i)-betasdt *(a(1,i) - damp(1,i))
420 da = da * omega - a(1,i)
421 damp(1,i) = a(1,i)
422 a(1,i) = a(1,i) + da
423C DW =DW+DA*(V(1,I)+HALF*ACC(1,I)*DT1)*DT12*WEIGHT(I)
424C 2nd order error
425 dw =dw+da*v(1,i)*dt12*weight(i)
426 END DO
427 dampa = dampr(5,nd)
428 dampb = dampr(6,nd)
429 betasdt= -min(dampb,dampt)*dt1/max(dt1*dt1,em30)
430 omega = one/ (one + half * dampa * dt1)
431 DO n=1,igrnod(igr)%NENTITY
432 i=igrnod(igr)%ENTITY(n)
433 IF(tagslv_rby(i)/=0) cycle
434 da=a(2,i)-dampa*z_sms(2,i)-betasdt *(a(2,i) - damp(2,i))
435 da = da * omega - a(2,i)
436 damp(2,i) = a(2,i)
437 a(2,i) = a(2,i) + da
438C 2nd order error
439 dw =dw+da*v(2,i)*dt12*weight(i)
440 END DO
441 dampa = dampr(7,nd)
442 dampb = dampr(8,nd)
443 betasdt= -min(dampb,dampt)*dt1/max(dt1*dt1,em30)
444 omega = one/ (one + half * dampa * dt1)
445 DO n=1,igrnod(igr)%NENTITY
446 i=igrnod(igr)%ENTITY(n)
447 IF(tagslv_rby(i)/=0) cycle
448 da=a(3,i)-dampa*z_sms(3,i)-betasdt *(a(3,i) - damp(3,i))
449 da = da * omega - a(3,i)
450 damp(3,i) = a(3,i)
451 a(3,i) = a(3,i) + da
452C 2nd order error
453 dw =dw+da*v(3,i)*dt12*weight(i)
454 END DO
455 ELSE
456#include "vectorize.inc"
457 DO n=1,igrnod(igr)%NENTITY
458 i=igrnod(igr)%ENTITY(n)
459 IF(tagslv_rby(i)/=0) cycle
460 mvskw(1,i)= skew(1,isk)*z_sms(1,i)
461 . +skew(2,isk)*z_sms(2,i)
462 . +skew(3,isk)*z_sms(3,i)
463 mvskw(2,i)= skew(4,isk)*z_sms(1,i)
464 . +skew(5,isk)*z_sms(2,i)
465 . +skew(6,isk)*z_sms(3,i)
466 mvskw(3,i)= skew(7,isk)*z_sms(1,i)
467 . +skew(8,isk)*z_sms(2,i)
468 . +skew(9,isk)*z_sms(3,i)
469 vskw(1,i)= skew(1,isk)*v(1,i)
470 . +skew(2,isk)*v(2,i)
471 . +skew(3,isk)*v(3,i)
472 vskw(2,i)= skew(4,isk)*v(1,i)
473 . +skew(5,isk)*v(2,i)
474 . +skew(6,isk)*v(3,i)
475 vskw(3,i)= skew(7,isk)*v(1,i)
476 . +skew(8,isk)*v(2,i)
477 . +skew(9,isk)*v(3,i)
478 rskw(1,i)= skew(1,isk)*a(1,i)
479 . +skew(2,isk)*a(2,i)
480 . +skew(3,isk)*a(3,i)
481 rskw(2,i)= skew(4,isk)*a(1,i)
482 . +skew(5,isk)*a(2,i)
483 . +skew(6,isk)*a(3,i)
484 rskw(3,i)= skew(7,isk)*a(1,i)
485 . +skew(8,isk)*a(2,i)
486 . +skew(9,isk)*a(3,i)
487 dampskw(1,i)= skew(1,isk)*damp(1,i)
488 . +skew(2,isk)*damp(2,i)
489 . +skew(3,isk)*damp(3,i)
490 dampskw(2,i)= skew(4,isk)*damp(1,i)
491 . +skew(5,isk)*damp(2,i)
492 . +skew(6,isk)*damp(3,i)
493 dampskw(3,i)= skew(7,isk)*damp(1,i)
494 . +skew(8,isk)*damp(2,i)
495 . +skew(9,isk)*damp(3,i)
496 END DO
497 dampa = dampr(3,nd)
498 dampb = dampr(4,nd)
499 betasdt= -min(dampb,dampt)*dt1/max(dt1*dt1,em30)
500 omega = one/ (one + half * dampa * dt1)
501#include "vectorize.inc"
502 DO n=1,igrnod(igr)%NENTITY
503 i=igrnod(igr)%ENTITY(n)
504 IF(tagslv_rby(i)/=0) cycle
505 da = rskw(1,i) - dampa*mvskw(1,i)
506 . - betasdt *(rskw(1,i) - dampskw(1,i))
507 da = da * omega - rskw(1,i)
508 dampskw(1,i) = rskw(1,i)
509 rskw(1,i) = rskw(1,i) + da
510C 2nd order error
511 dw =dw+da*vskw(1,i)*dt12*weight(i)
512 ENDDO
513 dampa = dampr(5,nd)
514 dampb = dampr(6,nd)
515 betasdt= -min(dampb,dampt)*dt1/max(dt1*dt1,em30)
516 omega = one/ (one + half * dampa * dt1)
517#include "vectorize.inc"
518 DO n=1,igrnod(igr)%NENTITY
519 i=igrnod(igr)%ENTITY(n)
520 IF(tagslv_rby(i)/=0) cycle
521 da = rskw(2,i) - dampa*mvskw(2,i)
522 . - betasdt *(rskw(2,i) - dampskw(2,i))
523 da = da * omega - rskw(2,i)
524 dampskw(2,i) = rskw(2,i)
525 rskw(2,i) = rskw(2,i) + da
526C 2nd order error
527 dw =dw+da*vskw(2,i)*dt12*weight(i)
528 ENDDO
529 dampa = dampr(7,nd)
530 dampb = dampr(8,nd)
531 betasdt= -min(dampb,dampt)*dt1/max(dt1*dt1,em30)
532 omega = one/ (one + half * dampa * dt1)
533#include "vectorize.inc"
534 DO n=1,igrnod(igr)%NENTITY
535 i=igrnod(igr)%ENTITY(n)
536 IF(tagslv_rby(i)/=0) cycle
537 da = rskw(3,i) - dampa*mvskw(3,i)
538 . - betasdt *(rskw(3,i) - dampskw(3,i))
539 da = da * omega - rskw(3,i)
540 dampskw(3,i) = rskw(3,i)
541 rskw(3,i) = rskw(3,i) + da
542C 2nd order error
543 dw =dw+da*vskw(3,i)*dt12*weight(i)
544 ENDDO
545#include "vectorize.inc"
546 DO n=1,igrnod(igr)%NENTITY
547 i=igrnod(igr)%ENTITY(n)
548 IF(tagslv_rby(i)/=0) cycle
549 a(1,i)= skew(1,isk)*rskw(1,i)
550 . +skew(4,isk)*rskw(2,i)
551 . +skew(7,isk)*rskw(3,i)
552 a(2,i)= skew(2,isk)*rskw(1,i)
553 . +skew(5,isk)*rskw(2,i)
554 . +skew(8,isk)*rskw(3,i)
555 a(3,i)= skew(3,isk)*rskw(1,i)
556 . +skew(6,isk)*rskw(2,i)
557 . +skew(9,isk)*rskw(3,i)
558 damp(1,i)= skew(1,isk)*dampskw(1,i)
559 . +skew(4,isk)*dampskw(2,i)
560 . +skew(7,isk)*dampskw(3,i)
561 damp(2,i)= skew(2,isk)*dampskw(1,i)
562 . +skew(5,isk)*dampskw(2,i)
563 . +skew(8,isk)*dampskw(3,i)
564 damp(3,i)= skew(3,isk)*dampskw(1,i)
565 . +skew(6,isk)*dampskw(2,i)
566 . +skew(9,isk)*dampskw(3,i)
567 END DO
568 END IF
569 END IF
570 END DO
571#include "lockon.inc"
572 wfext = wfext + dw
573#include "lockoff.inc"
574 IF (imon>0) CALL stoptime(timers,5)
575 END IF
576C
577 CALL my_barrier
578C-----------------------------------
579 IF (istat==1.OR.istat==3) THEN
580!$OMP SINGLE
581 omega = betate * dt12
582 uomega = one - omega
583 domega = two*betate
584 dw = zero
585 IF(istatg==0)THEN
586 DO j= 1,3
587 DO i=1,numnod
588 IF(tagslv_rby(i)/=0) cycle
589 da = a(j,i)
590 a(j,i) = uomega*a(j,i) -domega*z_sms(j,i)
591 da = a(j,i) -da
592 dw =dw+da*v(j,i)*dt12*weight(i)
593 END DO
594 END DO
595 ELSE
596 IF(istatg<0)THEN
597 istatg=ngr2usr(-istatg,igrnod,ngrnod)
598 ENDIF
599 DO j= 1,3
600#include "vectorize.inc"
601 DO n=1,igrnod(istatg)%NENTITY
602 i=igrnod(istatg)%ENTITY(n)
603 IF(tagslv_rby(i)/=0) cycle
604 da = a(j,i)
605 a(j,i) = uomega*a(j,i) -domega*z_sms(j,i)
606 da = a(j,i) -da
607 dw =dw+da*v(j,i)*dt12*weight(i)
608 END DO
609 END DO
610 END IF !(ISTATG==0)THEN
611#include "lockon.inc"
612 wfext = wfext + dw
613#include "lockoff.inc"
614!$OMP END SINGLE
615C
616 CALL my_barrier
617 END IF !(ISTAT==3) THEN
618C
619 END IF
620
621C-----------------------------------
622C RBE2
623C-----------------------------------
624 IF (nrbe2>0.OR.r2size>0) THEN
625 IF(itask==0)THEN
626 CALL sms_rbe_cnds(
627 1 irbe2 ,lrbe2 ,x ,a ,am ,
628 1 ms ,in ,skew ,weight ,iad_rbe2,
629 2 fr_rbe2m,nmrbe2)
630 END IF
631C
632 CALL my_barrier
633C
634 END IF
635C-----------------------------------
636C RBE3
637C-----------------------------------
638 IF (nrbe3>0)THEN
639 IF(itask==0)THEN
640 CALL sms_rbe3t1(
641 1 irbe3 ,lrbe3 ,x ,a ,frbe3 ,
642 2 skew ,weight ,iad_rbe3m,fr_rbe3m,fr_rbe3mp,
643 3 rrbe3 ,rrbe3_pon ,r3size)
644 END IF
645C
646 CALL my_barrier
647C
648 END IF
649C-----------------------------------
650C CONDITIONS AUX LIMITES
651 CALL sms_thbcs(nodft1_sms,nodlt1_sms,indx1_sms,icodt ,icodr ,
652 2 iskew ,skew ,a ,am ,fthreac ,
653 3 nodreac,cptreac)
654C
655 CALL sms_bcs(nodft1_sms,nodlt1_sms,indx1_sms,icodt ,iskew ,
656 2 skew ,a ,nodlt1_sms)
657C
658 IF(iroddl/=0)
659 1 CALL sms_bcs(nodft1_sms,nodlt1_sms,indx1_sms,icodr ,iskew ,
660 2 skew ,am ,nodlt1_sms)
661C
662 IF (nbcscyc>0) CALL sms_bcscyc(ibcscyc,lbcscyc,skew,x,a)
663C
664 CALL my_barrier
665C
666C-----------------------------------
667C
668C PREC_SMS utilise pour stocker la diagonale vraie (cf rbodies)
669 prec_sms(nodft:nodlt)=diag_sms(nodft:nodlt)
670C
671 CALL my_barrier()
672C
673 IF(nrbody/=0)THEN
674C
675!$omp DO schedule(dynamic,1)
676 DO m =1,nrbody
677 DO k = 1, 6
678 rby6(1,k,m) = zero
679 END DO
680C
681 msr=npby(1,m)
682 IF(msr < 0) cycle
683C
684 IF(tagmsr_rby_sms(msr) /= 0) THEN
685 rby6(1,1,m)=diag_sms(msr)*weight(msr)
686 END IF
687C
688 END DO
689!$OMP END DO
690
691!$OMP SINGLE
692 DO n=1,nindx1_sms
693 i=indx1_sms(n)
694 m=tagslv_rby_sms(i)
695 IF(m /= 0)THEN
696 IF(weight(i) /= 0)THEN
697 rby6(1,1,m)=rby6(1,1,m)+diag_sms(i)
698 END IF
699 END IF
700 END DO
701!$omp END single
702
703 IF (nspmd > 1) THEN
704!$OMP SINGLE
705 nrbdim=1
706 CALL spmd_exch_a_rb6(
707 1 nrbdim,iad_rby,fr_rby6,iad_rby(nspmd+1),rby6)
708!$OMP END SINGLE
709 END IF
710
711!$OMP DO SCHEDULE(DYNAMIC,1)
712 DO m =1,nrbody
713C
714 msr=npby(1,m)
715C
716 IF(msr < 0) cycle
717C
718 IF(tagmsr_rby_sms(msr) /= 0) THEN
719 prec_sms(msr)=rby6(1,1,m)
720 END IF
721C
722 END DO
723!$OMP END DO
724C
725 DO n=nodft1_sms,nodlt1_sms
726 i=indx1_sms(n)
727 m=tagslv_rby_sms(i)
728 IF(m /= 0)THEN
729 msr=npby(1,m)
730 prec_sms(i)=prec_sms(msr)
731 END IF
732 END DO
733C
734 CALL my_barrier()
735C
736 END IF
737C-----------------------------------
738C
739 IF(nfxvel > 0)THEN
740 IF(itask==0)THEN
741 it=0
742 CALL sms_fixvel(ibfv ,a ,v ,npc ,tf ,
743 2 vel ,ms ,x ,skew ,sensor_tab,
744 3 weight ,d ,iframe ,xframe ,nsensor ,
745 4 it ,prec_sms,nodxi_sms,cptreac,nodreac,
746 5 fthreac,am ,vr ,dr ,in ,
747 6 rby ,wfext)
748 END IF
749C
750 CALL my_barrier
751C
752 END IF
753C-----------------------------------
754 IF(njoint > 0)THEN
755 CALL sms_cjoint_0(a ,am ,v ,vr,x ,
756 2 fsav ,ljoint,ms,in,iadcj,
757 3 fr_cj,cjwork,tag_lnk_sms(nrlink+nlink+1),
758 . prec_sms,itask)
759C
760 CALL my_barrier
761C
762 END IF
763C-----------------------------------
764 IF(nadmesh/=0)THEN
765 IF(itask==0)THEN
766 CALL sms_admesh_0(a, prec_sms, ixc, ixtg,sh4tree ,
767 . sh3tree )
768 END IF
769C
770 CALL my_barrier
771C
772 END IF
773C-----------------------------------
774 CALL sms_pcg(timers, nodft ,nodlt ,nnz_sms,jad_sms ,
775 2 jdi_sms ,diag_sms ,lt_sms ,a ,isp ,
776 3 x_sms ,p_sms ,z_sms ,y_sms ,prec_sms ,
777 4 nodft1_sms,nodlt1_sms,indx1_sms,icodt ,icodr ,
778 5 iskew ,skew ,itask ,nodxi_sms,iad_elem,
779 6 fr_elem ,weight ,ibfv ,vel ,npc ,
780 7 tf ,v ,x ,d ,sensor_tab,
781 8 iframe ,xframe ,jadi_sms ,jdii_sms ,nsensor ,
782 9 lti_sms ,fr_sms ,fr_rms ,list_sms ,list_rms,
783 a mskyi_fi_sms,vfi ,iskyi_sms,mskyi_sms,
784 b res_sms ,ilink ,rlink ,fr_rl ,frl6 ,
785 c nnlink ,lnlink ,fr_ll ,fnl6 ,ms ,
786 d tag_lnk_sms,itab ,fsav ,ljoint ,iadcj ,
787 e fr_cj ,cjwork ,frl ,fnl ,nprw ,
788 f lprw ,rwbuf ,rwsav ,fopt ,fr_wall ,
789 g irwl_work,nrwl_sms,frea ,intstamp ,imv ,
790 h mv ,mv6 ,mw6 ,kinet ,ixc ,
791 i ixtg ,sh4tree ,sh3tree,cptreac ,nodreac ,
792 j fthreac ,frwl6 ,am ,vr ,
793 k dr ,in ,rby ,npby ,lpby ,
794 l tagmsr_rby_sms ,irbe2 ,lrbe2 ,iad_rbe2 ,fr_rbe2m,
795 m nmrbe2 ,r2size ,irbe3 ,lrbe3 ,frbe3 ,
796 n iad_rbe3m ,fr_rbe3m ,fr_rbe3mp,rrbe3,rrbe3_pon,
797 o prec_sms3,diag_sms3,iad_rby ,fr_rby6 ,rby6,
798 p tagslv_rby_sms,r3size,nodft2_sms,nodlt2_sms,indx2_sms,
799 q nodii_sms,ibcscyc ,lbcscyc ,wfext,ams_work )
800C
801 CALL my_barrier
802C
803c DT15=HALF*DT1
804c DT25=HALF*DT2
805c TFEXTT=ERRTE_SMS
806c ERRTET =ZERO
807c DO N=NODFT1_SMS,NODLT1_SMS
808c I = INDX1_SMS(N)
809c VX = V(1,I)+DT05*A(1,I)
810c VY = V(2,I)+DT05*A(2,I)
811c VZ = V(3,I)+DT05*A(3,I)
812c MVX = RES_SMS(1,I)
813c MVY = RES_SMS(2,I)
814c MVZ = RES_SMS(3,I)
815c DW = (VX*MVX + VY*MVY + VZ*MVZ)*WEIGHT(I)
816c TFEXTT =TFEXTT + DT15*DW
817c ERRTET =ERRTET + DT25*DW
818c END DO
819c#include "lockon.inc"
820c TFEXT=TFEXT+TFEXTT
821c ERRTE_SMS=ERRTE_SMS+ERRTET
822c#include "lockoff.inc"
823c
824c CALL MY_BARRIER
825c
826C
827 IF(njoint > 0)THEN
828 CALL sms_cjoint_2(a ,am ,v ,vr,x ,
829 2 ljoint,ms,in,iadcj,fr_cj,
830 3 cjwork,tag_lnk_sms(nrlink+nlink+1),itask)
831C
832 CALL my_barrier
833C
834 END IF
835C-----------------------------------
836C
837 DO n=nodft1_sms,nodlt1_sms
838 i=indx1_sms(n)
839 a(1,i) = a(1,i)*ms(i)
840 a(2,i) = a(2,i)*ms(i)
841 a(3,i) = a(3,i)*ms(i)
842 ENDDO
843C
844 CALL my_barrier
845C
846 IF(iparit/=0)THEN
847 DEALLOCATE(imv, mv, mv6)
848 END IF
849 DEALLOCATE(mvskw)
850 DEALLOCATE(vskw)
851 DEALLOCATE(rskw)
852 DEALLOCATE(dampskw)
853C
854 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
groupdef_mod
Definition groupdef_mod.F:662
intstamp_mod
Definition intstamp_mod.F:38
message_mod
Definition message_mod.F:1249
ngr2usr
integer function ngr2usr(iu, igr, ngr)
Definition nintrr.F:325
sms_admesh_0
subroutine sms_admesh_0(a, diag_sms, ixc, ixtg, sh4tree, sh3tree)
Definition sms_admesh.F:34
sms_bcs
subroutine sms_bcs(nodft, nodlt, indx1, icodt, iskew, skew, a, nodlast)
Definition sms_bcs.F:34
sms_bcscyc
subroutine sms_bcscyc(ibcscyc, lbcscyc, skew, x, a)
Definition sms_bcscyc.F:33
sms_cjoint_0
subroutine sms_cjoint_0(a, ar, v, vr, x, fsav, ljoint, ms, in, iadcj, fr_cj, cjwork, tag_lnk_sms, diag_sms, itask)
Definition sms_cjoint.F:35
sms_cjoint_2
subroutine sms_cjoint_2(a, ar, v, vr, x, ljoint, ms, in, iadcj, fr_cj, cjwork, tag_lnk_sms, itask)
Definition sms_cjoint.F:178
sms_fixvel
subroutine sms_fixvel(ibfv, a, v, npc, tf, vel, ms, x, skew, sensor_tab, weight, d, iframe, xframe, nsensor, it, diag_sms, nodnx_sms, cptreac, nodreac, fthreac, ar, vr, dr, in, rby, wfext)
Definition sms_fixvel.F:40
sms_gravit
subroutine sms_gravit(igrv, agrv, npc, tf, a, v, x, skew, ms, sensor_tab, weight, ib, itask, tagslv_rby_sms, nsensor, wfext, python)
Definition sms_gravit.F:37
sms_pcg
subroutine sms_pcg(timers, nodft, nodlt, nnz, iadk, jdik, diag_sms, lt_k, r, isp, x_sms, p_sms, z_sms, y_sms, prec_sms, nodft1_sms, nodlt1_sms, indx1_sms, icodt, icodr, iskew, skew, itask, nodnx_sms, iad_elem, fr_elem, weight, ibfv, vel, npc, tf, v, x, d, sensor_tab, iframe, xframe, jadi_sms, jdii_sms, nsensor, lti_sms, fr_sms, fr_rms, list_sms, list_rms, mskyi_fi_sms, vfi, iskyi_sms, mskyi_sms, res_sms, ilink, llink, fr_rl, frl6, nnlink, lnlink, fr_ll, fnl6, ms, tag_lnk_sms, itab, fsav, ljoint, iadcj, fr_cj, cjwork, frl, fnl, nprw, lprw, rwbuf, rwsav, fopt, fr_wall, irwl_work, nrwl_sms, frea, intstamp, imv, mv, mv6, mw6, kinet, ixc, ixtg, sh4tree, sh3tree, cptreac, nodreac, fthreac, frwl6, am, vr, dr, in, rby, npby, lpby, tagmsr_rby_sms, irbe2, lrbe2, iad_rbe2, fr_rbe2m, nmrbe2, r2size, irbe3, lrbe3, frbe3, iad_rbe3m, fr_rbe3m, fr_rbe3mp, rrbe3, rrbe3_pon, prec_sms3, diag_sms3, iad_rby, fr_rby6, rby6, tagslv_rby_sms, r3size, nodft2_sms, nodlt2_sms, indx2_sms, nodii_sms, ibcscyc, lbcscyc, wfext, ams_work)
Definition sms_pcg.F:92
sms_mav_lt
subroutine sms_mav_lt(timers, nodft, nodlt, numnod, iadl, jdil, itask, diag_k, lt_k, v, w, nodft1_sms, nodlt1_sms, indx1_sms, nodnx_sms, iad_elem, fr_elem, weight, jadi_sms, jdii_sms, lti_sms, iskyi_sms, mskyi_sms, fr_sms, fr_rms, list_sms, list_rms, mskyi_fi_sms, vfi, imv, mv, mv6, mw6, nodft2_sms, nodlt2_sms, indx2_sms, nodii_sms)
Definition sms_pcg.F:1706
sms_rbe_cnds
subroutine sms_rbe_cnds(irbe2, lrbe2, x, a, ar, ms, in, skew, weight, iad_rbe2, fr_rbe2m, nmrbe2)
Definition sms_rbe2.F:274
sms_rbe3t1
subroutine sms_rbe3t1(irbe3, lrbe3, x, a, frbe3, skew, weight, iad_m, fr_m, fr_mpon, rsum, rsum_pon, r3size)
Definition sms_rbe3.F:143
sms_thbcs
subroutine sms_thbcs(nodft, nodlast, indx1, icodt, icodr, iskew, skew, a, ar, fthreac, nodreac, cptreac)
Definition sms_thbcs.F:33
spmd_exch_a_rb6
subroutine spmd_exch_a_rb6(nrbdim, iad_rby, fr_rby6, icsize, rbf6)
Definition spmd_exch_a_rb6.F:37
spmd_list_sms
subroutine spmd_list_sms(iskyi_sms, fr_sms, fr_rms, list_sms, list_rms, npby, tagslv_rby_sms)
Definition spmd_sms.F:263
spmd_mij_sms
subroutine spmd_mij_sms(iskyi_sms, fr_sms, fr_rms, list_rms, mskyi_sms, mij_sms)
Definition spmd_sms.F:452
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
my_barrier
subroutine my_barrier
Definition machine.F:31
startime
subroutine startime(event, itask)
Definition timer.F:93
stoptime
subroutine stoptime(event, itask)
Definition timer.F:135