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

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_friction_orientations (intbuf_fric_tab, npfricorth, igrpart, ipart, pfricorth, irepforth, iskn, phiforth, vforth, skew, iflag, tagprt_fric, rtrans, lsubmodel, unitab)

Function/Subroutine Documentation

◆ hm_read_friction_orientations()

subroutine hm_read_friction_orientations ( type(intbuf_fric_struct_), dimension(*) intbuf_fric_tab,
integer npfricorth,
type (group_), dimension(ngrpart) igrpart,
integer, dimension(lipart1,*) ipart,
integer, dimension(*) pfricorth,
integer, dimension(*) irepforth,
integer, dimension(liskn,*) iskn,
phiforth,
vforth,
skew,
integer iflag,
integer, dimension(*) tagprt_fric,
rtrans,
type(submodel_data), dimension(*) lsubmodel,
type (unit_type_), intent(in) unitab )

Definition at line 42 of file hm_read_friction_orientations.F.

46
47C============================================================================
48C M o d u l e s
49C-----------------------------------------------
50 USE r2r_mod
51 USE message_mod
52 USE intbuf_fric_mod
53 USE groupdef_mod
54 USE submodel_mod
55 USE unitab_mod
56 USE hm_option_read_mod
57 USE names_and_titles_mod , ONLY : nchartitle
58C-----------------------------------------------
59C I m p l i c i t T y p e s
60C-----------------------------------------------
61#include "implicit_f.inc"
62C-----------------------------------------------
63C C o m m o n B l o c k s
64C-----------------------------------------------
65#include "com04_c.inc"
66#include "units_c.inc"
67#include "param_c.inc"
68#include "scr17_c.inc"
69C-----------------------------------------------
70C D u m m y A r g u m e n t s
71C-----------------------------------------------
72 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
73 INTEGER IFLAG ,NPFRICORTH
74 INTEGER IPART(LIPART1,*) ,PFRICORTH(*),IREPFORTH(*),TAGPRT_FRIC(*),
75 . ISKN(LISKN,*) !,IDFRICORIENT(*)
76
77 my_real
78 . phiforth(*) ,vforth(3,*) ,skew(lskew,*) ,rtrans(ntransf,*)
79
80c CHARACTER*ncharline , TITFRICORIENT(*)
81 TYPE(INTBUF_FRIC_STRUCT_) INTBUF_FRIC_TAB(*)
82C-----------------------------------------------
83 TYPE (GROUP_) , DIMENSION(NGRPART) :: IGRPART
84 TYPE(SUBMODEL_DATA) LSUBMODEL(*)
85C-----------------------------------------------
86C L o c a l V a r i a b l e s
87C-----------------------------------------------
88 INTEGER NIF ,NIN ,ISK ,IERRR ,IREP ,NOINTFORTH ,IDSK ,
89 . FLAGP ,FLAGGRP ,GRPART ,IDPART ,N ,KK ,IDTGRS ,IPL ,J ,IP ,
90 . IPG ,SUB_ID ,NINPUT ,NL
91 my_real an ,vx ,vy ,vz ,phi
92 CHARACTER(LEN=NCHARTITLE) :: TITR
93 LOGICAL IS_AVAILABLE
94C
95C=======================================================================
96C READING /FRIC_ORIENT
97C=======================================================================
98 is_available = .false.
99C
100C--------------------------------------------------
101C WRITE TITLE IN OUT FILE
102C--------------------------------------------------
103
104 IF(iflag==1) WRITE(iout,1000)
105
106 npfricorth = 0
107
108C--------------------------------------------------
109C START BROWSING FRICTION ORIENTATIONS
110C--------------------------------------------------
111 CALL hm_option_start('/FRIC_ORIENT')
112C--------------------------------------------------
113C BROWSING FRICTION ORIENTATIONS MODELS 1->NFRIC_ORIENT
114C--------------------------------------------------
115 DO nin=1,nfric_orient
116c
117C--------------------------------------------------
118C EXTRACT DATAS OF /FRIC_ORIENT
119C--------------------------------------------------
120 CALL hm_option_read_key(lsubmodel,
121 . option_id = nointforth,
122 . submodel_id = sub_id,
123 . option_titr = titr)
124
125c KFRICORIENT = KFRICORIENT + 1
126
127C--Output ---
128
129 IF(iflag==1) THEN
130 WRITE(iout,1500) nointforth, trim(titr)
131 ENDIF
132
133
134C EXTRACT DATAS (INTEGER VALUES) : Number of connected parts as defined by user
135 CALL hm_get_intv('n_orient',ninput,is_available,lsubmodel)
136
137 DO nl=1,ninput
138
139C EXTRACT DATAS (INTEGER VALUES) :
140
141 CALL hm_get_int_array_index('grpart_ID1',grpart,nl,is_available,lsubmodel)
142 CALL hm_get_int_array_index('part_ID1',idpart,nl,is_available,lsubmodel)
143 CALL hm_get_int_array_index('skew_id',idsk,nl,is_available,lsubmodel)
144 CALL hm_get_int_array_index('iorth',irep,nl,is_available,lsubmodel)
145
146C EXTRACT DATAS (REAL VALUES) :
147
148 CALL hm_get_float_array_index('vx',vx,nl,is_available,lsubmodel,unitab)
149 CALL hm_get_float_array_index('vy',vy,nl,is_available,lsubmodel,unitab)
150 CALL hm_get_float_array_index('vz',vz,nl,is_available,lsubmodel,unitab)
151 CALL hm_get_float_array_index('phi',phi,nl,is_available,lsubmodel,unitab)
152C--------------------
153 IF (sub_id /= 0)
154 . CALL subrotvect(vx,vy,vz,rtrans,sub_id,lsubmodel)
155
156C
157C----CHECK PARTS
158C
159 flagp = 0
160 flaggrp = 0
161 IF(idpart/=0)THEN
162 DO n=1,npart
163 IF(idpart == ipart(4,n))THEN
164 flagp = 1
165 ip = n
166 EXIT
167 ENDIF
168 ENDDO
169
170 IF(flagp == 0)THEN
171 CALL ancmsg(msgid=1642,
172 . msgtype=msgerror,
173 . anmode=aninfo_blind_1,
174 . i1=nointforth,
175 . c1=titr,
176 . i2=idpart)
177
178 ENDIF
179 ENDIF
180C
181C----CHECK PARTS group
182C
183 IF(grpart/=0)THEN
184 flaggrp = 0
185 kk=ngrnod+
186 + ngrbric+ngrquad+ngrshel+ngrsh3n+ngrtrus+ngrbeam+ngrspri
187 DO n=1,ngrpart
188 IF (igrpart(n)%ID == grpart) THEN
189 idtgrs=n
190 flaggrp = 1
191 EXIT
192 END IF
193 END DO
194 IF(flaggrp == 0) THEN
195 CALL ancmsg(msgid=1642,
196 . msgtype=msgerror,
197 . anmode=aninfo_blind_1,
198 . i1=nointforth,
199 . c1=titr,
200 . i2=grpart)
201 ENDIF
202 ENDIF
203C
204C----CHECK Values
205C
206
207C Vect orhotrope
208
209 an=sqrt(vx*vx+vy*vy+vz*vz)
210 IF(an < em10)THEN
211 vx=one
212 vy=zero
213 vz=zero
214 ELSE
215 vx=vx/an
216 vy=vy/an
217 vz=vz/an
218 ENDIF
219
220 isk = 0
221 IF (idsk/=0) THEN
222 ierrr = 0
223 DO j=0,numskw+nsubmod
224 IF(idsk == iskn(4,j+1)) THEN
225 isk=j+1
226 ierrr = 1
227 EXIT
228 ENDIF
229 END DO
230 IF(ierrr == 0 ) THEN
231 CALL ancmsg(msgid=184,
232 . msgtype=msgerror,
233 . anmode=aninfo,
234 . c1='FRICTION ORIENTATION PART',
235 . i1=nointforth,
236 . c2='FRICTION ORIENTATION PART',
237 . c3=titr,
238 . i2=idsk)
239 ENDIF
240 ENDIF
241
242C
243C COUNTING AND STORAGE IN TEMPORARY TABLES
244C
245
246 IF(flagp > 0) THEN
247 ipg = tagprt_fric(ip)
248 IF(ipg > 0) THEN
249 DO nif =1,ninterfric
250 CALL friction_parts_search (
251 . ipg,intbuf_fric_tab(nif)%S_TABPARTS_FRIC,
252 . intbuf_fric_tab(nif)%TABPARTS_FRIC,ipl )
253 IF(ipl >0) THEN
254 npfricorth = npfricorth + 1
255 IF(iflag ==1 ) THEN
256 pfricorth(ip) = npfricorth
257 phiforth(npfricorth) = phi
258 irepforth(npfricorth) = irep
259 IF(isk == 0) THEN
260 vforth(1,npfricorth) = vx
261 vforth(2,npfricorth) = vy
262 vforth(3,npfricorth) = vz
263 ELSE
264 vforth(1,npfricorth) = skew(1,isk)
265 vforth(2,npfricorth) = skew(2,isk)
266 vforth(3,npfricorth) = skew(3,isk)
267 ENDIF
268 ENDIF
269 ENDIF
270 ENDDO
271 ENDIF
272
273 IF(iflag==1) THEN
274 WRITE(iout,1501) idpart
275 IF(isk==0) THEN
276 WRITE(iout,1503) irep,vx,vy,vz
277 ELSE
278 WRITE(iout,1504) irep,idsk
279 ENDIF
280 ENDIF
281 ENDIF
282
283 IF(flaggrp > 0) THEN
284 DO j=1,igrpart(idtgrs)%NENTITY
285 ip=igrpart(idtgrs)%ENTITY(j)
286 ipg = tagprt_fric(ip)
287 IF(ipg > 0) THEN
288 DO nif =1,ninterfric
289 CALL friction_parts_search (
290 . ipg,intbuf_fric_tab(nif)%S_TABPARTS_FRIC,
291 . intbuf_fric_tab(nif)%TABPARTS_FRIC,ipl )
292 IF(ipl > 0) THEN
293 npfricorth = npfricorth + 1
294 IF(iflag ==1 ) THEN
295 pfricorth(ip) = npfricorth
296 phiforth(npfricorth) = phi
297 irepforth(npfricorth) = irep
298 IF(isk == 0) THEN
299 vforth(1,npfricorth) = vx
300 vforth(2,npfricorth) = vy
301 vforth(3,npfricorth) = vz
302 ELSE
303 vforth(1,npfricorth) = skew(1,isk)
304 vforth(2,npfricorth) = skew(2,isk)
305 vforth(3,npfricorth) = skew(3,isk)
306 ENDIF
307 ENDIF
308 ENDIF
309 ENDDO
310 ENDIF
311 ENDDO
312 IF(iflag==1) THEN
313 WRITE(iout,1502) grpart
314 IF(isk==0) THEN
315 WRITE(iout,1503) irep,vx,vy,vz
316 ELSE
317 WRITE(iout,1504) irep,idsk
318 ENDIF
319 ENDIF
320 ENDIF
321C
322
323 ENDDO ! N=1,NLINE
324 ENDDO !NIN=1,NFRIC_ORIENT
325C
326C=======================================================================
327 RETURN
328C-----
329 1000 FORMAT( /1x,' FRICTION ORIENTATIONS ' /
330 . 1x,' -------------- '// )
331
332 1500 FORMAT(/1x,' FRICTION ORIENTATIONS CARD NUMBER :',i10,1x,a/
333 . 1x,' ------------------------------- '/)
334 1501 FORMAT(/
335 . ' PART . . . . . . . . . . . . . . . . . . ',i10)
336 1502 FORMAT(/
337 . ' GR_PART . . . . . . . . . . . . . . . . .',i10)
338 1503 FORMAT(
339 . ' LOCAL ORTOTHROPY SYSTEM FLAG. . . . . . =',i10/,
340 . ' X COMPONENT OF DIR 1 OF ORTHOTROPY. . . =',1pg20.13/,
341 . ' Y COMPONENT OF DIR 1 OF ORTHOTROPY. . . =',1pg20.13/,
342 . ' Z COMPONENT OF DIR 1 OF ORTHOTROPY. . . =',1pg20.13/)
343 1504 FORMAT(
344 . ' LOCAL ORTOTHROPY SYSTEM FLAG. . . . . . =',i10/,
345 . ' SKEW OF THE FIRST ORTHOTROPY DIRECTION. =',i10/)
346
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
friction_parts_search
subroutine friction_parts_search(ip, npartsfric, partsfric, ipl)
Definition i7sti3.F:1267
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:410
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
r2r_mod
Definition r2r_mod.F:125
submodel_mod
Definition submodel_mod.F:712
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:720
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
nl
character *2 function nl()
Definition message.F:2354
subrotvect
subroutine subrotvect(x, y, z, rtrans, sub_id, lsubmodel)
Definition subrot.F:54