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 61 of file sms_mass_scale_2.F.

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