OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_eref.F File Reference
#include "implicit_f.inc"
#include "scr03_c.inc"
#include "scr17_c.inc"
#include "com04_c.inc"
#include "units_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_eref (itabm1, ipart, ipartc, ipartg, iparts, ixc, ixtg, ixs, x, xrefc, xreftg, xrefs, lsubmodel, iddlevel, itab, tagxref, tagrefsta)

Function/Subroutine Documentation

◆ hm_read_eref()

subroutine hm_read_eref ( integer, dimension(*) itabm1,
integer, dimension(lipart1,*) ipart,
integer, dimension(*) ipartc,
integer, dimension(*) ipartg,
integer, dimension(*) iparts,
integer, dimension(nixc,*) ixc,
integer, dimension(nixtg,*) ixtg,
integer, dimension(nixs,*) ixs,
x,
xrefc,
xreftg,
xrefs,
type(submodel_data), dimension(*) lsubmodel,
integer iddlevel,
integer, dimension(numnod) itab,
integer, dimension(*) tagxref,
integer, dimension(*) tagrefsta )

Definition at line 41 of file hm_read_eref.F.

45C-----------------------------------------------
46C M o d u l e s
47C-----------------------------------------------
48 USE unitab_mod
49 USE submodel_mod
50 USE message_mod
51 USE hm_option_read_mod
52 USE names_and_titles_mod , ONLY : nchartitle, ncharkey
53C-----------------------------------------------
54C I m p l i c i t T y p e s
55C-----------------------------------------------
56#include "implicit_f.inc"
57C-----------------------------------------------
58C C o m m o n B l o c k s
59C-----------------------------------------------
60#include "scr03_c.inc"
61#include "scr17_c.inc"
62#include "com04_c.inc"
63#include "units_c.inc"
64C-----------------------------------------------
65C G l o b a l V a r i a b l e s
66C-----------------------------------------------
67 INTEGER ITABM1(*),IPART(LIPART1,*),IPARTC(*),IPARTG(*),IPARTS(*)
68 INTEGER IXC(NIXC,*),IXTG(NIXTG,*),IXS(NIXS,*)
69 INTEGER IDDLEVEL,ITAB(NUMNOD),TAGXREF(*),TAGREFSTA(*)
70 my_real
71 . x(3,*),xrefc(4,3,*),xreftg(3,3,*),xrefs(8,3,*)
72 TYPE(SUBMODEL_DATA) LSUBMODEL(*)
73C-----------------------------------------------
74C L o c a l V a r i a b l e s
75C-----------------------------------------------
76 INTEGER, DIMENSION(:), ALLOCATABLE :: TAGELC,TAGELTG,TAGELS
77 INTEGER, DIMENSION(:), ALLOCATABLE :: TAGNOD
78 INTEGER I,IX(8),IE,J,IN,ID,IP,IR,NN,PARTID,UID,ITYP
79 INTEGER SUB_ID,MM, NEL
80 CHARACTER(LEN=NCHARLINE) :: TITLE
81 CHARACTER(LEN=NCHARKEY) :: KEY1,KEY
82 CHARACTER MESS*40
83 LOGICAL :: IS_AVAILABLE
84 DATA mess/'EREF ELEMENT REFERENCE GEOMETRY'/
85C-----------------------------------------------
86C E x t e r n a l F u n c t i o n s
87C-----------------------------------------------
88 INTEGER USR2SYS,R2R_SYS,NINTRI
89C=======================================================================
90
91 ALLOCATE(tagelc(numelc),tageltg(numeltg),tagels(numels8),tagnod(numnod))
92C
93 is_available = .false.
94C
95 IF(nxref == 0 .AND. irefsta == 0) THEN
96 DO ie=1,numelc
97 DO in = 1,4
98 nn = ixc(in+1,ie)
99 DO j = 1,3
100 xrefc(in,j,ie) = x(j,nn)
101 ENDDO
102 ENDDO
103 ENDDO
104 DO ie=1,numeltg
105 DO in = 1,3
106 nn = ixtg(in+1,ie)
107 DO j = 1,3
108 xreftg(in,j,ie) = x(j,nn)
109 ENDDO
110 ENDDO
111 ENDDO
112 DO ie=1,numels8
113 DO in = 1,8
114 nn = ixs(in+1,ie)
115 DO j = 1,3
116 xrefs(in,j,ie) = x(j,nn)
117 ENDDO
118 ENDDO
119 ENDDO
120 ENDIF
121C
122 IF(iddlevel == 0) WRITE(iout,1000)
123 nitrs = 100
124 tagnod(1:numnod) = 0
125C
126 CALL hm_option_start('/EREF')
127C
128 DO ir=1,neref
129C
130 CALL hm_option_read_key(lsubmodel,
131 . unit_id = uid,
132 . submodel_id = sub_id,
133 . option_titr = title,
134 . keyword1 = key1,
135 . keyword2 = key)
136C
137 CALL hm_get_intv('component',partid,is_available,lsubmodel)
138C
139 IF (key1(1:4) == 'EREF')THEN
140 IF(iddlevel == 0) WRITE(iout,1001) title,partid
141 ip = 0
142 DO i = 1,npart
143 IF (ipart(4,i) == partid) ip = i
144 ENDDO
145C
146 tagelc(1:numelc) = 0
147 tageltg(1:numeltg)= 0
148 tagels(1:numels8) = 0
149 ityp = 0
150C
151 DO ie=1,numelc
152 IF (ip == ipartc(ie).OR.ip==0) THEN
153 tagelc(ie) = 1
154 ityp = 1
155 ENDIF
156 ENDDO
157 DO ie=1,numeltg
158 IF (ip == ipartg(ie).OR.ip==0) THEN
159 tageltg(ie) = 1
160 ityp = 1
161 ENDIF
162 ENDDO
163 IF (ityp == 0) THEN
164 DO ie=1,numels8
165 IF (ip == iparts(ie).OR.ip==0) THEN
166 tagels(ie) = 1
167 ityp = 2
168 ENDIF
169 ENDDO
170 ENDIF
171C
172 SELECT CASE (ityp)
173 CASE (1)
174 IF(key(1:5)=='SHELL') THEN
175 IF(iddlevel == 0.AND.ipri >= 5) WRITE(iout,'(9X,A7,4(9X,A2))') 'ELEM-ID','N1','N2','N3','N4'
176 CALL hm_get_intv('table_count',nel,is_available,lsubmodel)
177C
178 DO i=1,nel
179C
180 CALL hm_get_int_array_index('elems_table_elem',id,i,is_available,lsubmodel)
181 CALL hm_get_int_array_index('elems_table_n1',ix(1),i,is_available,lsubmodel)
182 CALL hm_get_int_array_index('elems_table_n2',ix(2),i,is_available,lsubmodel)
183 CALL hm_get_int_array_index('elems_table_n3',ix(3),i,is_available,lsubmodel)
184 CALL hm_get_int_array_index('elems_table_n4',ix(4),i,is_available,lsubmodel)
185C
186 ie=nintri(id,ixc,nixc,numelc,nixc)
187 IF(id > 0 .AND. ie == 0) THEN
188 CALL ancmsg(msgid=1011,
189 . msgtype=msgerror,
190 . anmode=aninfo,
191 . c1='SHELL',i1=id)
192 ELSEIF (id > 0 .AND. tagelc(ie) == 1) THEN
193 DO in=1,4
194 nn = usr2sys(ix(in),itabm1,mess,id)
195 mm = ixc(in+1,ie)
196 tagnod(mm) = 1
197 xrefc(in,1,ie) = x(1,nn)
198 xrefc(in,2,ie) = x(2,nn)
199 xrefc(in,3,ie) = x(3,nn)
200 ENDDO
201 IF(iddlevel == 0.AND.ipri >= 5) WRITE(iout,'(5X,5(1X,I10))') id,(ix(in),in=1,4)
202 ENDIF
203 ENDDO
204 IF(iddlevel == 0.AND.ipri < 5) WRITE(iout,1010) nel
205C
206 ELSEIF(key(1:4)=='SH3N') THEN
207 IF(iddlevel == 0.AND.ipri >= 5) WRITE(iout,'(9X,A7,4(9X,A2))') 'ELEM-ID','N1','N2','N3'
208 CALL hm_get_intv('table_count',nel,is_available,lsubmodel)
209C
210 DO i=1,nel
211C
212 CALL hm_get_int_array_index('elems_table_elem',id,i,is_available,lsubmodel)
213 CALL hm_get_int_array_index('elems_table_n1',ix(1),i,is_available,lsubmodel)
214 CALL hm_get_int_array_index('elems_table_n2',ix(2),i,is_available,lsubmodel)
215 CALL hm_get_int_array_index('elems_table_n3',ix(3),i,is_available,lsubmodel)
216C
217 ie=nintri(id,ixtg,nixtg,numeltg,nixtg)
218 IF(id > 0 .AND. ie == 0) THEN
219 CALL ancmsg(msgid=1011,
220 . msgtype=msgerror,
221 . anmode=aninfo,
222 . c1='TRIANGLE',i1=id)
223 ELSEIF (id > 0 .AND. tageltg(ie) == 1) THEN
224 DO in=1,3
225 nn = usr2sys(ix(in),itabm1,mess,id)
226 mm = ixtg(in+1,ie)
227 tagnod(mm) = 1
228 xreftg(in,1,ie) = x(1,nn)
229 xreftg(in,2,ie) = x(2,nn)
230 xreftg(in,3,ie) = x(3,nn)
231 ENDDO
232 IF(iddlevel == 0.AND.ipri >= 5) WRITE(iout,'(5X,4(1X,I10))') id,(ix(in),in=1,3)
233 ENDIF
234 ENDDO
235 IF(iddlevel == 0.AND.ipri < 5) WRITE(iout,1020) nel
236 ENDIF
237C
238 CASE (2)
239 IF(key(1:5)=='BRICK') THEN
240C
241 IF(iddlevel == 0.AND.ipri >= 5)WRITE(iout,'(9X,A7,8(9X,A2))')'ELEM-ID','N1','N2','N3','N4','N5','N6','N7','N8'
242 CALL hm_get_intv('table_count',nel,is_available,lsubmodel)
243C
244 DO i=1,nel
245C
246 CALL hm_get_int_array_index('elems_table_elem',id,i,is_available,lsubmodel)
247 CALL hm_get_int_array_index('elems_table_n1',ix(1),i,is_available,lsubmodel)
248 CALL hm_get_int_array_index('elems_table_n2',ix(2),i,is_available,lsubmodel)
249 CALL hm_get_int_array_index('elems_table_n3',ix(3),i,is_available,lsubmodel)
250 CALL hm_get_int_array_index('elems_table_n4',ix(4),i,is_available,lsubmodel)
251 CALL hm_get_int_array_index('elems_table_n5',ix(5),i,is_available,lsubmodel)
252 CALL hm_get_int_array_index('elems_table_n6',ix(6),i,is_available,lsubmodel)
253 CALL hm_get_int_array_index('elems_table_n7',ix(7),i,is_available,lsubmodel)
254 CALL hm_get_int_array_index('elems_table_n8',ix(8),i,is_available,lsubmodel)
255C
256 ie=nintri(id,ixs,nixs,numels8,nixs)
257 IF(id > 0 .AND. ie == 0) THEN
258 CALL ancmsg(msgid=1011,
259 . msgtype=msgerror,
260 . anmode=aninfo,
261 . c1='SOLID',i1=id)
262 ELSEIF (id > 0 .AND. tagels(ie) == 1) THEN
263 DO in=1,8
264 nn = usr2sys(ix(in),itabm1,mess,id)
265 mm = ixs(in+1,ie)
266 tagnod(mm) = 1
267 xrefs(in,1,ie) = x(1,nn)
268 xrefs(in,2,ie) = x(2,nn)
269 xrefs(in,3,ie) = x(3,nn)
270 ENDDO
271 IF(iddlevel == 0.AND.ipri >= 5) WRITE(iout,'(5X,9(1X,I10))') id,(ix(in),in=1,8)
272 ENDIF
273 ENDDO
274 IF(iddlevel == 0.AND.ipri < 5) WRITE(iout,1030) nel
275 ELSEIF(key(1:6)=='TETRA4') THEN
276 IF(iddlevel == 0.AND.ipri >= 5) WRITE(iout,'(9X,A7,4(9X,A2))') 'ELEM-ID','N1','N2','N3','N4'
277 CALL hm_get_intv('table_count',nel,is_available,lsubmodel)
278C
279 DO i=1,nel
280C
281 CALL hm_get_int_array_index('elems_table_elem',id,i,is_available,lsubmodel)
282 CALL hm_get_int_array_index('elems_table_n1',ix(1),i,is_available,lsubmodel)
283 CALL hm_get_int_array_index('elems_table_n2',ix(3),i,is_available,lsubmodel)
284 CALL hm_get_int_array_index('elems_table_n3',ix(6),i,is_available,lsubmodel)
285 CALL hm_get_int_array_index('elems_table_n4',ix(5),i,is_available,lsubmodel)
286C
287 ix(2)=ix(1)
288 ix(4)=ix(3)
289 ix(8)=ix(5)
290 ix(7)=ix(6)
291 ie=nintri(id,ixs,nixs,numels8,nixs)
292C
293 IF(id > 0 .AND. ie == 0) THEN
294 CALL ancmsg(msgid=1011,
295 . msgtype=msgerror,
296 . anmode=aninfo,
297 . c1='TETRA4',i1=id)
298 ELSEIF (id > 0 .AND. tagels(ie) == 1) THEN
299 DO in=1,8
300 nn = usr2sys(ix(in),itabm1,mess,id)
301 mm = ixs(in+1,ie)
302 tagnod(mm) = 1
303 xrefs(in,1,ie) = x(1,nn)
304 xrefs(in,2,ie) = x(2,nn)
305 xrefs(in,3,ie) = x(3,nn)
306 ENDDO
307 IF(iddlevel == 0.AND.ipri >= 5) WRITE(iout,'(5X,5(1X,I10))') id,ix(1),ix(3),ix(6),ix(5)
308 ENDIF
309 ENDDO
310 IF(iddlevel == 0.AND.ipri < 5) WRITE(iout,1040) nel
311 ENDIF
312 END SELECT
313C
314 ENDIF
315 ENDDO
316C------------------------------------------
317C CHECK COMPATIBILITY WITH XREF AND REFSTA
318
319C------------------------------------------
320
321 IF(iddlevel == 1) THEN
322
323 ELSE
324 IF( nxref /= 0) THEN
325 DO in=1,numnod
326 IF(tagnod(in) == 0) cycle
327 IF(tagxref(in) == 1) THEN
328 CALL ancmsg(msgid=1098,msgtype=msgerror,anmode=aninfo, i1=itab(in))
329 ENDIF
330 ENDDO
331 ENDIF
332 IF( irefsta /= 0) THEN
333 DO in=1,numnod
334 IF(tagnod(in) == 0) cycle
335 IF(tagrefsta(in) == 1) THEN
336 CALL ancmsg(msgid=1099,msgtype=msgerror,anmode=aninfo,i1=itab(in))
337 ENDIF
338 ENDDO
339 ENDIF
340 ENDIF
341C
342 DEALLOCATE(tagelc,tageltg,tagels,tagnod)
343 RETURN
344 1000 FORMAT(//
345 & 5x,' REFERENCE STATE (EREF) ',/
346 & 5x,' ---------------------- ' )
347 1001 FORMAT(/
348 & 5x, a ,/
349 & 5x,'PART ID . . . . . . . . . . . . =',i10)
350 1010 FORMAT(
351 & 5x,'NUMBER OF 4-NODES SHELL . . . . =',i10)
352 1020 FORMAT(
353 & 5x,'NUMBER OF 3-NODES SHELL . . . . =',i10)
354 1030 FORMAT(
355 & 5x,'NUMBER OF 8-NODES BRICK . . . . =',i10)
356 1040 FORMAT(
357 & 5x,'NUMBER OF 4-NODES TETRA . . . . =',i10)
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_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:251
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:410
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
names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1000
submodel_mod
Definition submodel_mod.F:712
unitab_mod
Definition unitab_mod.F:513
nintri
integer function nintri(iext, antn, m, n, m1)
Definition nintrr.F:46
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
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:160
tagnod
subroutine tagnod(ix, nix, nix1, nix2, numel, iparte, tagbuf, npart)
Definition tagnod.F:29