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
54 use element_mod , only : nixc
55C-----------------------------------------------
56C I m p l i c i t T y p e s
57C-----------------------------------------------
58#include "implicit_f.inc"
59C-----------------------------------------------
60C C o m m o n B l o c k s
61C-----------------------------------------------
62#include "scr17_c.inc"
63#include "units_c.inc"
64#include "com04_c.inc"
65#include "param_c.inc"
66#include "r2r_c.inc"
67C-----------------------------------------------
68C D u m m y A r g u m e n t s
69C-----------------------------------------------
70 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
71 INTEGER,INTENT(IN) :: IXC(NIXC,*),ITABM1(*)
72 INTEGER,INTENT(INOUT) :: LGAUGE(3,*)
73 INTEGER NOM_OPT(LNOPT1,*)
74 my_real gauge(llgauge,*)
75 TYPE(SUBMODEL_DATA) LSUBMODEL(*)
76C-----------------------------------------------
77 LOGICAL IS_AVAILABLE
78C-----------------------------------------------
79C E x t e r n a l F u n c t i o n s
80C-----------------------------------------------
81 INTEGER USR2SYS
82C-----------------------------------------------
83C L o c a l V a r i a b l e s
84C-----------------------------------------------
85 INTEGER I, J, NGAU, NOD, NBGAUGE_SPH, NBGAUGE_POINT
86 INTEGER NS, NG
87 my_real ff,bid,dist,xgauge,ygauge,zgauge
88 CHARACTER MESS*40
89 CHARACTER(LEN=NCHARTITLE) :: TITR
90 CHARACTER(LEN=NCHARKEY) :: KEY
91 DATA mess/'GAUGE DEFINITION '/
92C=======================================================================
93 is_available = .false.
94C-----------------------------------------------
95C---------------------------------------------
96C READING DES PARAMETRES DE GAUGES
97C-----------------------------------------------
98c LGAUGE(3,*)
99c 1: -Isolid -(NUMELS_G+1) if SPH gauge
100c 2: GaugeId
101c 3: +Node or -Shell
102c
103c => GAUGE(LLGAUGE,*), LLGAUGE = 37
104c 1: Dist (distance from Shell) Dist (distance from Shell)
105c 2: XG XG
106c 3: YG YG
107c 4: ZG ZG
108c 5: Alpha (Solid penetration ratio) not yet used
109c 6: XSAV (SPH sorting)
110c 7: YSAV (SPH sorting)
111c 8: ZSAV (SPH sorting)
112c 9: FF (sph only)
113c 10: Intantaneous Pressure
114c 11: intantaneous PA
115c 12: intantaneous Rho
116c 13: intantaneous E
117c 14: ! Butterworth !
118c 15: ! Butterworth !
119c 16: ! Butterworth !
120c 17: ! Butterworth !
121c 18: ! Butterworth !
122c 19: ! Butterworth !
123c 20: ! Butterworth !
124c 21: ! Butterworth !
125c 22: ! Butterworth !
126c 23: ! Butterworth !
127c 24: ! Butterworth !
128c 25: ! Butterworth !
129c 26: ! Butterworth !
130c 27: ! Butterworth !
131c 28: ! Butterworth !
132c 29: ! Butterworth !
133c 30: Pressure filtered Pressure
134c 31: PA filtered PA
135c 32: Rho filtered Rho
136c 33: E filtered E
137c 34: ! Xpoint !
138c 35: ! Ypoint !
139c 36: ! Zpoint !
140c 37: ! Butterworth !
141C=======================================================================
142 ng = 0
143 ff = 0
144 CALL hm_option_count('/GAUGE/SPH', nbgauge_sph)
145C-----------------------------------------------------------------
146 IF ( nbgauge_sph > 0)THEN
147C-----------------------------------------------------------------
148 CALL hm_option_start('/GAUGE/SPH')
149 DO i=1,nbgauge_sph
150 ng=ng+1
151 !--- Multidomatic-> We do not know the non-tagged sections ----
152 IF(nsubdom > 0) THEN
153 IF(taggau(ng) == 0) CALL sz_r2r(taggau,ng)
154 ENDIF
155 !----------------------------------------------------------
156 key=''
157 CALL hm_option_read_key(lsubmodel,option_id=ngau,keyword2=key,option_titr=titr)
158 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)
159
160
161 nom_opt(1,i)=ngau
162
163 lgauge(1,i)=-(numels+1)
164 dist = zero
165 CALL hm_get_intv ('NODE1' ,nod ,is_available,lsubmodel)
166 CALL hm_get_intv ('shell_ID' ,ns ,is_available,lsubmodel)
167 CALL hm_get_floatv ('DIST' ,dist ,is_available, lsubmodel, unitab)
168 CALL hm_get_floatv ('Fcut' ,ff ,is_available, lsubmodel, unitab)
169
170 gauge(1,i) =dist
171 gauge(9,i) =ff
172 lgauge(2,i)=ngau
173
174 WRITE (iout,'(///,A)')' SPH GAUGE'
175 WRITE (iout,'(A/)') ' ---------'
176 WRITE (iout,'(A,I10)')' SPH GAUGE NUMBER . . . . . . . . . . .',ngau
177
178 IF(nod /= 0)THEN
179 lgauge(3,i)=usr2sys(nod,itabm1,mess,ngau)
180 WRITE (iout,'(A,I10)')' NODE NUMBER. . . . . . . . . . . . . .',nod
181 ELSEIF(ns /= 0)THEN
182 DO j=1,numelc
183 IF(ixc(nixc,j)==ns)THEN
184 lgauge(3,i)=-j
185 EXIT
186 ENDIF
187 ENDDO
188 WRITE (iout,'(A,I10)') ' SHELL NUMBER . . . . . . . . . . . . .',ns
189 WRITE (iout,'(A,1PG20.13)')' DISTANCE . . . . . . . . . . . . . . .',dist
190 ENDIF
191 WRITE (iout,'(A,1PG20.13)') ' 4-POLE BUTTERWORTH CORNER FREQUENCY. .',ff
192C-------------------------------------
193
194 ENDDO ! NBGAUGE_SPH
195
196 ENDIF
197
198C-----------------------------------------------
199c--------/GAUGE/POINT
200C-----------------------------------------------
201 CALL hm_option_count('/GAUGE/POINT', nbgauge_point)
202C-----------------------------------------------------------------
203 IF ( nbgauge_point > 0)THEN
204 CALL hm_option_start('/GAUGE/POINT')
205 DO i=1,nbgauge_point
206 key=''
207 CALL hm_option_read_key(lsubmodel,option_id=ngau,keyword2=key,option_titr=titr)
208 nom_opt(1,i)=ngau
209 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)
210 ng=ng+1
211 !Multidomatic-> We do not know the non-tagged sections ----
212 IF(nsubdom > 0) THEN
213 IF(taggau(ng) == 0) CALL sz_r2r(taggau,ng)
214 ENDIF
215 !-----------------------------------------------------------------
216 lgauge(1,ng)=0
217 CALL hm_get_floatv ('Xi' ,xgauge ,is_available, lsubmodel, unitab)
218 CALL hm_get_floatv ('Yi' ,ygauge ,is_available, lsubmodel, unitab)
219 CALL hm_get_floatv ('Zi' ,zgauge ,is_available, lsubmodel, unitab)
220 lgauge(2,ng)=ngau
221 lgauge(3,ng)=0 ! ID shell or node only
222 gauge(1,ng)=zero ! DIST
223 gauge(9,ng)=zero ! FF
224 gauge(34,ng)=xgauge
225 gauge(35,ng)=ygauge
226 gauge(36,ng)=zgauge
227 WRITE (iout,'(///,A)')' GAUGE'
228 WRITE (iout,'(A/)') ' -----'
229 WRITE (iout,'(A,I10)')' GAUGE NUMBER . . . . . . . . . . . . .',ngau
230 WRITE (iout,'(A,I10)')' GAUGE POINT coordinate:'
231 WRITE (iout,'(A,/1P3G20.13/)')' Xg Yg Zg',xgauge, ygauge, zgauge
232 WRITE (iout,'(A,1PG20.13)')' 4-POLE BUTTERWORTH CORNER FREQUENCY. .',ff
233 ENDDO ! DO I=1,NBGAUGE_POINT
234 ENDIF ! IF ( NBGAUGE_POINT > 0)
235C-----------------------------------------------
236c--------/GAUGE
237C-----------------------------------------------
238 CALL hm_option_start('/GAUGE')
239C-----------------------------------------------
240 DO i=1,nbgauge
241 key=''
242 CALL hm_option_read_key(lsubmodel,option_id=ngau,keyword2=key,option_titr=titr)
243 nom_opt(1,i)=ngau
244 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)
245
246 IF (key == 'SPH' .OR. key == 'POINT') cycle
247 ng=ng+1
248 !Multidomatic-> We do not know the non-tagged sections ----
249 IF(nsubdom > 0) THEN
250 IF(taggau(ng) == 0) CALL sz_r2r(taggau,ng)
251 ENDIF
252 !-----------------------------------------------------------------
253 lgauge(1,ng)=0
254
255 dist = zero
256 CALL hm_get_intv ('NODE1' ,nod ,is_available,lsubmodel)
257 CALL hm_get_intv ('shell_ID' ,ns ,is_available,lsubmodel)
258 CALL hm_get_floatv ('DIST' ,dist ,is_available, lsubmodel, unitab)
259
260 gauge(1,ng)=dist
261 gauge(9,ng)=zero
262 lgauge(2,ng)=ngau
263
264 WRITE (iout,'(///,A)')' GAUGE'
265 WRITE (iout,'(A/)') ' -----'
266 WRITE (iout,'(A,I10)')' GAUGE NUMBER . . . . . . . . . . . . .',ngau
267 IF(nod /= 0)THEN
268 lgauge(3,ng)=usr2sys(nod,itabm1,mess,ngau)
269 WRITE (iout,'(A,I10)')' NODE NUMBER. . . . . . . . . . . . . .',nod
270 ELSEIF(ns /= 0)THEN
271 DO j=1,numelc
272 IF(ixc(nixc,j)==ns)THEN
273 lgauge(3,ng)=-j
274 EXIT
275 ENDIF
276 ENDDO
277 IF (lgauge(3,ng) == 0)CALL ancmsg(msgid=3013,msgtype=msgerror,anmode=aninfo,i1=ngau,c1=titr,i2=ns)
278 WRITE (iout,'(/,A,I10)')' SHELL NUMBER . . . . . . . . . . . . .',ns
279 WRITE (iout,'(A,1PG20.13)')' DISTANCE . . . . . . . . . . . . . . .',dist
280 ENDIF
281 WRITE (iout,'(A,1PG20.13)')' 4-POLE BUTTERWORTH CORNER FREQUENCY. .',ff
282C-------------------------------------
283 ENDDO ! NBGAUGE
284
285C-------------------------------------
286C Recherche des ID doubles
287C-------------------------------------
288 CALL vdouble(nom_opt,lnopt1,nbgauge,mess,0,bid)
289C----
290 RETURN
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:418
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:528
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:253
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:414
hm_option_read_mod
Definition hm_option_read_mod.F:412
message_mod
Definition message_mod.F:1257
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1008
names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1005
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:717
unitab_mod
Definition unitab_mod.F:517
sz_r2r
subroutine sz_r2r(tag, val)
Definition routines_r2r.F:241
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:895
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:615
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:146
vdouble
subroutine vdouble(list, ilist, nlist, mess, ir, rlist)
Definition sysfus.F:868