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