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

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_thgrki_rbody (ityp, key, inopt1, iad, ifi, ithgrp, ithbuf, nv, vare, num, varg, nvg, ivarg, nsne, nv0, ithvar, flagabf, nvarabf, nom_opt, igs, npby, lsubmodel)

Function/Subroutine Documentation

◆ hm_read_thgrki_rbody()

subroutine hm_read_thgrki_rbody ( 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,
integer, dimension(nnpby,*) npby,
type(submodel_data), dimension(nsubmod) lsubmodel )

Definition at line 42 of file hm_read_thgrki_rbody.F.

48C
49 USE message_mod
50 USE submodel_mod
51 USE hm_option_read_mod
52 USE names_and_titles_mod , ONLY : nchartitle
53 USE format_mod , ONLY : fmw_i_a
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 "param_c.inc"
62#include "r2r_c.inc"
63#include "scr03_c.inc"
64#include "scr17_c.inc"
65#include "units_c.inc"
66C-----------------------------------------------
67C D u m m y A r g u m e n t s
68C-----------------------------------------------
69 INTEGER ITYP,INOPT1,
70 . ITHGRP(NITHGR),ITHBUF(*),
71 . IFI,IAD,NV,NUM,NVG,NSNE ,IVARG(18,*),
72 . NV0,ITHVAR(*),FLAGABF,NVARABF,IGS
73 CHARACTER*10 VARE(NV),KEY,VARG(NVG)
74 INTEGER NOM_OPT(LNOPT1,*)
75 TYPE(SUBMODEL_DATA) LSUBMODEL(NSUBMOD)
76 INTEGER NPBY(NNPBY,*)
77C-----------------------------------------------
78C L o c a l V a r i a b l e s
79C-----------------------------------------------
80 INTEGER J,JJ, I,ISU,ID,NNE,NOSYS,J10(10),NTOT,KK,IER,
81 . OK,IGRS,NSU,K,L,JREC,CONT,IAD0,IADV,NTRI,
82 . IFITMP,IADFIN,NVAR,M,N,IAD1,IAD2,ISK,IPROC,
83 . IDSMAX,IDS,IDS_OBJ1,
84 . TAG(NUM),IRB
85 CHARACTER, DIMENSION(10) :: VAR
86 LOGICAL :: IS_AVAILABLE
87 CHARACTER(LEN=NCHARTITLE)::TITR
88C-----------------------------------------------
89C E x t e r n a l F u n c t i o n s
90C-----------------------------------------------
91 INTEGER,EXTERNAL :: HM_THVARC,R2R_EXIST
92C-----------------------------------------------
93 is_available = .false.
94 nsne = 0
95 ! ID of the /TH
96 id = ithgrp(1)
97 ! Title of the /TH
98 CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
99 ! Type of the /TH
100 ithgrp(2)=ityp
101 ithgrp(3)=0
102 ifitmp=ifi+1000
103c
104 ! Number of variables indicated by the user
105 CALL hm_get_intv('Number_Of_Variables',nvar,is_available,lsubmodel)
106c
107 ! Number of stored variables and reading the variables
108 IF (nvar>0) nvar = hm_thvarc(vare,nv,ithbuf(iad),varg,nvg,ivarg,nv0,id,titr,lsubmodel)
109c
110 ! Filling the tables
111 IF (nvar == 0) THEN
112 IF (ityp /= 107)
113 . CALL ancmsg(msgid=1109,
114 . msgtype=msgerror ,
115 . anmode=aninfo_blind_1,
116 . i1=id,
117 . c1=titr )
118 igs = igs - 1
119 ithgrp(1:nithgr) = 0
120 ELSE
121c
122 ! Number of Objects IDs
123 CALL hm_get_intv('idsmax',idsmax,is_available,lsubmodel)
124 CALL hm_get_int_array_index('ids',ids_obj1,1,is_available,lsubmodel)
125
126 IF(idsmax > 0 .AND. ids_obj1 == 0) THEN
127 ! Filling tables
128 ithgrp(6) = nvar
129 ithgrp(7) = iad
130 iad = iad+nvar
131 ifi = ifi+nvar
132 nne = idsmax
133 !ITHGRP(4) = NNE
134 ithgrp(5) = iad
135 iad2 = iad+3*nne
136 ithgrp(8) = iad2
137 CALL zeroin(iad,iad+43*nne-1,ithbuf)
138 nne = 0
139 tag(:)=0
140 idsmax = num
141C
142 ! Loop over Objects IDs
143 DO k = 1,idsmax
144 ids = nom_opt(1,inopt1+k)
145 IF (nsubdom > 0) THEN
146 IF (r2r_exist(ityp,ids) == 0) cycle
147 ENDIF
148 IF(ids==0)cycle !skip empty object
149 !check then if object_id does exist
150 n = 0
151 DO j = 1,num
152 IF (ids == nom_opt(1,inopt1+j)) THEN
153 n = j
154 EXIT
155 ENDIF
156 ENDDO
157 IF (n == 0) THEN
158 CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
159 CALL ancmsg(msgid=257,
160 . msgtype=msgwarning,
161 . anmode=aninfo_blind_1,
162 . i1=ithgrp(1),
163 . c1=titr,
164 . c2=key,
165 . i2=ids)
166 ELSE
167 IF(npby(12,n) /= 0) THEN
168 irb=npby(13,n)
169 IF(tag(irb) == 0) THEN
170 nne=nne+1
171 nsne=nsne+1
172 ithbuf(iad)=irb
173 iad=iad+1
174 tag(irb)=1
175 ENDIF
176 ELSEIF(tag(n) == 0) THEN
177 nne=nne+1
178 nsne=nsne+1
179 ithbuf(iad)=n
180 iad=iad+1
181 tag(n)=1
182 ENDIF
183 ENDIF
184 ENDDO
185C
186 iad = ithgrp(5)
187 ithgrp(4) = nne
188 iad2 = iad+3*nne
189 ithgrp(8) = iad2
190 ifi = ifi+3*nne+40*nne
191cc
192 CALL hord(ithbuf(iad),nne)
193C
194 DO i = 1,nne
195 n = ithbuf(iad)
196 ithbuf(iad+2*nne) = nom_opt(1,inopt1+n)
197 DO j = 1,40
198 ithbuf(iad2+j-1)=nom_opt(j+lnopt1-ltitr,inopt1+n)
199 ENDDO
200 iad=iad+1
201 iad2=iad2+40
202 ENDDO
203C
204 iad = iad2
205C
206C=======================================================================
207C ABF FILES
208C=======================================================================
209 nvar = ithgrp(6)
210 iad0 = ithgrp(7)
211 ithgrp(9) = nvarabf
212 DO j = iad0,iad0+nvar-1
213 DO k = 1,10
214 ithvar((ithgrp(9)+(j-iad0)-1)*10+k) = ichar(vare(ithbuf(j))(k:k))
215 ENDDO
216 ENDDO
217 nvarabf = nvarabf + nvar
218C=======================================================================
219C PRINTOUT
220C=======================================================================
221 IF(ipri<1) RETURN
222C
223 n = ithgrp(4)
224 iad1 = ithgrp(5)
225 nvar=ithgrp(6)
226 iad0=ithgrp(7)
227 iad2=ithgrp(8)
228 WRITE(iout,'(//)')
229 CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
230 WRITE(iout,'(A,I10,3A,I3,A,I5,2A)')' TH GROUP:',ithgrp(1),',',trim(titr),',',nvar,' VAR',n, key,':'
231 WRITE(iout,'(A)')' -------------------'
232 WRITE(iout,'(10A10)')(vare(ithbuf(j)),j=iad0,iad0+nvar-1)
233 WRITE(iout,'(3A)')' ',key,' NAME '
234 DO k=iad1,iad1+n-1
235 CALL fretitl2(titr,ithbuf(iad2),40)
236 iad2=iad2+40
237 WRITE(iout,fmt=fmw_i_a)nom_opt(1,inopt1+ithbuf(k)),titr(1:40)
238 ENDDO
239C
240
241 ELSE
242c
243 ! Filling tables
244 ithgrp(6) = nvar
245 ithgrp(7) = iad
246 iad = iad+nvar
247 ifi = ifi+nvar
248 nne = idsmax
249 !ITHGRP(4) = NNE
250 ithgrp(5) = iad
251 iad2 = iad+3*nne
252 ithgrp(8) = iad2
253 CALL zeroin(iad,iad+43*nne-1,ithbuf)
254 nne = 0
255 tag(:)=0
256C
257 ! Loop over Objects IDs
258 DO k = 1,idsmax
259 CALL hm_get_int_array_index('ids',ids,k,is_available,lsubmodel)
260 IF (nsubdom > 0) THEN
261 IF (r2r_exist(ityp,ids) == 0) cycle
262 ENDIF
263 IF(ids==0)cycle !skip empty object
264 !check then if object_id does exist
265 n = 0
266 DO j = 1,num
267 IF (ids == nom_opt(1,inopt1+j)) THEN
268 n = j
269 EXIT
270 ENDIF
271 ENDDO
272 IF (n == 0) THEN
273 CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
274 CALL ancmsg(msgid=257,
275 . msgtype=msgwarning,
276 . anmode=aninfo_blind_1,
277 . i1=ithgrp(1),
278 . c1=titr,
279 . c2=key,
280 . i2=ids)
281 ELSE
282 IF(npby(12,n) /= 0) THEN
283 irb=npby(13,n)
284 IF(tag(irb) == 0) THEN
285 nne=nne+1
286 nsne=nsne+1
287 ithbuf(iad)=irb
288 iad=iad+1
289 tag(irb)=1
290 ENDIF
291 ELSEIF(tag(n) == 0) THEN
292 nne=nne+1
293 nsne=nsne+1
294 ithbuf(iad)=n
295 iad=iad+1
296 tag(n)=1
297 ENDIF
298 ENDIF
299 ENDDO
300C
301 iad = ithgrp(5)
302 ithgrp(4) = nne
303 iad2 = iad+3*nne
304 ithgrp(8) = iad2
305 ifi = ifi+3*nne+40*nne
306cc
307 CALL hord(ithbuf(iad),nne)
308C
309 DO i = 1,nne
310 n = ithbuf(iad)
311 ithbuf(iad+2*nne) = nom_opt(1,inopt1+n)
312 DO j = 1,40
313 ithbuf(iad2+j-1)=nom_opt(j+lnopt1-ltitr,inopt1+n)
314 ENDDO
315 iad=iad+1
316 iad2=iad2+40
317 ENDDO
318C
319 iad = iad2
320C
321C=======================================================================
322C ABF FILES
323C=======================================================================
324 nvar = ithgrp(6)
325 iad0 = ithgrp(7)
326 ithgrp(9) = nvarabf
327 DO j = iad0,iad0+nvar-1
328 DO k = 1,10
329 ithvar((ithgrp(9)+(j-iad0)-1)*10+k) = ichar(vare(ithbuf(j))(k:k))
330 ENDDO
331 ENDDO
332 nvarabf = nvarabf + nvar
333C=======================================================================
334C PRINTOUT
335C=======================================================================
336 IF(ipri<1) RETURN
337C
338 n = ithgrp(4)
339 iad1 = ithgrp(5)
340 nvar=ithgrp(6)
341 iad0=ithgrp(7)
342 iad2=ithgrp(8)
343 WRITE(iout,'(//)')
344 CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
345 WRITE(iout,'(A,I10,3A,I3,A,I5,2A)')' TH GROUP:',ithgrp(1),',',trim(titr),',',nvar,' VAR',n, key,':'
346 WRITE(iout,'(A)')' -------------------'
347 WRITE(iout,'(10A10)')(vare(ithbuf(j)),j=iad0,iad0+nvar-1)
348 WRITE(iout,'(3A)')' ',key,' NAME '
349 DO k=iad1,iad1+n-1
350 CALL fretitl2(titr,ithbuf(iad2),40)
351 iad2=iad2+40
352 WRITE(iout,fmt=fmw_i_a)nom_opt(1,inopt1+ithbuf(k)),titr(1:40)
353 ENDDO
354C
355 ENDIF !IDSMAX > 0
356 ENDIF !IF (NVAR == 0)
357 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
hord
subroutine hord(nel, nsel)
Definition hord.F:35
id
initmumps id
Definition multiplerhs_example.m:4
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
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