OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_rwall_lagmul.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_rwall_lagmul ../starter/source/constraints/general/rwall/hm_read_rwall_lagmul.F
25!||--- called by ------------------------------------------------------
26!|| read_rwall ../starter/source/constraints/general/rwall/read_rwall.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| anodset ../starter/source/output/analyse/analyse_node.c
30!|| fretitl ../starter/source/starter/freform.F
31!|| hm_get_floatv ../starter/source/devtools/hm_reader/hm_get_floatv.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!|| kinset ../starter/source/constraints/general/kinset.F
36!|| ngr2usr ../starter/source/system/nintrr.F
37!|| remove_nd ../starter/source/elements/solid/solide10/dim_s10edg.F
38!|| subrotpoint ../starter/source/model/submodel/subrot.F
39!|| subrotvect ../starter/source/model/submodel/subrot.F
40!|| usr2sys ../starter/source/system/sysfus.F
41!||--- uses -----------------------------------------------------
42!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
43!|| message_mod ../starter/share/message_module/message_mod.F
44!|| r2r_mod ../starter/share/modules1/r2r_mod.F
45!|| submodel_mod ../starter/share/modules1/submodel_mod.F
46!||====================================================================
47 SUBROUTINE hm_read_rwall_lagmul(RWL ,NPRW ,LPRW ,IFI ,MS ,
48 . V ,ITAB ,ITABM1 ,X ,IKINE ,
49 . IGRNOD ,MFI ,IMERGE ,UNITAB ,IDDLEVEL,
50 . LSUBMODEL,RTRANS ,NOM_OPT ,ITAGND ,NCHLAGM ,
51 . K ,OFFS ,IKINE1LAG)
52C-------------------------------------
53C READING 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 A n a l y s e M o d u l e
70C-----------------------------------------------
71#include "analyse_name.inc"
72C-----------------------------------------------
73C C o m m o n B l o c k s
74C-----------------------------------------------
75#include "lagmult.inc"
76#include "com04_c.inc"
77#include "units_c.inc"
78#include "scr03_c.inc"
79#include "scr17_c.inc"
80#include "param_c.inc"
81#include "tabsiz_c.inc"
82#include "r2r_c.inc"
83C-----------------------------------------------
84C D u m m y A r g u m e n t s
85C-----------------------------------------------
86 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
87 INTEGER IFI,MFI,IDDLEVEL,NCHLAGM,K,OFFS
88 INTEGER NPRW(*), LPRW(*), ITAB(*), ITABM1(*),
89 . IKINE(*), IMERGE(*),ITAGND(*),IKINE1LAG(*)
90 TYPE(submodel_data) LSUBMODEL(*)
91 my_real
92 . rwl(nrwlp,*), ms(*), v(3,*), x(3,*),
93 . rtrans(ntransf,*)
94 INTEGER NOM_OPT(LNOPT1,*)
95C-----------------------------------------------
96 TYPE (GROUP_) ,TARGET, DIMENSION(NGRNOD) :: IGRNOD
97C-----------------------------------------------
98C L o c a l V a r i a b l e s
99C-----------------------------------------------
100 INTEGER N, ITYP, ITIED, NSL, NUSER, MSR, J, I,L, IGU,IGU2, IGRS, NOSYS, IFQ, JC, UID,IFLAGUNIT,SUB_ID, SUB_INDEX
101 my_real :: DIST, FRIC, DIAM, XMAS, VX, VY, VZ, XM1, YM1, ZM1
102 my_real :: XN, X1, Y1, Z1, DISN, X2, X3, FREQ, ALPHA, FAC_M_R2R
103 CHARACTER MESS*40
104 CHARACTER(LEN=NCHARTITLE) :: TITR
105 LOGICAL :: IS_AVAILABLE
106C-----------------------------------------------
107C E x t e r n a l F u n c t i o n s
108C-----------------------------------------------
109 INTEGER USR2SYS, NGR2USR
110 INTEGER, DIMENSION(:), POINTER :: INGR2USR
111 DATA MESS/'STANDARD RIGID WALL DEFINITION '/
112C=======================================================================
113C-----------------------------------------------
114! ************************** !
115! RWALL/PLANE read with hm reader !
116! ************************** !
117C-----------------------------------------------
118 is_available = .false.
119 CALL hm_option_start('/RWALL/LAGMUL')
120 ! Flag for RWALL type PLANE
121 ityp = 1
122 !----------------------------------------------------------------------
123 ! Loop over HM_RWALLs
124 !----------------------------------------------------------------------
125 DO n = 1+offs, nchlagm+offs
126C
127 ! Reading the option
128 ! /RWALL/type/rwall_ID/node_ID
129 ! rwall_title
130 titr = ''
131 CALL hm_option_read_key(lsubmodel,
132 . option_id = nuser,
133 . unit_id = uid,
134 . submodel_index = sub_index,
135 . submodel_id = sub_id,
136 . option_titr = titr)
137C
138 nom_opt(1,n)=nuser
139 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,n),ltitr)
140C
141 ! Checking flag unit
142 iflagunit = 0
143 DO j=1,unitab%NUNITS
144 IF (unitab%UNIT_ID(j) == uid) THEN
145 iflagunit = 1
146 EXIT
147 ENDIF
148 ENDDO
149 IF (uid /= 0 .AND. iflagunit == 0) THEN
150 CALL ancmsg(msgid=659,anmode=aninfo,msgtype=msgerror,
151 . i2=uid,i1=nuser,c1='RIGID WALL',
152 . c2='RIGID WALL',
153 . c3=titr)
154 ENDIF
155C
156 ! node_ID Slide grnd_ID1 grnd_ID2
157 CALL hm_get_intv('Node1',nuser,is_available,lsubmodel)
158 CALL hm_get_intv('slidingflag',itied,is_available,lsubmodel)
159 CALL hm_get_intv('NodeSet_ID',igu,is_available,lsubmodel)
160 CALL hm_get_intv('excludeNodeSet_ID',igu2,is_available,lsubmodel)
161C
162 IF (nuser /= 0) THEN
163 msr = usr2sys(nuser,itabm1,mess,nuser)
164 CALL anodset(msr, check_used)
165 DO jc = 1,nmerged
166 IF (msr == imerge(jc)) msr = imerge(numcnod+jc)
167 ENDDO
168 ELSE
169 msr = 0
170 ENDIF
171C
172 ! 2nd card
173 ! d fric Diameter ffac ifq
174 CALL hm_get_floatv('offset' ,dist ,is_available, lsubmodel, unitab)
175 CALL hm_get_floatv('fric' ,fric ,is_available, lsubmodel, unitab)
176 CALL hm_get_floatv('Diameter' ,diam ,is_available, lsubmodel, unitab)
177 CALL hm_get_floatv('Filteringfactor',freq ,is_available, lsubmodel, unitab)
178 CALL hm_get_intv('Filteringflag' ,ifq ,is_available, lsubmodel)
179 IF (freq == 0 .AND. ifq /= 0) ifq = 0
180 IF (ifq == 0) freq = one
181 alpha = zero
182 IF (ifq >= 0) THEN
183 IF (ifq <= 1) alpha = freq
184 IF (ifq == 2) alpha = four*atan2(one,zero) / freq
185 IF (ifq == 3) alpha = four*atan2(one,zero) * freq
186 ENDIF
187 IF ((alpha < zero) .OR. ((alpha > one .AND. ifq <= 2))) THEN
188 CALL ancmsg(msgid=350,anmode=aninfo,msgtype=msgerror,
189 . i1=nuser,
190 . c1=titr,
191 . r1=freq)
192 ENDIF
193 rwl(13,n) = fric
194 rwl(14,n) = alpha
195 rwl(15,n) = ifq
196C
197 ! 3rd card
198 ! if node_ID == 0
199 IF (msr == 0) THEN
200 ! XM YM ZM
201 CALL hm_get_floatv('x' ,x1 ,is_available, lsubmodel, unitab)
202 CALL hm_get_floatv('y' ,x2 ,is_available, lsubmodel, unitab)
203 CALL hm_get_floatv('z' ,x3 ,is_available, lsubmodel, unitab)
204 IF(sub_id /= 0) CALL subrotpoint(x1,x2,x3,rtrans,sub_id,lsubmodel)
205 rwl(4,n) = x1
206 rwl(5,n) = x2
207 rwl(6,n) = x3
208 ! if node_ID > 0
209 ELSE IF (msr /= 0)THEN
210 ! Mass VX0 VY0 VZ0
211 CALL hm_get_floatv('Mass' ,xmas ,is_available, lsubmodel, unitab)
212 CALL hm_get_floatv('motionx' ,vx ,is_available, lsubmodel, unitab)
213 CALL hm_get_floatv('motiony' ,vy ,is_available, lsubmodel, unitab)
214 CALL hm_get_floatv('motionz' ,vz ,is_available, lsubmodel, unitab)
215 ! Multidomains : masse of the rwall splitted between 2 domains
216 fac_m_r2r = one
217 IF (nsubdom > 0) THEN
218 IF(tagno(npart+msr) == 4) fac_m_r2r = half
219 ENDIF
220 IF(sub_id /= 0) CALL subrotvect(vx,vy,vz,rtrans,sub_id,lsubmodel)
221 rwl(4,n) = x(1,msr)
222 rwl(5,n) = x(2,msr)
223 rwl(6,n) = x(3,msr)
224 ms(msr) = ms(msr) + xmas*fac_m_r2r
225 v(1,msr) = vx
226 v(2,msr) = vy
227 v(3,msr) = vz
228 ENDIF
229C
230 ! 4th card (only for PLANE, CYL and PARAL)
231 ! XM1 YM1 ZM1
232 CALL hm_get_floatv('XH' ,xm1 ,is_available, lsubmodel, unitab)
233 CALL hm_get_floatv('YH' ,ym1 ,is_available, lsubmodel, unitab)
234 CALL hm_get_floatv('ZH' ,zm1 ,is_available, lsubmodel, unitab)
235 IF (sub_id /= 0) CALL subrotpoint(xm1,ym1,zm1,rtrans,sub_id,lsubmodel)
236C
237 ! Initialization depending on the type of interface
238 ! PLANE
239C M MUR ET MM1 NORMALE
240 rwl(1,n) = xm1-rwl(4,n)
241 rwl(2,n) = ym1-rwl(5,n)
242 rwl(3,n) = zm1-rwl(6,n)
243 xn = sqrt(rwl(1,n)**2+rwl(2,n)**2+rwl(3,n)**2)
244 IF (xn <= em10) THEN
245 CALL ancmsg(msgid=167,anmode=aninfo,msgtype=msgerror,
246 . i1=nuser,c2='PLANE',c1=titr)
247 ELSE
248 rwl(1,n) = rwl(1,n)/xn
249 rwl(2,n) = rwl(2,n)/xn
250 rwl(3,n) = rwl(3,n)/xn
251 ENDIF
252C
253 ! Looking for SECONDARY nodes
254 DO i = 1,numnod
255 lprw(k+i) = 0
256 ENDDO
257C
258 ! SECONDARY nodes at DIST from the RWALL
259 IF (dist /= zero) THEN
260 DO i = 1,numnod
261 x1 = (x(1,i)-rwl(4,n))*rwl(1,n)
262 y1 = (x(2,i)-rwl(5,n))*rwl(2,n)
263 z1 = (x(3,i)-rwl(6,n))*rwl(3,n)
264 disn = x1+y1+z1
265 IF (disn >= zero .AND. disn <= dist .AND. i /= msr) lprw(k+i)=1
266 ENDDO
267 ENDIF
268C
269 ! Node group +
270 ingr2usr => igrnod(1:ngrnod)%ID
271 igrs = ngr2usr(igu,ingr2usr,ngrnod)
272 IF (igrs /= 0) THEN
273 DO j = 1,igrnod(igrs)%NENTITY
274 nosys = igrnod(igrs)%ENTITY(j)
275 lprw(k+nosys) = 1
276 IF (itab(nosys) == nuser) THEN
277 CALL ancmsg(msgid=637,
278 . msgtype=msgerror,
279 . anmode=aninfo_blind_1,
280 . i1=nuser,
281 . c1=titr,
282 . i2=nuser)
283 ENDIF
284 ENDDO
285 ENDIF
286C
287 ! Node group -
288 ingr2usr => igrnod(1:ngrnod)%ID
289 igrs = ngr2usr(igu2,ingr2usr,ngrnod)
290 IF (igrs /= 0) THEN
291 DO j = 1,igrnod(igrs)%NENTITY
292 nosys = igrnod(igrs)%ENTITY(j)
293 lprw(k+nosys) = 0
294 ENDDO
295 ENDIF
296C
297 ! Compaction
298 nsl = 0
299 DO i = 1,numnod
300 IF (lprw(k+i) > 0) THEN
301 IF (ns10e > 0) THEN
302 IF(itagnd(i) /= 0) cycle
303 ENDIF
304 nsl = nsl+1
305 lprw(k+nsl) = i
306 IF (iddlevel == 0) THEN
307 CALL kinset(512,itab(i),ikine(i),7,0,ikine1lag(i))
308 ENDIF
309 ENDIF
310 ENDDO
311 ! Itet=2 of S10
312 IF (ns10e > 0 ) CALL remove_nd(nsl,lprw(k+1),itagnd)
313 ifi=ifi+nsl
314 IF (ifq > 0) THEN
315 mfi=mfi+3*nsl
316 srwsav = srwsav + 3 * nsl
317 ENDIF
318C
319 ! Printing
320 IF (msr == 0) THEN
321 WRITE(iout,1100) n,ityp,itied,nsl
322 ELSE
323 WRITE(iout,1150) n,ityp,itied,nsl,nuser,xmas,vx,vy,vz
324 ENDIF
325C
326 WRITE(iout,1160)
327 WRITE(iout,2001)(rwl(l,n),l=4,6),(rwl(l,n),l=1,3)
328
329 IF (itied == 2) WRITE(iout,2101)fric,ifq,freq
330 IF (ipri >= 1) THEN
331 WRITE(iout,1200)
332 WRITE(iout,1201) (itab(lprw(i+k)),i=1,nsl)
333 ENDIF
334C
335 nprw(n) = nsl
336 nprw(n+nrwall) = itied
337 nprw(n+2*nrwall) = msr
338 nprw(n+3*nrwall) = ityp
339 nprw(n+4*nrwall) = 0
340 nprw(n+5*nrwall) = 1
341 nrwlag = max(nrwlag,nsl)
342 IF (itied == 0) THEN
343 lag_ncl=lag_ncl+nsl
344 lag_nkl=lag_nkl+nsl*3
345 ELSE IF (itied == 1) THEN
346 lag_ncl=lag_ncl+nsl*3
347 lag_nkl=lag_nkl+nsl*3
348 ENDIF
349 IF (msr /= 0) THEN
350 lag_nkl=lag_nkl+nsl*3
351 ENDIF
352 k = k+nsl
353C
354 ENDDO
355C
356 ! Updating the OFFSET
357 offs = offs + nchlagm
358C
359 RETURN
360C
361 1100 FORMAT(/5x,'RIGID WALL NUMBER. . . . .',i10
362 . /10x,'rigid wall TYPE . . . . .',I10
363 . /10X,'type slide/tied/friction.',I10
364 . /10X,'number of nodes . . . . .',I10)
365 1150 FORMAT(/5X,'rigid wall number. . . . .',I10
366 . /10X,'rigid wall TYPE . . . . .',I10
367 . /10X,'type slide/tied/friction.',I10
368 . /10X,'number of nodes . . . . .',I10
369 . /10X,'wall node number. . . . .',I10
370 . /10X,'wall mass . . . . . . . .',1PG14.4
371 . /10X,'wall x-velocity . . . . .',1PG14.4
372 . /10X,'wall y-velocity . . . . .',1PG14.4
373 . /10X,'wall z-velocity . . . . .',1PG14.4)
374 1160 FORMAT(10X,'lagrange multiplier option')
375 1200 FORMAT(/10X,'secondary nodes : ')
376 1201 FORMAT(/10X,10I10)
377 2001 FORMAT(/5X,'infinite wall characteristics',
378 . /10X,'point m . . . . . . . . .',1P3G20.13
379 . /10X,'normal vector . . . . . .',1P3G20.13)
380 2101 FORMAT(/5X,'coulomb friction characteristics',
381 . /10X,'friction coefficient . . .',1PG14.4
382 . /10X,'filtration flag. . . . . .',I10
383 . /10X,'filtration factor. . . . .',1PG14.4)
384 END
anodset
void anodset(int *id, int *type)
Definition analyse_node.c:321
my_real
#define my_real
Definition cppsort.cpp:32
remove_nd
subroutine remove_nd(nn, inn, itagnd)
Definition dim_s10edg.F:221
hm_get_floatv
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
Definition hm_get_floatv.F:418
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_rwall_lagmul
subroutine hm_read_rwall_lagmul(rwl, nprw, lprw, ifi, ms, v, itab, itabm1, x, ikine, igrnod, mfi, imerge, unitab, iddlevel, lsubmodel, rtrans, nom_opt, itagnd, nchlagm, k, offs, ikine1lag)
Definition hm_read_rwall_lagmul.F:52
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:414
kinset
subroutine kinset(ik, node, ikine, idir, isk, ikine1)
Definition kinset.F:57
max
#define max(a, b)
Definition macros.h:21
groupdef_mod
Definition groupdef_mod.F:668
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
names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1005
r2r_mod
Definition r2r_mod.F:125
r2r_mod::tagno
integer, dimension(:), allocatable tagno
Definition r2r_mod.F:132
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
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:615
submodel_mod::submodel_data
Definition submodel_mod.F:728
subrotvect
subroutine subrotvect(x, y, z, rtrans, sub_id, lsubmodel)
Definition subrot.F:54
subrotpoint
subroutine subrotpoint(x, y, z, rtrans, sub_id, lsubmodel)
Definition subrot.F:180
velocity
subroutine velocity(a, ar, v, vr, fzero, itab, nale)
Definition velocity.F:29