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

Go to the source code of this file.

Functions/Subroutines

subroutine hm_thgrki_vent (ityp, key, inopt1, iad, ifi, ithgrp, ithbuf, nv, vare, num, varg, nvg, ivarg, nsne, nv0, ithvar, flagabf, nvarabf, nom_opt, igs, t_monvol, nvarmvent, lsubmodel)
subroutine name_fvbag (ibaghol, vent_name, nvent)

Function/Subroutine Documentation

◆ hm_thgrki_vent()

subroutine hm_thgrki_vent ( integer ityp,
character*10 key,
integer inopt1,
integer iad,
integer ifi,
integer, dimension(nithgr) ithgrp,
integer, dimension(*) ithbuf,
integer nv,
character*10, dimension(nv) vare,
integer num,
character*10, dimension(nvg) varg,
integer nvg,
integer, dimension(18,*) ivarg,
integer nsne,
integer nv0,
integer, dimension(*) ithvar,
integer flagabf,
integer nvarabf,
integer, dimension(lnopt1,*) nom_opt,
integer igs,
type(monvol_struct_), dimension(nvolu), intent(in) t_monvol,
integer nvarmvent,
type(submodel_data), dimension(nsubmod) lsubmodel )

Definition at line 52 of file hm_thgrki_vent.F.

58C-----------------------------------------------
59C M o d u l e s
60C-----------------------------------------------
61 USE fvbag_mod
62 USE message_mod
63 USE monvol_struct_mod
64 USE submodel_mod
65 USE hm_option_read_mod
66 USE names_and_titles_mod , ONLY : nchartitle
67 USE format_mod , ONLY : fmw_i_a
68 USE user_id_mod , ONLY : id_limit
69C-----------------------------------------------
70C I m p l i c i t T y p e s
71C-----------------------------------------------
72#include "implicit_f.inc"
73C-----------------------------------------------
74C C o m m o n B l o c k s
75C-----------------------------------------------
76#include "scr03_c.inc"
77#include "scr17_c.inc"
78#include "com01_c.inc"
79#include "com04_c.inc"
80#include "units_c.inc"
81#include "param_c.inc"
82#include "r2r_c.inc"
83C-----------------------------------------------
84C D u m m y A r g u m e n t s
85C-----------------------------------------------
86 INTEGER ITYP,INOPT1,
87 . ITHGRP(NITHGR),ITHBUF(*),
88 . IFI,IAD,NV,NUM,NVG,NSNE ,IVARG(18,*),
89 . NV0,ITHVAR(*),FLAGABF,NVARABF,ID_VENT(10)
90 CHARACTER*10 VARE(NV),KEY,VARG(NVG)
91 INTEGER NOM_OPT(LNOPT1,*),NVARMVENT
92 TYPE(MONVOL_STRUCT_), DIMENSION(NVOLU), INTENT(IN) :: T_MONVOL
93 TYPE(SUBMODEL_DATA) :: LSUBMODEL(NSUBMOD)
94C-----------------------------------------------
95C L o c a l V a r i a b l e s
96C-----------------------------------------------
97 INTEGER J,JJ, I,ISU,ID,NNE,NOSYS,NTOT,KK,IER,
98 . OK,IGS,IGRS,NSU,K,L,CONT,IAD0,IADV,NTRI,
99 . IFITMP,IADFIN,NVAR,M,N,IAD1,IAD2,ISK,IPROC,VARVENT(NVARMVENT),
100 . NBMONVOL,NBVENT,NVAR_TMP,ITYP_MONV,
101 . NVENT(NVOLU),NBVENT_MAX,N_BAK,IDSMAX,
102 . K1,K2,KIBJET,KIBHOL
103 CHARACTER(LEN=NCHARTITLE) :: TITR,TITR1
104 CHARACTER MESS*40,TMP_CHAR*40
105 CHARACTER*20 VENT_NAME(10,NVOLU)
106 LOGICAL IS_AVAILABLE
107C-----------------------------------------------
108C E x t e r n a l F u n c t i o n s
109C-----------------------------------------------
110 INTEGER USR2SYS,ULIST2S,LISTCNT,NINTRN,THVARC
111 INTEGER,EXTERNAL :: HM_THVARC
112 INTEGER R2R_LISTCNT,R2R_EXIST
113 DATA mess/'TH GROUP DEFINITION '/
114C-----------------------------------------------
115C
116C
117C-----------------------------------------------
118 vent_name(1:10,1:nvolu) = ''
119
120 nvent(1:nvolu) = 0
121 varvent(1:nvarmvent) = 0
122 id=ithgrp(1)
123 id_vent(1:10) = 0
124 nbvent_max = 0
125 CALL fretitl2(titr1,ithgrp(nithgr-ltitr+1),ltitr)
126 ithgrp(2)=ityp
127 ithgrp(3)=0
128 ifitmp=ifi+1000
129
130 CALL hm_get_intv('idsmax',nbmonvol,is_available,lsubmodel)
131 CALL hm_get_intv('Number_Of_Variables',nvar,is_available,lsubmodel)
132 IF(nvar>0)nvar=hm_thvarc(vare,nv,ithbuf(iad),varg,nvg,ivarg,nv0,id,titr1,lsubmodel)
133
134 k1=1
135 k2=1+nimv*nvolu
136 kibjet=k2+licbag
137 kibhol=kibjet+libagjet
138 DO n=1,nvolu
139 ityp_monv=t_monvol(n)%TYPE
140 nvent(n)=t_monvol(n)%NVENT
141 IF (nvent(n) /= 0) THEN
142 CALL name_fvbag(t_monvol(n)%IBAGHOL,vent_name(1,n),nvent(n))
143 ENDIF
144 ENDDO
145
146 CALL hm_get_intv('idsmax',idsmax,is_available,lsubmodel)
147
148 ! Loop over Objects IDs
149 DO k = 1,idsmax
150 CALL hm_get_int_array_index('ids',n,k,is_available,lsubmodel)
151 CALL hm_get_int_array_index('SKEW_ARRAY',isk,k,is_available,lsubmodel)
152 CALL hm_get_string_index('NAME_ARRAY',titr,k,40,is_available)
153 IF (nsubdom>0) THEN
154C----------->Multidomaines - on saute si l'entite n'existe plus--------
155 IF(r2r_exist(ityp,n)==0) cycle
156C----------------------------------------------------------------------
157 ENDIF
158 n_bak=n
159 n=0
160 DO j=1,num
161 IF(n_bak==nom_opt(1,inopt1+j))THEN
162 n=j
163 EXIT
164 ENDIF
165 ENDDO
166 IF(n==0)THEN
167 CALL fretitl2(titr1,ithgrp(nithgr-ltitr+1),ltitr)
168 CALL ancmsg(msgid=257,
169 . msgtype=msgwarning,
170 . anmode=aninfo_blind_1,
171 . i1=ithgrp(1),
172 . c1=titr1,
173 . c2=key,
174 . i2=n_bak)
175 ELSE
176 nbvent_max = max(nbvent_max,nvent(n))
177 ENDIF
178 ENDDO
179c
180 CALL hm_thvarvent(vare,nv,ithbuf(iad),varg,nvg,ivarg,nv0,id,titr1,varvent,nbvent_max,lsubmodel)
181c
182 nbvent = 0
183 DO i=1,10
184 DO j=1,5
185 IF (varvent( 5*(i-1) + j ) == 1) THEN
186 nbvent = nbvent + 1
187 id_vent(nbvent) = i
188 EXIT
189 ENDIF
190 ENDDO
191 ENDDO
192c
193 IF (nbvent == 0 .OR. nbvent_max == 0) THEN
194 igs = igs - 1
195 ithgrp(1:nithgr)=0
196 ELSE
197c
198 nne = nbvent * nbmonvol
199c
200 nvar = 0
201 DO i=1,10
202 nvar_tmp = 0
203 DO j=1,5
204 IF (varvent((i-1)*5+j) == 1) THEN
205 nvar_tmp = nvar_tmp + 1
206 ENDIF
207 ENDDO
208 nvar = max(nvar,nvar_tmp)
209 ENDDO
210c
211 IF(nvar == 0) CALL ancmsg(msgid=1109,
212 . msgtype=msgerror,
213 . anmode=aninfo_blind_1,
214 . i1=id,
215 . c1=titr1 )
216c
217 ithgrp(6)=nvar
218 ithgrp(7)=iad
219 iad=iad+nvar
220 ifi=ifi+nvar
221 ithgrp(4)=nne
222 ithgrp(5)=iad
223 iad2=iad+3*nne
224 ithgrp(8)=iad2
225 ifi=ifi+3*nne+40*nne
226 CALL zeroin(iad,iad+43*nne-1,ithbuf)
227
228C
229 DO kk = 1,idsmax
230 CALL hm_get_int_array_index('ids',N,KK,IS_AVAILABLE,LSUBMODEL)
231 CALL HM_GET_INT_ARRAY_INDEX('skew_array',ISK,KK,IS_AVAILABLE,LSUBMODEL)
232 CALL HM_GET_STRING_INDEX('name_array',TITR,KK,40,IS_AVAILABLE)
233 IF(N/=0)THEN
234 IF (NSUBDOM>0) THEN
235C----------->Multidomaines - on saute si l'entite n'existe plus--------
236 IF(R2R_EXIST(ITYP,N)==0) CYCLE
237 ENDIF
238C----------------------------------------------------------------------
239 ENDIF
240 N_BAK = N
241 N=0
242 DO J=1,NUM
243 IF(N_BAK==NOM_OPT(1,INOPT1+J))THEN
244 N=J
245 EXIT
246 ENDIF
247 ENDDO
248 IF(N==0)THEN
249 CALL FRETITL2(TITR1,ITHGRP(NITHGR-LTITR+1),LTITR)
250 CALL ANCMSG(MSGID=257,
251 . MSGTYPE=MSGWARNING,
252 . ANMODE=ANINFO_BLIND_1,
253 . I1=ITHGRP(1),
254 . C1=TITR1,
255 . C2=KEY,
256 . I2=N_BAK)
257 ENDIF
258 DO J=1,NBVENT
259 NSNE=NSNE+1
260 ITHBUF(IAD)=N
261 IAD=IAD+1
262 ENDDO
263 ENDDO
264C
265 IAD = ITHGRP(5)
266 CALL HORD(ITHBUF(IAD),NNE)
267C
268 N=ITHBUF(IAD)
269 DO K=1,NBMONVOL
270 DO I=1,NBVENT
271 N=ITHBUF(IAD)
272 ITHBUF(IAD+2*NNE)=ID_LIMIT%TH
273 ID_LIMIT%TH = ID_LIMIT%TH + 1
274
275 DO J=1,20
276 ITHBUF(IAD2+J-1)=NOM_OPT(J+LNOPT1-LTITR,INOPT1+N)
277 ENDDO
278 CALL FRETITL2(TITR1,ITHBUF(IAD2),40)
279
280 IF (I <= NVENT(K)) THEN
281 WRITE(TMP_CHAR,FMT='(i2,a)') ID_VENT(I),VENT_NAME(I,K)
282 ELSE
283 WRITE(TMP_CHAR,FMT='(i2,a)') ID_VENT(I),''
284 ENDIF
285 TITR1(21:40) = TMP_CHAR(1:20)
286 CALL FRETITL(TITR1,ITHBUF(IAD2),40)
287
288 IAD=IAD+1
289 IAD2=IAD2+40
290 ENDDO
291 ENDDO
292C
293 IAD=IAD2
294C
295C=======================================================================
296C ABF FILES
297C=======================================================================
298 NVAR=ITHGRP(6)
299 IAD0=ITHGRP(7)
300 ITHGRP(9)=NVARABF
301 DO J=IAD0,IAD0+NVAR-1
302 DO K=1,10
303 ITHVAR((ITHGRP(9)+(J-IAD0)-1)*10+K)=
304 . ICHAR(VARE(ITHBUF(J))(K:K))
305 ENDDO
306 ENDDO
307 NVARABF = NVARABF + NVAR
308C=======================================================================
309C PRINTOUT
310C=======================================================================
311 IF(IPRI<1)RETURN
312C
313 N=ITHGRP(4)
314 IAD1=ITHGRP(5)
315 NVAR=ITHGRP(6)
316 IAD0=ITHGRP(7)
317 IAD2=ITHGRP(8)
318 WRITE(IOUT,'(//)')
319 CALL FRETITL2(TITR1,ITHGRP(NITHGR-LTITR+1),LTITR)
320 WRITE(IOUT,'(a,i10,3a,i3,a,i5,2a)')' th group:',ITHGRP(1),
321 . ',',TITR1,',',NVAR,' var',N, KEY,':'
322 WRITE(IOUT,'(a)')' -------------------'
323 WRITE(IOUT,'(10a10)')(VARE(ITHBUF(J)),J=IAD0,IAD0+NVAR-1)
324 WRITE(IOUT,'(3a)')' ',KEY,' name '
325 DO K=IAD1,IAD1+N-1
326 CALL FRETITL2(TITR1,ITHBUF(IAD2),40)
327 IAD2=IAD2+40
328 WRITE(IOUT,FMT=FMW_I_A)NOM_OPT(1,INOPT1+ITHBUF(K)),TITR1(1:40)
329 ENDDO
330 ENDIF
331 RETURN
hm_get_int_array_index
subroutine hm_get_int_array_index(name, ival, index, is_available, lsubmodel)
Definition hm_get_int_array_index.F:164
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:523
hm_get_string_index
subroutine hm_get_string_index(name, sval, index, size, is_available)
Definition hm_get_string_index.F:53
hm_thvarc
integer function hm_thvarc(vare, nv, ivar, varg, nvg, ivarg, nv0, id, titr, lsubmodel)
Definition hm_read_thvarc.F:46
name_fvbag
subroutine name_fvbag(ibaghol, vent_name, nvent)
Definition hm_thgrki_vent.F:342
hm_thvarvent
subroutine hm_thvarvent(vare, nv, ivar, varg, nvg, ivarg, nv0, id, titr, varvent, nbvent_max, lsubmodel)
Definition hm_thvarent.F:38
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
fvbag_mod
Definition fvbag_mod.F:44
hm_option_read_mod
Definition hm_option_read_mod.F:408
message_mod
Definition message_mod.F:1249
monvol_struct_mod
Definition monvol_struct_mod.F:66
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
submodel_mod
Definition submodel_mod.F:712
nvar
integer function nvar(text)
Definition nvar.F:32
r2r_exist
integer function r2r_exist(typ, id)
Definition routines_r2r.F:346
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:889
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804
zeroin
subroutine zeroin(n1, n2, ma)
Definition zeroin.F:47

◆ name_fvbag()

subroutine name_fvbag ( integer, dimension(nibhol,*) ibaghol,
character*20, dimension(*) vent_name,
integer nvent )

Definition at line 341 of file hm_thgrki_vent.F.

342C-----------------------------------------------
343C M o d u l e s
344C-----------------------------------------------
345 USE fvbag_mod
346C-----------------------------------------------
347C I m p l i c i t T y p e s
348C-----------------------------------------------
349#include "implicit_f.inc"
350C-----------------------------------------------
351C C o m m o n B l o c k s
352C-----------------------------------------------
353#include "param_c.inc"
354C-----------------------------------------------
355C D u m m y A r g u m e n t s
356C-----------------------------------------------
357 INTEGER IBAGHOL(NIBHOL,*),NVENT
358C-----------------------------------------------
359C L o c a l V a r i a b l e s
360C-----------------------------------------------
361 INTEGER K,IVENT,TITREVENT(20)
362 CHARACTER*20 VENTTITLE,VENT_NAME(*)
363C---+----1----+----2----+----3----+----4----+----5----+----6----+----7--
364 DO ivent=1,nvent
365 DO k=1,20
366 titrevent(k)=ibaghol(14+k,ivent)
367 venttitle(k:k) = achar(titrevent(k))
368 ENDDO
369 vent_name(ivent)=venttitle
370 ENDDO
371C
372 RETURN