OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_thgrki_vent.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| hm_thgrki_vent ../starter/source/output/th/hm_thgrki_vent.F
25!||--- called by ------------------------------------------------------
26!|| hm_read_thgrou ../starter/source/output/th/hm_read_thgrou.f
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| fretitl ../starter/source/starter/freform.F
30!|| fretitl2 ../starter/source/starter/freform.F
31!|| hm_get_int_array_index ../starter/source/devtools/hm_reader/hm_get_int_array_index.F
32!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
33!|| hm_get_string_index ../starter/source/devtools/hm_reader/hm_get_string_index.F
34!|| hm_thvarc ../starter/source/output/th/hm_read_thvarc.F
35!|| hm_thvarvent ../starter/source/output/th/hm_thvarent.F
36!|| hord ../starter/source/output/th/hord.F
37!|| name_fvbag ../starter/source/output/th/hm_thgrki_vent.F
38!|| nintrn ../starter/source/system/nintrn.F
39!|| r2r_exist ../starter/source/coupling/rad2rad/routines_r2r.f
40!|| r2r_listcnt ../starter/source/coupling/rad2rad/routines_r2r.F
41!|| ulist2s ../starter/source/system/sysfus.F
42!|| usr2sys ../starter/source/system/sysfus.F
43!|| zeroin ../starter/source/system/zeroin.F
44!||--- uses -----------------------------------------------------
45!|| format_mod ../starter/share/modules1/format_mod.F90
46!|| fvbag_mod ../starter/share/modules1/fvbag_mod.F
47!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
48!|| message_mod ../starter/share/message_module/message_mod.F
49!|| monvol_struct_mod ../starter/share/modules1/monvol_struct_mod.F
50!|| submodel_mod ../starter/share/modules1/submodel_mod.F
51!||====================================================================
52 SUBROUTINE hm_thgrki_vent(
53 1 ITYP ,KEY ,INOPT1,
54 3 IAD ,IFI ,ITHGRP,ITHBUF ,
55 4 NV ,VARE ,NUM ,VARG ,NVG ,
56 5 IVARG ,NSNE,NV0,ITHVAR,FLAGABF,NVARABF,
57 6 NOM_OPT,IGS,T_MONVOL,NVARMVENT,LSUBMODEL)
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
332 END
333C
334!||====================================================================
335!|| name_fvbag ../starter/source/output/th/hm_thgrki_vent.F
336!||--- called by ------------------------------------------------------
337!|| hm_thgrki_vent ../starter/source/output/th/hm_thgrki_vent.F
338!||--- uses -----------------------------------------------------
339!|| fvbag_mod ../starter/share/modules1/fvbag_mod.F
340!||====================================================================
341 SUBROUTINE name_fvbag(IBAGHOL, VENT_NAME, NVENT )
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
373 END
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_read_thgrou
subroutine hm_read_thgrou(ithgrp, ithbuf, itab, itabm1, ixtg, ixs, ixq, ixc, ixt, ixp, ixr, kxx, ixx, ipart, ifi, nthwa, kxsp, ixri, iskwn, iframe, nthgrp2, pathid, suthid, fxbipm, iparth, nparth, nvparth, nvsubth, imerge, ithvar, flagabf, nvarabf, nom_opt, ptr_nopt_fxby, ptr_nopt_inter, ptr_nopt_rwall, ptr_nopt_sect, ptr_nopt_joint, ptr_nopt_monv, ptr_nopt_acc, ptr_nopt_skw, ptr_nopt_gau, ptr_nopt_clus, ptr_nopt_sphio, isphio, rfi, t_monvol, igrsurf, subset, ithflag, npby, lsubmodel, iparg, iparts, ipartq, ipartc, ipartt, ipartp, ipartr, ipartg, ipartx, ipartsp, ipartig3d, lithbufmx, map_tables, iflag, ptr_nopt_slipring, ptr_nopt_retractor, sensors, interfaces, ipari, dump_thnms1_file, itherm_fe, checksum, nsubdom, ipri)
Definition hm_read_thgrou.F:78
hm_thgrki_vent
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)
Definition hm_thgrki_vent.F:58
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
hord
subroutine hord(nel, nsel)
Definition hord.F:35
max
#define max(a, b)
Definition macros.h:21
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
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:620
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804
starter
program starter
Definition starter.F:39
zeroin
subroutine zeroin(n1, n2, ma)
Definition zeroin.F:47