OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_prop32.F File Reference
#include "implicit_f.inc"
#include "tablen_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_prop32 (iout, nuvar, pargeo, unitab, ig, igtyp, prop_tag, titr, lsubmodel)
subroutine rini32 (nel, iout, iprop, ix, xl, mass, xiner, stifm, stifr, viscm, viscr, uvar, nuvar, id, titr, eint, npf, tf)
subroutine area (d1, x, x2, y, y2, eint, stif0)

Function/Subroutine Documentation

◆ area()

subroutine area ( d1,
x,
x2,
y,
y2,
eint,
stif0 )

Definition at line 566 of file hm_read_prop32.F.

567 USE message_mod
568C-------------------------------------------------------------------------
569C This subroutine compute the area under the curve (X,Y=F(X));(X2,Y2=F(X2)).
570C-------------------------------------------------------------------------
571C----------------------------------------------------------
572C D u m m y A r g u m e n t s a n d F u n c t i o n
573C----------------------------------------------------------
574 my_real
575 . d1,x,x2,y,y2,eint,stif0
576C-----------------------------------------------
577C L o c a l V a r i a b l e s
578C-----------------------------------------------
579 my_real
580 . x0,fd1
581C=======================================================================
582C Only positive area computed and if X <= D1 (spring length)
583 IF (d1>=x2)THEN
584 ELSEIF (d1>=x) THEN
585 fd1 = y+(y2-y)/(x2-x)*(d1-x)
586 IF (y<0.AND.y2>0) THEN
587 x0 = x-y*(x2-x)/(y2-y)
588 IF (d1<=x0) THEN
589 eint = eint + (x2-x0)*y2/2
590 ELSE
591 eint = eint + (x2-d1)*fd1+(x2-d1)*(y2-fd1)/2
592 eint = eint + (fd1/stif0)*fd1/2
593 ENDIF
594 ELSEIF (y>=0.AND.y2>0) THEN
595 eint = eint + (x2-d1)*fd1+(x2-d1)*(y2-fd1)/2
596 eint = eint + (fd1/stif0)*fd1/2
597 ENDIF
598 ELSEIF (y>=0.AND.y2>0) THEN
599 eint = eint + (x2-x)*y+(x2-x)*(y2-y)/2
600 ENDIF
601 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
message_mod
Definition message_mod.F:1249

◆ hm_read_prop32()

subroutine hm_read_prop32 ( integer iout,
integer nuvar,
pargeo,
type (unit_type_), intent(in) unitab,
integer ig,
integer igtyp,
type(prop_tag_), dimension(0:maxprop) prop_tag,
character(len=nchartitle) titr,
type(submodel_data), dimension(*), intent(in) lsubmodel )

Definition at line 40 of file hm_read_prop32.F.

42C-----------------------------------------------
43 USE unitab_mod
44 USE message_mod
45 USE elbuftag_mod
46 USE submodel_mod
47 USE names_and_titles_mod , ONLY : nchartitle
48C-----------------------------------------------
49C I m p l i c i t T y p e s
50C-----------------------------------------------
51#include "implicit_f.inc"
52C-----------------------------------------------
53C C o m m o n B l o c k s
54C-----------------------------------------------
55#include "tablen_c.inc"
56C-----------------------------------------------
57C A n a l y s e M o d u l e
58C-----------------------------------------------
59C----------+---------+---+---+--------------------------------------------
60C VAR | SIZE |TYP| RW| DEFINITION
61C----------+---------+---+---+--------------------------------------------
62C IIN | 1 | I | R | INPUT FILE UNIT (D00 file)
63C IOUT | 1 | I | R | OUTPUT FILE UNIT (L00 file)
64C NUVAR | 1 | I | W | NUMBER OF USER ELEMENT VARIABLES
65C----------+---------+---+---+--------------------------------------------
66C PARGEO | * | F | W | 1)SKEW NUMBER
67C | | | | 2)STIFNESS FOR INTERFACE
68C | | | | 3)FRONT WAVE OPTION
69C | | | | 4)... not yet used
70C----------+---------+---+---+--------------------------------------------
71C
72C This subroutine read the user geometry parameters.
73C
74C The geometry datas has to bee stored in radioss storage
75C with the function SET_U_GEO(value_index,value).
76C
77C If some standard radioss functions (time function or
78C x,y function) are used, this function IDs has to
79C bee stored with the function SET_U_PNU(func_index,func_id,KFUNC).
80C
81C If this property refers to a user material, this
82C material IDs has to bee stored with the function
83C SET_U_PNU(mat_index,mat_id,KMAT).
84C
85C If this property refers to a user property, this
86C sub-property IDs has to bee stored with the function
87C SET_U_PNU(sub_prop_index,sub_prop_id,KMAT).
88C
89C SET_U_GEO and SET_U_PNU return 0 if no error
90C SET_U_GEO and SET_U_PNU return the maximum allowed index
91C if index is larger than this maximum
92C-----------------------------------------------
93C D u m m y A r g u m e n t s
94C-----------------------------------------------
95 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
96 INTEGER IOUT,NUVAR,IGTYP
97 my_real pargeo(*)
98 INTEGER SET_U_PNU,SET_U_GEO,KFUNC
99 EXTERNAL set_u_pnu,set_u_geo
100 parameter(kfunc=29)
101 INTEGER IG
102 CHARACTER(LEN=NCHARTITLE) :: TITR
103 TYPE(PROP_TAG_) , DIMENSION(0:MAXPROP) :: PROP_TAG
104 TYPE(SUBMODEL_DATA),INTENT(IN)::LSUBMODEL(*)
105C=======================================================================
106C-----------------------------------------------
107C L o c a l V a r i a b l e s
108C-----------------------------------------------
109 INTEGER IFUNC1,IFUNC2,ISENS,IERROR,ITYP,ILOCK
110 my_real
111 . amas,aa,stif00,stif0,stif1,e1,f1,d1,tscal,dscal,fscal,
112 . t_unit,l_unit,f_unit
113 LOGICAL IS_AVAILABLE, IS_ENCRYPTED
114C=======================================================================
115C
116 is_encrypted = .false.
117 is_available = .false.
118C--------------------------------------------------
119C EXTRACT DATA (IS OPTION CRYPTED)
120C--------------------------------------------------
121 CALL hm_option_is_encrypted(is_encrypted)
122C--------------------------------------------------
123C EXTRACT DATAS (INTEGER VALUES)
124C--------------------------------------------------
125 CALL hm_get_intv('ISENSOR',isens,is_available,lsubmodel)
126 CALL hm_get_intv('ILock',ilock,is_available,lsubmodel)
127 CALL hm_get_intv('FUN_A1',ifunc1,is_available,lsubmodel)
128 CALL hm_get_intv('FUN_B1',ifunc2,is_available,lsubmodel)
129C--------------------------------------------------
130C EXTRACT DATAS (REAL VALUES)
131C--------------------------------------------------
132 CALL hm_get_floatv('MASS',amas,is_available,lsubmodel,unitab)
133 CALL hm_get_floatv('STIFF0',stif0,is_available,lsubmodel,unitab)
134 CALL hm_get_floatv('STIFF1',stif1,is_available,lsubmodel,unitab)
135 CALL hm_get_floatv('SPR_PRE_F1',f1,is_available,lsubmodel,unitab)
136 CALL hm_get_floatv('SPR_PRE_D1',d1,is_available,lsubmodel,unitab)
137 CALL hm_get_floatv('SPR_PRE_E1',e1,is_available,lsubmodel,unitab)
138 CALL hm_get_floatv('Scale_t',tscal,is_available,lsubmodel,unitab)
139 CALL hm_get_floatv('Scale_d',dscal,is_available,lsubmodel,unitab)
140 CALL hm_get_floatv('Scale_f',fscal,is_available,lsubmodel,unitab)
141C
142 CALL hm_get_floatv_dim('Scale_t',t_unit,is_available,lsubmodel,unitab)
143 CALL hm_get_floatv_dim('Scale_d',l_unit,is_available,lsubmodel,unitab)
144 CALL hm_get_floatv_dim('Scale_f',f_unit,is_available,lsubmodel,unitab)
145C
146C----------------------
147C
148 IF(.NOT. is_encrypted)THEN
149 WRITE(iout,1400) ig
150 ELSE
151 WRITE(iout,1500) ig
152 ENDIF
153C
154 nuvar = 4
155C
156 IF (tscal == zero) tscal = one * t_unit
157 IF (dscal == zero) dscal = one * l_unit
158 IF (fscal == zero) fscal = one * f_unit
159C
160 d1 = -abs(d1)
161 stif00=em20
162 IF(ifunc1/=0.AND.ifunc2/=0)THEN
163 ityp=4
164 ELSEIF(ifunc2/=0)THEN
165 ityp=3
166 ELSEIF(ifunc1/=0)THEN
167 ityp=2
168 ELSE
169 ityp=1
170 IF(f1/=0..AND.d1/=0.)THEN
171 IF(e1/=0..OR.stif1/=0.)THEN
172 CALL ancmsg(msgid=408,
173 . msgtype=msgerror,
174 . anmode=aninfo_blind_2,
175 . i1=ig,
176 . c1=titr)
177 ENDIF
178 ELSEIF(f1/=0..AND.e1/=0.)THEN
179 IF(stif1/=0.)THEN
180 CALL ancmsg(msgid=408,
181 . msgtype=msgerror,
182 . anmode=aninfo_blind_2,
183 . i1=ig,
184 . c1=titr)
185 ENDIF
186 ELSEIF(d1/=0..AND.e1/=0.)THEN
187 IF(stif1/=0.)THEN
188 CALL ancmsg(msgid=408,
189 . msgtype=msgerror,
190 . anmode=aninfo_blind_2,
191 . i1=ig,
192 . c1=titr)
193 ENDIF
194 ENDIF
195 IF(f1/=zero)THEN
196 IF(d1/=zero)THEN
197 stif1=-f1/d1
198 ELSEIF(e1/=zero)THEN
199 stif1=half*f1*f1/e1
200 ELSEIF(stif1==zero)THEN
201 stif1=stif00
202 ENDIF
203 d1=-f1/stif1
204 e1=-half*f1*d1
205 ELSEIF(d1/=zero)THEN
206 IF(e1/=zero)THEN
207 stif1=two*e1/d1/d1
208 ELSEIF(stif1==zero)THEN
209 stif1=stif00
210 ENDIF
211 f1=-stif1*d1
212 e1=-half*f1*d1
213 ELSEIF(e1/=zero)THEN
214 IF(stif1==zero)THEN
215 stif1=stif00
216 ENDIF
217 f1=sqrt(two*e1*stif1)
218 d1=-f1/stif1
219 ELSE
220 IF(stif1==zero)THEN
221 stif1=stif00
222 ENDIF
223 f1=zero
224 e1=zero
225 d1=zero
226 ENDIF
227 ENDIF
228 IF(stif1==zero)stif1=stif0
229 aa = isens
230 ierror = set_u_geo(5,aa)
231 aa = ityp
232 ierror = set_u_geo(6,aa)
233 aa = ilock
234 ierror = set_u_geo(10,aa)
235C
236 pargeo(1) = 0
237 pargeo(2) = stif0+stif1
238C
239 IF(.NOT. is_encrypted)THEN
240 IF(ityp==1)THEN
241 WRITE(iout,1001)amas,stif0,isens,ilock,f1,d1,e1,stif1
242 ELSEIF(ityp==2)THEN
243 WRITE(iout,1002)amas,stif0,isens,ilock,ifunc1,dscal
244 ELSEIF(ityp==3)THEN
245 WRITE(iout,1003)amas,stif0,isens,ilock,ifunc2,tscal
246 ELSEIF(ityp==4)THEN
247 WRITE(iout,1004)amas,stif0,isens,ilock,ifunc1,dscal,ifunc2,tscal
248 ENDIF
249 ENDIF
250C
251 ierror = set_u_geo(1,amas)
252 ierror = set_u_geo(2,stif0)
253 ierror = set_u_geo(3,stif1)
254 ierror = set_u_geo(4,f1)
255 ierror = set_u_pnu(1,ifunc1,kfunc)
256 ierror = set_u_pnu(2,ifunc2,kfunc)
257 ierror = set_u_geo(7,one/tscal)
258 ierror = set_u_geo(8,one/dscal)
259 ierror = set_u_geo(9,fscal)
260 ierror = set_u_geo(11,d1)
261C
262C-----------------------------
263C PROPERTY BUFFER
264C-----------------------------
265C
266 prop_tag(igtyp)%G_FOR = 3
267 prop_tag(igtyp)%G_MOM = 3
268 prop_tag(igtyp)%G_SKEW = 3
269 prop_tag(igtyp)%G_SKEW_ERR = 3
270 prop_tag(igtyp)%G_MASS = 1
271 prop_tag(igtyp)%G_V_REPCVT = 3 ! -- VITESSES REPERE CONVECTEE (V_REPCVT)
272 prop_tag(igtyp)%G_VR_REPCVT = 3 ! -- VITESSES REPERE CONVECTEE (VR_REPCVT)
273 prop_tag(igtyp)%G_NUVAR = nuvar
274C
275 RETURN
276 CALL ancmsg(msgid=401,
277 . msgtype=msgerror,
278 . anmode=aninfo,
279 . i1=ig,
280 . c2=titr,
281 . c1='USER 32')
282 RETURN
283 1001 FORMAT(
284 & 5x,'LINEAR PRETENSION SPRING',/,
285 & 5x,'MASS. . . . . . . . . . . . . . . . . .=',1pg20.13/,
286 & 5x,'STIFFNESS BEFORE SENSOR ACTIVATION. . .=',1pg20.13/,
287 & 5x,'ACTIVATION SENSOR ID. . . . . . . . . .=',i10/,
288 & 5x,'FLAG FOR LOCK FEATURE ACTIVATION. . . .=',i10/,
289 & 5x,'FORCE AFTER SENSOR ACTIVATION . . . . .=',1pg20.13/,
290 & 5x,'MAX RETRACTION AFTER SENSOR ACTIVATION.=',1pg20.13/,
291 & 5x,'INITIAL ENERGY AFTER SENSOR ACTIVATION.=',1pg20.13/,
292 & 5x,'STIFFNESS AFTER SENSOR ACTIVATION . . .=',1pg20.13//)
293 1002 FORMAT(
294 & 5x,'NON LINEAR PRETENSION SPRING',/,
295 & 5x,'----------------------------',/,
296 & 5x,' DISPLACEMENT DEPENDING F=f(x-x0)',/,
297 & 5x,'MASS. . . . . . . . . . . . . . . . . .=',1pg20.13/,
298 & 5x,'STIFFNESS BEFORE SENSOR ACTIVATION. . .=',1pg20.13/,
299 & 5x,'ACTIVATION SENSOR ID. . . . . . . . . .=',i10/,
300 & 5x,'FLAG FOR LOCK FEATURE ACTIVATION. . . .=',i10/,
301 & 5x,'FORCE SCALE VERSUS DISP. FUNCTION ID. .=',i10/,
302 & 5x,'ABSCISSA SCALE FACTOR ON CURVE. . . . .=',1pg20.13//)
303 1003 FORMAT(
304 & 5x,'NON LINEAR PRETENSION SPRING',/,
305 & 5x,'----------------------------',/,
306 & 5x,' TIME DEPENDING F=f(t-t0)',/,
307 & 5x,'MASS. . . . . . . . . . . . . . . . . .=',1pg20.13/,
308 & 5x,'STIFFNESS BEFORE SENSOR ACTIVATION. . .=',1pg20.13/,
309 & 5x,'ACTIVATION SENSOR ID. . . . . . . . . .=',i10/,
310 & 5x,'LOCK FEATURE. . . . . . . . . . . . . .=',i10/,
311 & 5x,'FORCE SCALE VERSUS TIME FUNCTION ID . .=',i10/,
312 & 5x,'ABSCISSA SCALE FACTOR ON CURVE. . . . .=',1pg20.13//)
313 1004 FORMAT(
314 & 5x,'NON LINEAR PRETENSION SPRING',/,
315 & 5x,'----------------------------',/,
316 & 5x,' DISPLACEMENT AND TIME DEPENDING F=g(t-t0)*f(x-x0)',/,
317 & 5x,'MASS. . . . . . . . . . . . . . . . . .=',1pg20.13/,
318 & 5x,'STIFFNESS BEFORE SENSOR ACTIVATION. . .=',1pg20.13/,
319 & 5x,'ACTIVATION SENSOR ID. . . . . . . . . .=',i10/,
320 & 5x,'FLAG FOR LOCK FEATURE ACTIVATION. . . .=',i10/,
321 & 5x,'FORCE SCALE VERSUS DISP. FUNCTION ID. .=',i10/,
322 & 5x,'ABSCISSA SCALE FACTOR ON CURVE. . . . .=',1pg20.13/,
323 & 5x,'FORCE SCALE VERSUS TIME FUNCTION ID . .=',i10/,
324 & 5x,'ABSCISSA SCALE FACTOR ON CURVE. . . . .=',1pg20.13//)
325C
326 1400 FORMAT(
327 & 5x,'USER PROPERTY SET'/,
328 & 5x,'PROPERTY SET NUMBER . . . . . . . . . .=',i10)
329C
330 1500 FORMAT(
331 & 5x,'USER PROPERTY SET'/,
332 & 5x,'PROPERTY SET NUMBER . . . . . . . . . .=',i10,
333 & 5x,'CONFIDENTIAL DATA'//)
334C
dscal
subroutine dscal(n, da, dx, incx)
DSCAL
Definition dscal.f:79
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_is_encrypted
subroutine hm_option_is_encrypted(is_encrypted)
Definition hm_option_is_encrypted.F:284
elbuftag_mod
Definition elbuftag_mod.F:227
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
set_u_pnu
integer function set_u_pnu(ivar, ip, k)
Definition uaccess.F:127
set_u_geo
integer function set_u_geo(ivar, a)
Definition uaccess.F:64

◆ rini32()

subroutine rini32 ( integer nel,
integer iout,
integer iprop,
integer, dimension(4,nel) ix,
xl,
mass,
xiner,
stifm,
stifr,
viscm,
viscr,
uvar,
integer nuvar,
integer id,
character(len=nchartitle) titr,
eint,
integer, dimension(*) npf,
tf )

Definition at line 352 of file hm_read_prop32.F.

356 USE message_mod
357 USE names_and_titles_mod , ONLY : nchartitle
358C-------------------------------------------------------------------------
359C This subroutine initialize springs using user properties.
360C-------------------------------------------------------------------------
361C----------+---------+---+---+--------------------------------------------
362C VAR | SIZE |TYP| RW| DEFINITION
363C----------+---------+---+---+--------------------------------------------
364C IOUT | 1 | I | R | OUTPUT FILE UNIT (L00 file)
365C IPROP | 1 | I | R | PROPERTY NUMBER
366C----------+---------+---+---+--------------------------------------------
367C IX | 3*NEL | I | R | SPRING CONNECTIVITY
368C | IX(1,I) NODE 1 ID
369C | IX(2,I) NODE 2 ID
370C | IX(3,I) OPTIONAL NODE 3 ID
371C | IX(4,I) SPRING ID
372C XL | NEL | F | R | ELEMENT LENGTH
373C----------+---------+---+---+--------------------------------------------
374C MASS | NEL | F | W | ELEMENT MASS
375C XINER | NEL | F | W | ELEMENT INERTIA (SPHERICAL)
376C STIFM | NEL | F | W | ELEMENT STIFNESS (TIME STEP)
377C STIFR | NEL | F | W | ELEMENT ROTATION STIFNESS (TIME STEP)
378C VISCM | NEL | F | W | ELEMENT VISCOSITY (TIME STEP)
379C VISCR | NEL | F | W | ELEMENT ROTATION VISCOSITY (TIME STEP)
380C----------+---------+---+---+--------------------------------------------
381C UVAR |NUVAR*NEL| F | W | USER ELEMENT VARIABLES
382C NUVAR | 1 | I | R | NUMBER OF USER ELEMENT VARIABLES
383C----------+---------+---+---+--------------------------------------------
384C-------------------------------------------------------------------------
385C FUNCTION
386C-------------------------------------------------------------------------
387C INTEGER II = GET_U_PNU(I,IP,KK)
388C IFUNCI = GET_U_PNU(I,IP,KFUNC)
389C IPROPI = GET_U_PNU(I,IP,KPROP)
390C IMATI = GET_U_PNU(I,IP,KMAT)
391C I : VARIABLE INDEX(1 for first variable,...)
392C IP : PROPERTY NUMBER
393C KK : PARAMETER KFUNC,KMAT,KPROP
394C THIS FUNCTION RETURN THE USER STORED FUNCTION(IF KK=KFUNC),
395C MATERIAL(IF KK=KMAT) OR PROPERTY(IF KK=KPROP) NUMBERS.
396C SEE LECG29 FOR CORRESPONDING ID STORAGE.
397C-------------------------------------------------------------------------
398C INTEGER IFUNCI = GET_U_MNU(I,IM,KFUNC)
399C I : VARIABLE INDEX(1 for first function)
400C IM : MATERIAL NUMBER
401C KFUNC : ONLY FUNCTION ARE YET AVAILABLE.
402C THIS FUNCTION RETURN THE USER STORED FUNCTION NUMBERS(function
403C referred by users materials).
404C SEE LECM29 FOR CORRESPONDING ID STORAGE.
405C-------------------------------------------------------------------------
406C my_real PARAMI = GET_U_GEO(I,IP)
407C I : PARAMETER INDEX(1 for first parameter,...)
408C IP : PROPERTY NUMBER
409C THIS FUNCTION RETURN THE USER GEOMETRY PARAMETERS
410C-------------------------------------------------------------------------
411C my_real PARAMI = GET_U_MAT(I,IM)
412C I : PARAMETER INDEX(1 for first parameter,...)
413C IM : MATERIAL NUMBER
414C THIS FUNCTION RETURN THE USER MATERIAL PARAMETERS
415C NOTE: GET_U_MAT(0,IMAT) RETURN THE DENSITY
416C-------------------------------------------------------------------------
417C INTEGER MID = GET_U_PID(IP)
418C IP : PROPERTY NUMBER
419C THIS FUNCTION RETURN THE USER PROPERTY ID CORRESPONDING TO
420C USER PROPERTY NUMBER IP.
421C-------------------------------------------------------------------------
422C INTEGER PID = GET_U_MID(IM)
423C IM : MATERIAL NUMBER
424C THIS FUNCTION RETURN THE USER MATERIAL ID CORRESPONDING TO
425C USER MATERIAL NUMBER IM.
426C-------------------------------------------------------------------------
427C-----------------------------------------------
428C I m p l i c i t T y p e s
429C-----------------------------------------------
430#include "implicit_f.inc"
431C----------------------------------------------------------
432C D u m m y A r g u m e n t s a n d F u n c t i o n
433C----------------------------------------------------------
434 INTEGER IOUT,NUVAR,NEL,IPROP,
435 . IX(4,NEL),NPF(*),KFUNC,
436 . GET_U_PNU,GET_U_PID,GET_U_MID,GET_U_MNU
437 my_real
438 . xl(nel) ,mass(nel) ,xiner(nel) ,stifm(nel) ,
439 . stifr(nel),viscm(nel) ,viscr(nel),uvar(nuvar,*),
440 . get_u_mat,get_u_geo,eint(*),tf(*)
441C-----------------------------------------------
442 EXTERNAL get_u_pnu,get_u_mnu,get_u_mat,get_u_geo,get_u_pid,
443 . get_u_mid
444 parameter(kfunc=29)
445 INTEGER ID
446 CHARACTER(LEN=NCHARTITLE) :: TITR
447C-----------------------------------------------
448C L o c a l V a r i a b l e s
449C-----------------------------------------------
450 my_real
451 . amas,stif0,stif1,f1,tscal,dscal,fscal,
452 . d1,x,y,x2,y2,x3,y3,f0
453 INTEGER I , J, ITYP, IFUNC1, IFUNC2, NPOINT
454C=======================================================================
455 amas = get_u_geo(1,iprop)
456 stif0 = get_u_geo(2,iprop)
457 stif1 = get_u_geo(3,iprop)
458 f1 = get_u_geo(4,iprop)
459 ityp = get_u_geo(6,iprop)
460 tscal = get_u_geo(7,iprop)
461 dscal = get_u_geo(8,iprop)
462 fscal = get_u_geo(9,iprop)
463 d1 = get_u_geo(11,iprop)
464C
465C MEAN VALUES
466C
467C--------------------------------------
468C ELEMENT CHECK
469C--------------------------------------
470 DO i=1,nel
471 IF(xl(i)==0.0)THEN
472 CALL ancmsg(msgid=406,
473 . msgtype=msgerror,
474 . anmode=aninfo_blind_1,
475 . i1=id,
476 . c1=titr,
477 . i2=ix(4,i))
478 ENDIF
479 ENDDO
480C--------------------------------------
481C ELEMENT INITIALIZATION
482C--------------------------------------
483 DO i=1,nel
484C Compute initial internal energy
485 eint(i) = 0
486 IF (ityp == 1) THEN
487C Linear case
488 IF (d1==0) THEN
489 eint(i) = eint(i) + (f1/stif0)*f1/2
490 ELSE
491 eint(i) = eint(i) + abs(d1*f1)/2
492 ENDIF
493 ELSEIF (ityp == 2) THEN
494C Non linear case with only space IFUNC1 defined
495 ifunc1 = get_u_pnu(1,iprop,kfunc)
496 npoint=(npf(ifunc1+1)-npf(ifunc1))/2
497 x2=dscal*tf(npf(ifunc1)+2*0+0)
498 y2=fscal*tf(npf(ifunc1)+2*0+1)
499 x3=dscal*tf(npf(ifunc1)+2*0+2)
500 y3=fscal*tf(npf(ifunc1)+2*0+3)
501 IF (d1==0.AND.y2<=0) d1=-1e30
502 IF (d1>0.AND.y2>0.AND.x2>d1) THEN
503 y=y2+(y3-y2)/(x3-x2)*(d1-x2)
504 x=d1
505 CALL area(d1,x,x2,y,y2,eint(i),stif0)
506 ENDIF
507 DO j=0,npoint-2
508 x=dscal*tf(npf(ifunc1)+2*j)
509 y=fscal*tf(npf(ifunc1)+2*j+1)
510 x2=dscal*tf(npf(ifunc1)+2*j+2)
511 y2=fscal*tf(npf(ifunc1)+2*j+3)
512 IF (x<0) CALL area(d1,x,x2,y,y2,eint(i),stif0)
513 ENDDO
514 ELSEIF (ityp == 3) THEN
515C Non linear case with only time IFUNC2 defined
516C Warning: initial internal energy computed with STIF0 when no stiffness is defined
517 ifunc2 = get_u_pnu(2,iprop,kfunc)
518 f0=fscal*tf(npf(ifunc2)+1)
519 eint(i) = eint(i) + (f0/stif0)*f0/2
520 ELSEIF (ityp == 4) THEN
521C Non linear case with both space IFUNC1 and time IFUNC2 defined
522 ifunc1 = get_u_pnu(1,iprop,kfunc)
523 ifunc2 = get_u_pnu(2,iprop,kfunc)
524 f0=fscal*tf(npf(ifunc2)+1)
525 npoint=(npf(ifunc1+1)-npf(ifunc1))/2
526 x2=dscal*tf(npf(ifunc1)+2*0+0)
527 y2=fscal*tf(npf(ifunc1)+2*0+1)
528 x3=dscal*tf(npf(ifunc1)+2*0+2)
529 y3=fscal*tf(npf(ifunc1)+2*0+3)
530 IF (d1==0) d1=-1e30
531 IF (d1>0.AND.y2>0.AND.x2>d1) THEN
532 y=y2+(y3-y2)/(x3-x2)*(d1-x2)
533 x=d1
534 CALL area(d1,x,x2,y,y2,eint(i),stif0)
535 ENDIF
536 DO j=0,npoint-2
537 x=dscal*tf(npf(ifunc1)+2*j)
538 y=f0*tf(npf(ifunc1)+2*j+1)
539 x2=dscal*tf(npf(ifunc1)+2*j+2)
540 y2=f0*tf(npf(ifunc1)+2*j+3)
541 IF (x<0) CALL area(d1,x,x2,y,y2,eint(i),stif0)
542 ENDDO
543 ENDIF
544 mass(i) = amas
545 xiner(i) = 0.
546 uvar(1,i) = 0.
547 uvar(2,i) = 0.
548 uvar(3,i) = 0.
549 uvar(4,i) = 0.
550C FOR NODAL AND ELEMENT TIME STEP COMPUTATION
551 stifm(i) = stif0 + stif1
552 stifr(i) = 0.
553 viscm(i) = 0.
554 viscr(i) = 0.
555 ENDDO
556C
557 RETURN
area
subroutine area(d1, x, x2, y, y2, eint, stif0)
Definition hm_read_prop32.F:567
id
initmumps id
Definition multiplerhs_example.m:4
get_u_pid
integer function get_u_pid(ip)
Definition uaccess.F:626
get_u_pnu
integer function get_u_pnu(ivar, ip, k)
Definition uaccess.F:482
get_u_mid
integer function get_u_mid(im)
Definition uaccess.F:668
get_u_mnu
integer function get_u_mnu(ivar, im, k)
Definition uaccess.F:565