32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54#include "implicit_f.inc"
55#include "comlock.inc"
56
57
58
59#include "param_c.inc"
60#include "com04_c.inc"
61#include "com06_c.inc"
62#include "com08_c.inc"
63#include "vect01_c.inc"
64#include "scr06_c.inc"
65
66
67
68 INTEGER MAT(NEL), IFLAG, NEL
70 . off(nel) ,eint(nel) ,mu(nel) ,
71 . mu2(nel) ,espe(nel) ,dvol(nel) ,df(nel) ,
72 . vnew(nel) ,pnew(nel) ,dpdm(nel),
73 . dpde(nel)
74 my_real,
INTENT(INOUT) :: psh(nel)
75
76
77
78 INTEGER I,MX,IBFRAC
80 . rho0 , aa , bb , r1,
81 . r2, w1, bhe, p0, bulk,
82 . r1df,r2df,er1df,er2df,dpdmu
83
84
85
86
87 IF(iflag == 0THEN
88
89 ELSEIF(iflag == 1) THEN
90
91 ELSEIF(iflag == 2) THEN
92 mx = mat(1)
93 rho0 = pm( 1,mx)
94 aa = pm(33,mx)
95 bb = pm(34,mx)
96 r1 = pm(35,mx)
97 r2 = pm(36,mx)
98 w1 = pm(45,mx)
99 vdet = pm(38,mx)
100 bhe = pm(40,mx)
101 p0 = pm(31,mx)
102 bulk = pm(44,mx)
103 ibfrac = nint(pm(41,mx))
104 psh(1:nel) = pm(88,mx)
105 DO i=1,nel
106 bfrac(i)=one
107 ENDDO
108 DO i=1, nel
109 IF (vnew(i) > zero) THEN
110 r1df = r1*df(i)
111 r2df = r2*df(i)
112 er1df = exp(-r1df)
113 er2df = exp(-r2df)
114 pnew(i) = - psh(i) + aa*(one-w1/r1df)*er1df + bb*(one-w1/r2df)*er2df + w1*espe(i)/df(i)
115 pnew(i) =
max(zero - psh(i), pnew(i))
116
117
118
119 dpde(i) = w1/df(i)
120 dpdmu =
121 . -aa*w1*er1df/r1 + aa*(one-w1/(r1df))*r1df*r1df*er1df
122 . -bb*w1*er2df/r2 + bb*(one-w1/(r2df))*r2df*r2df*er2df
123 . +w1*espe(i)
124 dpdm(i) = dpdmu + (pnew(i)+psh(i))*df(i)*df(i)*dpde(i)
125 ENDIF
126 ENDDO
127 ENDIF
128
129
130 RETURN