41
42
43
44#include "implicit_f.inc"
45
46
47
48
49
50
51 INTEGER, INTENT(IN) :: NEL
52 INTEGER IKSUP
54 . px1(*), px2(*), px3(*), px4(*),
55 . py1(*), py2(*), py3(*), py4(*),
56 . pz1(*), pz2(*), pz3(*), pz4(*),
57 . k11(9,*) ,k12(9,*) ,k13(9,*) ,k14(9,*) ,k22(9,*) ,
58 . k23(9,*) ,k24(9,*) ,k33(9,*) ,k34(9,*) ,k44(9,*) ,
59 . dd(3,3,*),gg(*),dg(9,*) ,g33(9,*)
60
61
62
63 INTEGER IS
64
65
66 is =1
67 CALL s8zked3(1,nel,px1, py1 ,pz1 ,px1, py1, pz1, dd, k11,is)
68 CALL s8zked3(1,nel,px2, py2 ,pz2 ,px2, py2, pz2, dd, k22,is)
69 CALL s8zked3(1,nel,px3, py3 ,pz3 ,px3, py3, pz3, dd, k33,is)
70 CALL s8zked3(1,nel,px4, py4 ,pz4 ,px4, py4, pz4, dd, k44,is)
71
72 IF (iksup==0) THEN
73 CALL s8zkeg3(1,nel,py1, px1 ,pz1,px1 ,pz1,py1,
74 . py1, px1 ,pz1,px1 ,pz1,py1,gg,k11,is)
75 CALL s8zkeg3(1,nel,py2, px2 ,pz2,px2 ,pz2,py2,
76 . py2, px2 ,pz2,px2 ,pz2,py2,gg,k22,is)
77 CALL s8zkeg3(1,nel,py3, px3 ,pz3,px3 ,pz3,py3,
78 . py3, px3 ,pz3,px3 ,pz3,py3,gg,k33,is)
79 CALL s8zkeg3(1,nel,py4, px4 ,pz4,px4 ,pz4,py4,
80 . py4, px4 ,pz4,px4 ,pz4,py4,gg,k44,is)
81 ENDIF
82
83 is =0
84 CALL s8zked3(1,nel,px1, py1 ,pz1 ,px2, py2, pz2, dd, k12,is)
85 CALL s8zked3(1,nel,px1, py1 ,pz1 ,px3, py3, pz3, dd, k13,is)
86 CALL s8zked3(1,nel,px1, py1 ,pz1 ,px4, py4, pz4, dd, k14,is)
87 CALL s8zked3(1,nel,px2, py2 ,pz2 ,px3, py3, pz3, dd, k23,is)
88 CALL s8zked3(1,nel,px2, py2 ,pz2 ,px4, py4, pz4, dd, k24,is)
89 CALL s8zked3(1,nel,px3, py3 ,pz3 ,px4, py4, pz4, dd, k34,is)
90
91 IF (iksup==0) THEN
92 CALL s8zkeg3(1,nel,py1, px1 ,pz1,px1 ,pz1,py1,
93 . py2, px2 ,pz2,px2 ,pz2,py2,gg,k12,is)
94 CALL s8zkeg3(1,nel,py1, px1 ,pz1,px1 ,pz1,py1,
95 . py3, px3 ,pz3,px3 ,pz3,py3,gg,k13,is)
96 CALL s8zkeg3(1,nel,py1, px1 ,pz1,px1 ,pz1,py1,
97 . py4, px4 ,pz4,px4 ,pz4,py4,gg,k14,is)
98 CALL s8zkeg3(1,nel,py2, px2 ,pz2,px2 ,pz2,py2,
99 . py3, px3 ,pz3,px3 ,pz3,py3,gg,k23,is)
100 CALL s8zkeg3(1,nel,py2, px2 ,pz2,px2 ,pz2,py2,
101 . py4, px4 ,pz4,px4 ,pz4,py4,gg,k24,is)
102 CALL s8zkeg3(1,nel,py3, px3 ,pz3,px3 ,pz3,py3,
103 . py4, px4 ,pz4,px4 ,pz4,py4,gg,k34,is)
104 ELSE
105 CALL s8zkeg33(1,nel,py1, px1 ,pz1,px1 ,pz1,py1,
106 . py2, px2 ,pz2,px2 ,pz2,py2,g33,k12,is)
107 CALL s8zkeg33(1,nel,py1, px1 ,pz1,px1 ,pz1,py1,
108 . py3, px3 ,pz3,px3 ,pz3,py3,g33,k13,is)
109 CALL s8zkeg33(1,nel,py1, px1 ,pz1,px1 ,pz1,py1,
110 . py4, px4 ,pz4,px4 ,pz4,py4,g33,k14,is)
111 CALL s8zkeg33(1,nel,py2, px2 ,pz2,px2 ,pz2,py2,
112 . py3, px3 ,pz3,px3 ,pz3,py3,g33,k23,is)
113 CALL s8zkeg33(1,nel,py2, px2 ,pz2,px2 ,pz2,py2,
114 . py4, px4 ,pz4,px4 ,pz4,py4,g33,k24,is)
115 CALL s8zkeg33(1,nel,py3, px3 ,pz3,px3 ,pz3,py3,
116 . py4, px4 ,pz4,px4 ,pz4,py4,g33,k34,is)
117
118 CALL s8zkebg1(1,nel,px1, py1 ,pz1 ,px2, py2, pz2, dg, k12,is)
119 CALL s8zkebg1(1,nel,px1, py1 ,pz1 ,px3, py3, pz3, dg, k13,is)
120 CALL s8zkebg1(1,nel,px1, py1 ,pz1 ,px4, py4, pz4, dg, k14,is)
121 CALL s8zkebg1(1,nel,px2, py2 ,pz2 ,px3, py3, pz3, dg, k23,is)
122 CALL s8zkebg1(1,nel,px2, py2 ,pz2 ,px4, py4, pz4, dg, k24,is)
123 CALL s8zkebg1(1,nel,px3, py3 ,pz3 ,px4, py4, pz4, dg, k34,is)
124 is =1
125 CALL s8zkebg1(1,nel,px1, py1 ,pz1 ,px1, py1, pz1, dg, k11,is)
126 CALL s8zkebg1(1,nel,px2, py2 ,pz2 ,px2, py2, pz2, dg, k22,is)
127 CALL s8zkebg1(1,nel,px3, py3 ,pz3 ,px3, py3, pz3, dg, k33,is)
128 CALL s8zkebg1(1,nel,px4, py4 ,pz4 ,px4, py4, pz4, dg, k44,is)
129
130 CALL s8zkeg33(1,nel,py1, px1 ,pz1,px1 ,pz1,py1,
131 . py1, px1 ,pz1,px1 ,pz1,py1,g33,k11,is)
132 CALL s8zkeg33(1,nel,py2, px2 ,pz2,px2 ,pz2,py2,
133 . py2, px2 ,pz2,px2 ,pz2,py2,g33,k22,is)
134 CALL s8zkeg33(1,nel,py3, px3 ,pz3,px3 ,pz3,py3,
135 . py3, px3 ,pz3,px3 ,pz3,py3,g33,k33,is)
136 CALL s8zkeg33(1,nel,py4, px4 ,pz4,px4 ,pz4,py4,
137 . py4, px4 ,pz4,px4 ,pz4,py4,g33,k44,is)
138 ENDIF
139
140 RETURN
subroutine s8zkebg1(lft, llt, pxi, pyi, pzi, pxj, pyj, pzj, dg, kij, is)
subroutine s8zked3(lft, llt, pxi, pyi, pzi, pxj, pyj, pzj, dd, kij, is)
subroutine s8zkeg33(lft, llt, pxyi, pyxi, pxzi, pzxi, pyzi, pzyi, pxyj, pyxj, pxzj, pzxj, pyzj, pzyj, g33, kij, is)
subroutine s8zkeg3(lft, llt, pxyi, pyxi, pxzi, pzxi, pyzi, pzyi, pxyj, pyxj, pxzj, pzxj, pyzj, pzyj, g, kij, is)