OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
lossfun_98.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!|| lossfun_98 ../starter/source/materials/mat/mat098/lossfun_98.F
25!||--- calls -----------------------------------------------------
26!|| calc_uniax ../starter/source/materials/mat/mat098/lossfun_98.F
27!|| calc_uniax_2 ../starter/source/materials/mat/mat098/lossfun_98.F
28!|| fct_fiber ../starter/source/materials/mat/mat098/lossfun_98.F
29!|| fct_fiber_2 ../starter/source/materials/mat/mat098/lossfun_98.F
30!|| finter ../starter/source/tools/curve/finter.f
31!||--- uses -----------------------------------------------------
32!|| message_mod ../starter/share/message_module/message_mod.F
33!|| table_mod ../starter/share/modules1/table_mod.F
34!||====================================================================
35 SUBROUTINE lossfun_98(NVAR,NDC,X,FUN,DFUN,CONS,DCONS,IGOTO,
36 . NPC,PLD ,IFUNC,NFUNC,UPARAM,LENC,LENT,
37 . XBIA,NPTBI,ISYM )
38C-----------------------------------------------
39C M o d u l e s
40C-----------------------------------------------
41 USE message_mod
42 USE table_mod
43 USE names_and_titles_mod , ONLY : nchartitle
44C-----------------------------------------------
45C I m p l i c i t T y p e s
46C-----------------------------------------------
47#include "implicit_f.inc"
48C-----------------------------------------------
49C D u m m y A r g u m e n t s
50C-----------------------------------------------
51 !CHARACTER(LEN=NCHARTITLE) :: TITR
52 !INTEGER , DIMENSION(NFUNC) :: IFUNC,FUNC_ID
53 INTEGER IGOTO ,SIZEPN,NPTBI
54 INTEGER NVAR,NDC
55 my_real
56 . cons(*),dcons(*),x(nvar),uparam(*),fun(nvar),dfun(nvar),
57 . xbia(nptbi)
58! TYPE(TTABLE) TABLE(*)
59C-----------------------------------------------
60C VARIABLES FOR FUNCTION INTERPOLATION
61C-----------------------------------------------
62 INTEGER NPC(*), NFUNC, IFUNC(NFUNC)
63 my_real FINTER ,PLD(*)
64 EXTERNAL finter
65C-----------------------------------------------
66 INTENT(IN) :: npc,pld,igoto ,xbia,nptbi
67 INTENT(INOUT) :: fun,dfun,cons,dcons
68C-----------------------------------------------
69C L o c a l V a r i a b l e s
70C-----------------------------------------------
71 INTEGER I,II,J,ID,NP1,NP2,J1,K,K1,NCON, ITER,NITER,
72 . PN1,PN2,ISYM,LENC,LENT
73 my_real
74 . embc,embt,y,fmins,fminf,dembc,embcp,flexp,
75 . flex1,flex2,lc0,lt0,dc0,dt0,hc0,ht0,kc,kt,kfc,kft,
76 . hc,ht,dcc,dc,dt,udc,udt,hdc,hdt,fc,ft,fpc,fpt,kf,
77 . deric,dtt,func,dcp,dtp, t1,t2,a1,a2,dflex,flex2p,flex1p,
78 . fminc,fmint,fminc2,fmins2,fminf2,fminf1,yp,embtp,dembt,yfac(8)
79
80 my_real
81 . ec(lenc),fcu(lenc),lc(lenc),yc(lenc),sigc(lenc),
82 . sigcp(lenc),
83 . xfib(lenc),yfib(lenc),
84 . xcfib(nptbi),ycfib(nptbi),xtfib(nptbi),ytfib(nptbi)
85 my_real
86 . et(lent),ftu(lent),lt(lent),yt(lent),sigt(lent),
87 . sigtp(lent)
88
89c my_real, DIMENSION(:) ,ALLOCATABLE ::
90c----------------------------
91
92 IF (isym == 1)THEN
93 fminf = zero
94
95 fminf1 = zero
96 fminf2 = zero
97 fminc = zero
98 fmint = zero
99 fmins = zero
100 fmins2 = zero
101
102c----------------------------
103 embc = x(1)
104 embt = x(3)
105 flex1= x(2)
106 flex2= x(4)
107 dembc = max(em03 * embc, em10)
108 dflex = max(em03 * flex1, em10)
109 dembt = max(em03 * embt, em10)
110
111 niter= 5
112 DO i=1,8! NFUNC
113 yfac(i)= uparam(8+i)
114 ENDDO
115 dc0 = one+embc
116 hc0 = sqrt(dc0*dc0 - one)
117
118 dt0 = one+embt
119 ht0 = sqrt(dt0*dt0 - one)
120
121
122 ! TRANSFORMER CONTRAINTE DEF TISSU EN FORCE DEP FIBRE
123 CALL fct_fiber_2(npc,pld ,ifunc(7),ifunc(8),yfac(7),yfac(8),xbia,nptbi,
124 . flex1,flex2,dc0,hc0,dt0,ht0,xcfib,ycfib,xtfib,ytfib )
125C---------------------------------------------------------------------
126 pn1 = npc(ifunc(1))
127 pn2 = npc(ifunc(1)+1)
128 lenc = (pn2 - pn1) / 2
129 !DIRECTION CHAINE = FMINC
130 DO i = 1,lenc
131 ii = 2*(i-1)
132 ! for each x(i) we have sigc(i) OR sigt(i) as response
133 ec(i) = pld(npc(ifunc(1))+ ii )
134 fcu(i)= pld(npc(ifunc(1))+ ii+1 )*yfac(1)
135 CALL calc_uniax_2(ec(i),xcfib,ycfib,lenc,dc0,hc0,
136 . yfac(1),flex1,flex2,embc ,sigc(i)) !SIGC = SIGMA CALCULATED
137 a1 = (fcu(i) - sigc(i))/max(em20,fcu(i))
138 fminc = fminc + a1**2 !somme de la difference des carres
139 ENDDO
140 !DIRECTION TRAME = FMINT
141 pn1 = npc(ifunc(2))
142 pn2 = npc(ifunc(2)+1)
143 lent = half*(pn2 - pn1) !
144 DO i = 1,lent
145 ii = 2*(i-1)
146 et(i) = pld(npc(ifunc(2))+ ii )
147 ftu(i)= pld(npc(ifunc(2))+ ii+1 )*yfac(2)
148 CALL calc_uniax_2(et(i),xtfib,ytfib,lent,dt0,ht0,
149 . yfac(2),flex1,flex2,embt,sigt(i)) !SIGT = SIGMA CALCULATED
150 a2 = (ftu(i) - sigt(i))/max(em20,ftu(i))
151 fmint = fmint + a2**2 !somme de la difference des carres
152 ENDDO
153C-----------------------------------------------------------
154 IF (igoto == 5 .or. igoto == 8) fun = (fminc + fmint )/two
155C----------------------------------------------------------
156c DERIVATIVES - CHAINE
157C----------------------------------------------------------
158 !Deriv over stretch ( a voir si besoin de recalculer fonctions fibres)
159 IF (igoto == 3 .or. igoto == 8) THEN
160 !PERTURBATION STRETCH DIRECTION CHAINE = FMINS
161 embcp = x(1) + dembc
162 flex1 = x(2)
163 dc0 = one + embcp
164 hc0 = sqrt(dc0*dc0 - one)
165 DO i = 1,lenc
166 ii = 2*(i-1)
167 ec(i) = pld(npc(ifunc(1))+ ii )
168 fcu(i)= pld(npc(ifunc(1))+ ii +1)*yfac(1)
169 CALL calc_uniax_2(ec(i),xcfib,ycfib,lenc,dc0,hc0,
170 . yfac(1),flex1,flex2,embcp,sigc(i))
171c
172 a1 = (fcu(i) - sigc(i))/max(em20,fcu(i))
173 fmins = fmins + a1**2 !somme de la difference des carres
174 ENDDO !LENC
175c FMINS = SQRT(FMINS)
176 dfun(1) = (fmins - fminc) / dembc
177C----------------------------------------------------------
178 ! Deriv over flex
179C----------------------------------------------------------
180 !PERTURBATION FLEX DIRECTION CHAINE = FMINF1 ET FMINF2
181 embc = x(1)
182 embt = x(3)
183 flexp = x(2) + dflex
184 flex2 = x(4)
185 dc0 = one + embc
186 hc0 = sqrt(dc0*dc0 - one)
187 DO i = 1,lenc
188 ii = 2*(i-1)
189 ec(i) = pld(npc(ifunc(1))+ ii )
190 fcu(i)= pld(npc(ifunc(1))+ ii +1)*yfac(1)
191 CALL calc_uniax_2(ec(i),xcfib,ycfib,lenc,dc0,hc0,
192 . yfac(1),flexp,flex2,embc,sigc(i))
193c
194 a1 = (fcu(i) - sigc(i))/max(em20,fcu(i))
195 !A1 = FCU(I) - SIGC(I)
196 fminf1 = fminf1 + a1**2 !somme de la difference des carres
197 ENDDO !LENC
198
199 dt0 = one + embt
200 ht0 = sqrt(dt0*dt0 - one)
201 DO i = 1,lent
202 ii = 2*(i-1)
203 et(i) = pld(npc(ifunc(2))+ ii )
204 ftu(i)= pld(npc(ifunc(2))+ ii +1)*yfac(2)
205 CALL calc_uniax_2(et(i),xtfib,ytfib,lent,dt0,ht0,
206 . yfac(2),flexp,flex2,embt,sigt(i))
207c
208 a1 = (ftu(i) - sigt(i))/max(em20,ftu(i))
209 fminf2 = fminf2 + a1**2 !somme de la difference des carres
210 ENDDO !LENT
211c FMINF = SQRT(FMINF)
212 dfun(2) = (fminf1 + fminf2 - fminc - fmint) / dflex
213C----------------------------------------------------------
214c DERIVATIVES - TRAME
215C----------------------------------------------------------
216 fminf1 = zero
217 fminf2 = zero
218 embc = x(1)
219 flex1= x(2)
220 !PERTURBATION STRETCH DIRECTION TRAME = FMINS2
221 embtp = x(3) + dembt
222 flex2 = x(4)
223 dt0 = one + embtp
224 ht0 = sqrt(dt0*dt0 - one)
225 DO i = 1,lent
226 ii = 2*(i-1)
227 et(i) = pld(npc(ifunc(2))+ ii )
228 ftu(i)= pld(npc(ifunc(2))+ ii +1)*yfac(2)
229 CALL calc_uniax_2(et(i),xtfib,ytfib,lent,dt0,ht0,
230 . yfac(2),flex1,flex2,embtp,sigt(i))
231c
232 a1 = (ftu(i) - sigt(i))/max(em20,ftu(i))
233 fmins2 = fmins2 + a1**2 !somme de la difference des carres
234 ENDDO !LENT
235c FMINS = SQRT(FMINS)
236 dfun(3) = (fmins2 - fmint) / dembt
237C----------------------------------------------------------
238 ! Deriv over flex
239 !PERTURBATION FLEX DIRECTION TRAME = FMINF1 ET FMINF2
240 embc = x(1)
241 embt = x(3)
242 flex1= x(2)
243 flexp = x(4) + dflex
244
245 dc0 = one + embc
246 hc0 = sqrt(dc0*dc0 - one)
247 DO i = 1,lenc
248 ii = 2*(i-1)
249 ec(i) = pld(npc(ifunc(1))+ ii )
250 fcu(i)= pld(npc(ifunc(1))+ ii +1)*yfac(1)
251 CALL calc_uniax_2(ec(i),xcfib,ycfib,lenc,dc0,hc0,
252 . yfac(1),flex1,flexp,embc,sigc(i))
253c
254 a1 = (fcu(i) - sigc(i))/max(em20,fcu(i))
255 !A1 = FCU(I) - SIGC(I)
256 fminf1 = fminf1 + a1**2 !somme de la difference des carres
257 ENDDO !LENC
258 dt0 = one + embt
259 ht0 = sqrt(dt0*dt0 - one)
260 DO i = 1,lent
261 ii = 2*(i-1)
262 et(i) = pld(npc(ifunc(2))+ ii )
263 ftu(i)= pld(npc(ifunc(2))+ ii +1)*yfac(2)
264 CALL calc_uniax_2(et(i),xtfib,ytfib,lent,dt0,ht0,
265 . yfac(2),flex1,flexp,embt,sigt(i))
266c
267 a1 = (ftu(i) - sigt(i))/max(em20,ftu(i))
268 !A1 = FCU(I) - SIGC(I)
269 fminf2 = fminf2 + a1**2 !somme de la difference des carres
270 ENDDO !LENT
271 dfun(4) = (fminf1 + fminf2 - fminc - fmint) / dflex
272 ENDIF !IGOTO
273C----------------------------------------------------------
274C------------------ISYM------------------------
275C----------------------------------------------------------
276 ELSE
277 fminc = zero
278 fmins = zero
279 fminf = zero
280
281 embc = x(1)
282 embt = x(1)
283 flex1= x(2)
284 flex2= x(2)
285 dembc = max(em03 * embc, em10)
286 dflex = max(em03 * flex1, em10)
287 niter= 5
288 DO i=1,8! NFUNC
289 yfac(i)= uparam(8+i)
290 ENDDO
291 dc0 = one+embc
292 hc0 = sqrt(dc0*dc0 - one)
293
294 dt0 = one+embt
295 ht0 = sqrt(dt0*dt0 - one)
296 ! IL FAUT PRENDRE LA LONGUEUR DE LA FONCTION CR EE
297 pn1 = npc(ifunc(7))
298 pn2 = npc(ifunc(7)+1)
299 sizepn = half*(pn2 - pn1) !
300
301
302 ! TRANSFORMER CONTRAINTE DEF TISSU EN FORCE DEP FIBRE
303 CALL fct_fiber(npc,pld ,ifunc(7),sizepn,dc0,hc0,xfib,yfib)
304
305 ! STOP
306
307 DO i = 1,sizepn
308 ii = 2*(i-1)
309 ! for each x(i) we have sigc(i) and sigt(i) as response
310 ec(i) = pld(npc(ifunc(1))+ ii )
311 fcu(i)= pld(npc(ifunc(1))+ ii+1 )*yfac(1)
312
313 CALL calc_uniax(ec(i),xfib,yfib,sizepn,dc0,hc0,
314 . yfac(1),flex1,embc,sigc(i)) !SIGC = SIGMA CALCULATED
315 a1 = (fcu(i) - sigc(i))/max(em20,fcu(i))
316 fminc = fminc + a1**2 !somme de la difference des carres
317 ENDDO
318 !STOP
319 IF (igoto == 5 .or. igoto == 8) fun = fminc
320C----------------------------------------------------------
321c DERIVATIVES
322C----------------------------------------------------------
323 !Deriv over stretch ( a voir si besoin de recalculer fonctions fibres)
324 IF (igoto == 3 .or. igoto == 8) THEN
325 embcp = x(1) + dembc
326 flex1 = x(2)
327 dc0 = one + embcp
328 hc0 = sqrt(dc0*dc0 - one)
329 dt0 = dc0
330 ht0 = hc0
331 DO i = 1,sizepn
332 ii = 2*(i-1)
333 ec(i) = pld(npc(ifunc(1))+ ii )
334 fcu(i)= pld(npc(ifunc(1))+ ii +1)*yfac(1)
335 CALL calc_uniax(ec(i),xfib,yfib,sizepn,dc0,hc0,
336 . yfac(1),flex1,embcp,sigc(i))
337 a1 = (fcu(i) - sigc(i))/max(em20,fcu(i))
338 fmins = fmins + a1**2 !somme de la difference des carres
339 ENDDO !SIZEPN
340c FMINS = SQRT(FMINS)
341 dfun(1) = (fmins - fminc) / dembc
342C----------------------------------------------------------
343 ! Deriv over flex
344 embc = x(1)
345 flexp = x(2) + dflex
346 dc0 = one + embc
347 hc0 = sqrt(dc0*dc0 - one)
348 dt0 = dc0
349 ht0 = hc0
350 DO i = 1,sizepn
351 ii = 2*(i-1)
352 ec(i) = pld(npc(ifunc(1))+ ii )
353 fcu(i)= pld(npc(ifunc(1))+ ii +1)*yfac(1)
354 CALL calc_uniax(ec(i),xfib,yfib,sizepn,dc0,hc0,
355 . yfac(1),flexp,embc,sigc(i))
356c
357 a1 = (fcu(i) - sigc(i))/max(em20,fcu(i))
358 !A1 = FCU(I) - SIGC(I)
359 fminf = fminf + a1**2 !somme de la difference des carres
360 ENDDO !SIZEPN
361c FMINF = SQRT(FMINF)
362 dfun(2) = (fminf - fminc) / dflex
363C----------------------------------------------------------
364 ENDIF !IGOTO
365 ENDIF !ISYM
366C----------------------------------------------------------
367 !write(*,'(A,3G20.13)')'FUN , DF1,DF2 ', FUN,DFUN(1),DFUN(2)
368c-----------
369 RETURN
370 END
371
372
373!||====================================================================
374!|| calc_uniax ../starter/source/materials/mat/mat098/lossfun_98.F
375!||--- called by ------------------------------------------------------
376!|| lossfun_98 ../starter/source/materials/mat/mat098/lossfun_98.F
377!||--- uses -----------------------------------------------------
378!|| message_mod ../starter/share/message_module/message_mod.F
379!|| table_mod ../starter/share/modules1/table_mod.F
380!||====================================================================
381 SUBROUTINE calc_uniax(EC,XFIB,YFIB,SIZEPN,DC0,HC0,
382 . YFAC,FLEX,STRETCH,SIGC)
383! CALL CALC_UNIAX(EC,XFIB,YFIB,NPT,DC0,HC0,
384! . YFAC(7),FLEX,EMBCP,SIGC(I))
385C-----------------------------------------------
386C M o d u l e s
387C-----------------------------------------------
388 USE message_mod
389 USE table_mod
390C-----------------------------------------------
391C I m p l i c i t T y p e s
392C-----------------------------------------------
393#include "implicit_f.inc"
394C-----------------------------------------------
395C D u m m y A r g u m e n t s
396c-----------------------------------------------
397 INTEGER SIZEPN
398 my_real
399 . XFIB(SIZEPN),YFIB(SIZEPN)
400 my_real
401 . ec,dc0,hc0,yfac,flex,stretch,sigc,func
402c----------------------------
403 INTEGER ITER,NITER
404 my_real
405 . HC,HT,YC,DC,DCC,UDC,HDC,LC,LT,DERIC,DT0,
406 . fc,ec2,fpc
407 my_real
408 . finter58
409 EXTERNAL finter58
410c-----------------------------------------------
411
412 niter = 5
413 yc = zero ! initialization
414 lc = one + ec
415c----------------------
416 DO iter = 1, niter
417 hc = hc0 + yc
418 dc = sqrt(lc*lc + hc*hc)
419 dcc = dc - dc0
420 udc = one / dc
421 hdc = hc * udc
422 fc = yfac * finter58(dcc,xfib,yfib,fpc,sizepn)
423 fpc = fpc*hdc*yfac
424 func = two*flex*yc + fc*hdc
425 deric= two*flex + fpc*hdc + fc*udc*(one - hdc*hdc)
426 yc = yc - func / max(deric,em20)
427 ENDDO !iter
428c----------------------
429 hc = hc0 + yc
430 ht = hc0 - yc
431 dc = sqrt(lc*lc + hc*hc)
432 dcc = dc - dc0
433 fc = yfac * finter58(dcc,xfib,yfib,fpc,sizepn)
434 dt0 = dc0
435 lt = sqrt(max(em20, dt0**2 - ht**2))
436 ec2 = lt - one
437 sigc = fc * lc / dc ! ENGINEERING
438
439c SIGC = FC * LC / DC /(EC2+ONE)!TRUE
440c
441c-----------
442 RETURN
443 END
444
445C----------------------------------------------------------
446 my_real
447 . FUNCTION finter58(XX,XC,YC,DERI,NPT)
448! FINTER58(DCC,XFIB,YFIB,FPC,SIZEPN)
449C-----------------------------------------------
450C I m p l i c i t T y p e s
451C-----------------------------------------------
452#include "implicit_f.inc"
453C-----------------------------------------------
454
455 INTEGER ifunc, i,npt
456 my_real
457 . abc,deri,xx,dx1,dx2,xc(npt),yc(npt)
458C-----------------------------------------------
459 finter58 = zero
460C
461 dx2 = xc(1) - xx
462 DO 100 i=2,npt
463 dx1 = -dx2
464 dx2 = xc(i) - xx
465 IF(dx2>=0.0.OR.i==npt)THEN
466 deri = (yc(i) - yc(i-1)) / (xc(i) - xc(i-1))
467 IF(dx1<=dx2)THEN
468 finter58 = yc(i-1) + dx1 * deri
469 ELSE
470 finter58 = yc(i) - dx2 * deri
471 ENDIF
472 RETURN
473 ENDIF
474 100 CONTINUE
475
476C
477 RETURN
478 END
479
480!||====================================================================
481!|| fct_fiber_2 ../starter/source/materials/mat/mat098/lossfun_98.F
482!||--- called by ------------------------------------------------------
483!|| lossfun_98 ../starter/source/materials/mat/mat098/lossfun_98.f
484!||--- calls -----------------------------------------------------
485!|| finter ../starter/source/tools/curve/finter.F
486!||--- uses -----------------------------------------------------
487!|| message_mod ../starter/share/message_module/message_mod.F
488!|| table_mod ../starter/share/modules1/table_mod.F
489!||====================================================================
490 SUBROUTINE fct_fiber_2(NPC,PLD ,IDN1,IDN2,YFAC1,YFAC2,
491 . XBIA,NPTBI,KFC,KFT,DC0,HC0,DT0,HT0,XCFIB,YCFIB,XTFIB,YTFIB )
492C-----------------------------------------------
493C M o d u l e s
494C-----------------------------------------------
495 USE message_mod
496 USE table_mod
497C-----------------------------------------------
498C I m p l i c i t T y p e s
499C-----------------------------------------------
500#include "implicit_f.inc"
501C-----------------------------------------------
502C D u m m y A r g u m e n t s
503C-----------------------------------------------
504 INTEGER NPC(*)
505 my_real FINTER ,PLD(*),XBIA(NPTBI)
506 EXTERNAL FINTER
507 INTEGER I,J,IDN1,IDN2,NPTBI,NP1, NITER,ITER
508 my_real
509 . dc0,hc0,dt0,ht0,lc,lt,dc,udc,udt,hdc,hdt,yfac1,yfac2,yc,yt,
510 . fpc,fpt, y,hc,ht,dt, fc,ft,kf,kft,kfc,func,deric,
511 . xx(nptbi),yb(nptbi),xfib(nptbi),yfib(nptbi),xcfib(nptbi),
512 . ycfib(nptbi),xtfib(nptbi),ytfib(nptbi),dcc(nptbi),
513 . dtt(nptbi),stissuc(nptbi),stissut(nptbi)
514C-----------------------------------------------
515 INTENT(IN) :: npc,pld ,nptbi,yfac1,yfac2
516c----------------------------------------------
517 !IDN = IFUNC(7)
518 niter = 5
519 DO i = 1, nptbi-1
520 j = 2*(i-1)
521 stissuc(i) = yfac1 * finter(idn1,xbia(i),npc,pld,fpc)!IFUNC7
522 stissut(i) = yfac2 * finter(idn2,xbia(i),npc,pld,fpt)!IFUNC8
523 lc = one + xbia(i)
524 lt = one + xbia(i)
525
526c FTISS(I)= YB(I)*(1.0 + XX(I))
527 y = zero
528 DO iter = 1, niter
529 hc = hc0 + y
530 ht = ht0 - y
531 dc = sqrt(lc *lc + hc*hc)
532 dt = sqrt(lt *lt + ht*ht)
533 udc= one / dc
534 udt= one / dt
535 hdc= hc * udc
536 hdt= ht * udt
537 fc = stissuc(i) * lc/dc
538 fpc = -fc * hdc/dc
539 !FPC = STISSUC(I) * HDC
540 ft = stissut(i) * lt/dt
541 fpt = -ft * hdt/dt
542 !FPT = STISSUT(I) * HDT
543 kf = kfc + kft
544 func = kf*y + fc * hdc - ft * hdt
545 deric = kf + fpc*hdc + fc*udc*(one - hdc*hdc)
546 . + fpt*hdt + ft*udt*(one - hdt*hdt)
547 y = y - func / deric
548C
549 IF (y > 0) THEN
550 y = min(y, ht0)
551 ELSE
552 y = max(y,-hc0)
553 ENDIF
554 ENDDO !iter
555
556 yc = y
557 yt =-y
558 hc = hc0 + yc
559 ht = ht0 + yt
560 dc = sqrt(lc *lc + hc*hc)
561 dt = sqrt(lt *lt + ht*ht)
562 xcfib(i) = dc - dc0
563 xtfib(i) = dt - dt0
564 ycfib(i) = stissuc(i) *lc/dc
565 ytfib(i) = stissut(i) *lt/dt
566 !PRINT*, 'C,XFIB, YFIB ', I, XCFIB(I), YCFIB(I)
567 !PRINT*, 'T,XFIB, YFIB ', I, XTFIB(I), YTFIB(I)
568 ENDDO
569 ! STOP
570c-----------
571 RETURN
572 END
573
574!||====================================================================
575!|| fct_fiber ../starter/source/materials/mat/mat098/lossfun_98.F
576!||--- called by ------------------------------------------------------
577!|| lossfun_98 ../starter/source/materials/mat/mat098/lossfun_98.F
578!||--- uses -----------------------------------------------------
579!|| message_mod ../starter/share/message_module/message_mod.F
580!|| table_mod ../starter/share/modules1/table_mod.F
581!||====================================================================
582 SUBROUTINE fct_fiber(NPC,PLD ,IDN,SIZEPN,DC0,HC0,XFIB,YFIB)
583C-----------------------------------------------
584C M o d u l e s
585C-----------------------------------------------
586 USE message_mod
587 USE table_mod
588C-----------------------------------------------
589C I m p l i c i t T y p e s
590C-----------------------------------------------
591#include "implicit_f.inc"
592C-----------------------------------------------
593C D u m m y A r g u m e n t s
594C-----------------------------------------------
595 INTEGER NPC(*)
596 my_real
597 . PLD(*)
598 INTEGER I,J,IDN,SIZEPN,NP1
599 my_real
600 . xx(sizepn),yb(sizepn),xfib(sizepn),yfib(sizepn),dc0,hc0,
601 . lc,dc
602C-----------------------------------------------
603 INTENT(IN) :: npc,pld
604c----------------------------
605 !IDN = IFUNC(7)
606 np1 = (npc(idn+1)-npc(idn))*half
607
608 DO i = 1, np1
609 j = 2*(i-1)
610 xx(i) = pld(npc(idn)+j)
611 lc = one + xx(i)
612 dc = sqrt(hc0*hc0 + lc*lc)
613 xfib(i) = dc - dc0
614 yfib(i) = pld(npc(idn)+j+1)*lc/dc
615c FTISS(I)= YB(I)*(1.0 + XX(I))
616 ENDDO
617c-----------
618 RETURN
619 END
620
621!||====================================================================
622!|| calc_uniax_2 ../starter/source/materials/mat/mat098/lossfun_98.f
623!||--- called by ------------------------------------------------------
624!|| lossfun_98 ../starter/source/materials/mat/mat098/lossfun_98.F
625!||--- uses -----------------------------------------------------
626!|| message_mod ../starter/share/message_module/message_mod.F
627!|| table_mod ../starter/share/modules1/table_mod.F
628!||====================================================================
629 SUBROUTINE calc_uniax_2(EC,XFIB,YFIB,SIZEPN,DC0,HC0,
630 . YFAC,FLEX1,FLEX2,EMBC ,SIGC)
631! CALL CALC_UNIAX_2(EC(I),XCFIB,YCFIB,LENC,DC0,HC0,
632! . YFAC(1),FLEX1,FLEX2,EMBC ,EMBT,SIGC(I)) !SIGC = SIGMA CALCULATED
633C-----------------------------------------------
634C M o d u l e s
635C-----------------------------------------------
636 USE message_mod
637 USE table_mod
638C-----------------------------------------------
639C I m p l i c i t T y p e s
640C-----------------------------------------------
641#include "implicit_f.inc"
642C-----------------------------------------------
643C D u m m y A r g u m e n t s
644c-----------------------------------------------
645 INTEGER SIZEPN
646 my_real
647 . XFIB(SIZEPN),YFIB(SIZEPN)
648 my_real
649 . EC,DC0,HC0,YFAC,FLEX1,FLEX2,EMBC ,SIGC,FUNC
650c----------------------------
651 INTEGER ITER,NITER
652 my_real
653 . hc,ht,yc,dc,dcc,udc,hdc,lc,lt,deric,dt0,
654 . fc,ec2,fpc
655 my_real
656 . finter58
657 EXTERNAL finter58
658c-----------------------------------------------
659
660 niter = 5
661 yc = zero ! initialization
662 lc = one + ec
663c----------------------
664 DO iter = 1, niter
665 hc = hc0 + yc
666 dc = sqrt(lc*lc + hc*hc)
667 dcc = dc - dc0
668 udc = one / dc
669 hdc = hc * udc
670 fc = yfac * finter58(dcc,xfib,yfib,fpc,sizepn)
671 fpc = fpc*hdc*yfac
672 func = (flex1+flex2)*yc + fc*hdc
673 deric= (flex1+flex2) + fpc*hdc + fc*udc*(one - hdc*hdc)
674 yc = yc - func / max(deric,em20)
675 ENDDO !iter
676c----------------------
677 hc = hc0 + yc
678 dc = sqrt(lc*lc + hc*hc)
679 dcc = dc - dc0
680 fc = yfac * finter58(dcc,xfib,yfib,fpc,sizepn)
681 sigc = fc * lc / dc ! ENGINEERING (ON PREND L INITIAL EC2 = 0)
682
683c SIGC = FC * LC / DC /(EC2+ONE)
684c
685c-----------
686 RETURN
687 END
688
my_real
#define my_real
Definition cppsort.cpp:32
lossfun_98
subroutine lossfun_98(nvar, ndc, x, fun, dfun, cons, dcons, igoto, npc, pld, ifunc, nfunc, uparam, lenc, lent, xbia, nptbi, isym)
Definition lossfun_98.F:38
fct_fiber
subroutine fct_fiber(npc, pld, idn, sizepn, dc0, hc0, xfib, yfib)
Definition lossfun_98.F:583
calc_uniax_2
subroutine calc_uniax_2(ec, xfib, yfib, sizepn, dc0, hc0, yfac, flex1, flex2, embc, sigc)
Definition lossfun_98.F:631
calc_uniax
subroutine calc_uniax(ec, xfib, yfib, sizepn, dc0, hc0, yfac, flex, stretch, sigc)
Definition lossfun_98.F:383
fct_fiber_2
subroutine fct_fiber_2(npc, pld, idn1, idn2, yfac1, yfac2, xbia, nptbi, kfc, kft, dc0, hc0, dt0, ht0, xcfib, ycfib, xtfib, ytfib)
Definition lossfun_98.F:492
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
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
table_mod
Definition table_mod.F:112
starter
program starter
Definition starter.F:39