OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_gauge.F File Reference
#include "implicit_f.inc"
#include "scr17_c.inc"
#include "units_c.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "r2r_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_gauge (lgauge, gauge, itabm1, unitab, ixc, nom_opt, lsubmodel)

Function/Subroutine Documentation

◆ hm_read_gauge()

subroutine hm_read_gauge ( integer, dimension(3,*), intent(inout) lgauge,
gauge,
integer, dimension(*), intent(in) itabm1,
type (unit_type_), intent(in) unitab,
integer, dimension(nixc,*), intent(in) ixc,
integer, dimension(lnopt1,*) nom_opt,
type(submodel_data), dimension(*) lsubmodel )

Definition at line 44 of file hm_read_gauge.F.

45C-----------------------------------------------
46C M o d u l e s
47C-----------------------------------------------
48 USE unitab_mod
49 USE message_mod
50 USE r2r_mod
51 USE hm_option_read_mod
52 USE submodel_mod
53 USE names_and_titles_mod , ONLY : nchartitle, ncharkey
54C-----------------------------------------------
55C I m p l i c i t T y p e s
56C-----------------------------------------------
57#include "implicit_f.inc"
58C-----------------------------------------------
59C C o m m o n B l o c k s
60C-----------------------------------------------
61#include "scr17_c.inc"
62#include "units_c.inc"
63#include "com04_c.inc"
64#include "param_c.inc"
65#include "r2r_c.inc"
66C-----------------------------------------------
67C D u m m y A r g u m e n t s
68C-----------------------------------------------
69 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
70 INTEGER,INTENT(IN) :: IXC(NIXC,*),ITABM1(*)
71 INTEGER,INTENT(INOUT) :: LGAUGE(3,*)
72 INTEGER NOM_OPT(LNOPT1,*)
73 my_real gauge(llgauge,*)
74 TYPE(SUBMODEL_DATA) LSUBMODEL(*)
75C-----------------------------------------------
76 LOGICAL IS_AVAILABLE
77C-----------------------------------------------
78C E x t e r n a l F u n c t i o n s
79C-----------------------------------------------
80 INTEGER USR2SYS
81C-----------------------------------------------
82C L o c a l V a r i a b l e s
83C-----------------------------------------------
84 INTEGER I, J,ID, NGAU, NOD, ISK, UID, IFLAGUNIT, IG, L,NBGAUGE_SPH,NBGAUGE_POINT
85 INTEGER N,NS,NG,OFFS
86 my_real ff,bid,dist,xgauge,ygauge,zgauge
87 CHARACTER MESS*40
88 CHARACTER(LEN=NCHARTITLE) :: TITR
89 CHARACTER(LEN=NCHARKEY) :: KEY
90 DATA mess/'GAUGE DEFINITION '/
91C=======================================================================
92 is_available = .false.
93C-----------------------------------------------
94C---------------------------------------------
95C LECTURE DES PARAMETRES DE GAUGES
96C-----------------------------------------------
97c LGAUGE(3,*)
98c 1: -Isolid -(NUMELS_G+1) if SPH gauge
99c 2: GaugeId
100c 3: +Node or -Shell
101c
102c => GAUGE(LLGAUGE,*), LLGAUGE = 37
103c 1: Dist (distance from Shell) Dist (distance from Shell)
104c 2: XG XG
105c 3: YG YG
106c 4: ZG ZG
107c 5: Alpha (Solid penetration ratio) not yet used
108c 6: XSAV (SPH sorting)
109c 7: YSAV (SPH sorting)
110c 8: ZSAV (SPH sorting)
111c 9: FF (sph only)
112c 10: intantaneous Pressure
113c 11: intantaneous PA
114c 12: intantaneous Rho
115c 13: intantaneous E
116c 14: ! Butterworth !
117c 15: ! Butterworth !
118c 16: ! Butterworth !
119c 17: ! Butterworth !
120c 18: ! Butterworth !
121c 19: ! Butterworth !
122c 20: ! Butterworth !
123c 21: ! Butterworth !
124c 22: ! Butterworth !
125c 23: ! Butterworth !
126c 24: ! Butterworth !
127c 25: ! Butterworth !
128c 26: ! Butterworth !
129c 27: ! Butterworth !
130c 28: ! Butterworth !
131c 29: ! Butterworth !
132c 30: Pressure filtered Pressure
133c 31: PA filtered PA
134c 32: Rho filtered Rho
135c 33: E filtered E
136c 34: ! Xpoint !
137c 35: ! Ypoint !
138c 36: ! Zpoint !
139c 37: ! Butterworth !
140C=======================================================================
141 ng = 0
142 ff = 0
143 CALL hm_option_count('/GAUGE/SPH', nbgauge_sph)
144C-----------------------------------------------------------------
145 IF ( nbgauge_sph > 0)THEN
146C-----------------------------------------------------------------
147 CALL hm_option_start('/GAUGE/SPH')
148 DO i=1,nbgauge_sph
149 ng=ng+1
150 !---Multidomaines --> on ignore les sections non tagees----
151 IF(nsubdom > 0) THEN
152 IF(taggau(ng) == 0) CALL sz_r2r(taggau,ng)
153 ENDIF
154 !----------------------------------------------------------
155 key=''
156 CALL hm_option_read_key(lsubmodel,option_id=ngau,keyword2=key,option_titr=titr)
157 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)
158
159
160 nom_opt(1,i)=ngau
161
162 lgauge(1,i)=-(numels+1)
163 dist = zero
164 CALL hm_get_intv ('NODE1' ,nod ,is_available,lsubmodel)
165 CALL hm_get_intv ('shell_ID' ,ns ,is_available,lsubmodel)
166 CALL hm_get_floatv ('DIST' ,dist ,is_available, lsubmodel, unitab)
167 CALL hm_get_floatv ('Fcut' ,ff ,is_available, lsubmodel, unitab)
168
169 gauge(1,i) =dist
170 gauge(9,i) =ff
171 lgauge(2,i)=ngau
172
173 WRITE (iout,'(///,A)')' SPH GAUGE'
174 WRITE (iout,'(A/)') ' ---------'
175 WRITE (iout,'(A,I10)')' SPH GAUGE NUMBER . . . . . . . . . . .',ngau
176
177 IF(nod /= 0)THEN
178 lgauge(3,i)=usr2sys(nod,itabm1,mess,ngau)
179 WRITE (iout,'(A,I10)')' NODE NUMBER. . . . . . . . . . . . . .',nod
180 ELSEIF(ns /= 0)THEN
181 DO j=1,numelc
182 IF(ixc(nixc,j)==ns)THEN
183 lgauge(3,i)=-j
184 EXIT
185 ENDIF
186 ENDDO
187 WRITE (iout,'(A,I10)') ' SHELL NUMBER . . . . . . . . . . . . .',ns
188 WRITE (iout,'(A,1PG20.13)')' DISTANCE . . . . . . . . . . . . . . .',dist
189 ENDIF
190 WRITE (iout,'(A,1PG20.13)') ' 4-POLE BUTTERWORTH CORNER FREQUENCY. .',ff
191C-------------------------------------
192
193 ENDDO ! NBGAUGE_SPH
194
195 ENDIF
196
197C-----------------------------------------------
198c--------/GAUGE/POINT
199C-----------------------------------------------
200 CALL hm_option_count('/GAUGE/POINT', nbgauge_point)
201C-----------------------------------------------------------------
202 IF ( nbgauge_point > 0)THEN
203 CALL hm_option_start('/GAUGE/POINT')
204 DO i=1,nbgauge_point
205 key=''
206 CALL hm_option_read_key(lsubmodel,option_id=ngau,keyword2=key,option_titr=titr)
207 nom_opt(1,i)=ngau
208 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)
209 ng=ng+1
210 !Multidomaines --> on ignore les sections non tagees----
211 IF(nsubdom > 0) THEN
212 IF(taggau(ng) == 0) CALL sz_r2r(taggau,ng)
213 ENDIF
214 !-----------------------------------------------------------------
215 lgauge(1,ng)=0
216 CALL hm_get_floatv ('Xi' ,xgauge ,is_available, lsubmodel, unitab)
217 CALL hm_get_floatv ('Yi' ,ygauge ,is_available, lsubmodel, unitab)
218 CALL hm_get_floatv ('Zi' ,zgauge ,is_available, lsubmodel, unitab)
219 lgauge(2,ng)=ngau
220 lgauge(3,ng)=0 ! ID shell or node only
221 gauge(1,ng)=zero ! DIST
222 gauge(9,ng)=zero ! FF
223 gauge(34,ng)=xgauge
224 gauge(35,ng)=ygauge
225 gauge(36,ng)=zgauge
226 WRITE (iout,'(///,A)')' gauge'
227 WRITE (IOUT,'(a/)') ' -----'
228 WRITE (IOUT,'(a,i10)')' gauge number . . . . . . . . . . . . .',NGAU
229 WRITE (IOUT,'(a,i10)')' gauge point coordinate:'
230 WRITE (IOUT,'(a,/1p3g20.13/)')' xg yg zg',Xgauge, Ygauge, Zgauge
231 WRITE (IOUT,'(a,1pg20.13)')' 4-pole butterworth corner frequency. .',FF
232 ENDDO ! DO I=1,NBGAUGE_POINT
233 ENDIF ! IF ( NBGAUGE_POINT > 0)
234C-----------------------------------------------
235c--------/GAUGE
236C-----------------------------------------------
237 CALL HM_OPTION_START('/gauge')
238C-----------------------------------------------
239 DO I=1,NBGAUGE
240 KEY=''
241 CALL HM_OPTION_READ_KEY(LSUBMODEL,OPTION_ID=NGAU,KEYWORD2=KEY,OPTION_TITR=TITR)
242 NOM_OPT(1,I)=NGAU
243 CALL FRETITL(TITR,NOM_OPT(LNOPT1-LTITR+1,I),LTITR)
244
245 IF (KEY == 'sph.OR.' KEY == 'point') CYCLE
246 NG=NG+1
247 !Multidomaines --> on ignore les sections non tagees----
248 IF(NSUBDOM > 0) THEN
249 IF(TAGGAU(NG) == 0) CALL SZ_R2R(TAGGAU,NG)
250 ENDIF
251 !-----------------------------------------------------------------
252 LGAUGE(1,NG)=0
253
254 DIST = ZERO
255 CALL HM_GET_INTV ('node1' ,NOD ,IS_AVAILABLE,LSUBMODEL)
256 CALL HM_GET_INTV ('shell_id' ,NS ,IS_AVAILABLE,LSUBMODEL)
257 CALL HM_GET_FLOATV ('dist' ,DIST ,IS_AVAILABLE, LSUBMODEL, UNITAB)
258
259 GAUGE(1,NG)=DIST
260 GAUGE(9,NG)=ZERO
261 LGAUGE(2,NG)=NGAU
262
263 WRITE (IOUT,'(///,a)')' gauge'
264 WRITE (IOUT,'(a/)') ' -----'
265 WRITE (IOUT,'(a,i10)')' gauge number . . . . . . . . . . . . .',NGAU
266 IF(NOD /= 0)THEN
267 LGAUGE(3,NG)=USR2SYS(NOD,ITABM1,MESS,NGAU)
268 WRITE (IOUT,'(a,i10)')' node number. . . . . . . . . . . . . .',NOD
269 ELSEIF(NS /= 0)THEN
270 DO J=1,NUMELC
271 IF(IXC(NIXC,J)==NS)THEN
272 LGAUGE(3,NG)=-J
273 EXIT
274 ENDIF
275 ENDDO
276 IF (LGAUGE(3,NG) == 0)CALL ANCMSG(MSGID=3013,MSGTYPE=MSGERROR,ANMODE=ANINFO,I1=NGAU,C1=TITR,I2=NS)
277 WRITE (IOUT,'(/,a,i10)')' shell number . . . . . . . . . . . . .',NS
278 WRITE (IOUT,'(a,1pg20.13)')' distance . . . . . . . . . . . . . . .',DIST
279 ENDIF
280 WRITE (IOUT,'(a,1pg20.13)')' 4-pole butterworth corner frequency. .',FF
281C-------------------------------------
282 ENDDO ! NBGAUGE
283
284C-------------------------------------
285C Recherche des ID doubles
286C-------------------------------------
287 CALL VDOUBLE(NOM_OPT,LNOPT1,NBGAUGE,MESS,0,BID)
288C----
289 RETURN
butterworth
subroutine butterworth(dt, freq, x2, x1, x, fx2, fx1, fx)
Definition butterworth.F:31
my_real
#define my_real
Definition cppsort.cpp:32
hm_get_floatv
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
Definition hm_get_floatv.F:415
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:523
hm_option_count
subroutine hm_option_count(entity_type, hm_option_number)
Definition hm_option_count.F:105
hm_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:251
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:410
hm_option_read_mod
Definition hm_option_read_mod.F:408
message_mod
Definition message_mod.F:1249
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1000
r2r_mod
Definition r2r_mod.F:125
r2r_mod::taggau
integer, dimension(:), allocatable taggau
Definition r2r_mod.F:142
submodel_mod
Definition submodel_mod.F:712
unitab_mod
Definition unitab_mod.F:513
sz_r2r
subroutine sz_r2r(tag, val)
Definition routines_r2r.F:242
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:620
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:160