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 464 of file agauge.F.

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

◆ agaug30()

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

Definition at line 370 of file agauge.F.

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

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

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