OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_xref.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_xref ../starter/source/loads/reference_state/xref/hm_read_xref.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| fretitl2 ../starter/source/starter/freform.F
30!|| hm_get_float_array_index ../starter/source/devtools/hm_reader/hm_get_float_array_index.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_option_read_key ../starter/source/devtools/hm_reader/hm_option_read_key.F
34!|| hm_option_start ../starter/source/devtools/hm_reader/hm_option_start.F
35!|| r2r_sys ../starter/source/coupling/rad2rad/routines_r2r.F
36!|| subrotpoint ../starter/source/model/submodel/subrot.F
37!|| usr2sys ../starter/source/system/sysfus.F
38!||--- uses -----------------------------------------------------
39!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
40!|| message_mod ../starter/share/message_module/message_mod.F
41!|| submodel_mod ../starter/share/modules1/submodel_mod.F
42!||====================================================================
43 SUBROUTINE hm_read_xref(ITABM1 ,IPART ,IPARTC ,IPARTG ,IPARTS ,
44 . UNITAB ,IXC ,IXTG ,IXS ,X ,
45 . XREFC ,XREFTG ,XREFS ,RTRANS ,LSUBMODEL,
46 . TAGXREF ,IDDLEVEL ,ISOLNOD ,IPM ,IGEO )
47C-----------------------------------------------
48C M o d u l e s
49C-----------------------------------------------
50 USE unitab_mod
51 USE submodel_mod
52 USE message_mod
53 USE hm_option_read_mod
54 USE names_and_titles_mod , ONLY : nchartitle
55 use element_mod , only : nixs,nixc,nixtg
56C-----------------------------------------------
57C I m p l i c i t T y p e s
58C-----------------------------------------------
59#include "implicit_f.inc"
60C-----------------------------------------------
61C G l o b a l P a r a m e t e r s
62C-----------------------------------------------
63#include "param_c.inc"
64#include "scr03_c.inc"
65#include "scr17_c.inc"
66#include "com04_c.inc"
67#include "r2r_c.inc"
68C-----------------------------------------------
69C C o m m o n B l o c k s
70C-----------------------------------------------
71#include "units_c.inc"
72C-----------------------------------------------
73C G l o b a l V a r i a b l e s
74C-----------------------------------------------
75 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
76 INTEGER ITABM1(*),IPART(LIPART1,*),IPARTC(*),IPARTG(*),IPARTS(*),
77 . IXC(NIXC,*),IXTG(NIXTG,*),IXS(NIXS,*),TAGXREF(NUMNOD)
78 INTEGER IDDLEVEL
79 my_real
80 . x(3,*),xrefc(4,3,*),xreftg(3,3,*),xrefs(8,3,*),
81 . rtrans(ntransf,*)
82 TYPE(submodel_data) LSUBMODEL(*)
83C MODIFIED ARGUMENT
84 INTEGER,INTENT(IN)::IGEO(NPROPGI,*)
85 INTEGER,INTENT(IN)::IPM(NPROPMI,*)
86 INTEGER,INTENT(IN)::ISOLNOD(*)
87C-----------------------------------------------
88C L o c a l V a r i a b l e s
89C-----------------------------------------------
90 INTEGER :: IFLAGUNIT
91 INTEGER, DIMENSION(:), ALLOCATABLE :: ID
92 INTEGER I,J,IE,IN,IP,IR,NN,NITER,PARTID,UID,ITYP,ICOMPA
93 INTEGER SUB_ID,NNOD,SUB_INDEX,IMID, MAT_ID,MTN,NSOLID,NPT,ISMSTR
94 my_real, dimension(:,:), allocatable :: xtmp
95 my_real, DIMENSION(:), ALLOCATABLE ::
96 . xx,yy,zz
97 CHARACTER MESS*40
98 CHARACTER(LEN=NCHARTITLE) :: TITR,TITR1
99 DATA MESS/'XREF'/
100 LOGICAL :: IS_AVAILABLE
101 integer, dimension(:), allocatable :: TAGELC,TAGELTG,TAGELS,TAGNOD
102C-----------------------------------------------
103C E x t e r n a l F u n c t i o n s
104C-----------------------------------------------
105 INTEGER USR2SYS,R2R_SYS
106C=======================================================================
107 IS_AVAILABLE = .false.
108 ALLOCATE(tagelc(numelc),tageltg(numeltg),tagels(numels),tagnod(numnod))
109 ALLOCATE(xtmp(3,numnod))
110
111C
112 DO ie=1,numelc
113 DO in = 1,4
114 nn = ixc(in+1,ie)
115 DO j = 1,3
116 xrefc(in,j,ie) = x(j,nn)
117 ENDDO
118 ENDDO
119 ENDDO
120 DO ie=1,numeltg
121 DO in = 1,3
122 nn = ixtg(in+1,ie)
123 DO j = 1,3
124 xreftg(in,j,ie) = x(j,nn)
125 ENDDO
126 ENDDO
127 ENDDO
128 DO ie=1,numels8
129 DO in = 1,8
130 nn = ixs(in+1,ie)
131 DO j = 1,3
132 xrefs(in,j,ie) = x(j,nn)
133 ENDDO
134 ENDDO
135 ENDDO
136C
137 IF(iddlevel == 0) WRITE(iout,1000)
138 nitrs = 100
139C--------------------------------------------------
140C START BROWSING MODEL XREF
141C--------------------------------------------------
142c
143 CALL hm_option_start('/XREF')
144c
145C--------------------------------------------------
146C EXTRACT DATAS
147C--------------------------------------------------
148C-------------------
149C
150 !----------------------------------------------------------------------
151 ! Loop over XREF
152 !----------------------------------------------------------------------
153 DO ir = 1, nxref
154C
155 ! Reading the option
156 titr = ''
157 CALL hm_option_read_key(lsubmodel,
158 . unit_id = uid,
159 . submodel_index = sub_index,
160 . submodel_id = sub_id,
161 . option_titr = titr)
162C
163 CALL hm_get_intv('Comp_Id',partid,is_available,lsubmodel)
164C
165 ! Checking UNIT_ID
166 iflagunit = 0
167 DO j=1,unitab%NUNITS
168 IF (unitab%UNIT_ID(j) == uid) THEN
169 iflagunit = 1
170 EXIT
171 ENDIF
172 ENDDO
173 IF (uid/=0.AND.iflagunit==0) THEN
174 CALL ancmsg(msgid=659,anmode=aninfo,msgtype=msgerror,
175 . i2=uid,i1=partid,c1='XREF',
176 . c2='XREF',
177 . c3=titr)
178 ENDIF
179C
180 ip = 0
181 DO i = 1,npart
182 IF (ipart(4,i) == partid) THEN
183 ip = i
184 EXIT
185 ENDIF
186 ENDDO
187C
188 IF (ip /= 0) THEN
189 tagnod = 0
190 tagelc = 0
191 tageltg= 0
192 tagels = 0
193 ityp = 0
194 xtmp = zero
195 DO ie=1,numelc
196 IF (ip == ipartc(ie)) THEN
197 tagelc(ie) = 1
198 ityp = 1
199 ENDIF
200 ENDDO
201 DO ie=1,numeltg
202 IF (ip == ipartg(ie)) THEN
203 tageltg(ie) = 1
204 ityp = 1
205 ENDIF
206 ENDDO
207 nsolid = 0
208 IF (ityp == 0) THEN
209 DO ie=1,numels8
210 IF (ip == iparts(ie)) THEN
211 tagels(ie) = 1
212 ityp = 2
213 nsolid = isolnod(ie)
214 ENDIF
215 ENDDO
216 ENDIF
217 IF(ityp == 2 ) THEN
218 imid = ipart(1,ip)
219 ipid = ipart(2,ip)
220 mat_id = ipm(1,imid)
221 mtn = ipm(2, imid)
222 IF(mtn /= 35 .AND.mtn /= 38 .AND. mtn /= 42 .AND.
223 . mtn /= 70 .AND. mtn /= 90 .AND. mtn /= 1)THEN
224 CALL fretitl2(titr1,ipm(npropmi-ltitr+1,imid),ltitr)
225 CALL ancmsg(msgid=2014, msgtype=msgerror, anmode=anstop, i1=mat_id, c1=titr1, i2=mtn )
226 END IF
227 npt = igeo(4,ipid)
228 ismstr = igeo(5,ipid)
229 icompa = 0
230 IF (npt==1) icompa = 1
231 IF (ismstr>=10.OR.ismstr<0) icompa = 1
232 IF( ((nsolid /= 8 .AND.nsolid /= 4) .OR. icompa == 0 )) THEN
233 CALL fretitl2(titr1,igeo(npropgi-ltitr+1,ipid),ltitr)
234 CALL ancmsg(msgid=2013,
235 . msgtype=msgerror,
236 . anmode=aninfo,
237 . i1=igeo(1,ipid),
238 . c1=titr1)
239 ENDIF
240 ENDIF
241C
242 ! Number of iterations
243 CALL hm_get_intv('NITRS',niter,is_available,lsubmodel)
244 nitrs = max(nitrs,niter)
245C
246 IF(iddlevel == 0) THEN
247 WRITE(iout,1001) titr,nitrs,partid
248 IF(ipri >= 5) WRITE(iout,'(8X,A7,3(18X,A2))') 'NODE-ID',' X',' Y',' Z'
249 ENDIF
250C
251 ! Read nodes new coordinates
252 CALL hm_get_intv('refnodesmax',nnod,is_available,lsubmodel)
253 IF (ALLOCATED(id)) DEALLOCATE(id)
254 IF (ALLOCATED(xx)) DEALLOCATE(xx)
255 IF (ALLOCATED(yy)) DEALLOCATE(yy)
256 IF (ALLOCATED(zz)) DEALLOCATE(zz)
257 ALLOCATE(xx(nnod),yy(nnod),zz(nnod),id(nnod))
258C
259 ! Loop over nodes
260 DO j = 1,nnod
261C
262 CALL hm_get_int_array_index('node_id',id(j),j,is_available,lsubmodel)
263 CALL hm_get_float_array_index('globalx',xx(j),j,is_available, lsubmodel, unitab)
264 CALL hm_get_float_array_index('globaly',yy(j),j,is_available, lsubmodel, unitab)
265 CALL hm_get_float_array_index('globalz',zz(j),j,is_available, lsubmodel, unitab)
266C
267 IF(sub_id /= 0)
268 . CALL subrotpoint(xx(j),yy(j),zz(j),rtrans,sub_id,lsubmodel)
269 IF (nsubdom>0) THEN
270 nn = r2r_sys(id(j),itabm1,mess)
271 ELSE
272 nn = usr2sys(id(j),itabm1,mess,partid)
273 ENDIF
274 IF(iddlevel == 0.AND.ipri >= 5) WRITE(iout,'(5X,I10,5X,1P3G20.13)') id(j),xx(j),yy(j),zz(j)
275 tagnod(nn) = 1
276 tagxref(nn)= 1
277 xtmp(1,nn) = xx(j)
278 xtmp(2,nn) = yy(j)
279 xtmp(3,nn) = zz(j)
280 ENDDO
281 IF(iddlevel == 0.AND.ipri < 5) WRITE(iout,1010) nnod
282C
283 SELECT CASE (ityp)
284 CASE (1)
285 DO ie=1,numelc
286 IF (tagelc(ie) == 1) THEN
287 DO in=1,4
288 nn = ixc(in+1,ie)
289 IF (tagnod(nn) == 1) THEN
290 xrefc(in,1,ie) = xtmp(1,nn)
291 xrefc(in,2,ie) = xtmp(2,nn)
292 xrefc(in,3,ie) = xtmp(3,nn)
293 ENDIF
294 ENDDO
295 ENDIF
296 ENDDO
297 DO ie=1,numeltg
298 IF (tageltg(ie) == 1) THEN
299 DO in=1,3
300 nn = ixtg(in+1,ie)
301 IF (tagnod(nn) == 1) THEN
302 xreftg(in,1,ie) = xtmp(1,nn)
303 xreftg(in,2,ie) = xtmp(2,nn)
304 xreftg(in,3,ie) = xtmp(3,nn)
305 ENDIF
306 ENDDO
307 ENDIF
308 ENDDO
309 CASE (2)
310 DO ie=1,numels8
311 IF (tagels(ie) == 1) THEN
312 DO in=1,8
313 nn = ixs(in+1,ie)
314 IF (tagnod(nn) == 1) THEN
315 xrefs(in,1,ie) = xtmp(1,nn)
316 xrefs(in,2,ie) = xtmp(2,nn)
317 xrefs(in,3,ie) = xtmp(3,nn)
318 ENDIF
319 ENDDO
320 ENDIF
321 ENDDO
322 END SELECT
323 ENDIF
324 END DO
325C
326 ! Table deallocation
327 IF (ALLOCATED(id)) DEALLOCATE(id)
328 IF (ALLOCATED(xx)) DEALLOCATE(xx)
329 IF (ALLOCATED(yy)) DEALLOCATE(yy)
330 IF (ALLOCATED(zz)) DEALLOCATE(zz)
331C-----------
332 DEALLOCATE(tagelc,tageltg,tagels,tagnod)
333 DEALLOCATE(xtmp)
334
335 RETURN
336 1000 FORMAT(//
337 & 5x,' REFERENCE STATE (XREF) ',/
338 & 5x,' ---------------------- ' )
339 1001 FORMAT(/
340 & 5x, a ,/
341 & 5x,'NUMBER OF ITERATIONS. . . . . . =',i10/
342 & 5x,'PART ID . . . . . . . . . . . . =',i10)
343 1010 FORMAT(
344 & 5x,'NUMBER OF NODES . . . . . . . . =',i10)
345 END SUBROUTINE hm_read_xref
my_real
#define my_real
Definition cppsort.cpp:32
hm_get_float_array_index
subroutine hm_get_float_array_index(name, rval, index, is_available, lsubmodel, unitab)
Definition hm_get_float_array_index.F:105
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_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:253
hm_read_xref
subroutine hm_read_xref(itabm1, ipart, ipartc, ipartg, iparts, unitab, ixc, ixtg, ixs, x, xrefc, xreftg, xrefs, rtrans, lsubmodel, tagxref, iddlevel, isolnod, ipm, igeo)
Definition hm_read_xref.F:47
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:414
max
#define max(a, b)
Definition macros.h:21
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
unitab_mod
Definition unitab_mod.F:517
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
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:799
submodel_mod::submodel_data
Definition submodel_mod.F:728
subrotpoint
subroutine subrotpoint(x, y, z, rtrans, sub_id, lsubmodel)
Definition subrot.F:180