OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_thgrne.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_read_thgrne ../starter/source/output/th/hm_read_thgrne.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!|| hord3 ../starter/source/output/th/hord3.F
36!|| nintrn ../starter/source/system/nintrn.F
37!|| r2r_nin ../starter/source/coupling/rad2rad/routines_r2r.F
38!|| r2r_sys ../starter/source/coupling/rad2rad/routines_r2r.F
39!|| set_usrtos ../starter/source/model/sets/ipartm1.F
40!|| udouble ../starter/source/system/sysfus.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!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
46!|| message_mod ../starter/share/message_module/message_mod.F
47!|| submodel_mod ../starter/share/modules1/submodel_mod.F
48!||====================================================================
49 SUBROUTINE hm_read_thgrne(
50 1 ITYP ,KEY ,ITAB ,ITABM1 ,IX ,
51 3 NIX ,IAD ,IFI ,ITHGRP ,ITHBUF ,
52 4 NV ,VARE ,NUMEL ,VARG ,NVG ,
53 5 IVARG ,NSNE ,NV0 ,IMERGE ,ITHVAR ,ITHERM_FE,
54 6 FLAGABF,NVARABF,RFI ,LSUBMODEL,MAP ,
55 7 MAPSIZE)
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
328 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:528
hm_get_string_index
subroutine hm_get_string_index(name, sval, index, size, is_available)
Definition hm_get_string_index.F:53
hm_read_thgrne
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)
Definition hm_read_thgrne.F:56
hord3
subroutine hord3(nel, nsel, isk, iasc, l)
Definition hord3.F:30
hm_option_read_mod
Definition hm_option_read_mod.F:412
message_mod
Definition message_mod.F:1257
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1008
submodel_mod
Definition submodel_mod.F:717
nvar
integer function nvar(text)
Definition nvar.F:32
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:895
nl
character *2 function nl()
Definition message.F:2360
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:615
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:799
udouble
subroutine udouble(list, ilist, nlist, mess, ir, rlist)
Definition sysfus.F:573
zeroin
subroutine zeroin(n1, n2, ma)
Definition zeroin.F:47