OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
agauge.F File Reference
#include "implicit_f.inc"
#include "comlock.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "com08_c.inc"
#include "vect01_c.inc"
#include "param_c.inc"
#include "task_c.inc"
#include "tabsiz_c.inc"
#include "lockon.inc"
#include "lockoff.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine agauge (iparg, elbuf_str, phi, ixs, ixq, x, ale_connect, itask, nercvois, nesdvois, lercvois, lesdvois, lencom, lgauge, gauge, v, igaup, ngaup, ixtg)
subroutine agaug30 (lgauge, gauge, ix, x, nix, numel, nconnect)
subroutine agaug3 (lgauge, gauge, phi, ixs, x, ale_connect)
subroutine agauge0 (lgauge, gauge, x, ixc, igaup, ngaup)

Function/Subroutine Documentation

◆ agaug3()

subroutine agaug3 ( integer, dimension(3,nbgauge) lgauge,
gauge,
phi,
integer, dimension(nixs,numels) ixs,
x,
type(t_ale_connectivity), intent(in) ale_connect )

Definition at line 467 of file agauge.F.

468 USE ale_connectivity_mod
469 use element_mod , only : nixs
470C-----------------------------------------------
471C I m p l i c i t T y p e s
472C-----------------------------------------------
473#include "implicit_f.inc"
474#include "comlock.inc"
475C-----------------------------------------------
476C C o m m o n B l o c k s
477C-----------------------------------------------
478#include "com04_c.inc"
479#include "vect01_c.inc"
480#include "param_c.inc"
481#include "tabsiz_c.inc"
482C-----------------------------------------------
483C D u m m y A r g u m e n t s
484C-----------------------------------------------
485 INTEGER IXS(NIXS,NUMELS),LGAUGE(3,NBGAUGE)
486 my_real phi(sphi),x(3,numnod),gauge(llgauge,nbgauge)
487 TYPE(t_ale_connectivity), INTENT(IN) :: ALE_CONNECT
488C-----------------------------------------------
489C L o c a l V a r i a b l e s
490C-----------------------------------------------
491 INTEGER I,II,J,N,N1,N2,N3,N4,IG,IAD2
492 INTEGER IFACE(4,6)
493 my_real alpha,xx0,yy0,zz0,xx1,yy1,zz1,xx2,yy2,zz2,a1,a2,a3,
494 . vol,areap32,xg,yg,zg
495 DATA iface/ 1, 2, 3, 4,
496 2 4, 3, 7, 8,
497 3 8, 7, 6, 5,
498 4 5, 6, 2, 1,
499 5 2, 6, 7, 3,
500 5 1, 4, 8, 5/
501C-----------------------------------------------
502C S o u r c e L i n e s
503C-----------------------------------------------
504c--------------------------------------------------------------
505c Searching for the new element associated to the gauge
506c--------------------------------------------------------------
507 DO i=1,llt
508 ii=i+nft
509 iad2 = ale_connect%ee_connect%iad_connect(ii)
510 DO j=1,6
511 n= ale_connect%ee_connect%connected(iad2 + j - 1)
512 IF(n<=0)cycle
513 ig=nint(phi(n))
514 IF(ig==0)cycle
515C
516 xg = gauge(2,ig)
517 yg = gauge(3,ig)
518 zg = gauge(4,ig)
519C
520 n1 = ixs(iface(1,j)+1,ii)
521 n2 = ixs(iface(2,j)+1,ii)
522 n3 = ixs(iface(3,j)+1,ii)
523 n4 = ixs(iface(4,j)+1,ii)
524C
525 xx0 = (x(1,n1)+x(1,n2)+x(1,n3)+x(1,n4))*fourth
526 yy0 = (x(2,n1)+x(2,n2)+x(2,n3)+x(2,n4))*fourth
527 zz0 = (x(3,n1)+x(3,n2)+x(3,n3)+x(3,n4))*fourth
528 xx1 = x(1,n3)-x(1,n1)
529 yy1 = x(2,n3)-x(2,n1)
530 zz1 = x(3,n3)-x(3,n1)
531 xx2 = x(1,n4)-x(1,n2)
532 yy2 = x(2,n4)-x(2,n2)
533 zz2 = x(3,n4)-x(3,n2)
534c incoming vector surface
535 a1 = yy1*zz2 - yy2*zz1
536 a2 = xx2*zz1 - xx1*zz2
537 a3 = xx1*yy2 - xx2*yy1
538 vol = a1*(xg-xx0) + a2*(yg-yy0) + a3*(zg-zz0)
539 areap32 = (a1*a1+a2*a2+a3*a3)**three_over_4
540 alpha = vol/max(areap32,em20)
541#include "lockon.inc"
542 IF(alpha >= zero .AND. alpha >= gauge(5,ig))THEN
543c the gauge is changing of element
544c element associated to the gauge
545 lgauge(1,ig)=-ii
546 gauge(5,ig)=alpha
547 ENDIF
548#include "lockoff.inc"
549 ENDDO
550 ENDDO
551
552
553 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
alpha
#define alpha
Definition eval.h:35
iface
integer function iface(ip, n)
Definition iface.F:36
max
#define max(a, b)
Definition macros.h:21
ale_connectivity_mod
Definition ale_connectivity_mod.F:225

◆ agaug30()

subroutine agaug30 ( integer, dimension(3,nbgauge) lgauge,
gauge,
integer, dimension(nix,numel) ix,
x,
integer nix,
integer numel,
integer nconnect )

Definition at line 372 of file agauge.F.

373C-----------------------------------------------
374C Description
375C-----------------------------------------------
376c Searching for element associated to the gauge
377c algorithmic complexity:quadratic (numels*nbgauge) at time 0
378c can be improved
379C-----------------------------------------------
380C I m p l i c i t T y p e s
381C-----------------------------------------------
382#include "implicit_f.inc"
383#include "comlock.inc"
384C-----------------------------------------------
385C C o m m o n B l o c k s
386C-----------------------------------------------
387#include "com04_c.inc"
388#include "vect01_c.inc"
389#include "param_c.inc"
390C-----------------------------------------------
391C D u m m y A r g u m e n t s
392C-----------------------------------------------
393 INTEGER NIX,NUMEL,NCONNECT
394 INTEGER IX(NIX,NUMEL),LGAUGE(3,NBGAUGE)
395 my_real x(3,numnod),gauge(llgauge,nbgauge)
396C-----------------------------------------------
397C L o c a l V a r i a b l e s
398C-----------------------------------------------
399 INTEGER I,II,J,IG,IGAUGE
400 my_real xx1,yy1,zz1,xx2,yy2,zz2,xg,yg,zg
401C-----------------------------------------------
402C S o u r c e L i n e s
403C-----------------------------------------------
404 DO i=1,llt
405 ii=i+nft
406 xx1 = ep30
407 yy1 = ep30
408 zz1 = ep30
409 xx2 = -ep30
410 yy2 = -ep30
411 zz2 = -ep30
412 DO j=2,nconnect+1
413 xx1 = min(xx1,x(1,ix(j,ii)))
414 yy1 = min(yy1,x(2,ix(j,ii)))
415 zz1 = min(zz1,x(3,ix(j,ii)))
416 xx2 = max(xx2,x(1,ix(j,ii)))
417 yy2 = max(yy2,x(2,ix(j,ii)))
418 zz2 = max(zz2,x(3,ix(j,ii)))
419 ENDDO
420C
421 igauge = 0
422 DO ig=1,nbgauge
423 IF(lgauge(1,ig) > 0 .OR.
424 . lgauge(1,ig) < -(numels+numelq+numeltg)) cycle
425 xg = gauge(2,ig)
426 yg = gauge(3,ig)
427 zg = gauge(4,ig)
428 IF (nconnect == 8) THEN
429 ! solid (8N)
430 IF(xg < xx1)cycle
431 IF(xg > xx2)cycle
432
433 IF(yg < yy1)cycle
434 IF(yg > yy2)cycle
435
436 IF(zg < zz1)cycle
437 IF(zg > zz2)cycle
438 ELSEIF (nconnect == 3 . or. nconnect == 4) THEN
439 ! tria 2D + quad 2D
440 IF(yg < yy1)cycle
441 IF(yg > yy2)cycle
442
443 IF(zg < zz1)cycle
444 IF(zg > zz2)cycle
445 ENDIF
446
447 igauge=ig
448 IF(igauge == 0)cycle
449c element associated to the gauge
450c in case of multiple solutions do not need to choose the best one : AGAUG3 will update it.
451#include "lockon.inc"
452 lgauge(1,igauge)=-ii
453#include "lockoff.inc"
454 ENDDO
455 ENDDO
456
457 RETURN
min
#define min(a, b)
Definition macros.h:20

◆ agauge()

subroutine agauge ( integer, dimension(nparg,ngroup) iparg,
type(elbuf_struct_), dimension(ngroup), target elbuf_str,
phi,
integer, dimension(nixs,numels) ixs,
integer, dimension(nixq,numelq) ixq,
x,
type(t_ale_connectivity), intent(in) ale_connect,
integer itask,
integer, dimension(*) nercvois,
integer, dimension(*) nesdvois,
integer, dimension(*) lercvois,
integer, dimension(*) lesdvois,
integer lencom,
integer, dimension(3,nbgauge) lgauge,
gauge,
v,
integer, dimension(nbgauge) igaup,
integer, dimension(nspmd) ngaup,
integer, dimension(nixtg,numeltg) ixtg )

Definition at line 43 of file agauge.F.

48C-----------------------------------------------
49C M o d u l e s
50C-----------------------------------------------
51 USE initbuf_mod
52 USE elbufdef_mod
53 USE ale_connectivity_mod
54 use element_mod , only : nixs,nixq,nixtg
55C-----------------------------------------------
56C I m p l i c i t T y p e s
57C-----------------------------------------------
58#include "implicit_f.inc"
59#include "comlock.inc"
60C-----------------------------------------------
61C C o m m o n B l o c k s
62C-----------------------------------------------
63#include "com01_c.inc"
64#include "com04_c.inc"
65#include "com08_c.inc"
66#include "vect01_c.inc"
67#include "param_c.inc"
68#include "task_c.inc"
69#include "tabsiz_c.inc"
70C-----------------------------------------------
71C D u m m y A r g u m e n t s
72C-----------------------------------------------
73 INTEGER IPARG(NPARG,NGROUP), ITASK, LENCOM,IXTG(NIXTG,NUMELTG),
74 . NERCVOIS(*),NESDVOIS(*),LERCVOIS(*),LESDVOIS(*),
75 . IXS(NIXS,NUMELS),IXQ(NIXQ,NUMELQ),LGAUGE(3,NBGAUGE),IGAUP(NBGAUGE),NGAUP(NSPMD)
76 my_real phi(sphi),gauge(llgauge,nbgauge),x(3,numnod),v(3,numnod)
77 TYPE(ELBUF_STRUCT_), TARGET, DIMENSION(NGROUP) :: ELBUF_STR
78 TYPE(t_ale_connectivity), INTENT(IN) :: ALE_CONNECT
79C-----------------------------------------------
80C L o c a l V a r i a b l e s
81C-----------------------------------------------
82 INTEGER NG, JMUL, IADR, I, II,J,JJ(6),N,IG,IS,IGAUGE,IG0,ITAG(NBGAUGE),NEL,NUMEL,NCONNECT
83 my_real p,rho,e,pa,u2,alpha(nbgauge)
84 TYPE(G_BUFEL_) ,POINTER :: GBUF
85C-----------------------------------------------
86c LGAUGE(3,*)
87c 1: -Isolid -(NUMELS_G+1) if SPH gauge
88c 2: GaugeId
89c 3: +Node or -Shell
90c
91c => GAUGE(LLGAUGE,*), LLGAUGE = 37
92c 1: Dist (distance from Shell) Dist (distance from Shell)
93c 2: XG XG
94c 3: YG YG
95c 4: ZG ZG
96c 5: Alpha (Solid penetration ratio) not yet used
97c 6: XSAV (SPH sorting)
98c 7: YSAV (SPH sorting)
99c 8: ZSAV (SPH sorting)
100c 9: FF (sph only)
101c 10: Intantaneous Pressure
102c 11: intantaneous PA
103c 12: intantaneous Rho
104c 13: intantaneous E
105c 14: ! Butterworth !
106c 15: ! Butterworth !
107c 16: ! Butterworth !
108c 17: ! Butterworth !
109c 18: ! Butterworth !
110c 19: ! Butterworth !
111c 20: ! Butterworth !
112c 21: ! Butterworth !
113c 22: ! Butterworth !
114c 23: ! Butterworth !
115c 24: ! Butterworth !
116c 25: ! Butterworth !
117c 26: ! Butterworth !
118c 27: ! Butterworth !
119c 28: ! Butterworth !
120c 29: ! Butterworth !
121c 30: Pressure filtered Pressure
122c 31: PA filtered PA
123c 32: Rho filtered Rho
124c 33: E filtered E
125c 34: ! Xpoint !
126c 35: ! Ypoint !
127c 36: ! Zpoint !
128c 37: ! Butterworth !
129C-----------------------------------------------
130
131C-----------------------------------------------
132C S o u r c e L i n e s
133C-----------------------------------------------
134 igauge=0
135 DO ig=1,nbgauge
136 IF(lgauge(1,ig) <= 0 .AND. lgauge(1,ig) >= -(numels+numelq+numeltg))
137 . igauge=1
138 END DO
139C
140 CALL my_barrier
141C
142 IF(igauge == 0)RETURN
143C
144C-----------------------------
145C Recherche des elements T=0
146C-----------------------------
147 IF(tt==zero)THEN
148 DO ng=itask+1,ngroup,nthread
149 IF( iparg(5,ng) /= 1 .AND. iparg(5,ng) /= 2 .AND.
150 . (iparg(5,ng) /= 7 .AND. n2d == 0) ) cycle
151 CALL initbuf(iparg ,ng ,
152 2 mtn ,llt ,nft ,iadr ,ity ,
153 3 npt ,jale ,ismstr ,jeul ,jtur ,
154 4 jthe ,jlag ,jmul ,jhbe ,jivf ,
155 5 nvaux ,jpor ,jcvt ,jclose ,jplasol ,
156 6 irep ,iint ,igtyp ,israt ,isrot ,
157 7 icsen ,isorth ,isorthg ,ifailure,jsms )
158 IF (iparg(8,ng) == 1) cycle
159 lft=1
160 IF (iparg(5,ng) == 1) THEN
161 ! solid (8N)
162 numel = numels
163 nconnect = 8
164 CALL agaug30(lgauge,gauge,ixs ,x ,nixs,numel,nconnect)
165 ELSEIF (iparg(5,ng) == 2) THEN
166 ! quad 2D
167 numel = numelq
168 nconnect = 4
169 CALL agaug30(lgauge,gauge,ixq ,x ,nixq,numel,nconnect)
170 ELSEIF (iparg(5,ng) == 7) THEN
171 ! tria 2D
172 numel = numeltg
173 nconnect = 3
174 CALL agaug30(lgauge,gauge,ixtg ,x ,nixtg,numel,nconnect)
175 ENDIF
176 ENDDO
177 CALL my_barrier
178 ENDIF
179C
180 IF(itask==0)THEN
181 DO i=1,max(numels,numelq,numeltg)
182 phi(i)=zero
183 END DO
184C
185 DO ig=1,nbgauge
186 is = -lgauge(1,ig)
187 IF(is > 0 .AND. is <= numels+numelq+numeltg)THEN
188 phi(is)= ig
189C
190C PHI(IS)=I
191c penetration ratio within element (initialisation)
192 gauge(5,ig)=zero
193 ENDIF
194 END DO
195 ENDIF
196C
197 CALL my_barrier
198C-----------------------------
199C SPMD EXCHANGE
200C-----------------------------
201 IF (nspmd > 1) THEN
202!$OMP SINGLE
203 CALL spmd_e1vois(phi,nercvois,nesdvois,lercvois,lesdvois,lencom)
204!$OMP END SINGLE
205 ENDIF
206C-----------------------------
207C Searching for new elements
208C-----------------------------
209 DO ng=itask+1,ngroup,nthread
210 IF( iparg(5,ng) /= 1 .AND. iparg(5,ng) /= 2 .AND.
211 . (iparg(5,ng) /= 7 .AND. n2d == 0) ) cycle
212 CALL initbuf(iparg ,ng ,
213 2 mtn ,llt ,nft ,iadr ,ity ,
214 3 npt ,jale ,ismstr ,jeul ,jtur ,
215 4 jthe ,jlag ,jmul ,jhbe ,jivf ,
216 5 nvaux ,jpor ,jcvt ,jclose ,jplasol ,
217 6 irep ,iint ,igtyp ,israt ,isrot ,
218 7 icsen ,isorth ,isorthg ,ifailure,jsms )
219 IF(iparg(8,ng) == 1) cycle
220
221 lft=1
222 IF (iparg(5,ng) == 1) THEN
223 ! solid (8N)
224 CALL agaug3(lgauge,gauge,phi,ixs ,x ,ale_connect )
225 ELSEIF (iparg(5,ng) == 2) THEN
226 ! quad 2d
227 CALL agaug3q(lgauge,gauge,phi,ixq ,x ,ale_connect )
228 ELSEIF (iparg(5,ng) == 7) THEN
229 ! tria 2D
230 CALL agaug3t(lgauge,gauge,phi,ixtg ,x ,ale_connect )
231 ENDIF
232 END DO
233C
234 CALL my_barrier
235 IF(itask==0)THEN
236 DO i=1,max(numels,numelq,numeltg)
237 phi(i)=zero
238 END DO
239C
240C This array is used when several gauges are on the same element
241c
242 DO ig= 1,nbgauge
243 itag(ig) = 0
244 ENDDO
245C
246 DO ig=1,nbgauge
247 is = -lgauge(1,ig)
248 IF(is > 0 .AND. is <= (numels+numelq+numeltg))THEN
249 ig0 = nint(phi(is))
250 IF(ig0 > 0) THEN
251 itag(ig) = ig0
252 ELSE
253 phi(is) = ig
254 ENDIF
255 ENDIF
256 END DO
257 ENDIF
258C
259 CALL my_barrier
260C-----------------------------
261C SPMD EXCHANGE
262C-----------------------------
263 IF (nspmd > 1) THEN
264!$OMP SINGLE
265 CALL spmd_e1vois(phi,nercvois,nesdvois,lercvois,lesdvois,lencom)
266!$OMP END SINGLE
267 ENDIF
268C-----------------------------
269C CALCULATION OF GAUGE MEASURES
270C-----------------------------
271 DO ng=itask+1,ngroup,nthread
272C-----------------------------
273 IF( iparg(5,ng) /= 1 .AND. iparg(5,ng) /= 2 .AND.
274 . (iparg(5,ng) /= 7 .AND. n2d == 0) ) cycle
275 CALL initbuf(iparg ,ng ,
276 2 mtn ,llt ,nft ,iadr ,ity ,
277 3 npt ,jale ,ismstr ,jeul ,jtur ,
278 4 jthe ,jlag ,jmul ,jhbe ,jivf ,
279 5 nvaux ,jpor ,jcvt ,jclose ,jplasol ,
280 6 irep ,iint ,igtyp ,israt ,isrot ,
281 7 icsen ,isorth ,isorthg ,ifailure,jsms )
282 IF (iparg(8,ng) == 1) cycle
283 gbuf => elbuf_str(ng)%GBUF
284 lft=1
285!
286 nel = llt
287 DO i=1,6
288 jj(i) = nel*(i-1)
289 ENDDO
290!
291 DO i=lft,llt
292 ii=i+nft
293 ig = nint(phi(ii))
294 IF (ig <= 0) cycle
295c
296 p = (gbuf%SIG(jj(1)+i) + gbuf%SIG(jj(2)+i) + gbuf%SIG(jj(3)+i))/three
297 rho = gbuf%RHO(i)
298 e = gbuf%EINT(i)
299 u2 = zero
300c
301 IF (iparg(5,ng) == 1) THEN
302 ! Solid (8N)
303 DO j=2,9
304 n = ixs(j,ii)
305 u2 = u2+ v(1,n)*v(1,n)
306 u2 = u2+ v(2,n)*v(2,n)
307 u2 = u2+ v(3,n)*v(3,n)
308 ENDDO
309 ELSEIF (iparg(5,ng) == 2) THEN
310 ! Quad 2D
311 DO j=2,5
312 n = ixq(j,ii)
313 u2 = u2+ v(1,n)*v(1,n)
314 u2 = u2+ v(2,n)*v(2,n)
315 u2 = u2+ v(3,n)*v(3,n)
316 ENDDO
317 ELSEIF (iparg(5,ng) == 7) THEN
318 ! Tria 2D
319 DO j=2,4
320 n = ixtg(j,ii)
321 u2 = u2+ v(1,n)*v(1,n)
322 u2 = u2+ v(2,n)*v(2,n)
323 u2 = u2+ v(3,n)*v(3,n)
324 ENDDO
325 ENDIF
326 pa = p - rho*u2/sixteen
327#include "lockon.inc"
328 gauge(30,ig)= -p
329 gauge(31,ig)= -pa
330 gauge(32,ig)= rho
331 gauge(33,ig)= e
332#include "lockoff.inc"
333 END DO ! I
334 ENDDO ! NG=ITASK+1,NGROUP,NTASK
335
336 IF(itask == 0) THEN
337 DO ig=1,nbgauge
338 ig0= itag(ig)
339 IF(ig0 > 0) THEN
340#include "lockon.inc"
341 gauge(30,ig)= gauge(30,ig0)
342 gauge(31,ig)= gauge(31,ig0)
343 gauge(32,ig)= gauge(32,ig0)
344 gauge(33,ig)= gauge(33,ig0)
345#include "lockoff.inc"
346 ENDIF
347 ENDDO
348 ENDIF
349C
350 CALL my_barrier
351C-------------
352 IF(nspmd > 1) THEN
353 IF(itask == 0) THEN
354 DO ig=1,nbgauge
355 alpha(ig) = gauge(5,ig)
356 ENDDO
357 CALL spmd_sd_gaug(lgauge,gauge,igaup,ngaup)
358 CALL spmd_rbcast(gauge,gauge,llgauge,nbgauge,0,2)
359C
360 DO ig=1,nbgauge
361 IF(gauge(5,ig) /= alpha(ig))lgauge(1,ig) = 0
362 ENDDO
363 ENDIF
364 ENDIF
365 RETURN
agaug3q
subroutine agaug3q(lgauge, gauge, phi, ixq, x, ale_connect)
Definition agaug3q.F:32
agaug3t
subroutine agaug3t(lgauge, gauge, phi, ixtg, x, ale_connect)
Definition agaug3t.F:32
agaug30
subroutine agaug30(lgauge, gauge, ix, x, nix, numel, nconnect)
Definition agauge.F:373
agaug3
subroutine agaug3(lgauge, gauge, phi, ixs, x, ale_connect)
Definition agauge.F:468
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
spmd_e1vois
subroutine spmd_e1vois(phi, nercvois, nesdvois, lercvois, lesdvois, lencom)
Definition spmd_cfd.F:375
spmd_rbcast
subroutine spmd_rbcast(tabi, tabr, n1, n2, from, add)
Definition spmd_rbcast.F:62
spmd_sd_gaug
subroutine spmd_sd_gaug(lgauge, gauge, igaup, ngaup)
Definition spmd_sd_gaug.F:33
my_barrier
subroutine my_barrier
Definition machine.F:31

◆ agauge0()

subroutine agauge0 ( integer, dimension(3,nbgauge) lgauge,
gauge,
x,
integer, dimension(nixc,numelc) ixc,
integer, dimension(*) igaup,
integer, dimension(*) ngaup )

Definition at line 565 of file agauge.F.

566 use element_mod , only : nixc
567C-----------------------------------------------
568C D e s c r i p t i o n
569C-----------------------------------------------
570c LGAUGE(3,*)
571c 1: -Isolid -(NUMELS_G+1) if SPH gauge
572c 2: GaugeId
573c 3: +Node or -Shell
574c
575c => GAUGE(LLGAUGE,*), LLGAUGE = 37
576c 1: Dist (distance from Shell) Dist (distance from Shell)
577c 2: XG XG
578c 3: YG YG
579c 4: ZG ZG
580c 5: Alpha (Solid penetration ratio) not yet used
581c 6: XSAV (SPH sorting)
582c 7: YSAV (SPH sorting)
583c 8: ZSAV (SPH sorting)
584c 9: FF (sph only)
585c 10: Intantaneous Pressure
586c 11: intantaneous PA
587c 12: intantaneous Rho
588c 13: intantaneous E
589c 14: ! Butterworth !
590c 15: ! Butterworth !
591c 16: ! Butterworth !
592c 17: ! Butterworth !
593c 18: ! Butterworth !
594c 19: ! Butterworth !
595c 20: ! Butterworth !
596c 21: ! Butterworth !
597c 22: ! Butterworth !
598c 23: ! Butterworth !
599c 24: ! Butterworth !
600c 25: ! Butterworth !
601c 26: ! Butterworth !
602c 27: ! Butterworth !
603c 28: ! Butterworth !
604c 29: ! Butterworth !
605c 30: Pressure filtered Pressure
606c 31: PA filtered PA
607c 32: Rho filtered Rho
608c 33: E filtered E
609c 34: ! Xpoint !
610c 35: ! Ypoint !
611c 36: ! Zpoint !
612c 37: ! Butterworth !
613C-----------------------------------------------
614C I m p l i c i t T y p e s
615C-----------------------------------------------
616#include "implicit_f.inc"
617C-----------------------------------------------
618C C o m m o n B l o c k s
619C-----------------------------------------------
620#include "com01_c.inc"
621#include "com04_c.inc"
622#include "param_c.inc"
623C-----------------------------------------------
624C D u m m y A r g u m e n t s
625C-----------------------------------------------
626 INTEGER IXC(NIXC,NUMELC),LGAUGE(3,NBGAUGE),IGAUP(*),NGAUP(*)
627 my_real x(3,numnod),gauge(llgauge,nbgauge)
628C-----------------------------------------------
629C L o c a l V a r i a b l e s
630C-----------------------------------------------
631 INTEGER IG,IS,IGAUGE,N,N1,N2,N3,N4
632 my_real xx0,yy0,zz0,xx1,yy1,zz1,xx2,yy2,zz2,a1,a2,a3,
633 . aa,dist
634C-----------------------------------------------
635C S o u r c e L i n e s
636C-----------------------------------------------
637 igauge=0
638 DO ig=1,nbgauge
639 IF(lgauge(1,ig) <= 0) igauge=1
640 END DO
641 IF(igauge == 0)RETURN
642C
643 DO ig=1,nbgauge
644 is = -lgauge(1,ig)
645C
646C ALL GAUGES (ALE, SPH, ..)
647 IF(is >= 0)THEN
648 gauge(5,ig) = -ep20
649 n = lgauge(3,ig)
650 IF(n > 0)THEN
651 gauge(2,ig) = x(1,n)
652 gauge(3,ig) = x(2,n)
653 gauge(4,ig) = x(3,n)
654 ELSEIF(n < 0)THEN
655 n=-n
656 dist = gauge(1,ig)
657 n1 = ixc(2,n)
658 n2 = ixc(3,n)
659 n3 = ixc(4,n)
660 n4 = ixc(5,n)
661 xx0 = (x(1,n1)+x(1,n2)+x(1,n3)+x(1,n4))*fourth
662 yy0 = (x(2,n1)+x(2,n2)+x(2,n3)+x(2,n4))*fourth
663 zz0 = (x(3,n1)+x(3,n2)+x(3,n3)+x(3,n4))*fourth
664 xx1 = x(1,n3)-x(1,n1)
665 yy1 = x(2,n3)-x(2,n1)
666 zz1 = x(3,n3)-x(3,n1)
667 xx2 = x(1,n4)-x(1,n2)
668 yy2 = x(2,n4)-x(2,n2)
669 zz2 = x(3,n4)-x(3,n2)
670cc A1 = YY1*YY2 - ZZ1*ZZ2
671cc A2 = ZZ1*ZZ2 - XX1*XX2
672cc A3 = XX1*XX2 - YY1*YY2
673 a1 = yy1*zz2 - yy2*zz1
674 a2 = xx2*zz1 - xx1*zz2
675 a3 = xx1*yy2 - xx2*yy1
676 aa = dist/sqrt(max(em20,a1*a1+a2*a2+a3*a3))
677 gauge(2,ig) = xx0 + aa*a1
678 gauge(3,ig) = yy0 + aa*a2
679 gauge(4,ig) = zz0 + aa*a3
680 ELSE
681 ! point coordinates
682 gauge(2,ig) = gauge(34,ig)
683 gauge(3,ig) = gauge(35,ig)
684 gauge(4,ig) = gauge(36,ig)
685 ENDIF
686 ENDIF
687 END DO
688C
689 IF(nspmd > 1 ) THEN
690 CALL spmd_sd_gau(gauge,igaup,ngaup)
691 CALL spmd_rbcast(gauge,gauge,llgauge,nbgauge,0,2)
692 ENDIF
693C
694 RETURN
spmd_sd_gau
subroutine spmd_sd_gau(gauge, igaup, ngaup)
Definition spmd_sd_gau.F:34