46
47
48
49#include "implicit_f.inc"
50
51
52
53 INTEGER :: NEL, NUPARAM, NUVAR,ISMSTR,NGL(*),IHET,IEXPAN
54 my_real :: time , timestep , uparam(nuparam)
55 my_real ,
DIMENSION(NEL) :: rho , rho0 , volume, eint,
56 . epspxx, epspyy, epspzz, epspxy,
57 . epspyz, epspzx, depsxx, depsyy,
58 . depszz, depsxy, depsyz, depszx,
59 . epsxx , epsyy , epszz , epsxy ,
60 . epsyz , epszx , sigoxx,
61 . sigozz, sigoxy, sigoyz, sigozx
62 . offg , epsth3,
63 . mfxx , mfxy , mfxz , mfyx ,
64 . mfyy , mfyz , mfzx , mfzy ,
65 . mfzz
66
67
68
69 my_real ,
DIMENSION(NEL) :: signxx , signyy , signzz,
70 . signxy , signyz , signzx,
71 . sigvxx , sigvyy , sigvzz,
72 . sigvxy , sigvyz , sigvzx,
73 . soundsp, viscmax, et
74
75
76
78 my_real ,
DIMENSION(NEL,NUVAR) :: uvar
79
80
81
82 INTEGER :: NPF(*), NFUNC, IFUNC(NFUNC)
83 my_real :: finter,fintte,tf(*),fint2v
84 EXTERNAL finter,fintte
85
86
87
88 INTEGER :: I,J,ITEST,ONLY_TENSION_DATA
89 INTEGER , DIMENSION(NEL) :: ICOMP
90 my_real :: dw_di,l2,l3,l5,delta,
91 . g,rbulk,scale,t,epst,df,du,
92 . trace,p,fac,invjdetf,nu,gini,rbulkini,diff
93 my_real :: b(nel,6),lam2(nel,3),
94 . lambda(nel,3),evd(3),bd(nel,6)
95 my_real ,
DIMENSION(NEL) :: jdetf,i1,i1b,lamt,j2third,
96 . t1,t2,t3,eti,gs,k
97 my_real,
DIMENSION(NEL,3,3) :: f,fft
98
99
100
101
102
103 nu = uparam(1)
104 itest = nint(uparam(2))
105 scale = uparam(3)
106 g = uparam(4)
107 rbulk = uparam(5)
108 gini = uparam(6)
109 only_tension_data = nint(uparam(7))
110
111 DO i=1,nel
112 f(i,1,1) = one + mfxx(i)
113 f(i,2,2) = one + mfyy(i)
114 f(i,3,3) = one + mfzz(i)
115 f(i,1,2) = mfxy(i)
116 f(i,2,3) = mfyz(i)
117 f(i,3,1) = mfzx(i)
118 f(i,2,1) = mfyx(i)
119 f(i,3,2) = mfzy(i)
120 f(i,1,3) = mfxz(i)
121 ENDDO
122
124
125 DO i=1,nel
126 b(i,1) = fft(i,1,1)
127 b(i,2) = fft(i,2,2)
128 b(i,3) = fft(i,3,3)
129 b(i,4) = fft(i,1,2)
130 b(i,5) = fft(i,2,3)
131 b(i,6) = fft(i,3,1)
132 ENDDO
133 icomp(1:nel) = 0
134 DO i = 1,nel
135
136 jdetf(i) = f(i,1,1)*f(i,2,2)*f(i,3,3) - f(i,1,1)*f(i,2,3)*f(i,3,2)
137 . - f(i,3,3)*f(i,1,2)*f(i,2,1) + f(i,1,2)*f(i,2,3)*f(i,3,1)
138 . + f(i,2,1)*f(i,3,2)*f
139
140 i1b(i) = fft(i,1,1) + fft
141
142 IF (jdetf(i) > zero) THEN
143 j2third(i) = exp((-two_third )*log(jdetf(i)))
144 ELSE
145 j2third(i) = zero
146 ENDIF
147
148 trace = (b(i,1)+b(i,2)+ b(i,3))*third
149 bd(i,1) = j2third(i)*(b(i,1) - trace)
150 bd(i,2) = j2third(i)*(b(i,2) - trace)
151 bd(i,3) = j2third(i)*(b(i,3) - trace)
152 bd(i,4:6) = j2third(i)*b(i,4:6)
153 i1(i) = j2third(i)*i1b(i)
154 ENDDO
155
156 IF(only_tension_data == 0) THEN
157 DO i = 1,nel
158 diff = jdetf(i) - one
159 IF(diff < zero) icomp(i) = 1
160 ENDDO
161 ENDIF
162
163 SELECT CASE (itest)
164
165 CASE (1)
166
167
168
169
171
172 DO i=1,nel
173 invjdetf = one/
max(em20, jdetf(i))
174 epst = lamt(i) - one
175 t = scale*finter(ifunc(1),epst,npf
176 l2 = lamt(i)**2
177 dw_di = zero
178 IF (i1b(i) == three .OR. lamt(i) == one) THEN
179 dw_di = zero
180 ELSEIF((lamt(i)*l2 - one) /= zero)THEN
181 dw_di = t*l2 / (lamt(i)*l2 - one)
182 ENDIF
183 gs(i)=
max(gini,df*scale)
184 k(i) = two*gs(i)*(one+nu) /
max(em20,three*(one-two*nu))
185 p = rbulk*(jdetf(i) - one)
186 signxx(i) = invjdetf*dw_di * bd(i,1) + p
187 signyy(i) = invjdetf*dw_di * bd(i,2) + p
188 signzz(i) = invjdetf*dw_di * bd(i,3) + p
189 signxy(i) = invjdetf*dw_di * bd(i,4)
190 signyz(i) = invjdetf*dw_di * bd(i,5)
191 signzx(i) = invjdetf*dw_di * bd(i,6)
192 uvar(i,1) = lamt(i) - one
193 uvar(i,2) = jdetf(i)*signzz(i) / lamt(i)
194 ENDDO
195 CASE(2)
196
197
198
199
200
201
203
204 DO i=1,nel
205 invjdetf = one/
max(em20, jdetf(i))
206 lamt(i) = one/
max(em20,lamt
207 lamt(i) = sqrt(lamt(i))
208 epst = lamt(i) - one
209 t = scale*finter(ifunc(1),epst,npf,tf,df)
210 l5 = lamt(i)**(-5)
211 dw_di = zero
212 IF (i1b(i) == three .OR. lamt(i) == oneTHEN
213 dw_di = zero
214 ELSEIF((lamt(i) - l5) /= zero) THEN
215 dw_di = t / (lamt(i) - l5)
216 ENDIF
217 gs(i)=
max(gini,df*scale)
218 k(i) = two*gs(i)*(one+nu) /
max(em20,three*(one-two*nu))
219 p = rbulk*(jdetf(i) - one)
220 signxx(i) = invjdetf*dw_di * bd(i,1) + p
221 signyy(i) = invjdetf*dw_di * bd(i,2) + p
222 signzz(i) = invjdetf*dw_di * bd(i,3) + p
223 signxy(i) = invjdetf*dw_di * bd(i,4)
224 signyz(i) = invjdetf*dw_di * bd(i,5)
225 signzx(i) = invjdetf*dw_di * bd(i,6)
226 uvar(i,1) = lamt(i) - one
227 uvar(i,2) = jdetf(i)*signzz(i) / lamt(i)
228 ENDDO
229 CASE(3)
230
231
232
233
234
235
236 DO i=1,nel
237 delta = (one - i1(i)) ** 2 - four
238 lamt(i) = one
239 IF(delta > 0) THEN
240 lamt(i) = half*
max(i1(i)+ sqrt(delta) - one ,i1(i) - sqrt(delta) - one)
241 ELSEIF(delta == zero) THEN
242 lamt(i) = half*(i1(i) - one)
243 ENDIF
244 ENDDO
245
246 DO i=1,nel
247 invjdetf= one/
max(em20, jdetf(i))
248 lamt(i) = sqrt(
max(zero,lamt(i)))
249 epst = lamt(i) - one
250 t = scale*finter(ifunc(1),epst,npf,tf,df)
251 l3 = lamt(i)**(-3)
252 dw_di = zero
253 IF (i1b(i) == three .OR. lamt(i) == one) THEN
254 dw_di = zero
255 ELSEIF((lamt(i) - l3) /= zero) THEN
256 dw_di = t / (lamt(i) - l3)
257 ENDIF
258 gs(i)=
max(gini,df*scale)
259 k(i) = two*gs(i)*(one+nu) /
max(em20,three*(one-two*nu))
260 p = rbulk*(jdetf(i) - one)
261 signxx(i) = invjdetf*dw_di * bd(i,1) + p
262 signyy(i) = invjdetf*dw_di * bd(i,2) + p
263 signzz(i) = invjdetf*dw_di * bd(i,3) + p
264 signxy(i) = invjdetf*dw_di * bd(i,4)
265 signyz(i) = invjdetf*dw_di * bd(i,5)
266 signzx(i) = invjdetf*dw_di * bd(i,6)
267 uvar(i,1) = lamt(i) - one
268 uvar(i,2) = -jdetf(i)*signzx(i) / lamt(i)
269 ENDDO
270 END SELECT
271
272 IF (ihet > 1) THEN
273 DO i=1,nel
274 et(i) =
max(one, gs(i)/gini)
275 ENDDO
276 ENDIF
277
278 DO i=1,nel
279 soundsp(i) = sqrt((four_over_3*g + rbulk)/rho(i))
280 viscmax(i) = zero
281 ENDDO
282
283 RETURN
subroutine prodaat(a, c, nel)
subroutine cardan_method(itest, nel, i1, icomp, lamt)