OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
forintp.F File Reference
#include "implicit_f.inc"
#include "comlock.inc"
#include "mvsiz_p.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "com08_c.inc"
#include "sphcom.inc"
#include "param_c.inc"
#include "parit_c.inc"
#include "vect01_c.inc"
#include "scr07_c.inc"
#include "scr17_c.inc"
#include "task_c.inc"
#include "units_c.inc"
#include "scr02_c.inc"
#include "scr18_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine forintp (timers, pm, geo, x, a, v, ms, w, elbuf_tab, wa, fv, stifn, pld, bufmat, partsav, nloc_dmg, fsav, dt2t, iads, iparg, npc, neltst, ityptst, ipart, itab, isky, bufgeo, fskyi, xframe, kxsp, ixsp, nod2sp, ipartsp, spbuf, ispcond, ispsym, xspsym, vspsym, wasph, lprtsph, lonfsph, waspact, isphio, vsphio, sphveln, itask, ipm, gresav, grth, igrth, table, lgauge, gauge, ngrounc, igrounc, ixs, irst, sol2sph, sph2sol, fskyv, fsky, igeo, temp, fthe, ftheskyi, sphg_f6, wsmcomp, sol2sph_typ, mat_elem, output, sph_iord1, snpc, stf, sbufmat, idtmins, nsvois, iresp, maxfunc, imon_mat, userl_avail, impl_s, idyna, dt, glob_therm, sph_work, wfext, sensors)

Function/Subroutine Documentation

◆ forintp()

subroutine forintp ( type(timer_), intent(inout) timers,
pm,
geo,
x,
a,
v,
ms,
w,
type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
wa,
fv,
stifn,
pld,
bufmat,
partsav,
type (nlocal_str_), target nloc_dmg,
fsav,
dt2t,
integer, dimension(8,*) iads,
integer, dimension(nparg,*) iparg,
integer, dimension(*) npc,
integer neltst,
integer ityptst,
integer, dimension(lipart1,*) ipart,
integer, dimension(*) itab,
integer, dimension(*) isky,
bufgeo,
fskyi,
xframe,
integer, dimension(nisp,*) kxsp,
integer, dimension(kvoisph,*) ixsp,
integer, dimension(*) nod2sp,
integer, dimension(*) ipartsp,
spbuf,
integer, dimension(nispcond,*) ispcond,
integer, dimension(nspcond,*) ispsym,
xspsym,
vspsym,
wasph,
integer, dimension(2,0:npart) lprtsph,
integer, dimension(*) lonfsph,
integer, dimension(*) waspact,
integer, dimension(nisphio,*) isphio,
vsphio,
sphveln,
integer itask,
integer, dimension(*) ipm,
gresav,
integer, dimension(*) grth,
integer, dimension(*) igrth,
type(ttable), dimension(*) table,
integer, dimension(3,*) lgauge,
gauge,
integer ngrounc,
integer, dimension(*) igrounc,
integer, dimension(nixs,*) ixs,
integer, dimension(3,*) irst,
integer, dimension(2,*) sol2sph,
integer, dimension(*) sph2sol,
fskyv,
fsky,
integer, dimension(npropgi,*) igeo,
temp,
fthe,
ftheskyi,
double precision, dimension(4,6,nbgauge) sphg_f6,
wsmcomp,
integer, dimension(*) sol2sph_typ,
type (mat_elem_), intent(inout) mat_elem,
type(output_), intent(inout) output,
integer, intent(in) sph_iord1,
integer, intent(in) snpc,
integer, intent(in) stf,
integer, intent(in) sbufmat,
integer, intent(in) idtmins,
integer, intent(in) nsvois,
integer, intent(in) iresp,
integer, intent(in) maxfunc,
integer, intent(in) imon_mat,
integer, intent(in) userl_avail,
integer, intent(in) impl_s,
integer, intent(in) idyna,
type (dt_), intent(in) dt,
type(glob_therm_), intent(inout) glob_therm,
type (sph_work_), intent(inout) sph_work,
double precision, intent(inout) wfext,
type (sensors_), intent(in) sensors )
Parameters
[in,out]outputoutput structure
[in]sensorssensor structure

Definition at line 68 of file forintp.F.

87C-----------------------------------------------
88C M o d u l e s
89C-----------------------------------------------
90 USE timer_mod
91 USE initbuf_mod
92 USE sphbox
93 USE table_mod
94 USE mat_elem_mod
95 USE elbufdef_mod
96 USE nlocal_reg_mod
97 USE output_mod , ONLY : output_
98 USE dt_mod
99 use glob_therm_mod
100 use sensor_mod
101 USE sph_work_mod
102C----6---------------------------------------------------------------7---------8
103C I m p l i c i t T y p e s
104C-----------------------------------------------
105#include "implicit_f.inc"
106#include "comlock.inc"
107C-----------------------------------------------
108C G l o b a l P a r a m e t e r s
109C-----------------------------------------------
110#include "mvsiz_p.inc"
111C-----------------------------------------------
112C C o m m o n B l o c k s
113C-----------------------------------------------
114#include "com01_c.inc"
115#include "com04_c.inc"
116#include "com08_c.inc"
117#include "sphcom.inc"
118#include "param_c.inc"
119#include "parit_c.inc"
120#include "vect01_c.inc"
121#include "scr07_c.inc"
122#include "scr17_c.inc"
123#include "task_c.inc"
124#include "units_c.inc"
125#include "scr02_c.inc"
126#include "scr18_c.inc"
127C-----------------------------------------------------------------
128C D u m m y A r g u m e n t s
129C-----------------------------------------------
130 TYPE(TIMER_), INTENT(INOUT) :: TIMERS
131 INTEGER, INTENT(IN) :: SNPC
132 INTEGER, INTENT(IN) :: STF
133 INTEGER, INTENT(IN) :: SBUFMAT
134 INTEGER, INTENT(IN) :: NSVOIS
135 INTEGER, INTENT(IN) :: IDTMINS
136 INTEGER ,INTENT(IN) :: IRESP
137 INTEGER ,INTENT(IN) :: MAXFUNC
138 INTEGER, INTENT(IN) :: IMPL_S
139 INTEGER, INTENT(IN) :: IDYNA
140 INTEGER, INTENT(IN) :: USERL_AVAIL
141 INTEGER, INTENT(IN) :: IMON_MAT
142 INTEGER IPART(LIPART1,*) ,NPC(*), IPARG(NPARG,*),IADS(8,*),
143 . NELTST, ITYPTST, IPARTSP(*), ISKY(*), ITAB(*),IPM(*),
144 . KXSP(NISP,*),IXSP(KVOISPH,*),NOD2SP(*),
145 . ISPCOND(NISPCOND,*),ISPSYM(NSPCOND,*),
146 . IGEO(NPROPGI,*),
147 . LPRTSPH(2,0:NPART),LONFSPH(*),WASPACT(*),ISPHIO(NISPHIO,*),
148 . ITASK,GRTH(*),IGRTH(*), LGAUGE(3,*), NGROUNC, IGROUNC(*),
149 . IXS(NIXS,*), IRST(3,*), SOL2SPH(2,*), SPH2SOL(*), SOL2SPH_TYP(*)
150 INTEGER, INTENT(IN) :: SPH_IORD1
151 my_real
152 . x(3,*), v(3,*), ms(*), w(*), pm(npropm,*), geo(npropg,*),
153 . bufmat(*), bufgeo(*), pld(*) ,
154 . fsav(nthvki,*), wa(*), fv(*), a(3,*),
155 . partsav(*), stifn(*), fskyi(lskyi,4) ,
156 . xframe(nxframe,*), spbuf(nspbuf,*), xspsym(3,*), vspsym(3,*),
157 . dt2t, wasph(*), vsphio(*),
158 . sphveln(*),gresav(*), gauge(llgauge,*),
159 . fskyv(lsky,8),fsky(8,lsky),temp(*),fthe(*),ftheskyi(*),wsmcomp(*)
160 TYPE(TTABLE) TABLE(*)
161 TYPE (ELBUF_STRUCT_), TARGET, DIMENSION(NGROUP) :: ELBUF_TAB
162 TYPE (NLOCAL_STR_) , TARGET :: NLOC_DMG
163 DOUBLE PRECISION SPHG_F6(4,6,NBGAUGE)
164 TYPE(MATPARAM_STRUCT_) , DIMENSION(NUMMAT) :: MATPARAM_TAB
165 TYPE(OUTPUT_), INTENT(INOUT) :: OUTPUT !< output structure
166 TYPE (MAT_ELEM_) ,INTENT(INOUT) :: MAT_ELEM
167 TYPE (DT_), INTENT(IN) :: DT
168 type(glob_therm_) ,intent(inout) :: glob_therm
169 TYPE (SPH_WORK_),INTENT(INOUT) :: SPH_WORK
170 type (sensors_) ,intent(in) :: sensors !< sensor structure
171 DOUBLE PRECISION,INTENT(INOUT) :: WFEXT
172C-----------------------------------------------
173C L o c a l V a r i a b l e s
174C-----------------------------------------------
175 INTEGER NDSVOID
176 INTEGER I,N, IG, NG, NVC, MLW, JFT, JLT, K, ISTRA,
177 . KAD,IAD2,NF1,IPRI,NGLOC, NELEM, NEL, OFFSET, NSG,
178 . INOD,MX,NS,KSMCOMP,KVNORM,MYADRN,ADRN, NISKY_L,
179 . IPRTSPH, NSOL, NSKI, N1, N2, N3, N4, N5, N6, N7, N8,
180 . K1, K2, K3, K4, K5, K6, K7, K8, IR, IS, IT, NSPHDIR, STAT,
181 . IEXPAN,IBID
182 my_real
183 . off,dtx,dt05,rhoi,vi,
184 . phi1,phi2,phi3,phi4,phi5,phi6,phi7,phi8,
185 . ksi, eta, zeta,
186 . voln(mvsiz)
187 my_real, DIMENSION(MVSIZ,6) :: svis
188C
189 TYPE(G_BUFEL_) ,POINTER :: GBUF
190C-----------------------------------------------
191 my_real
192 . a_gauss(9,9),a_gauss_tetra(9,9)
193 DATA a_gauss /
194 1 0. ,0. ,0. ,
195 1 0. ,0. ,0. ,
196 1 0. ,0. ,0. ,
197 2 -.5 ,0.5 ,0. ,
198 2 0. ,0. ,0. ,
199 2 0. ,0. ,0. ,
200 3 -.666666666666666,0. ,0.666666666666666,
201 3 0. ,0. ,0. ,
202 3 0. ,0. ,0. ,
203 4 -.75 ,-.25 ,0.25 ,
204 4 0.75 ,0. ,0. ,
205 4 0. ,0. ,0. ,
206 5 -.8 ,-.4 ,0. ,
207 5 0.4 ,0.8 ,0. ,
208 5 0. ,0. ,0. ,
209 6 -.833333333333333,-.5 ,-.166666666666666,
210 6 0.166666666666666,0.5 ,0.833333333333333,
211 6 0. ,0. ,0. ,
212 7 -.857142857142857,-.571428571428571,-.285714285714285,
213 7 0. ,0.285714285714285,0.571428571428571,
214 7 0.857142857142857,0. ,0. ,
215 8 -.875 ,-.625 ,-.375 ,
216 8 -.125 ,0.125 ,0.375,
217 8 0.625 ,0.875 ,0. ,
218 9 -.888888888888888,-.666666666666666,-.444444444444444,
219 9 -.222222222222222,0. ,0.222222222222222,
220 9 0.444444444444444,0.666666666666666,0.888888888888888/
221C-----------------------------------------------
222 DATA a_gauss_tetra /
223 1 0.250000000000000,0.000000000000000,0.000000000000000,
224 1 0.000000000000000,0.000000000000000,0.000000000000000,
225 1 0.000000000000000,0.000000000000000,0.000000000000000,
226 2 0.166666666666667,0.500000000000000,0.000000000000000,
227 2 0.000000000000000,0.000000000000000,0.000000000000000,
228 2 0.000000000000000,0.000000000000000,0.000000000000000,
229 3 0.125000000000000,0.375000000000000,0.625000000000000,
230 3 0.000000000000000,0.000000000000000,0.000000000000000,
231 3 0.000000000000000,0.000000000000000,0.000000000000000,
232 4 0.100000000000000,0.300000000000000,0.500000000000000,
233 4 0.700000000000000,0.000000000000000,0.000000000000000,
234 4 0.000000000000000,0.000000000000000,0.000000000000000,
235 5 0.083333333333333,0.250000000000000,0.416666666666667,
236 5 0.583333333333333,0.750000000000000,0.000000000000000,
237 5 0.000000000000000,0.000000000000000,0.000000000000000,
238 6 0.071428571428571,0.214285714285714,0.357142857142857,
239 6 0.500000000000000,0.642857142857143,0.785714285714286,
240 6 0.000000000000000,0.000000000000000,0.000000000000000,
241 7 0.062500000000000,0.187500000000000,0.312500000000000,
242 7 0.437500000000000,0.562500000000000,0.687500000000000,
243 7 0.812500000000000,0.000000000000000,0.000000000000000,
244 8 0.055555555555556,0.166666666666667,0.277777777777778,
245 8 0.388888888888889,0.500000000000000,0.611111111111111,
246 8 0.722222222222222,0.833333333333333,0.000000000000000,
247 9 0.050000000000000,0.150000000000000,0.250000000000000,
248 9 0.350000000000000,0.450000000000000,0.550000000000000,
249 9 0.650000000000000,0.750000000000000,0.850000000000000/
250C-----------------------------------------------
251C calcul des densites et taux de deformations.
252C charge WA(1:14*NUMSPH), qui ne doit pas etre ecrase
253C avt SPSTRES (pour redescente vers les buffers d'elements).
254C
255C DIVV=WA(13,1:NUMSPH) et ROTV=WA(14,1:NUMSPH) ne doivent pas etre
256C ecrases avt le calcul des forces (SPFORC).
257C
258C DIVV=WA(13,1:NUMSPH) ne doit pas etre ecrase avt SPADAH
259C (adaptation du diametre des particules).
260C-----------------------------------------------
261 ibid = 0
262C
263C Allocation SPMD a faire en memoire partagee
264C
265 IF(itask==0) THEN
266 ALLOCATE(sph_work%WASIGSM(6*nsphsym))
267 sph_work%WASIGSM = zero
268 ENDIF
269 IF(itask==0 .AND. nspmd > 1)THEN
270 ALLOCATE(sph_work%WAR(10,nsphr))
271 ALLOCATE(sph_work%WTR(nsphr))
272 ALLOCATE(sph_work%WGR(3,nsphr))
273 ALLOCATE(sph_work%LAMBDR(nsphr))
274 ALLOCATE(sph_work%WAR2(9,nsphr))
275 END IF
276C-------
277 kvnorm =16*numsph+1
278C-----------------------------------------------
279C old density storage.
280 DO n=itask+1,numsph,nthread
281 wa(kwasph*(n-1)+10)=spbuf(2,n)
282 ENDDO
283
284 IF( (glob_therm%ITHERM/=0) .OR. (glob_therm%ITHERM_FE/=0)) THEN
285 IF(itask==0)THEN
286 ALLOCATE(sph_work%WT(numsph))
287 ALLOCATE(sph_work%WGRADT(3*numsph))
288 ALLOCATE(sph_work%WLAPLT(numsph))
289 ALLOCATE(sph_work%LAMBDA(numsph))
290 ALLOCATE(sph_work%WGRADTSM(3*nsphsym))
291 END IF
292 ngdone = 1
293C /---------------/
294 CALL my_barrier
295C /---------------/
296C
297 50 CONTINUE
298#include "lockon.inc"
299 IF(ngdone>ngroup) THEN
300#include "lockoff.inc"
301 GOTO 51
302 ENDIF
303 ng=ngdone
304 ngdone = ng + 1
305#include "lockoff.inc"
306C--------
307 IF(iparg(8,ng)==1)GOTO 50
308 IF (iddw>0) CALL startimeg(ng)
309 DO nelem = 1,iparg(2,ng),nvsiz
310 offset = nelem - 1
311 nsg =iparg(10,ng)
312 nvc =iparg(19,ng)
313 CALL initbuf(iparg ,ng ,
314 2 mtn ,nel ,nft ,iad ,ity ,
315 3 npt ,jale ,ismstr ,jeul ,jtur ,
316 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
317 5 nvaux ,jpor ,jcvt ,jclose ,jplasol ,
318 6 irep ,iint ,igtyp ,israt ,isrot ,
319 7 icsen ,isorth ,isorthg ,ifailure,jsms )
320 lft=1
321 llt=min(nvsiz,nel-nelem+1)
322 IF(ity==51) THEN
323C-----------------------------------------------
324 gbuf => elbuf_tab(ng)%GBUF
325 IF(jthe > 0)THEN
326 DO i=lft,llt
327 n=nft+i
328 IF(kxsp(2,n)>0)THEN
329 sph_work%WT(n)=gbuf%TEMP(i)
330 mx =ipart(1,ipartsp(n))
331 IF(sph_work%WT(n)<=pm(80,mx))THEN
332 sph_work%LAMBDA(n)=pm(75,mx)+pm(76,mx)*sph_work%WT(n)
333 ELSE
334 sph_work%LAMBDA(n)=pm(77,mx)+pm(78,mx)*sph_work%WT(n)
335 END IF
336 END IF
337 END DO
338 ELSEIF (jthe < 0) THEN
339 DO i=lft,llt
340 n=nft+i
341 IF(kxsp(2,n)>0)THEN
342 inod = kxsp(3,n)
343 sph_work%WT(n)=temp(inod)
344 mx =ipart(1,ipartsp(n))
345 IF(sph_work%WT(n)<=pm(80,mx))THEN
346 sph_work%LAMBDA(n)=pm(75,mx)+pm(76,mx)*sph_work%WT(n)
347 ELSE
348 sph_work%LAMBDA(n)=pm(77,mx)+pm(78,mx)*sph_work%WT(n)
349 END IF
350 sph_work%LAMBDA(n)=sph_work%LAMBDA(n)*glob_therm%THEACCFACT
351 END IF
352 END DO
353 ELSE
354 DO i=lft,llt
355 n=nft+i
356 sph_work%WT(n) =zero
357 sph_work%LAMBDA(n)=zero
358 END DO
359 END IF
360C-----------------------------------------------
361 ENDIF
362 IF (iddw>0) CALL stoptimeg(ng)
363 END DO
364 GOTO 50
365C-------
366 51 CONTINUE
367C
368 IF(nspmd>1) THEN
369C /---------------/
370 CALL my_barrier
371C /---------------/
372 IF(itask==0) THEN
373 CALL startime(timers,93)
374 CALL spmd_sphgett(sph_work%WT,sph_work%WTR,sph_work%LAMBDA,sph_work%LAMBDR)
375 CALL stoptime(timers,93)
376 END IF
377 END IF
378C
379C /---------------/
380 CALL my_barrier
381C /---------------/
382C
383 ngdone = 1
384C
385C /---------------/
386 CALL my_barrier
387C /---------------/
388C
389 60 CONTINUE
390#include "lockon.inc"
391 IF(ngdone>ngroup) THEN
392#include "lockoff.inc"
393 GOTO 61
394 ENDIF
395 ng=ngdone
396 ngdone = ng + 1
397#include "lockoff.inc"
398C--------
399 IF(iparg(8,ng)==1)GOTO 60
400 IF (iddw>0) CALL startimeg(ng)
401 DO nelem = 1,iparg(2,ng),nvsiz
402 offset = nelem - 1
403 nsg =iparg(10,ng)
404 nvc =iparg(19,ng)
405 CALL initbuf(iparg ,ng ,
406 2 mtn ,nel ,nft ,iad ,ity ,
407 3 npt ,jale ,ismstr ,jeul ,jtur ,
408 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
409 5 nvaux ,jpor ,jcvt ,jclose ,jplasol ,
410 6 irep ,iint ,igtyp ,israt ,isrot ,
411 7 icsen ,isorth ,isorthg ,ifailure,jsms )
412 lft=1
413 llt=min(nvsiz,nel-nelem+1)
414 IF(ity==51.AND.jthe/=0) THEN
415C-----------------------------------------------
416 CALL spgradt(
417 1 x ,ms ,spbuf ,kxsp ,ixsp ,
418 2 nod2sp ,ispsym ,xspsym ,wa ,wasph ,
419 3 sph_work%WT,sph_work%WTR,sph_work%WGRADT , lft, llt, nft)
420C-----------------------------------------------
421 ENDIF
422 IF (iddw>0) CALL stoptimeg(ng)
423 END DO
424 GOTO 60
425C-------
426 61 CONTINUE
427C
428C /---------------/
429 CALL my_barrier
430C /---------------/
431C
432 IF(nspmd>1) THEN
433 IF(itask==0) THEN
434 CALL startime(timers,93)
435 CALL spmd_sphgetg(sph_work%WGRADT,wasph,sph_work%WGR,sph_iord1)
436 CALL stoptime(timers,93)
437 END IF
438C /---------------/
439 CALL my_barrier
440C /---------------/
441 END IF
442C
443 ngdone = 1
444C
445C-----------------------------------------------
446C PREPARE KERNEL CORRECTIONS FOR SYMMETRIC PARTICLES.
447C-----------------------------------------------
448 CALL spscomp(
449 1 ispsym ,wasph ,ispcond ,xframe ,wsmcomp,
450 2 geo ,ipart ,ipartsp ,waspact ,itask )
451C /---------------/
452 CALL my_barrier
453C /---------------/
454 IF(itask==0)
455 1 CALL spgtsym(
456 1 ispcond, xframe, ispsym, xspsym,
457 2 sph_work%WGRADT, sph_work%WGRADTSM,waspact, sph_work%WGR,
458 3 lft, llt, nft)
459C /---------------/
460 CALL my_barrier
461C /---------------/
462C
463 70 CONTINUE
464#include "lockon.inc"
465 IF(ngdone>ngroup) THEN
466#include "lockoff.inc"
467 GOTO 71
468 ENDIF
469 ng=ngdone
470 ngdone = ng + 1
471#include "lockoff.inc"
472C--------
473 IF(iparg(8,ng)==1)GOTO 70
474 IF (iddw>0) CALL startimeg(ng)
475 DO nelem = 1,iparg(2,ng),nvsiz
476 offset = nelem - 1
477 nsg =iparg(10,ng)
478 nvc =iparg(19,ng)
479 CALL initbuf(iparg ,ng ,
480 2 mtn ,nel ,nft ,iad ,ity ,
481 3 npt ,jale ,ismstr ,jeul ,jtur ,
482 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
483 5 nvaux ,jpor ,jcvt ,jclose ,jplasol ,
484 6 irep ,iint ,igtyp ,israt ,isrot ,
485 7 icsen ,isorth ,isorthg ,ifailure,jsms )
486 lft=1
487 llt=min(nvsiz,nel-nelem+1)
488 IF(ity==51.AND.jthe==1) THEN
489C-----------------------------------------------
490 CALL splaplt(
491 1 x ,ms ,spbuf ,kxsp ,ixsp ,
492 2 nod2sp ,ispsym ,xspsym ,wa ,wasph ,
493 3 sph_work%WGRADT ,sph_work%WGR ,sph_work%WGRADTSM ,sph_work%WLAPLT ,wsmcomp,
494 4 sph_work%LAMBDA ,sph_work%LAMBDR, lft, llt, nft )
495C-----------------------------------------------
496 gbuf => elbuf_tab(ng)%GBUF
497 DO i=lft,llt
498 n=nft+i
499 IF(kxsp(2,n)>0)THEN
500 inod =kxsp(3,n)
501 rhoi =spbuf(2,n)
502 vi =spbuf(12,n)/max(em20,rhoi)
503 gbuf%EINT(i) = gbuf%EINT(i)
504 . + vi*sph_work%WLAPLT(n)*dt1/max(em20,gbuf%VOL(i))
505 END IF
506 END DO
507 ELSEIF(ity==51.AND.jthe==-1)THEN
508C-----------------------------------------------
509 CALL splaplt(
510 1 x ,ms ,spbuf ,kxsp ,ixsp ,
511 2 nod2sp ,ispsym ,xspsym ,wa ,wasph ,
512 3 sph_work%WGRADT ,sph_work%WGR ,sph_work%WGRADTSM ,sph_work%WLAPLT ,wsmcomp,
513 4 sph_work%LAMBDA ,sph_work%LAMBDR ,lft,llt,nft )
514C-----------------------------------------------
515 gbuf => elbuf_tab(ng)%GBUF
516 DO i=lft,llt
517 n=nft+i
518 IF(kxsp(2,n)>0)THEN
519 myadrn =kwasph*(n-1)
520 inod =kxsp(3,n)
521 rhoi =spbuf(2,n)
522 vi =spbuf(12,n)/max(em20,rhoi)
523 wa(myadrn+15) = vi*sph_work%WLAPLT(n)*dt1
524 END IF
525 END DO
526C-----------------------------------------------
527 ENDIF
528 IF (iddw>0) CALL stoptimeg(ng)
529 END DO
530 GOTO 70
531C-------
532 71 CONTINUE
533C
534C /---------------/
535 CALL my_barrier
536C /---------------/
537C
538 IF(itask==0) DEALLOCATE(sph_work%WT, sph_work%WGRADT, sph_work%WLAPLT, sph_work%LAMBDA, sph_work%WGRADTSM)
539
540 END IF
541C-----------------------------------------------
542C
543 ngdone = 1
544C
545C /---------------/
546 CALL my_barrier
547C /---------------/
548C
549C-------
550100 CONTINUE
551#include "lockon.inc"
552 IF(ngdone>ngroup) THEN
553#include "lockoff.inc"
554 GOTO 101
555 ENDIF
556 ng=ngdone
557 ngdone = ng + 1
558#include "lockoff.inc"
559C--------
560 IF(iparg(8,ng)==1)GOTO 100
561 IF (iddw>0) CALL startimeg(ng)
562 DO nelem = 1,iparg(2,ng),nvsiz
563 offset = nelem - 1
564 nel =iparg(2,ng)
565 nft =iparg(3,ng) + offset
566 iad =iparg(4,ng)
567 ity =iparg(5,ng)
568 lft=1
569 llt=min(nvsiz,nel-nelem+1)
570 isph2sol=iparg(69,ng)
571 IF(ity==51) THEN
572 CALL spdens(
573 1 x ,v ,ms ,spbuf ,itab ,
574 2 kxsp ,ixsp ,nod2sp ,ispsym ,xspsym ,
575 3 vspsym ,iparg ,wa ,wasph )
576 ENDIF
577 IF (iddw>0) CALL stoptimeg(ng)
578 END DO
579 GOTO 100
580 101 CONTINUE
581C
582C /---------------/
583 CALL my_barrier
584C /---------------/
585C
586 IF(itask==0)THEN
587C-------
588C-----------------------------------------------
589C Inlets/outlets : Re-impose rho.
590C-----------------------------------------------
591 IF(nsphio/=0)THEN
592C Comm WA et WACOMP sur cellules remotes avant traitement part. sym.
593C on a besoin potentiellement de WA remote
594 IF(nspmd>1)THEN
595 CALL startime(timers,93)
596 CALL spmd_sphgetwa(wa,sph_work%WAR2,kxsp)
597 CALL stoptime(timers,93)
598 ENDIF
599
600 CALL sponfro(x ,v ,a ,ms ,
601 2 spbuf ,itab ,kxsp ,ixsp ,nod2sp ,
602 3 isphio ,ipart ,ipartsp ,waspact ,wa ,
603 4 wasph(kvnorm), sph_work%WAR2 )
604
605 ENDIF
606 ENDIF
607C
608 ngdone = 1
609C
610C /---------------/
611 CALL my_barrier
612C /---------------/
613C
614C-----------------------------------------------
615C Pression=f(densite) : lois materiaux.
616C-----------------------------------------------
617250 CONTINUE
618#include "lockon.inc"
619 IF(ngdone>ngroup) THEN
620#include "lockoff.inc"
621 GOTO 251
622 ENDIF
623 ng=ngdone
624 ngdone = ng + 1
625#include "lockoff.inc"
626C--------
627 IF(iparg(8,ng)==1)GOTO 250
628 IF (iddw>0) CALL startimeg(ng)
629 DO nelem = 1,iparg(2,ng),nvsiz
630 offset = nelem - 1
631 nsg =iparg(10,ng)
632 nvc =iparg(19,ng)
633 CALL initbuf(iparg ,ng ,
634 2 mtn ,nel ,nft ,iad ,ity ,
635 3 npt ,jale ,ismstr ,jeul ,jtur ,
636 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
637 5 nvaux ,jpor ,jcvt ,jclose ,jplasol ,
638 6 irep ,iint ,igtyp ,israt ,isrot ,
639 7 icsen ,isorth ,isorthg ,ifailure,jsms )
640 lft=1
641 llt=min(nvsiz,nel-nelem+1)
642 IF(ity==51) THEN
643 jsph=1
644 jcvt=0
645C full plasticity correction (radial return) by default.
646 jplasol=1
647 istra = iparg(44,ng)
648 isph2sol=iparg(69,ng)
649 iexpan = iparg(49,ng)
650 ipartsph=0
651C-----------------------------------------------
652C retourne SIG, STIF et SSP dans WA(1:8,1:NUMSPH).
653C a ne pas ecraser avt SPFORC.
654C-----------------------------------------------
655 ndsvoid=0
656 CALL spstres(timers,elbuf_tab,ng ,
657 1 pm ,geo ,x ,v ,ms ,
658 2 w ,spbuf ,wa ,nloc_dmg ,
659 3 itab ,pld ,bufmat ,bufgeo ,partsav ,
660 4 fsav ,dt2t ,iparg ,npc ,kxsp ,
661 5 ixsp ,nod2sp ,neltst ,ityptst ,ipart ,
662 6 ipartsp ,fv ,nel ,ipm ,gresav ,
663 7 grth ,igrth ,table ,istra ,voln ,
664 8 igeo ,iexpan ,temp ,itask ,sph2sol ,
665 9 mat_elem ,ibid ,output ,snpc ,stf ,
666 a sbufmat, svis ,nsvois ,idtmins ,iresp,
667 . idel7ng, idel7nok ,idtmin ,maxfunc ,lipart1,
668 . imon_mat, userl_avail,impl_s,
669 v idyna, dt ,glob_therm,sensors)
670 ENDIF
671 IF (iddw>0) CALL stoptimeg(ng)
672 END DO
673 GOTO 250
674C-------
675 251 CONTINUE
676C
677C /---------------/
678 CALL my_barrier
679C /---------------/
680C
681C-----------------------------------------------
682C Download RHO & P from solids to SPH
683C-----------------------------------------------
684 IF(nsphsol/=0)THEN
685C /---------------/
686 CALL my_barrier
687C /---------------/
688 CALL soltosphp(
689 . x ,spbuf ,ixs ,kxsp ,ipartsp ,
690 . irst ,elbuf_tab,iparg ,ngrounc ,igrounc ,
691 . sol2sph,wa ,pm)
692C barrier inside SOLTOSPHP
693 END IF
694C-----------------------------------------------
695C Stabilization (SPH without a tensile instability) :: W(Dp)
696C-----------------------------------------------
697 IF(itask==0)THEN
698 ALLOCATE(sph_work%STAB(7,numsph+nsphr+nsphsym+1),stat=stat)
699 IF (stat/=0)THEN
700 END IF
701 sph_work%STAB=zero
702 END IF
703C /---------------/
704 CALL my_barrier
705C /---------------/
706 CALL spstabw(
707 1 itask ,iparg ,ngrounc ,igrounc ,kxsp ,
708 2 ispcond ,ispsym ,waspact ,sph2sol ,wa ,
709 3 sph_work%WASIGSM,sph_work%WAR ,sph_work%STAB ,ixsp ,nod2sp ,
710 4 spbuf ,x ,ipart ,ipartsp ,xspsym )
711C
712C-------
713C
714C Comm WA et WACOMP sur cellules remotes avant traitement part. sym.
715C
716 IF(nspmd>1)THEN
717C /---------------/
718 CALL my_barrier
719C /---------------/
720 IF(itask==0)THEN
721 CALL startime(timers,93)
722 CALL spmd_sphgetw(spbuf,wasph,wa,sph_work%WAR,sph_iord1)
723C a optimiser (1 seule comm)
724 CALL spmd_sphgetstb(sph_work%STAB,sph_work%STAB(1,numsph+1))
725 CALL stoptime(timers,93)
726 ENDIF
727 END IF
728C-----------------------------------------------
729C Outlets : Re-impose P,E.
730C-----------------------------------------------
731 IF(itask==0)THEN
732 IF(nsphio/=0)THEN
733 CALL sponfprs(x ,v ,a ,ms ,
734 2 spbuf ,itab ,kxsp ,ixsp ,nod2sp ,
735 3 isphio ,vsphio ,npc ,pld ,pm ,
736 4 iparg ,elbuf_tab,ipart ,ipartsp ,waspact ,
737 5 wasph(kvnorm),wa ,sphveln ,sph_work%WAR, wfext)
738
739c on doit mettre a jour wa(1),wa(2),wa(3) suite a sponfprs
740 IF(nspmd>1) THEN
741 CALL startime(timers,93)
742 CALL spmd_sphgetw(spbuf,wasph,wa,sph_work%WAR,sph_iord1)
743 CALL stoptime(timers,93)
744 ENDIF
745 ENDIF
746 END IF
747C-----------------------------------------------
748C PREPARE SYMMETRIC PARTICLES STRESSES.
749C-----------------------------------------------
750 IF(itask==0)THEN
751 CALL spsgsym(ispcond ,xframe ,ispsym ,xspsym ,vspsym ,
752 2 wa ,sph_work%WASIGSM,waspact,sph_work%WAR )
753 ENDIF
754C------
755C
756
757C /---------------/
758 CALL my_barrier
759C /---------------/
760
761 DO ns=itask+1,nsphact,nthread
762 n=waspact(ns)
763 spbuf(11,n)=zero
764 ENDDO
765C
766C-----------------------------------------------
767C PREPARE KERNEL CORRECTIONS FOR SYMMETRIC PARTICLES.
768C-----------------------------------------------
769 IF (glob_therm%ITHERM==0)
770 . CALL spscomp(
771 1 ispsym ,wasph ,ispcond ,xframe ,wsmcomp,
772 2 geo ,ipart ,ipartsp ,waspact ,itask )
773C
774C-----------------------------------------------
775C Assemblage des forces sur les particules.
776C-----------------------------------------------
777C /---------------/
778 CALL my_barrier
779C /---------------/
780C initialisation sur task i
781 DO ns=itask+1,nsphact,nthread
782 n =waspact(ns)
783C (re)used for storage of FX, FY, FZ, STIF :
784 myadrn =kwasph*(n-1)
785 wa(myadrn+10)=zero
786 wa(myadrn+11)=zero
787 wa(myadrn+12)=zero
788 wa(myadrn+ 7)=zero
789 ENDDO
790C-----------------------------------------------
791C Stabilization (SPH without a tensile instability) :: Artificial Stress
792C-----------------------------------------------
793 CALL spstabs(
794 1 itask ,iparg ,ngrounc ,igrounc ,kxsp ,
795 2 ispcond ,ispsym ,waspact ,sph2sol ,wa ,
796 3 sph_work%WASIGSM,sph_work%WAR ,sph_work%STAB ,ixsp ,nod2sp ,
797 4 spbuf ,x )
798C
799C barriere sur WA & STAB obligatoire, WA & STAB partages
800 ngdone = 1
801C /---------------/
802 CALL my_barrier
803C /---------------/
804C-------
805 350 CONTINUE
806#include "lockon.inc"
807 IF(ngdone>ngroup) THEN
808#include "lockoff.inc"
809 GOTO 351
810 ENDIF
811 ng=ngdone
812 ngdone = ng + 1
813#include "lockoff.inc"
814C--------
815C Solids to SPH, particles must be computed when cloud active
816 IF(iparg(8,ng)==1)GOTO 350
817 IF (iddw>0) CALL startimeg(ng)
818 DO nelem = 1,iparg(2,ng),nvsiz
819 offset = nelem - 1
820 nel =iparg(2,ng)
821 nft =iparg(3,ng) + offset
822 iad =iparg(4,ng)
823 ity =iparg(5,ng)
824 isph2sol=iparg(69,ng)
825 ipartsph=0
826 lft=1
827 llt=min(nvsiz,nel-nelem+1)
828 IF(ity==51) THEN
829C-----------
830 CALL spforcp(
831 1 pm ,geo ,x ,v ,ms ,
832 2 spbuf ,itab ,pld ,bufmat ,bufgeo ,
833 3 partsav ,fsav ,dt2t ,iparg ,npc ,
834 4 kxsp ,ixsp ,nod2sp ,neltst ,ityptst ,
835 5 ipart ,ipartsp ,ispcond ,xframe ,ispsym ,
836 6 xspsym ,vspsym ,wa ,sph_work%WASIGSM,wasph ,
837 7 wsmcomp,waspact,sph_work%WAR ,sph_work%STAB, wfext)
838 ENDIF
839 IF (iddw>0) CALL stoptimeg(ng)
840 END DO
841 GOTO 350
842C--------
843 351 CONTINUE
844C
845 nisky_l = nisky
846C /---------------/
847 CALL my_barrier
848C /---------------/
849C--------
850 IF(nsphsol==0)THEN
851 IF (glob_therm%ITHERM_FE > 0)THEN
852 IF(iparit==0)THEN
853 DO ns=itask+1,nsphact,nthread
854 n=waspact(ns)
855 myadrn =kwasph*(n-1)
856 inod=kxsp(3,n)
857 a(1,inod)=a(1,inod)+wa(myadrn+10)
858 a(2,inod)=a(2,inod)+wa(myadrn+11)
859 a(3,inod)=a(3,inod)+wa(myadrn+12)
860 stifn(inod)=stifn(inod)+wa(myadrn+7)
861 fthe(inod)=fthe(inod)+wa(myadrn+15)
862 ENDDO
863 ELSE
864 DO ns=itask+1,nsphact,nthread
865 n=waspact(ns)
866 myadrn =kwasph*(n-1)
867 inod=kxsp(3,n)
868 fskyi(nisky_l+ns,1)=wa(myadrn+10)
869 fskyi(nisky_l+ns,2)=wa(myadrn+11)
870 fskyi(nisky_l+ns,3)=wa(myadrn+12)
871 fskyi(nisky_l+ns,4)=wa(myadrn+7)
872 ftheskyi(nisky_l+ns)=wa(myadrn+15)
873 isky(nisky_l+ns) =inod
874 ENDDO
875 IF(itask==0) nisky = nisky + nsphact
876 ENDIF
877 ELSE
878 IF(iparit==0)THEN
879 DO ns=itask+1,nsphact,nthread
880 n=waspact(ns)
881 myadrn =kwasph*(n-1)
882 inod=kxsp(3,n)
883 a(1,inod)=a(1,inod)+wa(myadrn+10)
884 a(2,inod)=a(2,inod)+wa(myadrn+11)
885 a(3,inod)=a(3,inod)+wa(myadrn+12)
886 stifn(inod)=stifn(inod)+wa(myadrn+7)
887 ENDDO
888 ELSE
889 DO ns=itask+1,nsphact,nthread
890 n=waspact(ns)
891 myadrn =kwasph*(n-1)
892 inod=kxsp(3,n)
893 fskyi(nisky_l+ns,1)=wa(myadrn+10)
894 fskyi(nisky_l+ns,2)=wa(myadrn+11)
895 fskyi(nisky_l+ns,3)=wa(myadrn+12)
896 fskyi(nisky_l+ns,4)=wa(myadrn+7)
897 isky(nisky_l+ns) =inod
898 ENDDO
899 IF(itask==0) nisky = nisky + nsphact
900 ENDIF
901 ENDIF
902 ELSE
903 IF(iparit==0)THEN
904 DO ns=itask+1,nsphact,nthread
905 n=waspact(ns)
906 myadrn =kwasph*(n-1)
907 IF(sph2sol(n)==0)THEN
908 inod=kxsp(3,n)
909 a(1,inod)=a(1,inod)+wa(myadrn+10)
910 a(2,inod)=a(2,inod)+wa(myadrn+11)
911 a(3,inod)=a(3,inod)+wa(myadrn+12)
912 stifn(inod)=stifn(inod)+wa(myadrn+7)
913 ELSEIF (sol2sph_typ(sph2sol(n))==4) THEN
914C---------------
915C------ Tetra --
916C---------------
917 nsol=sph2sol(n)
918C
919 n1=ixs(2,nsol)
920 n2=ixs(4,nsol)
921 n3=ixs(7,nsol)
922 n4=ixs(6,nsol)
923C
924 ir=irst(1,n-first_sphsol+1)
925 is=irst(2,n-first_sphsol+1)
926 it=irst(3,n-first_sphsol+1)
927 nsphdir=igeo(37,ixs(10,nsol))
928C
929 ksi = a_gauss_tetra(ir,nsphdir)
930 eta = a_gauss_tetra(is,nsphdir)
931 zeta = a_gauss_tetra(it,nsphdir)
932C
933 phi1=ksi
934 phi2=eta
935 phi3=zeta
936 phi4=1-ksi-eta-zeta
937C
938 a(1,n1)=a(1,n1)+phi1*wa(myadrn+10)
939 a(2,n1)=a(2,n1)+phi1*wa(myadrn+11)
940 a(3,n1)=a(3,n1)+phi1*wa(myadrn+12)
941 stifn(n1)=stifn(n1)+phi1*wa(myadrn+7)
942
943 a(1,n2)=a(1,n2)+phi2*wa(myadrn+10)
944 a(2,n2)=a(2,n2)+phi2*wa(myadrn+11)
945 a(3,n2)=a(3,n2)+phi2*wa(myadrn+12)
946 stifn(n2)=stifn(n2)+phi2*wa(myadrn+7)
947
948 a(1,n3)=a(1,n3)+phi3*wa(myadrn+10)
949 a(2,n3)=a(2,n3)+phi3*wa(myadrn+11)
950 a(3,n3)=a(3,n3)+phi3*wa(myadrn+12)
951 stifn(n3)=stifn(n3)+phi3*wa(myadrn+7)
952
953 a(1,n4)=a(1,n4)+phi4*wa(myadrn+10)
954 a(2,n4)=a(2,n4)+phi4*wa(myadrn+11)
955 a(3,n4)=a(3,n4)+phi4*wa(myadrn+12)
956 stifn(n4)=stifn(n4)+phi4*wa(myadrn+7)
957C
958 ELSE
959C---------------
960C------ Hexa --
961C---------------
962 nsol=sph2sol(n)
963C
964 n1=ixs(2,nsol)
965 n2=ixs(3,nsol)
966 n3=ixs(4,nsol)
967 n4=ixs(5,nsol)
968 n5=ixs(6,nsol)
969 n6=ixs(7,nsol)
970 n7=ixs(8,nsol)
971 n8=ixs(9,nsol)
972C
973 ir=irst(1,n-first_sphsol+1)
974 is=irst(2,n-first_sphsol+1)
975 it=irst(3,n-first_sphsol+1)
976 nsphdir=nint((sol2sph(2,nsol)-sol2sph(1,nsol))**third)
977C
978 ksi = a_gauss(ir,nsphdir)
979 eta = a_gauss(is,nsphdir)
980 zeta = a_gauss(it,nsphdir)
981C
982 phi1=one_over_8*(one-ksi)*(one-eta)*(one-zeta)
983 phi2=one_over_8*(one-ksi)*(one-eta)*(one+zeta)
984 phi3=one_over_8*(one+ksi)*(one-eta)*(one+zeta)
985 phi4=one_over_8*(one+ksi)*(one-eta)*(one-zeta)
986 phi5=one_over_8*(one-ksi)*(one+eta)*(one-zeta)
987 phi6=one_over_8*(one-ksi)*(one+eta)*(one+zeta)
988 phi7=one_over_8*(one+ksi)*(one+eta)*(one+zeta)
989 phi8=one_over_8*(one+ksi)*(one+eta)*(one-zeta)
990C
991 a(1,n1)=a(1,n1)+phi1*wa(myadrn+10)
992 a(2,n1)=a(2,n1)+phi1*wa(myadrn+11)
993 a(3,n1)=a(3,n1)+phi1*wa(myadrn+12)
994 stifn(n1)=stifn(n1)+phi1*wa(myadrn+7)
995
996 a(1,n2)=a(1,n2)+phi2*wa(myadrn+10)
997 a(2,n2)=a(2,n2)+phi2*wa(myadrn+11)
998 a(3,n2)=a(3,n2)+phi2*wa(myadrn+12)
999 stifn(n2)=stifn(n2)+phi2*wa(myadrn+7)
1000
1001 a(1,n3)=a(1,n3)+phi3*wa(myadrn+10)
1002 a(2,n3)=a(2,n3)+phi3*wa(myadrn+11)
1003 a(3,n3)=a(3,n3)+phi3*wa(myadrn+12)
1004 stifn(n3)=stifn(n3)+phi3*wa(myadrn+7)
1005
1006 a(1,n4)=a(1,n4)+phi4*wa(myadrn+10)
1007 a(2,n4)=a(2,n4)+phi4*wa(myadrn+11)
1008 a(3,n4)=a(3,n4)+phi4*wa(myadrn+12)
1009 stifn(n4)=stifn(n4)+phi4*wa(myadrn+7)
1010
1011 a(1,n5)=a(1,n5)+phi5*wa(myadrn+10)
1012 a(2,n5)=a(2,n5)+phi5*wa(myadrn+11)
1013 a(3,n5)=a(3,n5)+phi5*wa(myadrn+12)
1014 stifn(n5)=stifn(n5)+phi5*wa(myadrn+7)
1015
1016 a(1,n6)=a(1,n6)+phi6*wa(myadrn+10)
1017 a(2,n6)=a(2,n6)+phi6*wa(myadrn+11)
1018 a(3,n6)=a(3,n6)+phi6*wa(myadrn+12)
1019 stifn(n6)=stifn(n6)+phi6*wa(myadrn+7)
1020
1021 a(1,n7)=a(1,n7)+phi7*wa(myadrn+10)
1022 a(2,n7)=a(2,n7)+phi7*wa(myadrn+11)
1023 a(3,n7)=a(3,n7)+phi7*wa(myadrn+12)
1024 stifn(n7)=stifn(n7)+phi7*wa(myadrn+7)
1025
1026 a(1,n8)=a(1,n8)+phi8*wa(myadrn+10)
1027 a(2,n8)=a(2,n8)+phi8*wa(myadrn+11)
1028 a(3,n8)=a(3,n8)+phi8*wa(myadrn+12)
1029 stifn(n8)=stifn(n8)+phi8*wa(myadrn+7)
1030C
1031 END IF
1032 ENDDO
1033 ELSE
1034 IF(itask==0)THEN
1035 nski=0
1036 DO ns=1,nsphact
1037 n=waspact(ns)
1038 myadrn =kwasph*(n-1)
1039 IF(sph2sol(n)==0)THEN
1040 inod=kxsp(3,n)
1041 nski=nski+1
1042 fskyi(nisky_l+nski,1)=wa(myadrn+10)
1043 fskyi(nisky_l+nski,2)=wa(myadrn+11)
1044 fskyi(nisky_l+nski,3)=wa(myadrn+12)
1045 fskyi(nisky_l+nski,4)=wa(myadrn+7)
1046 isky(nisky_l+nski) =inod
1047 ELSEIF (sol2sph_typ(sph2sol(n))==4) THEN
1048C---------------
1049C------ Tetra --
1050C---------------
1051 nsol=sph2sol(n)
1052C
1053 k1=iads(1,nsol)
1054 k2=iads(3,nsol)
1055 k3=iads(6,nsol)
1056 k4=iads(5,nsol)
1057C
1058 ir=irst(1,n-first_sphsol+1)
1059 is=irst(2,n-first_sphsol+1)
1060 it=irst(3,n-first_sphsol+1)
1061 nsphdir=igeo(37,ixs(10,nsol))
1062C
1063 ksi = a_gauss_tetra(ir,nsphdir)
1064 eta = a_gauss_tetra(is,nsphdir)
1065 zeta = a_gauss_tetra(it,nsphdir)
1066C
1067 phi1=ksi
1068 phi2=eta
1069 phi3=zeta
1070 phi4=1-ksi-eta-zeta
1071C
1072 fsky(1,k1)=fsky(1,k1)+phi1*wa(myadrn+10)
1073 fsky(2,k1)=fsky(2,k1)+phi1*wa(myadrn+11)
1074 fsky(3,k1)=fsky(3,k1)+phi1*wa(myadrn+12)
1075 fsky(4,k1)=fsky(4,k1)+phi1*wa(myadrn+7)
1076
1077 fsky(1,k2)=fsky(1,k2)+phi2*wa(myadrn+10)
1078 fsky(2,k2)=fsky(2,k2)+phi2*wa(myadrn+11)
1079 fsky(3,k2)=fsky(3,k2)+phi2*wa(myadrn+12)
1080 fsky(4,k2)=fsky(4,k2)+phi2*wa(myadrn+7)
1081
1082 fsky(1,k3)=fsky(1,k3)+phi3*wa(myadrn+10)
1083 fsky(2,k3)=fsky(2,k3)+phi3*wa(myadrn+11)
1084 fsky(3,k3)=fsky(3,k3)+phi3*wa(myadrn+12)
1085 fsky(4,k3)=fsky(4,k3)+phi3*wa(myadrn+7)
1086
1087 fsky(1,k4)=fsky(1,k4)+phi4*wa(myadrn+10)
1088 fsky(2,k4)=fsky(2,k4)+phi4*wa(myadrn+11)
1089 fsky(3,k4)=fsky(3,k4)+phi4*wa(myadrn+12)
1090 fsky(4,k4)=fsky(4,k4)+phi4*wa(myadrn+7)
1091C
1092 ELSE
1093C---------------
1094C------ Hexa --
1095C---------------
1096 nsol=sph2sol(n)
1097C
1098 k1=iads(1,nsol)
1099 k2=iads(2,nsol)
1100 k3=iads(3,nsol)
1101 k4=iads(4,nsol)
1102 k5=iads(5,nsol)
1103 k6=iads(6,nsol)
1104 k7=iads(7,nsol)
1105 k8=iads(8,nsol)
1106C
1107 ir=irst(1,n-first_sphsol+1)
1108 is=irst(2,n-first_sphsol+1)
1109 it=irst(3,n-first_sphsol+1)
1110C
1111 nsphdir=nint((sol2sph(2,nsol)-sol2sph(1,nsol))**third)
1112 ksi = a_gauss(ir,nsphdir)
1113 eta = a_gauss(is,nsphdir)
1114 zeta = a_gauss(it,nsphdir)
1115C
1116 phi1=one_over_8*(one-ksi)*(one-eta)*(one-zeta)
1117 phi2=one_over_8*(one-ksi)*(one-eta)*(one+zeta)
1118 phi3=one_over_8*(one+ksi)*(one-eta)*(one+zeta)
1119 phi4=one_over_8*(one+ksi)*(one-eta)*(one-zeta)
1120 phi5=one_over_8*(one-ksi)*(one+eta)*(one-zeta)
1121 phi6=one_over_8*(one-ksi)*(one+eta)*(one+zeta)
1122 phi7=one_over_8*(one+ksi)*(one+eta)*(one+zeta)
1123 phi8=one_over_8*(one+ksi)*(one+eta)*(one-zeta)
1124C
1125 fsky(1,k1)=fsky(1,k1)+phi1*wa(myadrn+10)
1126 fsky(2,k1)=fsky(2,k1)+phi1*wa(myadrn+11)
1127 fsky(3,k1)=fsky(3,k1)+phi1*wa(myadrn+12)
1128 fsky(4,k1)=fsky(4,k1)+phi1*wa(myadrn+7)
1129
1130 fsky(1,k2)=fsky(1,k2)+phi2*wa(myadrn+10)
1131 fsky(2,k2)=fsky(2,k2)+phi2*wa(myadrn+11)
1132 fsky(3,k2)=fsky(3,k2)+phi2*wa(myadrn+12)
1133 fsky(4,k2)=fsky(4,k2)+phi2*wa(myadrn+7)
1134
1135 fsky(1,k3)=fsky(1,k3)+phi3*wa(myadrn+10)
1136 fsky(2,k3)=fsky(2,k3)+phi3*wa(myadrn+11)
1137 fsky(3,k3)=fsky(3,k3)+phi3*wa(myadrn+12)
1138 fsky(4,k3)=fsky(4,k3)+phi3*wa(myadrn+7)
1139
1140 fsky(1,k4)=fsky(1,k4)+phi4*wa(myadrn+10)
1141 fsky(2,k4)=fsky(2,k4)+phi4*wa(myadrn+11)
1142 fsky(3,k4)=fsky(3,k4)+phi4*wa(myadrn+12)
1143 fsky(4,k4)=fsky(4,k4)+phi4*wa(myadrn+7)
1144
1145 fsky(1,k5)=fsky(1,k5)+phi5*wa(myadrn+10)
1146 fsky(2,k5)=fsky(2,k5)+phi5*wa(myadrn+11)
1147 fsky(3,k5)=fsky(3,k5)+phi5*wa(myadrn+12)
1148 fsky(4,k5)=fsky(4,k5)+phi5*wa(myadrn+7)
1149
1150 fsky(1,k6)=fsky(1,k6)+phi6*wa(myadrn+10)
1151 fsky(2,k6)=fsky(2,k6)+phi6*wa(myadrn+11)
1152 fsky(3,k6)=fsky(3,k6)+phi6*wa(myadrn+12)
1153 fsky(4,k6)=fsky(4,k6)+phi6*wa(myadrn+7)
1154
1155 fsky(1,k7)=fsky(1,k7)+phi7*wa(myadrn+10)
1156 fsky(2,k7)=fsky(2,k7)+phi7*wa(myadrn+11)
1157 fsky(3,k7)=fsky(3,k7)+phi7*wa(myadrn+12)
1158 fsky(4,k7)=fsky(4,k7)+phi7*wa(myadrn+7)
1159
1160 fsky(1,k8)=fsky(1,k8)+phi8*wa(myadrn+10)
1161 fsky(2,k8)=fsky(2,k8)+phi8*wa(myadrn+11)
1162 fsky(3,k8)=fsky(3,k8)+phi8*wa(myadrn+12)
1163 fsky(4,k8)=fsky(4,k8)+phi8*wa(myadrn+7)
1164C
1165 END IF
1166 ENDDO
1167C
1168 nisky = nisky + nski
1169C
1170 END IF ! IF(ITASK==0)THEN
1171 END IF
1172 END IF
1173C--------
1174C pour travail des forces de visc. artificielle (par cellule).
1175 dt05=half*dt1
1176 DO ns=itask+1,nsphact,nthread
1177 n=waspact(ns)
1178 spbuf(10,n)=spbuf(10,n)+dt05*spbuf(11,n)
1179 ENDDO
1180C-----------------------------------------------
1181C SPH gauges
1182C-----------------------------------------------
1183 CALL spgauge(lgauge ,gauge ,kxsp ,ixsp ,
1184 1 spbuf ,iparg ,elbuf_tab,ispsym ,xspsym,
1185 2 nod2sp ,x ,itask ,wa ,sph_work%WASIGSM,
1186 3 sph_work%WAR ,sphg_f6)
1187C----------------------------------
1188C
1189 ngdone = 1
1190
1191C /---------------/
1192 CALL my_barrier
1193C /---------------/
1194C
1195C Deallocation SPMD a faire en memoire partagee
1196C
1197 IF(itask==0) DEALLOCATE(sph_work%STAB, sph_work%WASIGSM)
1198 IF(itask==0 .AND. nspmd > 1)THEN
1199 DEALLOCATE(sph_work%WAR, sph_work%WTR, sph_work%WGR, sph_work%LAMBDR, sph_work%WAR2)
1200 END IF
1201C
1202C--------
1203 IF(nodadt==1.AND.
1204 . (idtmin(51)==1
1205 . .OR.idtmin(51)==2
1206 . .OR.idtmin(51)==5))THEN
1207400 CONTINUE
1208#include "lockon.inc"
1209 IF(ngdone>ngroup) THEN
1210#include "lockoff.inc"
1211 GOTO 401
1212 ENDIF
1213 ng=ngdone
1214 ngdone = ng + 1
1215#include "lockoff.inc"
1216C--------
1217 IF(iparg(8,ng)==1)GOTO 400
1218 IF (iddw>0) CALL startimeg(ng)
1219 DO nelem = 1,iparg(2,ng),nvsiz
1220 offset = nelem - 1
1221 CALL initbuf(iparg ,ng ,
1222 2 mtn ,nel ,nft ,kad ,ity ,
1223 3 npt ,jale ,ismstr ,jeul ,jtur ,
1224 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
1225 5 nvaux ,jpor ,jcvt ,jclose ,jplasol ,
1226 6 irep ,iint ,igtyp ,israt ,isrot ,
1227 7 icsen ,isorth ,isorthg ,ifailure,jsms )
1228 lft=1
1229 llt=min(nvsiz,nel-nelem+1)
1230 IF(ity==51) THEN
1231 gbuf => elbuf_tab(ng)%GBUF
1232 DO 500 k=lft,llt
1233 n=nft+k
1234 IF(kxsp(2,n)<=0)GOTO 500
1235 inod=kxsp(3,n)
1236 adrn=kwasph*(n-1)+7
1237 dtx =dtfac1(51)*sqrt(two*ms(inod)/max(em20,wa(adrn)))
1238 IF(dtx>dtmin1(51)) GO TO 500
1239 IF(idtmin(51)==1)THEN
1240 tstop = tt
1241#include "lockon.inc"
1242 WRITE(iout,*)
1243 . ' **ERROR : TIME STEP LESS OR EQUAL DTMIN FOR SPH PARTICLE'
1244 WRITE(istdo,*)
1245 . ' **ERROR : TIME STEP LESS OR EQUAL DTMIN FOR SPH PARTICLE'
1246#include "lockoff.inc"
1247 ELSEIF(idtmin(51)==2)THEN
1248 IF (gbuf%OFF(k)/=zero)THEN
1249 gbuf%OFF(k) = zero
1250 kxsp(2,n) = 0
1251#include "lockon.inc"
1252 isphbuc =1
1253 idel7nok=1
1254 WRITE(iout,*)
1255 . ' -- DELETE SPH PARTICLE',kxsp(nisp,n)
1256 WRITE(istdo,*)
1257 . ' -- DELETE SPH PARTICLE',kxsp(nisp,n)
1258#include "lockoff.inc"
1259 END IF
1260 ELSEIF(idtmin(51)==5)THEN
1261 mstop=2
1262#include "lockon.inc"
1263 WRITE(iout,*)
1264 . ' **ERROR : TIME STEP LESS OR EQUAL DTMIN FOR SPH PARTICLE'
1265 WRITE(istdo,*)
1266 . ' **ERROR : TIME STEP LESS OR EQUAL DTMIN FOR SPH PARTICLE'
1267#include "lockoff.inc"
1268 ENDIF
1269 500 CONTINUE
1270 ENDIF
1271 END DO
1272 IF (iddw>0) CALL stoptimeg(ng)
1273 GOTO 400
1274C--------
1275 401 CONTINUE
1276C
1277C /---------------/
1278 CALL my_barrier
1279C /---------------/
1280
1281 ngdone = 1
1282C
1283 ENDIF
1284C-----------------------------------------------
1285C distances de recherche variables
1286C apres calcul des forces (optimisation cpu si CSPH).
1287C-----------------------------------------------
1288 CALL spadah(
1289 1 x ,v ,ms ,spbuf ,itab ,
1290 2 kxsp ,ixsp ,nod2sp ,wa ,waspact ,
1291 3 itask ,ipartsp ,ipart)
1292C-----------------------------------------------
1293C
1294C /---------------/
1295 CALL my_barrier
1296C /---------------/
1297C-----------
1298 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
soltosphp
subroutine soltosphp(x, spbuf, ixs, kxsp, ipartsp, irst, elbuf_tab, iparg, ngrounc, igrounc, sol2sph, wa, pm)
Definition soltosph.F:524
startimeg
subroutine startimeg(ng)
Definition timer.F:1487
stoptimeg
subroutine stoptimeg(ng)
Definition timer.F:1535
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
dt_mod
Definition dt_mod.F:79
initbuf_mod
Definition initbuf.F:160
initbuf_mod::initbuf
subroutine initbuf(iparg, ng, mtn, llt, nft, iad, ity, npt, jale, ismstr, jeul, jtur, jthe, jlag, jmult, jhbe, jivf, mid, jpor, jcvt, jclose, jpla, irep, iint, igtyp, israt, isrot, icsen, isorth, isorthg, ifailure, jsms)
Definition initbuf.F:261
nlocal_reg_mod
Definition nlocal_reg_mod.F:117
sphbox::nsphr
integer nsphr
Definition sphbox.F:83
table_mod
Definition table_mod.F:112
spadah
subroutine spadah(x, v, ms, spbuf, itab, kxsp, ixsp, nod2sp, wa, waspact, itask, ipartsp, ipart)
Definition spadah.F:37
spscomp
subroutine spscomp(ispsym, wacomp, ispcond, xframe, wsmcomp, geo, ipart, ipartsp, waspact, itask)
Definition spcompl.F:1186
spdens
subroutine spdens(x, v, ms, spbuf, itab, kxsp, ixsp, nod2sp, ispsym, xspsym, vspsym, iparg, wa, wacomp)
Definition spdens.F:36
spforcp
subroutine spforcp(pm, geo, x, v, ms, spbuf, itab, pld, bufmat, bufgeo, partsav, fsav, dt2t, iparg, npc, kxsp, ixsp, nod2sp, neltst, ityptst, ipart, ipartsp, ispcond, xframe, ispsym, xspsym, vspsym, wa, wasigsm, wacomp, wsmcomp, waspact, war, stab, wfext)
Definition spforcp.F:40
spgauge
subroutine spgauge(lgauge, gauge, kxsp, ixsp, spbuf, iparg, elbuf_tab, ispsym, xspsym, nod2sp, x, itask, wa, wasigsm, war, sphg_f6)
Definition spgauge.F:40
spmd_sphgetwa
subroutine spmd_sphgetwa(wa, war2, kxsp)
Definition spmd_sph.F:1499
spmd_sphgett
subroutine spmd_sphgett(wt, wtr, lambda, lambdr)
Definition spmd_sph.F:1198
spmd_sphgetg
subroutine spmd_sphgetg(wgradt, wacomp, wgr, sph_iord1)
Definition spmd_sph.F:1301
spmd_sphgetw
subroutine spmd_sphgetw(spbuf, wacomp, wa, war, sph_iord1)
Definition spmd_sph.F:487
spmd_sphgetstb
subroutine spmd_sphgetstb(stab, stabr)
Definition spmd_sph.F:719
sponfprs
subroutine sponfprs(x, v, a, ms, spbuf, itab, kxsp, ixsp, nod2sp, isphio, vsphio, npc, pld, pm, iparg, elbuf_tab, ipart, ipartsp, waspact, vnormal, wa, sphveln, war, wfext)
Definition sponfprs.F:39
sponfro
subroutine sponfro(x, v, a, ms, spbuf, itab, kxsp, ixsp, nod2sp, isphio, ipart, ipartsp, waspact, wa_epsd, vnormal, war2)
Definition sponfro.F:34
spsgsym
subroutine spsgsym(ispcond, xframe, ispsym, xspsym, vspsym, wa, wasigsm, waspact, war)
Definition spsgsym.F:33
spstabw
subroutine spstabw(itask, iparg, ngrounc, igrounc, kxsp, ispcond, ispsym, waspact, sph2sol, wa, wasigsm, war, stab, ixsp, nod2sp, spbuf, x, ipart, ipartsp, xspsym)
Definition spstab.F:37
spstabs
subroutine spstabs(itask, iparg, ngrounc, igrounc, kxsp, ispcond, ispsym, waspact, sph2sol, wa, wasigsm, war, stab, ixsp, nod2sp, spbuf, x)
Definition spstab.F:150
spstres
subroutine spstres(timers, elbuf_tab, ng, pm, geo, x, v, ms, w, spbuf, wa, nloc_dmg, itab, pld, bufmat, bufgeo, partsav, fsav, dt2t, iparg, npc, kxsp, ixsp, nod2sp, neltst, ityptst, ipart, ipartsp, fv, nel, ipm, gresav, grth, igrth, table, istrain, voln, igeo, iexpan, temp, itask, sph2sol, mat_elem, h3d_strain, output, snpc, stf, sbufmat, svis, nsvois, idtmins, iresp, idel7ng, idel7nok, idtmin, maxfunc, lipart1, imon_mat, userl_avail, impl_s, idyna, dt, glob_therm, sensors)
Definition spstres.F:67
spgtsym
subroutine spgtsym(ispcond, xframe, ispsym, xspsym, wgradt, wgradtsm, waspact, wgr, lft, llt, nft)
Definition sptemp.F:661
spgradt
subroutine spgradt(x, ms, spbuf, kxsp, ixsp, nod2sp, ispsym, xspsym, wa, wacomp, wtemp, wtr, wgradt, lft, llt, nft)
Definition sptemp.F:37
splaplt
subroutine splaplt(x, ms, spbuf, kxsp, ixsp, nod2sp, ispsym, xspsym, wa, wacomp, wgradt, wgr, wgradtsm, wlaplt, wsmcomp, lambda, lambdr, lft, llt, nft)
Definition sptemp.F:247
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