OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
noise.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "com08_c.inc"
#include "units_c.inc"
#include "scrnoi_c.inc"
#include "scr05_c.inc"
#include "scr13_c.inc"
#include "task_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine noise (dt2r, in, j, buf, v, a, ixs, elbuf_tab, iparg, weight, ixq)

Function/Subroutine Documentation

◆ noise()

subroutine noise ( dt2r,
integer, dimension(*) in,
integer, dimension(*) j,
buf,
v,
a,
integer, dimension(*) ixs,
type (elbuf_struct_), dimension(ngroup) elbuf_tab,
integer, dimension(*) iparg,
integer, dimension(*) weight,
integer, dimension(*) ixq )

Definition at line 37 of file noise.F.

41C-----------------------------------------------
42C M o d u l e s
43C-----------------------------------------------
44 USE elbufdef_mod
45C-----------------------------------------------
46C I m p l i c i t T y p e s
47C-----------------------------------------------
48#include "implicit_f.inc"
49C-----------------------------------------------
50C C o m m o n B l o c k s
51C-----------------------------------------------
52#include "com01_c.inc"
53#include "com04_c.inc"
54#include "com08_c.inc"
55#include "units_c.inc"
56#include "scrnoi_c.inc"
57#include "scr05_c.inc"
58#include "scr13_c.inc"
59#include "task_c.inc"
60C-----------------------------------------------
61C D u m m y A r g u m e n t s
62C-----------------------------------------------
63 INTEGER IN(*),J(*),IXS(*),IPARG(*), WEIGHT(*),IXQ(*)
64 my_real
65 . buf(ncnois,*),v(3,*),dt2r ,a(3,*)
66 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
67C-----------------------------------------------
68C L o c a l V a r i a b l e s
69C-----------------------------------------------
70 INTEGER , DIMENSION(:), ALLOCATABLE :: ELNOI,ELG,NOIADD
71 my_real,DIMENSION(:),ALLOCATABLE :: c
72 INTEGER IPELNOI,IPNOIADD,IPTC
73 INTEGER IFIRST,I,K,L,NE,NC,KK,IAD, LEN
74 my_real pi1,pi2,tol,te,tc,fne,fac,dec,to,trans,xi,w,cc,ttn
75 INTEGER LENGTH, ITAG(0:NUMNOD)
76 SAVE ifirst,te,iptc,c,nc,to,ipelnoi,elnoi,elg,ipnoiadd,noiadd
77 DATA ifirst/0/
78 my_real wa(nnoise)
79C-----------------------------------------------
80C INITIALIALISATION DES COEFFICIENTS DU FILTRE
81C-----------------------------------------------
82 ne = 0
83 tol=em01
84 IF(ispmd==0) THEN
85 iunit=iunoi
86 IF(itform==3) CALL cur_fil_c(iunit)
87 ENDIF
88 IF(ifirst==0)THEN
89 ifirst=1
90 IF(rnoi==0)THEN
91C NE : NOMBRE D'ECHANTILLON ENTRE CHAQUE SORTIE
92 te=dt2
93 dt2r=te
94 ne=max(1,int(dtnoise/te))
95 j(7)=ne
96 ELSEIF(rnoi==1)THEN
97 te=dt2r
98 ne=j(7)
99 ENDIF
100C
101C INITIALISATION DES TABLEAUX D'ELEMENTS PAR NOEUDS SAUVES
102C
103 IF(noisep/=0)THEN
104 ALLOCATE (noiadd(nnoise+1))
105 CALL initnoise(in,noiadd,ixs,itag(0),length,ixq)
106 ALLOCATE(elnoi(length))
107 ALLOCATE(elg(length))
108 CALL initnoise2(in,elnoi,elg,noiadd,ixs,itag(1),iparg,ixq)
109 ENDIF
110C TC PERIODE DE COUPURE
111 dtnoise=float(ne)*te
112 tc=2.*dtnoise
113C NOMBRE DE COEFFICIENTS ET ALLOCATION ; TO DEPHASAGE
114 nc=6*ne
115 fac=one/float(ne)
116 dec=float(3*ne) - half
117 to=float(3*ne)*te
118 IF(nc>0)THEN
119 ALLOCATE(c(nc))
120 ENDIF
121C
122C COEFF. DU FILTRE PARFAIT AVEC FENETRE DE HAMMING
123C
124 pi2 = two*pi
125 trans=0
126 DO i=1,nc
127 xi=float(i-1)-dec
128 w=0.54+0.46*cos(pi2*xi/float(nc))
129 IF(abs(pi*fac*xi)<tol)THEN
130 c(i)=fac
131 ELSE
132 c(i)=w*sin(pi*xi*fac)/pi/xi
133 ENDIF
134 trans=trans+c(i)
135 ENDDO
136C
137 IF(ispmd==0) THEN
138 WRITE(iout,1000)one/dtnoise,one/tc,nc,trans
139 WRITE(iout,'(1P8E10.3)')(c(i),i=1,nc)
140 WRITE(iout,'(//)')
141 ENDIF
142C
143 IF(rnoi==0)THEN
144 DO k=1,6
145 j(k)=(1-k)*ne-1
146 ENDDO
147 DO i=1,6*nnoise
148 DO l=1,ncnois
149 buf(l,i)=zero
150 ENDDO
151 ENDDO
152 ENDIF
153 ENDIF
154 IF(ispmd==0) THEN
155 IF(abs(1.-dt2/te)>tol)THEN
156 WRITE(iout,1100)
157 WRITE(istdo,1100)
158 ENDIF
159 ENDIF
160 IF(rnoi==0 .AND. tt-to<tnoise-nc*te)RETURN
161C-----------------------------------------------
162C PRESSION
163C-----------------------------------------------
164 IF(noisep/=0)CALL pnoise(elnoi,elg,noiadd,elbuf_tab,wa,iparg)
165C-----------------------------------------------
166C FILTRAGE
167C-----------------------------------------------
168C
169C Anullation buffer noise sur pi, i<>0 en SPMD
170C
171 IF(ispmd/=0) THEN
172 DO i=1,6*nnoise
173 DO l=1,ncnois
174 buf(l,i)=zero
175 ENDDO
176 ENDDO
177 ENDIF
178C
179 DO k=1,6
180 j(k)=j(k)+1
181 IF(j(k)>0)THEN
182 cc=c(j(k))
183 kk=(k-1)*nnoise
184 DO i=1,nnoise
185 kk=kk+1
186 IF(in(i) /= 0)THEN ! test if present on current domain (spmd)
187 IF(weight(in(i))==1) THEN
188 IF(noisev/=0)THEN
189 buf(1,kk)=buf(1,kk)+cc *v(1,in(i))
190 buf(2,kk)=buf(2,kk)+cc *v(2,in(i))
191 buf(3,kk)=buf(3,kk)+cc *v(3,in(i))
192 ENDIF
193 IF(noisea/=0)THEN
194 iad=3*noisev
195 buf(iad+1,kk)=buf(iad+1,kk)+cc *a(1,in(i))
196 buf(iad+2,kk)=buf(iad+2,kk)+cc *a(2,in(i))
197 buf(iad+3,kk)=buf(iad+3,kk)+cc *a(3,in(i))
198 ENDIF
199 ENDIF
200 END IF
201 IF(noisep/=0.AND.ispmd==0)THEN
202 iad=3*noisev+3*noisea+1
203 buf(iad,kk)=buf(iad,kk)-cc *wa(i)
204 ENDIF
205 ENDDO ! I
206 ENDIF
207 ENDDO ! K
208C
209C GATHER SPMD BUF
210C
211 IF(nspmd>1) THEN
212 len = 6*nnoise*ncnois
213 CALL spmd_glob_dsum9(buf,len)
214 ENDIF
215C-----------------------------------------------------
216C INCREMENTATION DES INDICES ET ECRITURE DES RESULTATS
217C-----------------------------------------------------
218 DO k=1,6
219 IF(j(k)==nc)THEN
220 j(k)=0
221 kk=(k-1)*nnoise+1
222 ttn=tt-to
223 IF(ispmd==0) THEN
224 CALL wrtdes(ttn,ttn,1,itform,1)
225 CALL wrtdes(ttn,ttn,1,itform,1)
226 CALL wrtdes(buf(1,kk),buf(1,kk),ncnois*nnoise,itform,1)
227 ENDIF
228 DO i=(k-1)*nnoise+1,k*nnoise
229 DO l=1,ncnois
230 buf(l,i)=zero
231 ENDDO
232 ENDDO
233 ENDIF
234 ENDDO
235c
236C-----------
237 RETURN
238 1000 FORMAT(///
239 . ' OUTPUT OF SAMPLED VELOCITIES FOR NOISE AND VIBRATION ',//
240 . ' EFFECTIVE SAMPLING FREQUENCY . . . . . . . . . . ',1pe10.4/
241 . ' HIGH FREQUENCY CUTOFF . . . . . . . . . . . . . ',1pe10.4/
242 . ' NUMBER OF COEFFICIENT USED FOR FILTERING . . . . ',i10/
243 . ' STATIC TRANSMITANCE OF FILTER . . . . . . . . . ',1pe10.4/
244 . ' LIST OF COEFFICIENTS USED FOR FILTERING . . . . ')
245 1100 FORMAT('*** WARNING STRUCTURAL TIME STEP MUST BE CONSTANT ***')
my_real
#define my_real
Definition cppsort.cpp:32
initnoise2
subroutine initnoise2(in, elnoi, elg, noiadd, ixs, iwa, iparg, ixq)
Definition initnoise.F:99
initnoise
subroutine initnoise(in, noiadd, ixs, iwa, length, ixq)
Definition initnoise.F:29
max
#define max(a, b)
Definition macros.h:21
pnoise
subroutine pnoise(elnoi, elg, noiadd, elbuf_tab, wa, iparg)
Definition pnoise.F:34
spmd_glob_dsum9
subroutine spmd_glob_dsum9(v, len)
Definition spmd_th.F:380
cur_fil_c
void cur_fil_c(int *nf)
Definition write_routtines.c:477
wrtdes
subroutine wrtdes(a, ia, l, iform, ir)
Definition wrtdes.F:45