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