OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_thgrne.F File Reference
#include "implicit_f.inc"
#include "scr16_c.inc"
#include "scr17_c.inc"
#include "scr03_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_read_thgrne (ityp, key, itab, itabm1, ix, nix, iad, ifi, ithgrp, ithbuf, nv, vare, numel, varg, nvg, ivarg, nsne, nv0, imerge, ithvar, itherm_fe, flagabf, nvarabf, rfi, lsubmodel, map, mapsize)

Function/Subroutine Documentation

◆ hm_read_thgrne()

subroutine hm_read_thgrne ( integer ityp,
character*10 key,
integer, dimension(numnod) itab,
integer, dimension(*) itabm1,
integer, dimension(nix,*) ix,
integer nix,
integer iad,
integer ifi,
integer, dimension(nithgr) ithgrp,
integer, dimension(*) ithbuf,
integer nv,
character*10, dimension(nv) vare,
integer numel,
character*10, dimension(nvg) varg,
integer nvg,
integer, dimension(18,*) ivarg,
integer nsne,
integer nv0,
integer, dimension(*) imerge,
integer, dimension(*) ithvar,
integer, intent(in) itherm_fe,
integer flagabf,
integer nvarabf,
integer rfi,
type(submodel_data), dimension(nsubmod) lsubmodel,
integer, dimension(mapsize,2), intent(in) map,
integer, intent(in) mapsize )

Definition at line 49 of file hm_read_thgrne.F.

56C-----------------------------------------------
57C M o d u l e s
58C-----------------------------------------------
59 USE message_mod
60 USE submodel_mod
61 USE hm_option_read_mod
62 USE names_and_titles_mod , ONLY : nchartitle
63C-----------------------------------------------
64C I m p l i c i t T y p e s
65C-----------------------------------------------
66#include "implicit_f.inc"
67C-----------------------------------------------
68C C o m m o n B l o c k s
69C-----------------------------------------------
70#include "scr16_c.inc"
71#include "scr17_c.inc"
72#include "scr03_c.inc"
73#include "com01_c.inc"
74#include "com04_c.inc"
75#include "units_c.inc"
76#include "param_c.inc"
77#include "r2r_c.inc"
78C-----------------------------------------------
79C D u m m y A r g u m e n t s
80C-----------------------------------------------
81 INTEGER NIX,ITYP,ITABM1(*),IX(NIX,*),
82 . ITAB(NUMNOD),ITHGRP(NITHGR),ITHBUF(*),
83 . IFI,IAD,NV,NUMEL,NVG,IVARG(18,*),NSNE,
84 . NV0,IMERGE(*),ITHVAR(*),FLAGABF,NVARABF,RFI
85 CHARACTER*10 VARE(NV),KEY,VARG(NVG),KEY1
86 INTEGER, INTENT(in) :: MAPSIZE
87 INTEGER, INTENT(in) :: ITHERM_FE
88 INTEGER, DIMENSION(MAPSIZE,2), INTENT(in) :: MAP
89 TYPE(SUBMODEL_DATA) :: LSUBMODEL(NSUBMOD)
90C-----------------------------------------------
91C L o c a l V a r i a b l e s
92C-----------------------------------------------
93 INTEGER J,JJ, I,ISU,ID,NNE,NOSYS,J10(10),NTOT,KK,IER,
94 . OK,IGS,IGRS,NSU,K,L,CONT,IAD0,IADV,NTRI,NL,
95 . IFITMP,IADFIN,NVAR,M,N,IAD1,IAD2,ISK,IPROC,JC,
96 . IDSMAX,SIZ
97 INTEGER :: ID_LOCAL
98 CHARACTER(LEN=NCHARTITLE) :: TITR,TITR1
99 CHARACTER MESS*40,DIRMSG*3
100 LOGICAL IS_AVAILABLE
101 my_real bid
102C-----------------------------------------------
103C E x t e r n a l F u n c t i o n s
104C-----------------------------------------------
105 INTEGER USR2SYS,ULIST2S,LISTCNT,NINTRN,HM_THVARC
106 INTEGER R2R_SYS,R2R_NIN
107 INTEGER SET_USRTOS
108 EXTERNAL set_usrtos
109 DATA mess/'TH GROUP '/
110C-----------------------------------------------
111C S o u r c e L i n e s
112C-----------------------------------------------
113 is_available = .false.
114 id=ithgrp(1)
115 CALL fretitl2(titr1,ithgrp(nithgr-ltitr+1),ltitr)
116 ithgrp(2)=ityp
117 ithgrp(3)=0
118 ifitmp=ifi+1000
119 ! Number of labels/variables indicated by the user (ex: DEF, DX, DY, DZ, REACX, ...)
120 CALL hm_get_intv('Number_Of_Variables',nvar,is_available,lsubmodel)
121
122 ! Number of stored labels/variables and reading the variables (ex: DEF, DX, DY, DZ, REACX, ...)
123 IF (nvar>0) nvar = hm_thvarc(vare,nv,ithbuf(iad),varg,nvg,ivarg,nv0,id,titr1 ,lsubmodel)
124
125 IF(nvar == 0) THEN
126 CALL ancmsg(msgid=1109,msgtype=msgerror,anmode=aninfo_blind_1,i1=id,c1=titr1 )
127 ENDIF
128
129 ithgrp(6)=nvar
130 ithgrp(7)=iad
131 iad=iad+nvar
132 ifi=ifi+nvar
133 rfi=0
134
135 cont=1
136 nne=0
137C------------------------
138 ! Number of Objects IDs
139 CALL hm_get_intv('idsmax',idsmax,is_available,lsubmodel)
140 ! Loop over Objects IDs
141 DO k = 1,idsmax
142 CALL hm_get_int_array_index('ids',n,k,is_available,lsubmodel)
143 IF (nsubdom /= 0) THEN
144C Multidomains-> skipping entities which are not on current domain
145 IF (ityp == 0) THEN
146 IF(r2r_sys(n,itabm1,mess) /= 0)THEN
147 nne=nne+1
148 ENDIF
149 ELSE
150 IF(r2r_nin(n,ix,nix,numel) /= 0)THEN
151 nne=nne+1
152 ENDIF
153 ENDIF
154 ELSE
155 nne = nne+1
156 ENDIF
157 ENDDO
158C------------------------
159 ithgrp(4)=nne
160 ithgrp(5)=iad
161 iad2=iad+lvarithb*nne
162 ithgrp(8)=iad2
163 ifi=ifi+lvarithb*nne+40*nne
164 CALL zeroin(iad,iad+(40+lvarithb)*nne-1,ithbuf)
165 rfi=0
166C------------------------
167 ! Loop again over Objects IDs
168 DO k=1,idsmax
169 CALL hm_get_int_array_index('ids',n,k,is_available,lsubmodel)
170 CALL hm_get_int_array_index('SKEW_ARRAY',isk,k,is_available,lsubmodel)
171 CALL hm_get_string_index('NAME_ARRAY',titr,k,40,is_available)
172 siz=len_trim(titr)
173 titr(siz+1:siz+1)=' '
174 IF (ityp == 0) THEN
175C Multidomains-> skipping nodes which are not on current domain
176 IF(nsubdom /= 0) THEN
177 IF (r2r_sys(n,itabm1,mess) == 0) cycle
178 ENDIF
179 ithbuf(iad)=usr2sys(n,itabm1,mess,id)
180 ithbuf(iad+nne)=isk
181 DO jc = 1,nmerged
182 IF (ithbuf(iad) == imerge(jc))
183 . ithbuf(iad) = imerge(numcnod+jc)
184 ENDDO
185 ELSE
186C Multidomains-> skipping elems which are not on current domain
187 IF(nsubdom /= 0) THEN
188 IF (r2r_nin(n,ix,nix,numel) == 0) cycle
189 ENDIF
190 id_local = set_usrtos(n,map,mapsize)
191 IF(id_local == 0) THEN
192 CALL ancmsg(msgid=69, msgtype=msgerror,anmode=aninfo,i1=ithgrp(1),c1=titr1,i2=n)
193 ithbuf(iad)=0
194 ELSE
195 ithbuf(iad)=map(id_local,2)
196 ENDIF
197 iproc=0
198 ithbuf(iad+nne)=iproc
199 ithbuf(iad+3*nne)=isk
200 IF(isk/=0) THEN
201 rfi=rfi+2
202 ENDIF
203 ENDIF
204 CALL fretitl(titr,ithbuf(iad2),40)
205 iad=iad+1
206 iad2=iad2+40
207 ENDDO
208C------------------------
209C
210 iad = ithgrp(5)
211 iad2= ithgrp(8)
212 CALL hord3(ithbuf(iad),nne,ithbuf(iad+nne),ithbuf(iad2),40)
213C
214 IF(ityp == 0) THEN
215 iad0=ithgrp(7)
216 DO i=iad0,iad0+nvar-1
217 IF((ireac == 0) .AND. (ithbuf(i) == 620 .OR.
218 . ithbuf(i) == 621 .OR. ithbuf(i) == 622 .OR.
219 . ithbuf(i) == 623 .OR. ithbuf(i) == 624 .OR.
220 . ithbuf(i) == 625)) ireac = 1
221 IF((ithbuf(i) == 626 .OR. ithbuf(i) == 627 .OR.
222 . ithbuf(i) == 628) .AND.
223 . ((isecut == 0 .AND. iisrot == 0 .AND. impose_dr == 0 .AND. idrot == 0) .OR. iroddl == 0)) THEN
224 IF (ithbuf(i) == 626)dirmsg='DRX'
225 IF (ithbuf(i) == 627)dirmsg='DRY'
226 IF (ithbuf(i) == 628)dirmsg='DRZ'
227 CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
228 CALL ancmsg(msgid=774, msgtype=msgwarning, anmode=aninfo_blind_1, i1=ithgrp(1), c1=titr, i2=ithgrp(1), c2=dirmsg)
229 ENDIF
230 IF(ithbuf(i) == 19 .AND. itherm_fe == 0 ) THEN
231 CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
232 CALL ancmsg(msgid=1087,
233 . msgtype=msgwarning,
234 . anmode=aninfo_blind_1,
235 . i1=ithgrp(1),
236 . c1=titr,
237 . i2=ithgrp(1),
238 . c2='TEMP')
239 ENDIF
240 ENDDO
241 DO i=1,nne
242 k = ithbuf(iad)
243 ithbuf(iad+2*nne)=itab(k)
244 iad=iad+1
245 ENDDO
246 iad=ithgrp(5)
247 CALL udouble(ithbuf(iad+2*nne),1,nne,mess,0,bid)
248 ELSE ! Not used in the program. Now is used for saving skew number when it's defined
249 DO i=1,nne
250 k = ithbuf(iad)
251 IF(k>0)THEN
252 ithbuf(iad+2*nne)=ix(nix,k)
253 iad=iad+1
254 !if K==0, error msg id=69 is already displayed (see above)
255 ENDIF
256 ENDDO
257 iad=ithgrp(5)
258 CALL udouble(ithbuf(iad+2*nne),1,nne,mess,0,bid)
259 ENDIF
260C
261 iad=iad2+40*nne
262C
263 nsne=nsne+nne
264C=======================================================================
265C ABF FILES
266C=======================================================================
267 nvar=ithgrp(6)
268 iad0=ithgrp(7)
269 ithgrp(9)=nvarabf
270 DO j=iad0,iad0+nvar-1
271 DO k=1,10
272 ithvar((ithgrp(9)+(j-iad0)-1)*10+k)=
273 . ichar(vare(ithbuf(j))(k:k))
274 ENDDO
275 ENDDO
276 nvarabf = nvarabf + nvar
277C=======================================================================
278 !---
279 ! STRAIN global flag for QUADS - compute STRAIN TENSOR for /TH/QUAD only
280 !---
281 IF (ityp == 2) THEN
282 DO j=iad0,iad0+nvar-1
283 IF ( vare(ithbuf(j))(1:3) == 'EPS' .OR.
284 . vare(ithbuf(j))(1:4) == 'LEPS' ) th_strain = 1
285 ENDDO
286 ENDIF ! IF (ITYP == 2)
287C=======================================================================
288C PRINTOUT
289C=======================================================================
290 IF (ipri < 1) RETURN
291 n=ithgrp(4)
292 iad1=ithgrp(5)
293 nvar=ithgrp(6)
294 iad0=ithgrp(7)
295 iad2=ithgrp(8)
296 WRITE(iout,'(//)')
297 IF ( key == 'NODE' ) THEN
298 IF ( n >= 2 ) THEN
299 key1 = 'NODES'
300 ELSE
301 key1 = 'NODE'
302 ENDIF
303 ELSE
304 key1 = key
305 ENDIF
306 CALL fretitl2(titr,ithgrp(nithgr-ltitr+1),ltitr)
307 WRITE(iout,'(A,I10,3A,I3,A,I5,A,2A)')'TH GROUP:',ithgrp(1),',',trim(titr),',',nvar,' VAR,',n,' ',key1,':'
308 WRITE(iout,'(A)')' -------------------'
309 IF(ityp == 0)THEN
310 WRITE(iout,'(10A10)')(vare(ithbuf(j)),j=iad0,iad0+nvar-1)
311 WRITE(iout,'(A)')' NODE SKEW(OR FRAME) NAME '
312 DO k=iad1,iad1+n-1
313 CALL fretitl2(titr,ithbuf(iad2),40)
314 iad2=iad2+40
315 WRITE(iout,'(2I10,8X,2A)')itab(ithbuf(k)),ithbuf(k+n),' ',titr(1:40)
316 ENDDO
317 ELSE
318 WRITE(iout,'(10A10)')(vare(ithbuf(j)),j=iad0,iad0+nvar-1)
319 WRITE(iout,'(2A)')key,' P_SPMD NAME '
320 DO k=iad1,iad1+n-1
321 CALL fretitl2(titr,ithbuf(iad2),40)
322 iad2=iad2+40
323 WRITE(iout,'(2I10,2A)')ix(nix,ithbuf(k)),ithbuf(k+n),' ',titr(1:40)
324 ENDDO
325 ENDIF
326C---------------------------------------------------------
327 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
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
hord3
subroutine hord3(nel, nsel, isk, iasc, l)
Definition hord3.F:30
set_usrtos
integer function set_usrtos(iu, ipartm1, npart)
Definition ipartm1.F:128
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_sys
integer function r2r_sys(iu, itabm1, mess)
Definition routines_r2r.F:67
r2r_nin
integer function r2r_nin(iext, ntn, m, n)
Definition routines_r2r.F:137
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339
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
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:160
udouble
subroutine udouble(list, ilist, nlist, mess, ir, rlist)
Definition sysfus.F:589
zeroin
subroutine zeroin(n1, n2, ma)
Definition zeroin.F:47