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

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_thgrpa (ipasu, npasu, ithbuf, iad, ifi, varpa, nvarpa, varg, nvarg, numthpart, ivarpag, pathid, tagp, iparth, nparth, nvparth, lsubmodel)
subroutine hm_read_thgrpa_sub (iad, ifi, ithbuf, nvarpa, varpa, varg, nvarg, ivarpag, pathid, suthid, tags, subset, ithflag, lsubmodel)

Function/Subroutine Documentation

◆ hm_read_thgrpa()

subroutine hm_read_thgrpa ( integer, dimension(npasu,*) ipasu,
integer npasu,
integer, dimension(*) ithbuf,
integer iad,
integer ifi,
character*10, dimension(nvarpa) varpa,
integer nvarpa,
character*10, dimension(nvarg) varg,
integer nvarg,
integer numthpart,
integer, dimension(18,*) ivarpag,
integer, dimension(*) pathid,
integer tagp,
integer, dimension(nparth,*) iparth,
integer nparth,
integer nvparth,
type(submodel_data), dimension(nsubmod) lsubmodel )

Definition at line 39 of file hm_read_thgrpa.F.

44C-----------------------------------------------
45 USE message_mod
46 USE submodel_mod
47 USE hm_option_read_mod
48 USE names_and_titles_mod , ONLY : nchartitle, ncharkey
49C-----------------------------------------------
50C I m p l i c i t T y p e s
51C-----------------------------------------------
52#include "implicit_f.inc"
53C-----------------------------------------------
54C C o m m o n B l o c k s
55C-----------------------------------------------
56#include "r2r_c.inc"
57#include "scr17_c.inc"
58C-----------------------------------------------
59C D u m m y A r g u m e n t s
60C-----------------------------------------------
61 INTEGER IAD,IFI,NVARPA,NUMTHPART,NVARG,
62 . NPARTH,NVPARTH,TAGP,NPASU
63 INTEGER ,DIMENSION(*) :: ITHBUF,PATHID
64 INTEGER ,DIMENSION(NPARTH,*) :: IPARTH
65 INTEGER ,DIMENSION(NPASU,*) :: IPASU
66 INTEGER ,DIMENSION(18,*) :: IVARPAG
67 TYPE(SUBMODEL_DATA),DIMENSION(NSUBMOD) :: LSUBMODEL
68 CHARACTER*10 VARPA(NVARPA),VARG(NVARG)
69C-----------------------------------------------
70C L o c a l V a r i a b l e s
71C-----------------------------------------------
72 INTEGER I,J,K,N,TH_ID,PART_ID,NVAR,ITYP,NUMOBJ,PART_ID_OBJ1
73 CHARACTER(LEN=NCHARKEY)::KEY
74 CHARACTER(LEN=NCHARTITLE)::TITR
75 LOGICAL :: IS_AVAILABLE
76C-----------------------------------------------
77C E x t e r n a l F u n c t i o n s
78C-----------------------------------------------
79 INTEGER ,EXTERNAL :: R2R_EXIST,HM_THVARC
80C=======================================================================
81 is_available = .false.
82 ityp = 1001 ! type /th/part
83
84 ! read option header
85 CALL hm_option_read_key(lsubmodel, option_id=th_id, option_titr=titr, keyword2=key)
86c
87 ! Number of variables counted in input line
88 CALL hm_get_intv('Number_Of_Variables',nvar,is_available,lsubmodel)
89c
90 ! Total number of stored variables
91 IF (nvar > 0) THEN
92 nvar = hm_thvarc(varpa,nvarpa,ithbuf(iad),varg,nvarg,ivarpag,nvarpa,th_id,titr,lsubmodel)
93 END IF
94c
95 IF (nvar == 0) THEN
96 CALL ancmsg(msgid=1109, msgtype=msgerror , anmode=aninfo_blind_1,
97 . i1=th_id,
98 . c1=titr )
99 ELSE IF (key(1:4) == 'PART') THEN
100
101 ! Number of Object (Part) IDs
102 CALL hm_get_intv('idsmax',numobj,is_available,lsubmodel)
103 CALL hm_get_int_array_index('ids',part_id_obj1,1,is_available,lsubmodel)
104
105 IF (numobj > 0 .AND. part_id_obj1 == 0) THEN
106
107 numobj = numthpart
108
109 DO k = 1,numobj
110 part_id = ipasu(4,k)
111 IF (nsubdom > 0) THEN
112 IF (r2r_exist(ityp,part_id) == 0) cycle
113 ENDIF
114 n = 0
115 DO j = 1,numthpart
116 IF (part_id == ipasu(4,j))THEN
117 n = j
118 tagp = tagp+1
119 pathid(tagp) = part_id
120 EXIT
121 ENDIF
122 ENDDO
123C
124 IF (n == 0) THEN
125 CALL ancmsg(msgid=1610, msgtype=msgwarning, anmode=aninfo_blind_1,
126 . i1=th_id,
127 . c1=titr ,
128 . c2=key ,
129 . i2=part_id )
130 ELSE
131 iparth(nvparth,n) = nvar
132 iparth(nvparth+1,n)= iad
133 ENDIF
134 ENDDO ! NUMOBJ
135
136 ELSE
137
138 ! Number of Object (Part) IDs
139 CALL hm_get_intv('idsmax',numobj,is_available,lsubmodel)
140
141 DO k = 1,numobj
142 CALL hm_get_int_array_index('ids',part_id,k,is_available,lsubmodel)
143 IF (nsubdom > 0) THEN
144 IF (r2r_exist(ityp,part_id) == 0) cycle
145 ENDIF
146 n = 0
147 DO j = 1,numthpart
148 IF (part_id == ipasu(4,j))THEN
149 n = j
150 tagp = tagp+1
151 pathid(tagp) = part_id
152 EXIT
153 ENDIF
154 ENDDO
155C
156 IF (n == 0) THEN
157 CALL ancmsg(msgid=1610, msgtype=msgwarning, anmode=aninfo_blind_1,
158 . i1=th_id,
159 . c1=titr ,
160 . c2=key ,
161 . i2=part_id )
162 ELSE
163 iparth(nvparth,n) = nvar
164 iparth(nvparth+1,n)= iad
165 ENDIF
166 ENDDO ! NUMOBJ
167 ENDIF !NUMOBJ > 0 || PART_ID_OBJ1 == 0
168
169 END IF ! NVAR > 0
170c
171 iad = iad + nvar
172 ifi = ifi + nvar
173c-----------
174 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_thvarc
integer function hm_thvarc(vare, nv, ivar, varg, nvg, ivarg, nv0, id, titr, lsubmodel)
Definition hm_read_thvarc.F:46
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
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

◆ hm_read_thgrpa_sub()

subroutine hm_read_thgrpa_sub ( integer iad,
integer ifi,
integer, dimension(*) ithbuf,
integer nvarpa,
character*10, dimension(nvarpa) varpa,
character*10, dimension(nvarg) varg,
integer nvarg,
integer, dimension(18,*) ivarpag,
integer, dimension(*) pathid,
integer, dimension(*) suthid,
integer tags,
type (subset_), dimension(nsubs) subset,
integer ithflag,
type(submodel_data), dimension(nsubmod) lsubmodel )

Definition at line 192 of file hm_read_thgrpa.F.

196C-----------------------------------------------
197C M o d u l e s
198C-----------------------------------------------
199 USE message_mod
200 USE submodel_mod
201 USE groupdef_mod
202 USE hm_option_read_mod
203 USE names_and_titles_mod , ONLY : nchartitle, ncharkey
204C-----------------------------------------------
205C I m p l i c i t T y p e s
206C-----------------------------------------------
207#include "implicit_f.inc"
208C-----------------------------------------------
209C C o m m o n B l o c k s
210C-----------------------------------------------
211#include "com04_c.inc"
212#include "r2r_c.inc"
213C-----------------------------------------------
214C D u m m y A r g u m e n t s
215C-----------------------------------------------
216 INTEGER IAD,IFI,NVARPA,NVARG
217 INTEGER NVPS,TAGS,ITHFLAG
218 INTEGER ,DIMENSION(*) :: ITHBUF,PATHID,SUTHID
219 INTEGER ,DIMENSION(18,*) :: IVARPAG
220 CHARACTER*10 VARPA(NVARPA),VARG(NVARG)
221 TYPE(SUBMODEL_DATA),DIMENSION(NSUBMOD) :: LSUBMODEL
222C-----------------------------------------------
223 TYPE (SUBSET_) , DIMENSION(NSUBS) :: SUBSET
224C-----------------------------------------------
225C L o c a l V a r i a b l e s
226C-----------------------------------------------
227 INTEGER I,J,K,N,TH_ID,SUBS_ID,NVAR,ITYP,NUMOBJ,SUBS_ID_OBJ1
228 CHARACTER(LEN=NCHARTITLE)::TITR
229 CHARACTER(LEN=NCHARKEY)::KEY
230 LOGICAL :: IS_AVAILABLE
231C-----------------------------------------------
232C E x t e r n a l F u n c t i o n s
233C-----------------------------------------------
234 INTEGER ,EXTERNAL :: R2R_EXIST,HM_THVARC
235C-----------------------------------------------
236C=======================================================================
237 is_available = .false.
238 ityp = 1002 ! type /th/subs
239c
240 ! read option header
241 CALL hm_option_read_key(lsubmodel, option_id=th_id, option_titr=titr, keyword2=key)
242c
243 ! Number of variables counted in input line
244 CALL hm_get_intv('Number_Of_Variables',nvar,is_available,lsubmodel)
245c
246 ! Total number of stored variables
247 IF (nvar > 0) THEN
248 nvar = hm_thvarc(varpa,nvarpa,ithbuf(iad),varg,nvarg,ivarpag,nvarpa,th_id,titr,lsubmodel)
249 END IF
250c
251 IF (nvar == 0) THEN
252 CALL ancmsg(msgid=1109, msgtype=msgerror , anmode=aninfo_blind_1,
253 . i1=th_id,
254 . c1=titr )
255 ELSE IF (key(1:4) == 'SUBS') THEN
256c
257 ! Number of Object (SUBS) IDs
258 CALL hm_get_intv('idsmax',numobj,is_available,lsubmodel)
259 CALL hm_get_int_array_index('ids',subs_id_obj1,1,is_available,lsubmodel)
260
261 IF (numobj > 0 .AND. subs_id_obj1 == 0) THEN
262 numobj = nsubs
263 DO k = 1,numobj
264 subs_id = subset(k)%ID
265 IF (nsubdom > 0) THEN
266 IF (r2r_exist(ityp,subs_id) == 0) cycle
267 ENDIF
268 n = 0
269 DO j = 1,nsubs
270 IF (subs_id == subset(j)%ID)THEN
271 n = j
272 tags = tags+1
273 suthid(tags)= subs_id
274 EXIT
275 ENDIF
276 ENDDO
277C
278 IF (n == 0) THEN
279 CALL ancmsg(msgid=257, msgtype=msgwarning, anmode=aninfo_blind_1,
280 . i1=th_id,
281 . c1=titr,
282 . c2=key,
283 . i2=subs_id)
284 nvar = 0
285 ELSE
286 subset(n)%NVARTH(ithflag) = nvar
287 subset(n)%THIAD = iad
288 ENDIF
289 ENDDO ! NUMOBJ
290
291 ELSE
292c
293 DO k = 1,numobj
294 CALL hm_get_int_array_index('ids',subs_id,k,is_available,lsubmodel)
295 IF (nsubdom > 0) THEN
296 IF (r2r_exist(ityp,subs_id) == 0) cycle
297 ENDIF
298 n = 0
299 DO j = 1,nsubs
300 IF (subs_id == subset(j)%ID)THEN
301 n = j
302 tags = tags+1
303 suthid(tags)= subs_id
304 EXIT
305 ENDIF
306 ENDDO
307C
308 IF (n == 0) THEN
309 CALL ancmsg(msgid=257, msgtype=msgwarning, anmode=aninfo_blind_1,
310 . i1=th_id,
311 . c1=titr,
312 . c2=key,
313 . i2=subs_id)
314 nvar = 0
315 ELSE
316 subset(n)%NVARTH(ithflag) = nvar
317 subset(n)%THIAD = iad
318 ENDIF
319 ENDDO ! NUMOBJ
320 ENDIF !NUMOBJ > 0 || SUBS_ID_OBJ1 == 0
321 END IF ! NVAR > 0
322c
323 iad = iad + nvar
324 ifi = ifi + nvar
325c-----------
326 RETURN
groupdef_mod
Definition groupdef_mod.F:662