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

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_rwall_therm (rwl, nprw, lprw, ifi, ms, v, itab, itabm1, x, ikine, igrnod, mfi, imerge, unitab, iddlevel, lsubmodel, rtrans, nom_opt, itagnd, nchtherm, k, offs, ikine1, ixs, ixq, npc)

Function/Subroutine Documentation

◆ hm_read_rwall_therm()

subroutine hm_read_rwall_therm ( rwl,
integer, dimension(*) nprw,
integer, dimension(*) lprw,
integer ifi,
ms,
v,
integer, dimension(*) itab,
integer, dimension(*) itabm1,
x,
integer, dimension(*) ikine,
type (group_), dimension(ngrnod), target igrnod,
integer mfi,
integer, dimension(*) imerge,
type (unit_type_), intent(in) unitab,
integer iddlevel,
type(submodel_data), dimension(*) lsubmodel,
rtrans,
integer, dimension(lnopt1,*) nom_opt,
integer, dimension(*) itagnd,
integer nchtherm,
integer k,
integer offs,
integer, dimension(3*numnod) ikine1,
integer, dimension(nixs,*) ixs,
integer, dimension(nixq,*) ixq,
integer, dimension(*) npc )

Definition at line 46 of file hm_read_rwall_therm.F.

52C-------------------------------------
53C LECTURE MUR RIGIDE
54C-----------------------------------------------
55C M o d u l e s
56C-----------------------------------------------
57 USE unitab_mod
58 USE submodel_mod
59 USE message_mod
60 USE r2r_mod
61 USE groupdef_mod
62 USE hm_option_read_mod
63 USE names_and_titles_mod , ONLY : nchartitle, ncharkey
64C-----------------------------------------------
65C I m p l i c i t T y p e s
66C-----------------------------------------------
67#include "implicit_f.inc"
68C-----------------------------------------------
69C C o m m o n B l o c k s
70C-----------------------------------------------
71#include "com01_c.inc"
72#include "com04_c.inc"
73#include "units_c.inc"
74#include "scr03_c.inc"
75#include "scr17_c.inc"
76#include "param_c.inc"
77#include "tabsiz_c.inc"
78C-----------------------------------------------
79C D u m m y A r g u m e n t s
80C-----------------------------------------------
81 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
82 INTEGER IFI,MFI,IDDLEVEL,NCHTHERM,K,OFFS
83 INTEGER NPRW(*), LPRW(*), ITAB(*), ITABM1(*),
84 . IKINE(*), IMERGE(*),ITAGND(*),IKINE1(3*NUMNOD),
85 . IXS(NIXS,*),IXQ(NIXQ,*),NPC(*)
86 TYPE(SUBMODEL_DATA) LSUBMODEL(*)
87 my_real rwl(nrwlp,*), ms(*), v(3,*), x(3,*),rtrans(ntransf,*)
88 INTEGER NOM_OPT(LNOPT1,*)
89C-----------------------------------------------
90 TYPE (GROUP_) ,TARGET, DIMENSION(NGRNOD) :: IGRNOD
91C-----------------------------------------------
92C L o c a l V a r i a b l e s
93C-----------------------------------------------
94 INTEGER N, ITYP, ITIED, NSL, NUSER, MSR, J, I,
95 . L, IGU,IGU2, IGRS, NOSYS, IFQ, JC, UID,
96 . IFLAGUNIT,SUB_ID, SUB_INDEX,IFUNC,NE,KK,ND,K0,NN,NF
97 my_real
98 . dist, fric, diam, xmas, vx, vy, vz, xm1, ym1, zm1,
99 . xn, x1, y1, z1, disn, x2, y2, z2, x3, freq, alpha, fac_m_r2r,
100 . temp,tstif,fheat,facx,fac_tstif
101 CHARACTER MESS*40
102 CHARACTER(LEN=NCHARKEY) :: OPT
103 CHARACTER(LEN=NCHARTITLE)::TITR
104 LOGICAL :: IS_AVAILABLE
105C-----------------------------------------------
106C E x t e r n a l F u n c t i o n s
107C-----------------------------------------------
108 INTEGER USR2SYS, NGR2USR
109 INTEGER, DIMENSION(:), POINTER :: INGR2USR
110 DATA mess/'STANDARD RIGID WALL DEFINITION '/
111C=======================================================================
112C-----------------------------------------------
113! ************************** !
114! RWALL/PLANE read with hm reader !
115! ************************** !
116C-----------------------------------------------
117 is_available = .false.
118 CALL hm_option_start('/RWALL/THERM')
119 ! Flag for RWALL type PLANE
120 ityp = 1
121 !----------------------------------------------------------------------
122 ! Loop over HM_RWALLs
123 !----------------------------------------------------------------------
124 DO n = 1+offs, nchtherm+offs
125C
126 ! Reading the option
127 ! /RWALL/type/rwall_ID/node_ID
128 ! rwall_title
129 titr = ''
130 CALL hm_option_read_key(lsubmodel,
131 . option_id = nuser,
132 . unit_id = uid,
133 . submodel_index = sub_index,
134 . submodel_id = sub_id,
135 . option_titr = titr)
136C
137 nom_opt(1,n)=nuser
138 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,n),ltitr)
139C
140 ! Checking flag unit
141 iflagunit = 0
142 DO j=1,unitab%NUNITS
143 IF (unitab%UNIT_ID(j) == uid) THEN
144 iflagunit = 1
145 EXIT
146 ENDIF
147 ENDDO
148 IF (uid /= 0 .AND. iflagunit == 0) THEN
149 CALL ancmsg(msgid=659,anmode=aninfo,msgtype=msgerror,
150 . i2=uid,i1=nuser,c1='RIGID WALL',
151 . c2='RIGID WALL',
152 . c3=titr)
153 ENDIF
154C
155 ! node_ID Slide grnd_ID1 grnd_ID2
156 CALL hm_get_intv('slidingflag',itied,is_available,lsubmodel)
157 CALL hm_get_intv('NodeSet_ID',igu,is_available,lsubmodel)
158 CALL hm_get_intv('excludeNodeSet_ID',igu2,is_available,lsubmodel)
159C
160 ! Fixed rigid wall
161 msr = 0
162C
163 ! 2nd card
164 ! d fric Diameter ffac ifq
165 CALL hm_get_floatv('offset' ,dist ,is_available, lsubmodel, unitab)
166 CALL hm_get_floatv('fric' ,fric ,is_available, lsubmodel, unitab)
167 CALL hm_get_floatv('Diameter' ,diam ,is_available, lsubmodel, unitab)
168 ifq = 0
169 freq = one
170 alpha = freq
171 rwl(13,n) = fric
172 rwl(14,n) = alpha
173 rwl(15,n) = ifq
174C
175 ! 3rd card
176 ! XM YM ZM
177 CALL hm_get_floatv('x' ,x1 ,is_available, lsubmodel, unitab)
178 CALL hm_get_floatv('y' ,x2 ,is_available, lsubmodel, unitab)
179 CALL hm_get_floatv('z' ,x3 ,is_available, lsubmodel, unitab)
180 IF(sub_id /= 0) CALL subrotpoint(x1,x2,x3,rtrans,sub_id,lsubmodel)
181 rwl(4,n) = x1
182 rwl(5,n) = x2
183 rwl(6,n) = x3
184C
185 ! 4th card
186 ! XM1 YM1 ZM1
187 CALL hm_get_floatv('XH' ,xm1 ,is_available, lsubmodel, unitab)
188 CALL hm_get_floatv('YH' ,ym1 ,is_available, lsubmodel, unitab)
189 CALL hm_get_floatv('ZH' ,zm1 ,is_available, lsubmodel, unitab)
190 IF (sub_id /= 0) CALL subrotpoint(xm1,ym1,zm1,rtrans,sub_id,lsubmodel)
191C
192 ! 5th card (only for THERM)
193 CALL hm_get_intv('fct_IDt' ,ifunc,is_available, lsubmodel)
194 CALL hm_get_floatv('Fscale_T' ,temp ,is_available, lsubmodel, unitab)
195 CALL hm_get_floatv('Thermalresistance',tstif,is_available, lsubmodel, unitab)
196C
197 ! Initialization depending on the type of interface
198 ! PLANE
199C M MUR ET MM1 NORMALE
200 rwl(1,n) = xm1-rwl(4,n)
201 rwl(2,n) = ym1-rwl(5,n)
202 rwl(3,n) = zm1-rwl(6,n)
203 xn = sqrt(rwl(1,n)**2+rwl(2,n)**2+rwl(3,n)**2)
204 IF (xn <= em10) THEN
205 CALL ancmsg(msgid=167,anmode=aninfo,msgtype=msgerror,
206 . i1=nuser,c2='PLANE',c1=titr)
207 ELSE
208 rwl(1,n) = rwl(1,n)/xn
209 rwl(2,n) = rwl(2,n)/xn
210 rwl(3,n) = rwl(3,n)/xn
211 ENDIF
212C
213 ! Looking for SECONDARY nodes
214 DO i = 1,numnod
215 lprw(k+i) = 0
216 ENDDO
217C
218 ! SECONDARY nodes at DIST from the RWALL
219 IF (dist /= zero) THEN
220 DO i = 1,numnod
221 x1 = (x(1,i)-rwl(4,n))*rwl(1,n)
222 y1 = (x(2,i)-rwl(5,n))*rwl(2,n)
223 z1 = (x(3,i)-rwl(6,n))*rwl(3,n)
224 disn = x1+y1+z1
225 IF (disn >= zero .AND. disn <= dist .AND. i /= msr) lprw(k+i)=1
226 ENDDO
227 ENDIF
228C
229 ! Node group +
230 ingr2usr => igrnod(1:ngrnod)%ID
231 igrs = ngr2usr(igu,ingr2usr,ngrnod)
232 IF (igrs /= 0) THEN
233 DO j = 1,igrnod(igrs)%NENTITY
234 nosys = igrnod(igrs)%ENTITY(j)
235 lprw(k+nosys) = 1
236 IF (itab(nosys) == nuser) THEN
237 CALL ancmsg(msgid=637,
238 . msgtype=msgerror,
239 . anmode=aninfo_blind_1,
240 . i1=nuser,
241 . c1=titr,
242 . i2=nuser)
243 ENDIF
244 ENDDO
245 ENDIF
246C
247 ! Node group -
248 ingr2usr => igrnod(1:ngrnod)%ID
249 igrs = ngr2usr(igu2,ingr2usr,ngrnod)
250 IF (igrs /= 0) THEN
251 DO j = 1,igrnod(igrs)%NENTITY
252 nosys = igrnod(igrs)%ENTITY(j)
253 lprw(k+nosys) = 0
254 ENDDO
255 ENDIF
256C
257 ! Compaction
258 nsl = 0
259 DO i = 1,numnod
260 IF (lprw(k+i) > 0) THEN
261 IF (ns10e > 0) THEN
262 IF(itagnd(i) /= 0) cycle
263 ENDIF
264 nsl = nsl+1
265 lprw(k+nsl) = i
266 IF (iddlevel == 0) THEN
267 CALL kinset(4,itab(i),ikine(i),1,n+numskw+1,ikine1(i))
268 ENDIF
269 ENDIF
270 ENDDO
271 ! Itet=2 of S10
272 IF (ns10e > 0 ) CALL remove_nd(nsl,lprw(k+1),itagnd)
273 ifi=ifi+nsl
274 IF (ifq > 0) THEN
275 mfi=mfi+3*nsl
276 srwsav = srwsav + 3 * nsl
277 ENDIF
278C
279 ! Printing
280 WRITE(iout,1100) n,ityp,itied,nsl
281 WRITE(iout,2001)(rwl(l,n),l=4,6),(rwl(l,n),l=1,3)
282 IF (itied == 2) WRITE(iout,2101)fric,ifq,freq
283 IF (ipri >= 1) THEN
284 WRITE(iout,1200)
285 WRITE(iout,1201) (itab(lprw(i+k)),i=1,nsl)
286 ENDIF
287C
288 nprw(n) = nsl
289 nprw(n+nrwall) = itied
290 nprw(n+2*nrwall) = msr
291 nprw(n+3*nrwall) = ityp
292 nprw(n+4*nrwall) = 0
293 nprw(n+5*nrwall) = 0
294 k0 = k
295 k = k+nsl
296C
297 ne = 0
298 kk = k+2*nsl
299 DO nd = kk+1,kk+numnod
300 lprw(nd) = 0
301 ENDDO
302 DO j = 1+k0,nsl+k0
303 nd = lprw(j) + kk
304 lprw(nd) = 1
305 ENDDO
306 IF (n2d == 0) THEN
307 DO i = 1,numels
308 nn = 0
309 DO j = 2,9
310 nd = ixs(j,i) + kk
311 nn = nn + lprw(nd)
312 ENDDO
313 IF (nn >= 4) THEN
314 ne = ne+1
315 nn = lprw(ixs(2,i) + kk)
316 . + lprw(ixs(3,i) + kk)
317 . + lprw(ixs(4,i) + kk)
318 . + lprw(ixs(5,i) + kk)
319 IF (nn == 4) THEN
320 lprw(k+ne) = i*10 + 1
321 ELSE
322 nn = lprw(ixs(4,i) + kk)
323 . + lprw(ixs(5,i) + kk)
324 . + lprw(ixs(8,i) + kk)
325 . + lprw(ixs(9,i) + kk)
326 IF (nn == 4) THEN
327 lprw(k+ne) = i*10 + 2
328 ELSE
329 nn = lprw(ixs(6,i) + kk)
330 . + lprw(ixs(7,i) + kk)
331 . + lprw(ixs(8,i) + kk)
332 . + lprw(ixs(9,i) + kk)
333 IF (nn == 4) THEN
334 lprw(k+ne) = i*10 + 3
335 ELSE
336 nn = lprw(ixs(2,i) + kk)
337 . + lprw(ixs(3,i) + kk)
338 . + lprw(ixs(6,i) + kk)
339 . + lprw(ixs(7,i) + kk)
340 IF (nn == 4) THEN
341 lprw(k+ne) = i*10 + 4
342 ELSE
343 nn = lprw(ixs(3,i) + kk)
344 . + lprw(ixs(4,i) + kk)
345 . + lprw(ixs(7,i) + kk)
346 . + lprw(ixs(8,i) + kk)
347 IF (nn == 4) THEN
348 lprw(k+ne) = i*10 + 5
349 ELSE
350 nn = lprw(ixs(2,i) + kk)
351 . + lprw(ixs(5,i) + kk)
352 . + lprw(ixs(6,i) + kk)
353 . + lprw(ixs(9,i) + kk)
354 IF (nn == 4)THEN
355 lprw(k+ne) = i*10 + 6
356 ELSE
357 ne = ne-1
358 ENDIF
359 ENDIF
360 ENDIF
361 ENDIF
362 ENDIF
363 ENDIF
364 ENDIF
365 ENDDO
366 ELSE
367 DO i = 1,numelq
368 nn = 0
369 DO j = 2,5
370 nd = ixq(j,i) + kk
371 nn = nn + lprw(nd)
372 ENDDO
373 IF (nn >= 2) THEN
374 ne = ne+1
375 nn = lprw(ixq(2,i) + kk) + lprw(ixq(3,i) + kk)
376 IF (nn == 2) THEN
377 lprw(k+ne) = i*10 + 1
378 ELSE
379 nn = lprw(ixq(3,i) + kk) + lprw(ixq(4,i) + kk)
380 IF (nn == 2) THEN
381 lprw(k+ne) = i*10 + 2
382 ELSE
383 nn = lprw(ixq(4,i) + kk) + lprw(ixq(5,i) + kk)
384 IF (nn == 2) THEN
385 lprw(k+ne) = i*10 + 3
386 ELSE
387 nn = lprw(ixq(5,i) + kk) + lprw(ixq(2,i) + kk)
388 IF (nn == 2) THEN
389 lprw(k+ne) = i*10 + 4
390 ELSE
391 ne = ne-1
392 ENDIF
393 ENDIF
394 ENDIF
395 ENDIF
396 ENDIF
397 ENDDO
398 ENDIF
399C
400 ! These two parameters are not set in the input deck
401 ! but remain in the buffer table
402 fheat = one
403 facx = one/unitab%FAC_T_WORK
404C
405 IF (tstif == zero) THEN
406 CALL hm_get_floatv_dim('Thermalresistance',fac_tstif,is_available,lsubmodel,unitab)
407 tstif = one*fac_tstif
408 ENDIF
409C
410 WRITE(iout,2100) ifunc,temp,tstif
411C
412 tstif = one/tstif
413C
414 nprw(n+3*nrwall)=-ityp
415C
416 nf = 0
417 IF (ifunc > 0) THEN
418 DO i=1,nfunct
419 IF (ifunc == npc(i)) THEN
420 nf = i
421 EXIT
422 ENDIF
423 ENDDO
424 IF (nf == 0) THEN
425 CALL ancmsg(msgid=120,
426 . msgtype=msgerror,
427 . anmode=aninfo,
428 . i1=ifunc,
429 . c1=titr)
430 ENDIF
431 ENDIF
432C
433 rwl(8,n) = ne
434 rwl(9,n) = nf
435 rwl(10,n) = temp
436 rwl(11,n) = tstif
437 rwl(12,n) = fheat
438 rwl(16,n) = facx
439C
440 ifi = ifi + ne
441C
442 k = k + ne
443C
444 ENDDO
445C
446 ! Updating the OFFSET
447 offs = offs + nchtherm
448C
449 RETURN
450C
451 1100 FORMAT(/5x,'RIGID WALL NUMBER. . . . .',i10
452 . /10x,'RIGID WALL TYPE . . . . .',i10
453 . /10x,'TYPE SLIDE/TIED/FRICTION.',i10
454 . /10x,'NUMBER OF NODES . . . . .',i10)
455 1200 FORMAT(/10x,'SECONDARY NODES : ')
456 1201 FORMAT(/10x,10i10)
457 2001 FORMAT(/5x,'INFINITE WALL CHARACTERISTICS',
458 . /10x,'POINT M . . . . . . . . .',1p3g20.13
459 . /10x,'NORMAL VECTOR . . . . . .',1p3g20.13)
460 2100 FORMAT(/5x,'THERMAL CHARACTERISTICS',
461 . /10x,'TEMPERATURE FUNCTION. . .',i10
462 . /10x,'TEMPERATURE SCALE FACTOR.',1pg14.4
463 . /10x,'THERMAL RESISTANCE. . . .',1pg14.4)
464 2101 FORMAT(/5x,'COULOMB FRICTION CHARACTERISTICS',
465 . /10x,'FRICTION COEFFICIENT . . .',1pg14.4
466 . /10x,'FILTRATION FLAG. . . . . .',i10
467 . /10x,'FILTRATION FACTOR. . . . .',1pg14.4)
my_real
#define my_real
Definition cppsort.cpp:32
remove_nd
subroutine remove_nd(nn, inn, itagnd)
Definition dim_s10edg.F:219
alpha
#define alpha
Definition eval.h:35
hm_get_floatv
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
Definition hm_get_floatv.F:415
hm_get_floatv_dim
subroutine hm_get_floatv_dim(name, dim_fac, is_available, lsubmodel, unitab)
Definition hm_get_floatv_dim.F:159
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
kinset
subroutine kinset(ik, node, ikine, idir, isk, ikine1)
Definition kinset.F:57
groupdef_mod
Definition groupdef_mod.F:662
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
r2r_mod
Definition r2r_mod.F:125
submodel_mod
Definition submodel_mod.F:712
unitab_mod
Definition unitab_mod.F:513
ngr2usr
integer function ngr2usr(iu, igr, ngr)
Definition nintrr.F:325
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
subrotpoint
subroutine subrotpoint(x, y, z, rtrans, sub_id, lsubmodel)
Definition subrot.F:180