OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_inter_type06.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_inter_type06 ../starter/source/interfaces/int06/hm_read_inter_type06.F
25!||--- called by ------------------------------------------------------
26!|| hm_read_inter_struct ../starter/source/interfaces/reader/hm_read_inter_struct.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| hm_get_floatv ../starter/source/devtools/hm_reader/hm_get_floatv.f
30!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
31!|| ngr2usr ../starter/source/system/nintrr.F
32!||--- uses -----------------------------------------------------
33!|| message_mod ../starter/share/message_module/message_mod.F
34!|| submodel_mod ../starter/share/modules1/submodel_mod.f
35!||====================================================================
36 SUBROUTINE hm_read_inter_type06(
37 1 IPARI ,STFAC ,FRIGAP ,NOINT ,
38 2 IGRSURF ,NPC1 ,TITR ,LSUBMODEL ,UNITAB )
39C============================================================================
40C
41C-----------------------------------------------
42C M o d u l e s
43C-----------------------------------------------
44 USE message_mod
45 USE groupdef_mod
46 USE submodel_mod
47 USE unitab_mod
48 USE names_and_titles_mod , ONLY : nchartitle, ncharkey, ncharfield
49C-----------------------------------------------
50C I m p l i c i t T y p e s
51C-----------------------------------------------
52#include "implicit_f.inc"
53C-----------------------------------------------
54C C o m m o n B l o c k s
55C-----------------------------------------------
56C-----------------------------------------------
57C D u m m y A r g u m e n t s
58C-----------------------------------------------
59 INTEGER ISU1,ISU2,NOINT
60 INTEGER IPARI(*),NPC1(*)
61 my_real
62 . stfac
63 my_real
64 . frigap(*)
65 CHARACTER(LEN=NCHARTITLE) :: TITR
66 TYPE(SUBMODEL_DATA),INTENT(IN)::LSUBMODEL(*)
67 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
68C-----------------------------------------------
69 TYPE (SURF_) ,TARGET , DIMENSION(NSURF) :: IGRSURF
70C-----------------------------------------------
71C C o m m o n B l o c k s
72C-----------------------------------------------
73#include "com04_c.inc"
74#include "units_c.inc"
75C-----------------------------------------------
76C L o c a l V a r i a b l e s
77C-----------------------------------------------
78 INTEGER J, NTYP,INACTI,IS1, IS2,ILEV,
79 . NDAMP1,NDAMP2,IRS,IRM,IFUN1,IFUN2,HFLAG,
80 . intkg, nfric1,nfric2,icor,ierr1,ierr2,ifric1,ifric2,
81 . idamp1,idamp2,igsti
82 my_real
83 . fac1,fac2,fac3,facf,facv,fric,gap,startt,stopt,sfric,
84 . visc,facx,stiff
85
86!
87 INTEGER, DIMENSION(:), POINTER :: INGR2USR
88 LOGICAL IS_AVAILABLE
89C-----------------------------------------------
90C E x t e r n a l F u n c t i o n s
91C-----------------------------------------------
92 INTEGER NGR2USR
93C=======================================================================
94C READING PENALTY INTERFACE /INTER/TYPE6
95C=======================================================================
96C Initializations
97 is1=0
98 is2=0
99 ifun1=0
100 ifun2=0
101 igsti = 0
102 inacti = 0
103 ilev = 0
104 intkg = 0
105C
106 fric = zero
107 gap = zero
108 startt = zero
109 stopt=ep30
110 visc = zero
111 facx = zero
112C
113 ntyp = 6
114 ipari(15)=noint
115 ipari(7)=ntyp
116C
117 is_available = .false.
118C--------------------------------------------------
119C EXTRACT DATAS (INTEGER VALUES)
120C--------------------------------------------------
121 CALL hm_get_intv('secondaryentityids',isu1,is_available,lsubmodel)
122 CALL hm_get_intv('mainentityids',isu2,is_available,lsubmodel)
123
124 CALL hm_get_intv('Gflag',irs,is_available,lsubmodel)
125 CALL hm_get_intv('Vflag',irm,is_available,lsubmodel)
126 CALL hm_get_intv('INACTIV',inacti,is_available,lsubmodel)
127 CALL hm_get_intv('Crx_Fun',nfric1,is_available,lsubmodel)
128 CALL hm_get_intv('Cry_Fun',nfric2,is_available,lsubmodel)
129
130 CALL hm_get_intv('FUN_A1',ifun1,is_available,lsubmodel)
131 CALL hm_get_intv('HFLAG1',hflag,is_available,lsubmodel)
132 CALL hm_get_intv('ISFLAG',icor,is_available,lsubmodel)
133
134 CALL hm_get_intv('FUNCT_ID',ifun2,is_available,lsubmodel)
135 CALL hm_get_intv('Crz_Fun',ndamp2,is_available,lsubmodel)
136 CALL hm_get_intv('Ctx_Fun',ndamp1,is_available,lsubmodel)
137C--------------------------------------------------
138C EXTRACT DATAS (REAL VALUES)
139C--------------------------------------------------
140 CALL hm_get_floatv('Friction_phi',sfric,is_available,lsubmodel,unitab)
141 CALL hm_get_floatv('FRIC',fric,is_available,lsubmodel,unitab)
142 CALL hm_get_floatv('GAP',gap,is_available,lsubmodel,unitab)
143 CALL hm_get_floatv('TSTART',startt,is_available,lsubmodel,unitab)
144 CALL hm_get_floatv('TSTOP',stopt,is_available,lsubmodel,unitab)
145
146 CALL hm_get_floatv('scale1',facf,is_available,lsubmodel,unitab)
147 CALL hm_get_floatv('scale2',facv,is_available,lsubmodel,unitab)
148
149 CALL hm_get_floatv('FACX',facx,is_available,lsubmodel,unitab)
150 CALL hm_get_floatv('FAC',fac1,is_available,lsubmodel,unitab)
151
152 CALL hm_get_floatv('STIFF1',stiff,is_available,lsubmodel,unitab)
153 CALL hm_get_floatv('PFscale',fac2,is_available,lsubmodel,unitab)
154 CALL hm_get_floatv('VISC',visc,is_available,lsubmodel,unitab)
155 CALL hm_get_floatv('scale3',fac3,is_available,lsubmodel,unitab)
156
157C....* CHECKS *.............
158
159 is1=1
160 is2=1
161 ingr2usr => igrsurf(1:nsurf)%ID
162 isu1=ngr2usr(isu1,ingr2usr,nsurf)
163 isu2=ngr2usr(isu2,ingr2usr,nsurf)
164
165C.......* Storage IPARI FRIGAP *........
166 ipari(45)=isu1
167 ipari(46)=isu2
168 ipari(13)=is1*10+is2
169 IF (stopt == zero) stopt = ep30
170
171C.....* Storage IPARI FRIGAP *.......
172 frigap(1)=fric
173 frigap(2)=gap
174 frigap(3)=startt
175 frigap(11)=stopt
176
177C....* CHECKS *.............
178
179 IF (hflag > 0 .AND. ifun2 == 0) hflag = 2
180 IF (hflag > 0 .AND. stiff == zero) hflag = 0
181 IF (hflag == 0 .AND. icor == 1) icor = 0
182 IF (facx == zero) facx = one
183 IF (fac1 == zero) fac1 = one
184 IF (fac2 == zero) fac2 = one
185 IF (fac3 == zero) fac3 = one
186 IF (facf == zero) facf = one
187 IF (facv == zero) facv = one
188 IF (stiff == zero) stiff = ep30
189 facx = one / facx
190 facf = one / facf
191 facv = one / facv
192C
193C.....* Storage IPARI FRIGAP *.......
194 stfac = fac1
195 IF (stfac == zero) stfac = one_fifth
196 ipari(11) = ifun1
197 ipari(22) = inacti
198 ipari(24) = irm
199 ipari(25) = irs
200 ipari(47) = hflag
201 ipari(49) = ifun2
202 ipari(51) = nfric1
203 ipari(52) = ndamp1
204 ipari(53) = ndamp2
205 ipari(54) = nfric2
206 ipari(58) = icor
207 ipari(20) = ilev
208 ipari(65) = intkg
209 frigap(5) = sfric
210 frigap(19) = facx
211 frigap(20) = fac2
212 frigap(21) = stiff
213 frigap(22) = facf
214 frigap(23) = facv
215 frigap(24) = fac3
216 frigap(14)=visc
217C
218C------------------------------------------------------------
219C RENUMBERING OF FUNCTIONS - USER TO INTERNAL ID
220C------------------------------------------------------------
221 ierr1 = 1
222 DO j=1,nfunct
223 IF (ipari(11) == npc1(j)) THEN
224 ipari(11)=j
225 ierr1 = 0
226 EXIT
227 ENDIF
228 ENDDO
229 IF (ierr1 == 1) THEN
230 CALL ancmsg(msgid=121,
231 . msgtype=msgerror,
232 . anmode=aninfo_blind_1,
233 . i1=noint,
234 . c1=titr,
235 . i2=ipari(11))
236 ENDIF
237c
238 IF (ipari(47) > 0 .AND. ipari(49) /= 0) THEN
239 ierr2 = 1
240 DO j=1,nfunct
241 IF(ipari(49) == npc1(j)) THEN
242 ipari(49)=j
243 ierr2 = 0
244 EXIT
245 ENDIF
246 ENDDO
247 IF (ierr2 == 1) THEN
248 CALL ancmsg(msgid=121,
249 . msgtype=msgerror,
250 . anmode=aninfo_blind_1,
251 . i1=noint,
252 . c1=titr,
253 . i2=ipari(49))
254 ENDIF
255 ENDIF
256c
257 ifric1 = ipari(51)
258 IF (ifric1 /= 0) THEN ! friction coefficient = f(Fn)
259 ierr1 = 1
260 DO j=1,nfunct
261 IF (ifric1 == npc1(j)) THEN
262 ipari(51) = j
263 ierr1 = 0
264 EXIT
265 ENDIF
266 ENDDO
267 IF (ierr1 == 1) CALL ancmsg(msgid=113,
268 . msgtype=msgerror,
269 . anmode=aninfo,
270 . i1=noint,
271 . c1=titr,
272 . i2=ifric1)
273 ENDIF
274c
275 idamp1 = ipari(52)
276 IF (idamp1 /= 0) THEN ! damping coefficient = f(Fn)
277 ierr1 = 1
278 DO j=1,nfunct
279 IF (idamp1 == npc1(j)) THEN
280 ipari(52) = j
281 ierr1 = 0
282 EXIT
283 ENDIF
284 ENDDO
285 IF (ierr1 == 1) CALL ancmsg(msgid=113,
286 . msgtype=msgerror,
287 . anmode=aninfo,
288 . i1=noint,
289 . c1=titr,
290 . i2=idamp1)
291 ENDIF
292c
293 idamp2 = ipari(53)
294 IF (idamp2 /= 0) THEN ! damping coefficient = f(Vn)
295 ierr1 = 1
296 DO j=1,nfunct
297 IF (idamp2 == npc1(j)) THEN
298 ipari(53) = j
299 ierr1 = 0
300 EXIT
301 ENDIF
302 ENDDO
303 IF (ierr1 == 1) CALL ancmsg(msgid=113,
304 . msgtype=msgerror,
305 . anmode=aninfo,
306 . i1=noint,
307 . c1=titr,
308 . i2=idamp2)
309 ENDIF
310c
311 ifric2 = ipari(54)
312 IF (ifric2 /= 0) THEN ! friction coefficient = f(Vn)
313 ierr1 = 1
314 DO j=1,nfunct
315 IF (ifric2 == npc1(j)) THEN
316 ipari(54) = j
317 ierr1 = 0
318 EXIT
319 ENDIF
320 ENDDO
321 IF (ierr1 == 1) CALL ancmsg(msgid=113,
322 . msgtype=msgerror,
323 . anmode=aninfo,
324 . i1=noint,
325 . c1=titr,
326 . i2=ifric2)
327 ENDIF
328C
329C------------------------------------------------------------
330C PRINTOUT
331C------------------------------------------------------------
332 WRITE(iout,1506) hflag,icor,ifun1,ifun2,facx,stfac,fac2,
333 . stiff,sfric,fric,nfric1,nfric2,visc,
334 . ndamp2,ndamp1,inacti,gap,startt,stopt,irs,irm
335C--------------------------------------------------------------
336 IF(is1==0)THEN
337 WRITE(iout,'(6X,A)')'NO SECONDARY SURFACE INPUT'
338 ELSEIF(is1==1)THEN
339 WRITE(iout,'(6X,A)')'SECONDARY SURFACE INPUT BY SEGMENTS'
340 ELSEIF(is1==2)THEN
341 WRITE(iout,'(6X,A)')'SECONDARY SURFACE INPUT BY NODES'
342 ELSEIF(is1==3)THEN
343 WRITE(iout,'(6X,A)')'SECONDARY SURFACE INPUT BY SEGMENTS'
344 ELSEIF(is1==4 )THEN
345 WRITE(iout,'(6X,A)')'SECONDARY SIDE INPUT BY BRICKS'
346 ELSEIF(is1==5 )THEN
347 WRITE(iout,'(6X,A)')'SECONDARY SIDE INPUT BY SOLID ELEMENTS'
348 ENDIF
349 IF(is2==0)THEN
350 WRITE(iout,'(6X,A)')'NO MAIN SURFACE INPUT'
351 ELSEIF(is2==1)THEN
352 WRITE(iout,'(6X,A)')'MAIN SURFACE INPUT BY SEGMENTS'
353 ELSEIF(is2==2)THEN
354 WRITE(iout,'(6X,A)')'MAIN SURFACE INPUT BY NODES'
355 ELSEIF(is2==3)THEN
356 WRITE(iout,'(6X,A)')'MAIN SURFACE INPUT BY SEGMENTS'
357 ELSEIF(is2==4)THEN
358 WRITE(iout,'(6X,A)')'MAIN SURFACE REFERS ',
359 . 'TO HYPER-ELLIPSOIDAL SURFACE'
360 ENDIF
361C
362C--------------------------------------------------------------
363C------------
364 RETURN
365
366 1506 FORMAT(//
367 . ' TYPE==6 RIGID BODY INTERFACE ' //,
368 . ' FORMULATION FLAG . . . . ',i10/,
369 . ' INITIAL PENETRATION FLAG . . . . ',i10/,
370 . ' LOADING FUNCTION ID . . . . ',i10/,
371 . ' UNLOADING FUNCTION ID . . . . ',i10/,
372 . ' ABSCISSA (DISPLACEMENT) SCALE FACTOR. . . ',1pg20.13/,
373 . ' LOAD FUNCTION SCALE FACTOR . . . . . . . ',1pg20.13/,
374 . ' UNLOAD FUNCTION SCALE FACTOR . . . . . . ',1pg20.13/,
375 . ' ELASTIC MODULUS . . . . . . . . . . . . . ',1pg20.13/,
376 . ' STATIC FRICTION FORCE . . . . . . . . . . ',1pg20.13/,
377 . ' FRICTION FACTOR . . . . . . . . . . . . . ',1pg20.13/,
378 . ' FRICTION FUNCTION OF NORMAL FORCE . . . . .',i10/,
379 . ' FRICTION FUNCTION OF SLIP VELOCITY. . . . .',i10/,
380 . ' DAMPING COEFFICIENT . . . . . . . . . . . ',1pg20.13/,
381 . ' DAMPING AMPLIFIER FUNCTION VS NORMAL FORCE.',i10/,
382 . ' DAMPING FORCE FUNCTION VS VELOCITY. . . . .',i10/,
383 . ' DE-ACTIVATION OF INITIAL PENETRATIONS . . .',i10/,
384 . ' INITIAL GAP . . . . . . . . . . . . . . . ',1pg20.13/,
385 . ' START TIME. . . . . . . . . . . . . . . . ',1pg20.13/,
386 . ' STOP TIME . . . . . . . . . . . . . . . . ',1pg20.13/,
387 . ' SECONDARY SURFACE REORDERING FLAG . . . . . . ',i1/,
388 . ' MAIN SURFACE REORDERING FLAG. . . . . . ',i1/)
389 END
my_real
#define my_real
Definition cppsort.cpp:32
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_read_inter_type06
subroutine hm_read_inter_type06(ipari, stfac, frigap, noint, igrsurf, npc1, titr, lsubmodel, unitab)
Definition hm_read_inter_type06.F:39
groupdef_mod
Definition groupdef_mod.F:668
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
names_and_titles_mod::ncharfield
integer, parameter ncharfield
Definition names_and_titles_mod.F:1010
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
starter
program starter
Definition starter.F:39