33
34
35
36#include "implicit_f.inc"
37
38
39
40 INTEGER,INTENT(INOUT) :: IER
41 my_real,
INTENT(INOUT) :: n1, n2, n3, ssc, ttc
43 my_real,
INTENT(INOUT) :: xx1(4), xx2(4),xx3(4),xs1,ys1,zs1,xc,yc,zc
44
45
46
48 . h(4), x0, y0, z0, xl1, xl2, xl3, xl4, yy1, yy2, yy3, yy4
49 . zz1, zz2, zz3, zz4, xi1, xi2, xi3, xi4, yi1, yi2, yi3, yi4,
50 . zi1, zi2, zi3, zi4, xn1, yn1, zn1, xn2, yn2, zn2, xn3, yn3,
51 . zn3, xn4, yn4, zn4, an,
area, a12, a23, a34, a41, b12, b23,
52 . b34, b41, ab1, ab2, tp, tm, sp, sm, x1,x2,x3,x4,
53 . y1,y2,y3,y4,z1,z2,z3,z4,xi,yi,zi
54
55
56
57
58 xi = xs1
59 yi = ys1
60 zi = zs1
61
62
63 x1 = xx1(1)
64 x2 = xx1(2)
65 x3 = xx1(3)
66 x4 = xx1(4)
67 y1 = xx2(1)
68 y2 = xx2(2)
69 y3 = xx2(3)
70 y4 = xx2(4)
71 z1 = xx3(1)
72 z2 = xx3(2)
73 z3 = xx3(3)
74 z4 = xx3(4)
75
76 x0 = fourth*(x1+x2+x3+x4)
77 y0 = fourth*(y1+y2+y3+y4)
78 z0 = fourth*(z1+z2+z3+z4)
79
80 xl1 = x1-x0
81 xl2 = x2-x0
82 xl3 = x3-x0
83 xl4 = x4-x0
84 yy1 = y1-y0
85 yy2 = y2-y0
86 yy3 = y3-y0
87 yy4 = y4-y0
88 zz1 = z1-z0
89 zz2 = z2-z0
90 zz3 = z3-z0
91 zz4 = z4-z0
92
93 xi1 = x1-xi
94 xi2 = x2-xi
95 xi3 = x3-xi
96 xi4 = x4-xi
97 yi1 = y1-yi
98 yi2 = y2-yi
99 yi3 = y3-yi
100 yi4 = y4-yi
101 zi1 = z1-zi
102 zi2 = z2-zi
103 zi3 = z3-zi
104 zi4 = z4-zi
105
106
107 xn1 = yy1*zz2 - yy2*zz1
108 yn1 = zz1*xl2 - zz2*xl1
109 zn1 = xl1*yy2 - xl2*yy1
110 n1 = xn1
111 n2 = yn1
112 n3 = zn1
113
114 xn2 = yy2*zz3 - yy3*zz2
115 yn2 = zz2*xl3 - zz3*xl2
116 zn2 = xl2*yy3 - xl3*yy2
117 n1 = n1+xn2
118 n2 = n2+yn2
119 n3 = n3+zn2
120
121 xn3 = yy3*zz4 - yy4*zz3
122 yn3 = zz3*xl4 - zz4*xl3
123 zn3 = xl3*yy4 - xl4*yy3
124 n1 = n1+xn3
125 n2 = n2+yn3
126 n3 = n3+zn3
127
128 xn4 = yy4*zz1 - yy1*zz4
129 yn4 = zz4*xl1 - zz1*xl4
130 zn4 = xl4*yy1 - xl1*yy4
131 n1 = n1+xn4
132 n2 = n2+yn4
133 n3 = n3+zn4
134
135 an =
max(em20,sqrt(n1*n1+n2*n2+n3*n3))
136 n1 = n1/an
137 n2 = n2/an
138 n3 = n3/an
139
140 IF(an<=em19) THEN
141 ier=-1
142 RETURN
143 ENDIF
145 a12 = (n1*xn1+n2*yn1+n3*zn1)
146 a23 = (n1*xn2+n2*yn2+n3*zn2)
147 a34 = (n1*xn3+n2*yn3+n3*zn3)
148 a41 = (n1*xn4+n2*yn4+n3*zn4)
149
150
151 xn1 = yi1*zi2 - yi2*zi1
152 yn1 = zi1*xi2 - zi2*xi1
153 zn1 = xi1*yi2 - xi2*yi1
154 b12 = (n1*xn1+n2*yn1+n3*zn1)
155
156 xn2 = yi2*zi3 - yi3*zi2
157 yn2 = zi2*xi3 - zi3*xi2
158 zn2 = xi2*yi3 - xi3*yi2
159 b23 = (n1*xn2+n2*yn2+n3*zn2)
160
161 xn3 = yi3*zi4 - yi4*zi3
162 yn3 = zi3*xi4 - zi4*xi3
163 zn3 = xi3*yi4 - xi4*yi3
164 b34 = (n1*xn3+n2*yn3+n3*zn3)
165
166 xn4 = yi4*zi1 - yi1*zi4
167 yn4 = zi4*xi1 - zi1*xi4
168 zn4 = xi4*yi1 - xi1*yi4
169 b41 = (n1*xn4+n2*yn4+n3*zn4)
170
171 ab1 = a23*b41
172 ab2 = b23*a41
173 IF(abs(ab1+ab2)/
area>em10)
THEN
174 ssc = (ab1-ab2)/(ab1+ab2)
175 ELSE
176 ssc = zero
177 ENDIF
178
179 IF(abs(a34/
area)>em10)
THEN
180 ab1 = b12*a34
181 ab2 = b34*a12
182 ttc = (ab1-ab2)/(ab1+ab2)
183 ELSE
184 ttc = (b12-a12)/a12
185 IF(b23<=zero .AND. b41<=zero)THEN
186 IF(-b23/a12<=alp.AND.-b41/a12<=alp)ssc=zero
187 ELSEIF(b23<=zero)THEN
188 IF(-b23/a12<=alp)ssc=one
189 ELSEIF(b41<=zero)THEN
190 IF(-b41/a12<=alp)ssc=-one
191 ENDIF
192 ENDIF
193
194
195 IF(abs(ssc)>one+alp.OR.abs(ttc)>one+alp) THEN
196 ier = 1
197 ELSE
198 ier = 0
199 IF(abs(ssc)>one)ssc=ssc/abs(ssc)
200 IF(abs(ttc)>one)ttc=ttc/abs(ttc)
201 ENDIF
202
203 tp = fourth*(one+ttc)
204 tm = fourth*(one-ttc)
205 sp = one+ssc
206 sm = one-ssc
207 h(1) = tm*sm
208 h(2) = tm*sp
209 h(3) = tp*sp
210 h(4) = tp*sm
211 xc = h(1)*x1+h(2)*x2+h(3)*x3+h(4)*x4
212 yc = h(1)*y1+h(2)*y2+h(3)*y3+h(4)*y4
213 zc = h(1)*z1+h(2)*z2+h(3)*z3+h(4)*z4
214
215 RETURN
subroutine area(d1, x, x2, y, y2, eint, stif0)