OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
fill_buffer_51.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!|| fill_buffer_51 ../starter/source/materials/mat/mat051/fill_buffer_51.F
25!||--- called by ------------------------------------------------------
26!|| fill_buffer_51_0 ../starter/source/materials/mat/mat051/fill_buffer_51_0.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| ie_bound ../starter/source/materials/mat/mat051/ie_bound.F
30!|| nintri ../starter/source/system/nintrr.F
31!||--- uses -----------------------------------------------------
32!|| elbuftag_mod ../starter/share/modules1/elbuftag_mod.F
33!|| message_mod ../starter/share/message_module/message_mod.F
34!||====================================================================
35 SUBROUTINE fill_buffer_51( IPM, PM, UPARAM, BUFMAT, USER_ID, TITR, INTERNAL_ID, MAT_PARAM, MLAW_TAG)
36C-----------------------------------------------
37C M o d u l e s
38C-----------------------------------------------
39 USE message_mod
40 USE names_and_titles_mod , ONLY : nchartitle
41 USE matparam_def_mod, ONLY : matparam_struct_
42 USE elbuftag_mod , ONLY : mlaw_tag_
43C-----------------------------------------------
44C D e s c r i p t i o n
45C-----------------------------------------------
46C This subroutine is filling law51 material buffer UPARAM(:)
47C from material identifiers which were provided in input
48C format related to IFLG=12
49C
50C It is done here and not in lecm51 because we need all
51C material cards and eos card to be treated before.
52C
53C you need yield criteria and eos to be defined for each submaterial.
54C
55C submaterial order from user is not the same as the one in buffer (UPARAM).
56C bijective app is in UPARAM(277:280) to get corresponding ids
57C-----------------------------------------------
58C I m p l i c i t T y p e s
59C-----------------------------------------------
60#include "implicit_f.inc"
61C-----------------------------------------------
62C C o m m o n B l o c k s
63C-----------------------------------------------
64#include "param_c.inc"
65#include "com04_c.inc"
66C-----------------------------------------------
67C D u m m y A r g u m e n t s
68C-----------------------------------------------
69 INTEGER,TARGET :: IPM(NPROPMI,NUMMAT)
70 INTEGER,INTENT(IN) :: USER_ID, INTERNAL_ID
71 my_real,TARGET :: pm(npropm,nummat),bufmat(*)
72 my_real :: uparam(*)
73 CHARACTER(LEN=NCHARTITLE),INTENT(IN) :: TITR
74 TYPE(matparam_struct_) ,DIMENSION(NUMMAT) ,INTENT(INOUT) :: MAT_PARAM
75 TYPE(mlaw_tag_) , DIMENSION(NUMMAT) , INTENT(INOUT) :: MLAW_TAG
76C-----------------------------------------------
77C L o c a l V a r i a b l e s
78C-----------------------------------------------
79 INTEGER :: IDX_AV, IDX_RHO, IDX_C1, IDX_C2, IDX_C3(3), IDX_C4, IDX_C5, IDX_G
80 INTEGER :: IDX_E0, IDX_C0, IDX_PM, IDX_IPLA, IDX_EINF, IDX_VISC
81 INTEGER :: IDX_YIELD(4)
82 INTEGER :: MID(4),MID_VALID(4),IEXP,NPAR,IADBUF,IDX_PSH_TAB
83 INTEGER :: IMID, MLN, EOS_TYPE, I, J, NJWL, COUNT_VALID_MAT, COUNT_NONEXPLO, ID, NBMAT, TAG(4),IPLA,NITER
84 INTEGER,EXTERNAL :: NINTRI
85
86 my_real :: av(4),e1_inf,e2_inf,e3_inf,e4_inf,pext,ratio,tmp1,tmp2,psh_tab(4),rho_max
87 my_real, POINTER, DIMENSION(:) :: pm_
88 my_real, EXTERNAL :: ie_bound
89 my_real, DIMENSION(:), POINTER :: uparam_
90
91 CHARACTER(LEN=NCHARTITLE) :: chain1
92
93 !====================================POLYNOMIAL EOS
94 my_real :: rho,c0,c1,c2,c3,c4,c5,e0,psh,p0,dpdmu,ssp
95
96 !====================================LAW05 - PARAMETERS
97 my_real :: vdet,pcj,vcj,b1,b2,r1,r2,w,
98 . pm4,av4,rho40,e04,c04,c14,
99 . tmelt4,thetl4,sph4,t40,xka4,xkb4,ssp4,
100 . eadd,tbegin,tend,reaction_rate,a_mil,m_mil,n_mil,reaction_rate2,alpha_unit
101 INTEGER :: IBFRAC,QOPT,NEXPLO,IMIN
102
103 !====================================LAW03 - PARAMETERS
104 my_real :: young,anu,g,bulk,pmin,ca,cb,cn,epsm,sigm,gg
105
106 !====================================LAW04 - PARAMETERS
107 my_real :: cc,eps0,m,tmelt,tmax,cs,sph,t0
108
109 !====================================LAW06 - PARAMETERS
110 my_real :: visc
111
112 !====================================LAW10 - PARAMETERS
113 my_real :: a0,a1,a2,amx,pstar
114
115C-----------------------------------------------
116C P r e c o n d i t i o n
117C-----------------------------------------------
118C already checked before subroutine call
119C-----------------------------------------------
120C I n i t i a l i z a t i o n
121C-----------------------------------------------
122 idx_av = 003
123 idx_rho = 008
124 idx_c1 = 011
125 idx_c2 = 014
126 idx_c3(1:3) = (/018,020,021/)
127 idx_c4 = 021
128 idx_c5 = 024
129 idx_g = 027
130 idx_e0 = 031
131 idx_c0 = 034
132 idx_pm = 038
133 idx_einf = 056
134 idx_ipla = 063
135 idx_visc = 080
136 idx_yield(1) = 100
137 idx_yield(2) = 150
138 idx_yield(3) = 200
139 idx_yield(4) = 250
140 nexplo=0
141
142 !filled in lecm51
143 mid(1:4) = nint(uparam(9:12))
144 av(1:4) = uparam(13:16)
145 uparam(9:280)=zero
146 uparam(31) = 12
147 mid_valid(1:4)=0
148 count_valid_mat = 0
149 count_nonexplo = 0
150
151 !pointers
152 NULLIFY(pm_)
153
154 !PSTAR INIT
155 uparam(123)=-infinity
156 uparam(173)=-infinity
157 uparam(223)=-infinity
158
159 !Ei_INF
160 uparam(57) = -infinity
161 uparam(58) = -infinity
162 uparam(59) = -infinity
163 uparam(60) = zero !-INFINITY
164
165 iexp = 0
166 njwl = 0
167 tag(1:4) = 0
168 ipla = 0
169
170 g = zero
171 gg = zero
172
173 psh_tab(1:4)=zero
174 idx_psh_tab = 0
175 pext = zero
176C-----------------------------------------------
177C S o u r c e L i n e s
178C-----------------------------------------------
179 DO i=1,4
180 IF(mid(i) == 0)EXIT !if defined
181 imid = nintri(mid(i),ipm,npropmi,nummat,1) !internal ID
182 mln = 0
183 id = 0
184 eos_type = 0
185 IF(imid /= 0)THEN
186 mln = ipm(2,imid)
187 id = ipm(1,imid)
188 eos_type = ipm(4,imid)
189 ENDIF
190 IF(mln == 5)njwl=njwl+1
191 IF(imid == 0)THEN
192 chain1='NON EXISTING SUBMATERIAL IDENTIFIER: '
193 write(chain1(37:46),'(i10)')mid(i)
194 IF(mid(i) > 0) THEN
195 CALL ancmsg(msgid=99,msgtype=msgerror,anmode=aninfo,i1=user_id,c1=titr,c2=chain1)
196 ELSE
197 !already checked in hm_read_mat51 (MID(I)=0 or MID(I) <0)
198 ENDIF
199 ELSE
200 IF(mln == 2 .OR. mln == 3 .OR. mln == 4 .OR. mln == 5 .OR. mln == 6 .OR. mln == 10 .OR. mln == 102 .OR. mln == 133)THEN
201 IF(mln /= 5)THEN
202 IF(eos_type == 18 .OR. eos_type == 1 .OR. eos_type == 7 .OR. eos_type == 10)THEN
203 ELSE
204 chain1='SUBMATERIAL COMPATIBLE EOS:POLYNOMIAL, IDEAL-GAS, STIFFENED-GAS, LINEAR'
205 CALL ancmsg(msgid=99,msgtype=msgerror,anmode=aninfo,i1=id,c1=titr,c2=chain1)
206 ENDIF
207 ELSE
208 iexp=1
209 nexplo=nexplo+1
210 ENDIF
211 IF(imid > 0)THEN
212 count_valid_mat = count_valid_mat + 1 !take into account only line with MID>0
213 mid_valid(count_valid_mat) = imid
214 !--UPARAM(276:280) is BIJECTION TO RETRIEVE PHASE ORDER FROM USER
215 IF(mln /= 5)THEN
216 count_nonexplo=count_nonexplo + 1
217 uparam(276+count_valid_mat)=minloc(tag(1:4),1)
218 tag(count_nonexplo)=1
219 ELSE
220 uparam(276+count_valid_mat)=4
221 tag(4)=1
222 ENDIF
223 ENDIF
224 ELSE
225 chain1='SUBMATERIAL CAN ONLY BE DEFINED FROM LAWS 2,3,4,5,6,10 102 OR 133 '
226 CALL ancmsg(msgid=99,msgtype=msgerror,anmode=aninfo,i1=id,c1=titr,c2=chain1)
227 ENDIF
228 ENDIF
229 ENDDO !next I
230
231 ! fill missing phases if user defines less 1,2,or 3 ; (ie, user did not defined all 4)
232 ! example UPARAM(276+4)=0 if user defines only 3 submaterial, then output related to phase 4 has wrond index : memory corruption)
233 ! (/1,2,4,0/) -> (/1,2,4,3/)
234 DO i=count_valid_mat+1,4
235 imin = minloc(tag(1:4),1)
236 IF(tag(imin)==0)THEN
237 tag(i)=1
238 uparam(276+i)=imin
239 ELSE
240 EXIT
241 ENDIF
242 ENDDO
243
244 nbmat = count_valid_mat
245 uparam(55)=1 !IEXP
246
247 IF(nexplo>1)THEN
248 chain1='ONLY ONE EXPLOSIVE SUBMATERIAL CAN BE DEFINED'
249 CALL ancmsg(msgid=99,msgtype=msgerror,anmode=aninfo,i1=id,c1=titr,c2=chain1)
250 ENDIF
251
252!ALREADY CHECKED IN LECM51
253! chain1='AT LEAST ONE SUBMATERIAL MUST BE DEFINED'
254
255
256 IF(nbmat>4)THEN
257 chain1='LAW51 IS COMPATIBLE WITH UP TO 4 SUBMATERIAL ONLY'
258 CALL ancmsg(msgid=99,msgtype=msgerror,anmode=aninfo,i1=id,c1=titr,c2=chain1)
259 ENDIF
260
261 ipm(5,internal_id)=count_valid_mat !storing NUMBER OF SUBMATERIALS
262 pm(27,internal_id) = zero
263
264 rho_max=zero
265 DO i=1,count_valid_mat
266 imid = nintri(mid(i),ipm,npropmi,nummat,1)
267 mat_param(internal_id)%MULTIMAT%MID(i) = imid !user ID -> internal ID
268 ipm(50+i,internal_id)=uparam(276+i) !storing bijective order of submaterial
269 mln = ipm(2,imid)
270 eos_type = ipm(4,imid)
271 pm_ => pm(1:,imid)
272 rho_max=max(rho_max,pm(1,imid))
273 e0 = zero
274 c0 = zero
275 c1 = zero
276 c2 = zero
277 c3 = zero
278 c4 = zero
279 c5 = zero
280 psh = zero
281 t0 = zero
282 IF(mln /= 5)THEN
283 SELECT CASE(eos_type)
284 !EOS PARAMETERS DEPENDS ON 'EOS_TYPE'
285 CASE(1,18) !18:/EOS/LINEAR
286 rho = pm_(1) !1 :/EOS/POLYNOMIAL
287 e0 = pm_(23)
288 c0 = pm_(104) !C0-PSH
289 c1 = pm_(32)
290 c2 = pm_(33)
291 c3 = pm_(34)
292 c4 = pm_(35)
293 c5 = pm_(36)
294 psh = pm_(88)
295 t0 = pm_(35)
296 CASE(7) !07:/EOS/IDEAL-GAS
297 rho = pm_(1)
298 e0 = pm_(23)
299 c0 = -pm_(88)
300 c1 = zero
301 c2 = zero
302 c3 = zero
303 c4 = pm_(32)-one
304 c5 = pm_(32)-one
305 psh = pm_(88)
306 t0 = pm_(35)
307 CASE(10) !10:/EOS/STIFF-GAS
308 rho = pm_(1)
309 e0 = pm_(23)
310 c0 = -pm_(34)*pm_(35)-pm_(88) !-gamma*P_star - PSH
311 c1 = zero
312 c2 = zero
313 c3 = zero
314 c4 = pm_(34)-one
315 c5 = pm_(34)-one
316 psh = pm_(88)
317 t0 = pm_(35)
318 CASE DEFAULT
319 rho = -huge(rho)
320 e0 = -huge(e0)
321 c0 = -huge(c0)
322 c1 = -huge(c1)
323 c2 = -huge(c2)
324 c3 = -huge(c3)
325 c4 = -huge(c4)
326 c5 = -huge(c5)
327 psh = -huge(psh)
328 t0 = -huge(t0)
329 END SELECT
330 !----update PSH
331 idx_psh_tab = idx_psh_tab + 1
332 psh_tab(idx_psh_tab)=psh
333 !no yield
334 IF(mln == 6)THEN
335 visc = pm_(24) !use submaterial viscosity (if defined with /MAT/LAW6)
336 ELSE
337 visc = uparam(1) !use global viscosity otherwise (if defined with /mat/law51)
338 ENDIF
339 pmin = pm_(37)
340 sph = pm_(69)
341 p0 = c0+c4*e0
342 g = pm_(22)
343 dpdmu = (c1+c5*e0) + c4*(p0)
344 ssp = sqrt( (dpdmu + two_third*g) / rho )
345 pm(27,internal_id) = max( pm(27,internal_id), ssp )
346 !---WRITING LAW51 SUBMATERIAL BUFFER FOR EOS
347 j = uparam(276+i)
348 uparam(idx_av +j) = av(i)
349 uparam(idx_rho +j) = rho
350 uparam(idx_c0 +j) = c0
351 uparam(idx_c1 +j) = c1
352 uparam(idx_c2 +j) = c2
353 uparam(idx_c3(j)) = c3
354 uparam(idx_c4 +j) = c4
355 uparam(idx_c5 +j) = c5
356 uparam(idx_e0 +j) = e0
357 uparam(idx_yield(j)+13)= t0
358 uparam(idx_pm +j) = pmin
359 uparam(idx_yield(j)+12)= sph
360 uparam(idx_yield(j)+24) = ssp
361 uparam(idx_yield(j)+26) = rho*ssp*ssp
362 uparam(idx_visc+j) = visc
363 ENDIF !(MLN/=5)
364
365 SELECT CASE(mln)
366 CASE (5) ! /MAT/JWL
367 !---READING MATERIAL LAW5 BUFFER
368 vdet = pm_(38)
369 pcj = pm_(39)
370 b1 = pm_(33)
371 b2 = pm_(34)
372 r1 = pm_(35)
373 r2 = pm_(36)
374 w = pm_(45)
375 ibfrac = nint(pm_(41))
376 qopt = nint(pm_(42))
377 psh = pm_(88)
378 pm4 = -psh
379 av4 = av(i)
380 rho40 = pm_(1)
381 e04 = pm_(23)
382 c04 = pm_(43)-pm_(88)
383 c14 = pm_(44)
384 tmelt4 = infinity
385 thetl4 = infinity
386 sph4 = one
387 t40 = three100
388 xka4 = em20
389 xkb4 = zero
390 ssp4 = vdet
391 eadd = pm_(160)
392 tbegin = pm_(161)
393 tend = pm_(162)
394 reaction_rate = pm_(163)
395 a_mil = pm_(164)
396 m_mil = pm_(165)
397 n_mil = pm_(166)
398 reaction_rate2 = pm_(167)
399 alpha_unit = pm_(168)
400 !---WRITING LAW51 SUBMATERIAL BUFFER
401 uparam(42) = vdet
402 pm(38,internal_id) = vdet
403 uparam(43) = pcj
404 IF(pcj > em20)THEN
405 uparam(44) = rho40 * vdet**2 / pcj
406 ELSE
407 uparam(44) = infinity
408 END IF
409 uparam(45) = b1
410 vcj = one - one/uparam(44)
411 uparam(46) = av4
412 uparam(47) = rho40
413 IF(uparam(47)==zero) uparam(47) = em20
414 uparam(48) = e04
415 uparam(49) = c04
416 uparam(50) = c14
417 uparam(51) = b2
418 uparam(52) = r1
419 uparam(53) = r2
420 uparam(54) = w
421 uparam(55) = iexp
422 IF(pm4==zero)pm4=-infinity
423 uparam(56) = pm4
424 uparam(68) = ibfrac
425 uparam(258) = tmelt4
426 uparam(259) = thetl4
427 uparam(262) = sph4
428 uparam(263) = t40
429 uparam(264) = xka4
430 uparam(265) = xkb4
431 uparam(273) = ssp4
432 uparam(274) = zero
433 uparam(275) = rho40*ssp4*ssp4
434 uparam(276) = zero
435
436 idx_psh_tab = idx_psh_tab + 1
437 psh_tab(idx_psh_tab) = psh
438 pm(27,internal_id) = max( pm(27,internal_id), ssp4 )
439
440 !MSG - specific case of law5 when used with law 51 (new input format iform=12)
441 IF(c14 <= zero)THEN
442 chain1='BULK MODULUS OF LAW5 (JWL) MUST BE PROVIDED FOR UNREACTED EXPLOSIVE'
443 CALL ancmsg(msgid=99,msgtype=msgerror,anmode=aninfo,i1=user_id,c1=titr,c2=chain1)
444 ENDIF
445
446 CASE(2) ! /MAT/PLAS_JOHNS
447 !yield criteria
448 young = pm_(20)
449 anu = zep2 !PM_(21)
450 g = pm_(22)
451 bulk = pm_(32)
452 pmin = pm_(37)
453 ca = pm_(38)
454 cb = pm_(39)
455 cn = pm_(40)
456 epsm = pm_(41)
457 sigm = pm_(42)
458 cc = pm_(43)
459 eps0 = pm_(44)
460 m = pm_(45)
461 tmelt = pm_(46)
462 tmax = pm_(47)
463 cs = pm_(48)
464 sph = pm_(69)
465 t0 = pm_(79)
466 gg = two*g
467 ssp = sqrt( (dpdmu + two_third*g) / rho )
468 !---WRITING LAW51 SUBMATERIAL BUFFER
469 j = uparam(276+i)
470 uparam(idx_ipla +j) = 1
471 ipla = 1
472 uparam(idx_g +j) = gg
473 uparam(idx_yield(j)+01) = g
474 uparam(idx_yield(j)+02) = ca
475 uparam(idx_yield(j)+03) = cb
476 uparam(idx_yield(j)+04) = cn
477 !specific law4 subcase
478 uparam(idx_yield(j)+05:idx_yield(j)+13)=zero
479 IF(mln == 4)THEN
480 uparam(idx_yield(j)+05) = cc
481 uparam(idx_yield(j)+06) = eps0
482 uparam(idx_yield(j)+07) = m
483 uparam(idx_yield(j)+08) = tmelt
484 uparam(idx_yield(j)+09) = tmax
485 uparam(idx_yield(j)+12) = sph
486 uparam(idx_yield(j)+13) = t0
487 ENDIF
488 uparam(idx_yield(j)+10) = epsm
489 uparam(idx_yield(j)+11) = sigm
490 uparam(idx_yield(j)+14) = zero
491 uparam(idx_yield(j)+15) = zero
492 uparam(idx_yield(j)+16) = zero
493 uparam(idx_yield(j)+17) = zero
494 uparam(idx_yield(j)+18) = zero
495 uparam(idx_yield(j)+19) = zero
496 uparam(idx_yield(j)+20) = zero
497 uparam(idx_yield(j)+21) = zero
498 uparam(idx_yield(j)+22) = anu
499 uparam(idx_yield(j)+23) = -infinity
500 uparam(idx_yield(j)+24) = ssp
501 uparam(idx_yield(j)+25) = zero
502 uparam(idx_yield(j)+26) = rho*ssp*ssp
503
504 CASE(3,4) ! /MAT/HYDPLA, /MAT/HYD_JCOOK
505 !yield criteria
506 young = pm_(20)
507 anu = zep2 !PM_(21)
508 g = pm_(22)
509 bulk = pm_(32)
510 pmin = pm_(37)
511 ca = pm_(38)
512 cb = pm_(39)
513 cn = pm_(40)
514 epsm = pm_(41)
515 sigm = pm_(42)
516 cc = pm_(43)
517 eps0 = pm_(44)
518 m = pm_(45)
519 tmelt = pm_(46)
520 tmax = pm_(47)
521 cs = pm_(48)
522 sph = pm_(69)
523 t0 = pm_(79)
524 gg = two*g
525 ssp = sqrt( (dpdmu + two_third*g) / rho )
526 !---WRITING LAW51 SUBMATERIAL BUFFER
527 j = uparam(276+i)
528 uparam(idx_ipla +j) = 1
529 ipla = 1
530 uparam(idx_g +j) = gg
531 uparam(idx_yield(j)+01) = g
532 uparam(idx_yield(j)+02) = ca
533 uparam(idx_yield(j)+03) = cb
534 uparam(idx_yield(j)+04) = cn
535 !specific law4 subcase
536 uparam(idx_yield(j)+05:idx_yield(j)+13)=zero
537 IF(mln == 4)THEN
538 uparam(idx_yield(j)+05) = cc
539 uparam(idx_yield(j)+06) = eps0
540 uparam(idx_yield(j)+07) = m
541 uparam(idx_yield(j)+08) = tmelt
542 uparam(idx_yield(j)+09) = tmax
543 uparam(idx_yield(j)+12) = sph
544 uparam(idx_yield(j)+13) = t0
545 ENDIF
546 uparam(idx_yield(j)+10) = epsm
547 uparam(idx_yield(j)+11) = sigm
548 uparam(idx_yield(j)+14) = zero
549 uparam(idx_yield(j)+15) = zero
550 uparam(idx_yield(j)+16) = zero
551 uparam(idx_yield(j)+17) = zero
552 uparam(idx_yield(j)+18) = zero
553 uparam(idx_yield(j)+19) = zero
554 uparam(idx_yield(j)+20) = zero
555 uparam(idx_yield(j)+21) = zero
556 uparam(idx_yield(j)+22) = anu
557 uparam(idx_yield(j)+23) = -infinity
558 uparam(idx_yield(j)+24) = ssp
559 uparam(idx_yield(j)+25) = zero
560 uparam(idx_yield(j)+26) = rho*ssp*ssp
561
562 CASE(6) ! /MAT/HYDRO
563 !no yield criteria
564 t0 = three100
565 g = zero
566 gg = zero
567 epsm = zero
568 sigm = zero
569 ca = zero
570 cb = zero
571 cn = zero
572 cc = zero
573 eps0 = zero
574 m = zero
575 tmelt = zero
576 tmax = zero
577 sph = zero
578 anu = zero
579 amx = zero
580 pstar = zero
581 young = zero
582 a0 = zero
583 a1 = zero
584 a2 = zero
585 amx = zero
586 ssp = sqrt( (dpdmu + zero) / rho )
587 !---WRITING LAW51 SUBMATERIAL BUFFER
588 j = uparam(276+i)
589 uparam(idx_ipla +j) = 0
590 uparam(idx_g +j) = gg
591 uparam(idx_yield(j)+01) = g
592 uparam(idx_yield(j)+02) = young
593 uparam(idx_yield(j)+05) = cc
594 uparam(idx_yield(j)+06) = eps0
595 uparam(idx_yield(j)+07) = m
596 uparam(idx_yield(j)+08) = tmelt
597 uparam(idx_yield(j)+09) = tmax
598 uparam(idx_yield(j)+12) = sph
599 uparam(idx_yield(j)+13) = t0
600 uparam(idx_yield(j)+14) = zero
601 uparam(idx_yield(j)+15) = zero
602 uparam(idx_yield(j)+16) = a0
603 uparam(idx_yield(j)+17) = a1
604 uparam(idx_yield(j)+18) = a2
605 uparam(idx_yield(j)+19) = amx
606 uparam(idx_yield(j)+20) = zero
607 uparam(idx_yield(j)+21) = zero
608 uparam(idx_yield(j)+22) = anu
609 uparam(idx_yield(j)+23) = pstar
610 uparam(idx_yield(j)+24) = ssp
611 uparam(idx_yield(j)+25) = zero
612 uparam(idx_yield(j)+26) = rho*ssp*ssp
613
614 CASE(10,102) ! /MAT/DPRAG1, /MAT/DPRAG2
615 !yield criteria
616 IF(mln == 10)THEN
617 young = pm_(20)
618 anu = pm_(21)
619 g = pm_(22)
620 bulk = pm_(32)
621 pmin = pm_(37)
622 a0 = pm_(38)
623 a1 = pm_(39)
624 a2 = pm_(40)
625 amx = pm_(41)
626 pstar = pm_(44)
627 ELSEIF(mln == 102)THEN
628 npar = ipm(9,imid)
629 iadbuf = ipm(7,imid)
630 iadbuf = max(1,iadbuf)
631 uparam_ => bufmat(iadbuf:iadbuf+npar)
632 young = uparam_(10)
633 anu = uparam_(11)
634 g = uparam_(08)
635 bulk = pm_(32)
636 IF(bulk == zero)bulk=third*young/(one-two*anu)
637 pmin = pm_(37)
638 a0 = uparam_(04)
639 a1 = uparam_(05)
640 a2 = uparam_(06)
641 amx = uparam_(07)
642 pstar = uparam_(03)
643 ENDIF
644 gg = two*g
645 ssp = sqrt( (dpdmu + two_third*g) / rho )
646 !---WRITING LAW51 SUBMATERIAL BUFFER
647 j = uparam(276+i)
648 uparam(idx_ipla +j) = 2
649 ipla = 1
650 uparam(idx_g +j) = gg
651 uparam(idx_yield(j)+01) = g
652 uparam(idx_yield(j)+02) = young
653 uparam(idx_yield(j)+14) = zero
654 uparam(idx_yield(j)+15) = zero
655 uparam(idx_yield(j)+16) = a0
656 uparam(idx_yield(j)+17) = a1
657 uparam(idx_yield(j)+18) = a2
658 uparam(idx_yield(j)+19) = amx
659 uparam(idx_yield(j)+20) = zero
660 uparam(idx_yield(j)+21) = zero
661 uparam(idx_yield(j)+22) = anu
662 uparam(idx_yield(j)+23) = pstar
663 uparam(idx_yield(j)+24) = ssp
664 uparam(idx_yield(j)+25) = zero
665 uparam(idx_yield(j)+26) = rho*ssp*ssp
666
667 CASE(133) ! /MAT/GRANULAR
668
669 mlaw_tag(imid)%NVARTMP = 6
670
671 !yield criteria
672 pmin = mat_param(imid)%uparam(1)
673 young = mat_param(imid)%young
674 bulk = mat_param(imid)%bulk
675 anu = mat_param(imid)%nu
676
677 g = young / two / (one+anu)
678 gg = two*g
679 ssp = sqrt( (dpdmu + two_third*gg) / rho )
680 !---WRITING LAW51 SUBMATERIAL BUFFER
681 j = uparam(276+i)
682 uparam(idx_ipla +j) = 3
683 ipla = 1
684 uparam(idx_g +j) = gg
685 uparam(idx_yield(j)+01) = zero
686 uparam(idx_yield(j)+02) = young
687 uparam(idx_yield(j)+14) = real(imid)
688 uparam(idx_yield(j)+15) = zero
689 uparam(idx_yield(j)+16) = zero
690 uparam(idx_yield(j)+17) = zero
691 uparam(idx_yield(j)+18) = zero
692 uparam(idx_yield(j)+19) = zero
693 uparam(idx_yield(j)+20) = zero
694 uparam(idx_yield(j)+21) = zero
695 uparam(idx_yield(j)+22) = anu
696 uparam(idx_yield(j)+23) = zero
697 uparam(idx_yield(j)+24) = ssp
698 uparam(idx_yield(j)+25) = zero
699 uparam(idx_yield(j)+26) = rho*ssp*ssp
700
701 CASE DEFAULT
702 !not expected, pre-condition tested above, error message if MLN is not relevant
703
704 END SELECT
705
706 enddo! next SUBMAT
707
708 pm(91,internal_id)=rho_max
709
710 !CHECK CONSISTENCY OF PSH PARAMETERS
711 IF(idx_psh_tab > 0)THEN
712 tmp1=minval(psh_tab(1:idx_psh_tab))
713 tmp2=maxval(psh_tab(1:idx_psh_tab))
714 IF(tmp1 == tmp2)THEN
715 pext = tmp1
716 ELSE
717 chain1='SUBMATERIAL EOS MUST HAVE CONSISTENT PSH PARAMETERS'
718 CALL ancmsg(msgid=99,msgtype=msgerror,anmode=aninfo,i1=user_id,c1=titr,c2=chain1)
719 ENDIF
720 uparam(8) = pext
721 ENDIF
722C-----------------------------------------------
723C Default
724C-----------------------------------------------
725 !ABCS
726 IF(uparam(38)==zero) uparam(38)=one
727 !SPH
728 IF(uparam(112)==zero) uparam(112)=one
729 IF(uparam(162)==zero) uparam(162)=one
730 IF(uparam(212)==zero) uparam(212)=one
731 IF(uparam(262)==zero) uparam(262)=one
732 !JCOOK EXPONENT
733 IF(uparam(104)==zero) uparam(104)=one
734 IF(uparam(154)==zero) uparam(154)=one
735 IF(uparam(204)==zero) uparam(204)=one
736 !IF(UPARAM(254)==ZERO) UPARAM(254)=ONE
737 !INITIAL TEMPERATURE
738 IF(uparam(113)==zero) uparam(113)=three100
739 IF(uparam(163)==zero) uparam(163)=three100
740 IF(uparam(213)==zero) uparam(213)=three100
741 IF(uparam(263)==zero) uparam(263)=three100
742 !MAXIMUM PLASTIC STRAIN
743 IF(uparam(110)==zero) uparam(110)=infinity
744 IF(uparam(160)==zero) uparam(160)=infinity
745 IF(uparam(210)==zero) uparam(210)=infinity
746 !IF(UPARAM(260)==ZERO) UPARAM(260)=INFINITY
747 !MAXIMUM STRESS
748 IF(uparam(111)==zero) uparam(111)=infinity
749 IF(uparam(161)==zero) uparam(161)=infinity
750 IF(uparam(211)==zero) uparam(211)=infinity
751 !IF(UPARAM(261)==ZERO) UPARAM(261)=INFINITY
752 !MELTING TEMPERATURE
753 IF(uparam(108)==zero) uparam(108)=infinity
754 IF(uparam(158)==zero) uparam(158)=infinity
755 IF(uparam(208)==zero) uparam(208)=infinity
756 IF(uparam(258)==zero) uparam(258)=infinity
757 !LIMIT TEMPERATURE
758 IF(uparam(109)==zero) uparam(109)=infinity
759 IF(uparam(159)==zero) uparam(159)=infinity
760 IF(uparam(209)==zero) uparam(209)=infinity
761 IF(uparam(259)==zero) uparam(259)=infinity
762 !THERMAL CONDUCTIVITY
763 IF(uparam(114)==zero) uparam(114)=em20
764 IF(uparam(164)==zero) uparam(164)=em20
765 IF(uparam(214)==zero) uparam(214)=em20
766 IF(uparam(264)==zero) uparam(264)=em20
767 !JCOOK EPS_DOT_REF
768 IF(uparam(106)==zero) uparam(106)=one
769 IF(uparam(156)==zero) uparam(156)=one
770 IF(uparam(206)==zero) uparam(206)=one
771 !IF(UPARAM(256)==ZERO) UPARAM(256)=ONE
772 !DPRAG MUMAX
773 IF(uparam(119)==zero) uparam(119)=infinity
774 IF(uparam(169)==zero) uparam(169)=infinity
775 IF(uparam(219)==zero) uparam(219)=infinity
776 !IF(UPARAM(269)==ZERO) UPARAM(269)=INFINITY
777 !DPRAG POISSON RATIO
778 IF(uparam(122)==zero) uparam(122)=zep2
779 IF(uparam(172)==zero) uparam(172)=zep2
780 IF(uparam(222)==zero) uparam(222)=zep2
781 !IF(UPARAM(272)==ZERO) UPARAM(272)=ZEP2
782 !Drucker-Prager unload modulus
783 IF(uparam(121) == zero) uparam(121) = uparam(12)
784 IF(uparam(171) == zero) uparam(171) = uparam(13)
785 IF(uparam(221) == zero) uparam(221) = uparam(14)
786
787 !E_INF
788 pext = zero
789 e1_inf = ie_bound(pext,uparam(39),uparam(35),uparam(12),uparam(15),uparam(18),uparam(22),uparam(25),uparam(32))
790 e2_inf = ie_bound(pext,uparam(40),uparam(36),uparam(13),uparam(16),uparam(20),uparam(23),uparam(26),uparam(33))
791 e3_inf = ie_bound(pext,uparam(41),uparam(37),uparam(14),uparam(17),uparam(21),uparam(24),uparam(27),uparam(34))
792 e4_inf = zero
793 uparam(57) = e1_inf
794 uparam(58) = e2_inf
795 uparam(59) = e3_inf
796 uparam(60) = e4_inf
797
798
799
800 !GLOBAL PARAMETERS
801 !IF(UPARAM(30)==ZERO) UPARAM(30)=ZEP2
802 uparam(62) = em03
803 uparam(69) = uparam(9)*uparam(4) + uparam(10)*uparam(5) + uparam(11)*uparam(6) + uparam(47)*uparam(46)
804 !UPARAM(31) = 1
805 uparam(72) = infinity
806 IF(uparam(43) <= em20) uparam(44)=infinity
807 IF(uparam(47)==zero) uparam(47) = em20
808 IF(uparam(56)==zero) uparam(56)=-infinity
809 uparam(63) = ipla
810
811 ratio=uparam(74)
812 IF(ratio <= zero)THEN
813 ratio = 0.25d00 !ONE is for previous formulation (permitted large volume change)
814 uparam(74)=ratio
815 ENDIF
816
817 niter=uparam(73)
818 IF(niter == 0)THEN
819 niter=10
820 uparam(73)=niter
821 ENDIF
822C-----------------------------------------------
823
824 RETURN
825 END SUBROUTINE
my_real
#define my_real
Definition cppsort.cpp:32
if
if(complex_arithmetic) id
fill_buffer_51
subroutine fill_buffer_51(ipm, pm, uparam, bufmat, user_id, titr, internal_id, mat_param, mlaw_tag)
Definition fill_buffer_51.F:36
ie_bound
function ie_bound(pext, pm, c0, c1, c2, c3, c4, c5, e0)
Definition ie_bound.F:30
max
#define max(a, b)
Definition macros.h:21
elbuftag_mod
Definition elbuftag_mod.F:227
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
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
elbuftag_mod::mlaw_tag_
Definition elbuftag_mod.F:232