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

Go to the source code of this file.

Functions/Subroutines

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

Function/Subroutine Documentation

◆ hm_read_thgrki()

subroutine hm_read_thgrki ( integer ityp,
character*10 key,
integer inopt1,
integer iad,
integer ifi,
integer, dimension(nithgr) ithgrp,
integer, dimension(lithbufmx) 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(sithvar) ithvar,
integer flagabf,
integer nvarabf,
integer, dimension(lnopt1,snom_opt/lnopt1) nom_opt,
integer igs,
type(submodel_data), dimension(nsubmod) lsubmodel,
integer, intent(in) lithbufmx )

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