OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spgauge.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "sphcom.inc"
#include "parit_c.inc"
#include "com08_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine spgauge (lgauge, gauge, kxsp, ixsp, spbuf, iparg, elbuf_tab, ispsym, xspsym, nod2sp, x, itask, wa, wasigsm, war, sphg_f6)
subroutine spgauge_f (p, ff, p0, p1, p2, n)

Function/Subroutine Documentation

◆ spgauge()

subroutine spgauge ( integer, dimension(3,*) lgauge,
gauge,
integer, dimension(nisp,*) kxsp,
integer, dimension(kvoisph,*) ixsp,
spbuf,
integer, dimension(nparg,*) iparg,
type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, dimension(nspcond,*) ispsym,
xspsym,
integer, dimension(*) nod2sp,
x,
integer itask,
wa,
wasigsm,
war,
double precision, dimension(4,6,nbgauge) sphg_f6 )

Definition at line 36 of file spgauge.F.

40C-----------------------------------------------
41C M o d u l e s
42C-----------------------------------------------
43 USE initbuf_mod
44 USE sphbox
45 USE elbufdef_mod
46C-----------------------------------------------
47C I m p l i c i t T y p e s
48C-----------------------------------------------
49#include "implicit_f.inc"
50C-----------------------------------------------
51C C o m m o n B l o c k s
52C-----------------------------------------------
53#include "com01_c.inc"
54#include "com04_c.inc"
55#include "param_c.inc"
56#include "sphcom.inc"
57#include "parit_c.inc"
58C-----------------------------------------------
59C D u m m y A r g u m e n t s
60C-----------------------------------------------
61 INTEGER LGAUGE(3,*), KXSP(NISP,*), IXSP(KVOISPH,*),
62 . IPARG(NPARG,*), ISPSYM(NSPCOND,*), NOD2SP(*), ITASK
63C REAL
64 my_real
65 . gauge(llgauge,*), spbuf(nspbuf,*), x(3,*),xspsym(3,*),
66 . wa(kwasph,*), wasigsm(6,*), war(10,*)
67 TYPE (ELBUF_STRUCT_), TARGET, DIMENSION(NGROUP) :: ELBUF_TAB
68 DOUBLE PRECISION SPHG_F6(4,6,NBGAUGE)
69C-----------------------------------------------
70c GAUGE(3,*)
71c 1: -Isolid -(NUMELS_G+1) if SPH gauge
72c 2: GaugeId
73c 3: +Node or -Shell
74c
75c => GAUGE(LLGAUGE,*), LLGAUGE = 37
76c 1: Dist (distance from Shell) Dist (distance from Shell)
77c 2: XG XG
78c 3: YG YG
79c 4: ZG ZG
80c 5: Alpha (Solid penetration ratio) not yet used
81c 6: XSAV (SPH sorting)
82c 7: YSAV (SPH sorting)
83c 8: ZSAV (SPH sorting)
84c 9: FF (sph only)
85c 10: intantaneous Pressure
86c 11: not yet available
87c 12: intantaneous Rho
88c 13: intantaneous E
89c 14: ! Butterworth !
90c 15: ! Butterworth !
91c 16: ! Butterworth !
92c 17: ! Butterworth !
93c 18: ! Butterworth !
94c 19: ! Butterworth !
95c 20: ! Butterworth !
96c 21: ! Butterworth !
97c 22: ! Butterworth !
98c 23: ! Butterworth !
99c 24: ! Butterworth !
100c 25: ! Butterworth !
101c 26: ! Butterworth !
102c 27: ! Butterworth !
103c 28: ! Butterworth !
104c 29: ! Butterworth !
105c 30: Pressure filtered Pressure
106c 31: PA not yet available
107c 32: Rho filtered Rho
108c 33: E filtered E
109c 34: ! Butterworth !
110c 35: ! Butterworth !
111c 36: ! Butterworth !
112c 37: ! Butterworth !
113C-----------------------------------------------
114C L o c a l V a r i a b l e s
115C-----------------------------------------------
116 INTEGER I,N,INOD,JNOD,J,NVOIS,M,
117 . NVOISS,SM,JS,NC,NS,NN,
118 . IG,NEL,KAD,NG,K,KK,SFGAUGE,FR_RL(NSPMD+2)
119 my_real
120 . xi,yi,zi,di,rhoi,xj,yj,zj,dj,rhoj,vj,
121 . wght,alphai,wcompi,
122 . pp,ee,press,ener,rho
123 TYPE(G_BUFEL_) ,POINTER :: GBUF
124 my_real
125 . , DIMENSION(:), ALLOCATABLE :: fgauge1,fgauge2,fgauge3,fgauge4
126C-----------------------------------------------
127 fr_rl(:) = 1
128!$OMP DO SCHEDULE(DYNAMIC,1)
129 DO ig=1,nbgauge
130 IF(lgauge(1,ig) > -(numels+1)) cycle
131C------
132 n=numsph+ig
133 xi =gauge(2,ig)
134 yi =gauge(3,ig)
135 zi =gauge(4,ig)
136 wcompi =zero
137 press =zero
138 ener =zero
139 rho =zero
140C------
141 nvois=kxsp(4,n)
142C------
143 sfgauge = kxsp(4,n) + kxsp(6,n)
144 ALLOCATE(fgauge1(sfgauge),fgauge2(sfgauge),fgauge3(sfgauge),fgauge4(sfgauge))
145C------
146 DO j=1,nvois
147 jnod=ixsp(j,n)
148 IF(jnod>0)THEN
149 m=nod2sp(jnod)
150 IF(kxsp(2,m)<=0) cycle
151 xj=x(1,jnod)
152 yj=x(2,jnod)
153 zj=x(3,jnod)
154 dj =spbuf(1,m)
155 rhoj=spbuf(2,m)
156 vj=spbuf(12,m)/max(em20,rhoj)
157 CALL weight0(xi,yi,zi,xj,yj,zj,dj,wght)
158 wcompi=vj*wght
159 pp=-third*(wa(1,m)+wa(2,m)+wa(3,m))
160 fgauge1(j) = wcompi
161 fgauge2(j) = vj*wght*pp
162 fgauge3(j) = vj*wght*rhoj
163 fgauge4(j) = ener
164 END IF
165 ENDDO
166C------
167C partie symetrique.
168 nvoiss=kxsp(6,n)
169 k = nvois
170 DO j=kxsp(5,n)+1,kxsp(5,n)+nvoiss
171 js=ixsp(j,n)
172 IF(js>0)THEN
173 sm=js/(nspcond+1)
174 nc=mod(js,nspcond+1)
175 js=ispsym(nc,sm)
176 xj =xspsym(1,js)
177 yj =xspsym(2,js)
178 zj =xspsym(3,js)
179 dj =spbuf(1,sm)
180 rhoj=spbuf(2,sm)
181 vj=spbuf(12,sm)/max(em20,rhoj)
182 CALL weight0(xi,yi,zi,xj,yj,zj,dj,wght)
183 wcompi=vj*wght
184 pp=-third*(wasigsm(1,js)+wasigsm(2,js)+wasigsm(3,js))
185 k = k+1
186 fgauge1(k) = wcompi
187 fgauge2(k) = vj*wght*pp
188 fgauge3(k) = vj*wght*rhoj
189 fgauge4(k) = ener
190 END IF
191 ENDDO
192C
193C Traitement Parith/ON avant echange
194C
195 DO k = 1, 6
196 sphg_f6(1,k,ig) = zero
197 sphg_f6(2,k,ig) = zero
198 sphg_f6(3,k,ig) = zero
199 sphg_f6(4,k,ig) = zero
200 END DO
201C
202 IF(iparit > 0)THEN
203 CALL sum_6_float(1 ,sfgauge ,fgauge1, sphg_f6(1,1,ig),4)
204 CALL sum_6_float(1 ,sfgauge ,fgauge2, sphg_f6(2,1,ig),4)
205 CALL sum_6_float(1 ,sfgauge ,fgauge3, sphg_f6(3,1,ig),4)
206 CALL sum_6_float(1 ,sfgauge ,fgauge4, sphg_f6(4,1,ig),4)
207 ELSE
208 DO i=1,sfgauge
209 k = 1
210 sphg_f6(1,k,ig) = sphg_f6(1,k,ig) + fgauge1(i)
211 sphg_f6(2,k,ig) = sphg_f6(2,k,ig) + fgauge2(i)
212 sphg_f6(3,k,ig) = sphg_f6(3,k,ig) + fgauge3(i)
213 sphg_f6(4,k,ig) = sphg_f6(4,k,ig) + fgauge4(i)
214 END DO
215 END IF
216C------
217 DEALLOCATE(fgauge1,fgauge2,fgauge3,fgauge4)
218C-----------------
219 END DO
220!$OMP END DO
221C
222C-------------
223 IF(nspmd > 1) THEN
224!$OMP SINGLE
225 CALL spmd_exch_fr6(fr_rl,sphg_f6,4*nbgauge*6)
226!$OMP END SINGLE
227 ENDIF
228C-------------
229C
230C Traitement Parith/ON apres echange
231C
232!$OMP DO SCHEDULE(DYNAMIC,1)
233 DO ig=1,nbgauge
234 IF(lgauge(1,ig) > -(numels+1)) cycle
235 wcompi = sphg_f6(1,1,ig)+sphg_f6(1,2,ig)+sphg_f6(1,3,ig)+
236 + sphg_f6(1,4,ig)+sphg_f6(1,5,ig)+sphg_f6(1,6,ig)
237 press = sphg_f6(2,1,ig)+sphg_f6(2,2,ig)+sphg_f6(2,3,ig)+
238 + sphg_f6(2,4,ig)+sphg_f6(2,5,ig)+sphg_f6(2,6,ig)
239 rho = sphg_f6(3,1,ig)+sphg_f6(3,2,ig)+sphg_f6(3,3,ig)+
240 + sphg_f6(3,4,ig)+sphg_f6(3,5,ig)+sphg_f6(3,6,ig)
241 alphai=one/max(em20,wcompi)
242 press=press*alphai
243 rho =rho*alphai
244 gauge(10,ig)=press
245 gauge(12,ig)=rho
246C energy not yet available
247 gauge(13,ig)=zero
248 END DO
249!$OMP END DO
250C
251 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
initbuf_mod
Definition initbuf.F:160
sum_6_float
subroutine sum_6_float(jft, jlt, f, f6, n)
Definition parit.F:64
spmd_exch_fr6
subroutine spmd_exch_fr6(fr, fs6, len)
Definition spmd_exch_fr6.F:51
weight0
subroutine weight0(xi, yi, zi, xj, yj, zj, h, w)
Definition weight.F:34

◆ spgauge_f()

subroutine spgauge_f ( p,
ff,
p0,
p1,
p2,
integer n )

Definition at line 258 of file spgauge.F.

259C-----------------------------------------------
260C I m p l i c i t T y p e s
261C-----------------------------------------------
262#include "implicit_f.inc"
263C-----------------------------------------------
264C C o m m o n B l o c k s
265C-----------------------------------------------
266#include "com08_c.inc"
267C-----------------------------------------------
268C D u m m y A r g u m e n t s
269C-----------------------------------------------
270 INTEGER N
271C REAL
272 my_real
273 . p(n),p0(n,2),p1(n,2),p2(n,2),ff
274C-----------------------------------------------
275C L o c a l V a r i a b l e s
276C-----------------------------------------------
277 INTEGER J,IFIRST
278 my_real
279 . pi1,pi8,pi38,spi8,spi38,c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,
280 , x1,x2,x3,y1,y2,y3,z1,z2,z3,d,dd,d2,dp,e,g,f
281C
282 IF(ff==zero)THEN
283 DO j=1,n
284 p2(j,1) = p(j)
285 ENDDO
286 RETURN
287 END IF
288C
289 f = min(ff,zep4/dt2)
290C-----------------------------------------------
291C INITIALIALISATION DES COEFFICIENTS DU FILTRE
292C-----------------------------------------------
293 pi1 = two*atan2(one,zero)
294 pi8 = pi1*one_over_8
295 pi38 = three*pi8
296 spi8 = sin(pi8)
297 spi38 = sin(pi38)
298C
299 d = tan(pi1*f*dt2)
300 dd = d*d
301 d2 = two*d
302 dp = one + dd
303 e = d2*spi8
304 g = e + dp
305 g = one/g
306C
307 c0 = dd * g
308 c1 = two* c0
309 c2 = c0
310 c3 = two * g - c1
311 c4 = (e - dp) * g
312C
313 e = d2*spi38
314 g = e + dp
315 g = one/g
316C
317 c5 = dd * g
318 c6 = two * c5
319 c7 = c5
320 c8 = two * g - c6
321 c9 = (e - dp) * g
322C-----------------------------------------------
323C FILTRAGE
324C-----------------------------------------------
325 DO j=1,n
326 x1 = p0(j,2)
327 x2 = p0(j,1)
328 x3 = p(j)
329 y1 = p1(j,2)
330 y2 = p1(j,1)
331 y3 = c0 * x3 + c1 * x2 + c2 * x1
332 . + c3 * y2 + c4 * y1
333 z1 = p2(j,2)
334 z2 = p2(j,1)
335 z3 = c5 * y3 + c6 * y2 + c7 * y1
336 . + c8 * z2 + c9 * z1
337C
338 p0(j,2) = x2
339 p0(j,1) = x3
340 p1(j,2) = y2
341 p1(j,1) = y3
342 p2(j,2) = z2
343 p2(j,1) = z3
344 ENDDO
345C
346 RETURN
min
#define min(a, b)
Definition macros.h:20