OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
cbasumg3.F File Reference
#include "implicit_f.inc"
#include "mvsiz_p.inc"
#include "vectorize.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine cbasumg3 (jft, jlt, vqn, vq, nplat, iplat, k11, k12, k13, k14, k22, k23, k24, k33, k34, k44, m11, m12, m13, m14, m22, m23, m24, m33, m34, m44, mf11, mf12, mf13, mf14, mf22, mf23, mf24, mf33, mf34, mf44, fm12, fm13, fm14, fm23, fm24, fm34, ke11, ke22, ke33, ke44, ke12, ke13, ke14, ke23, ke24, ke34, vcore, idril, iorth)
subroutine cbatran3 (jft, jlt, vqi, kk, vqj, isym)
subroutine cbatran2 (jft, jlt, vqi, kk, vqj, isym)
subroutine cbatran32 (jft, jlt, vqi, kk, vqj)
subroutine cbatran23 (jft, jlt, vqi, kk, vqj)
subroutine cbatran232 (jft, jlt, vqi, kk, vqj)
subroutine cbatran223 (jft, jlt, vqi, kk, vqj)
subroutine cbatran233 (jft, jlt, vqi, kk, vqj)
subroutine cbaprojk (jft, jlt, vqn, vq, k11, k12, k13, k14, k22, k23, k24, k33, k34, k44, m11, m12, m13, m14, m22, m23, m24, m33, m34, m44, mf11, mf12, mf13, mf14, mf22, mf23, mf24, mf33, mf34, mf44, fm12, fm13, fm14, fm23, fm24, fm34, corelv, z1)
subroutine set_rsj1 (r1, r2, r3, r4, z1, jft, jlt, corelv)
subroutine set_ri33 (xi, yi, zi, ri, jft, jlt)
subroutine setprojkba (dr, r1, r2, r3, r4, k11, k12, k13, k14, k22, k23, k24, k33, k34, k44, m11, m12, m13, m14, m22, m23, m24, m33, m34, m44, mf11, mf12, mf13, mf14, mf22, mf23, mf24, mf33, mf34, mf44, fm12, fm13, fm14, fm23, fm24, fm34, vq, vqn, jft, jlt)
subroutine tranqikqj33 (jft, jlt, ri, rd, rj, kd, isym)
subroutine tranqnkq (jft, jlt, vqn, kq)
subroutine cn4sumg3 (jft, jlt, iplat, k11, k12, k13, k14, k22, k23, k24, k33, k34, k44, m11, m12, m13, m14, m22, m23, m24, m33, m34, m44, mf11, mf12, mf13, mf14, mf22, mf23, mf24, mf33, mf34, mf44, fm12, fm13, fm14, fm23, fm24, fm34, ke11, ke22, ke33, ke44, ke12, ke13, ke14, ke23, ke24, ke34)
subroutine impkctmp (jft, jlt, iugeo, ke11, ke12, ke13, ke14, ke22, ke23, ke24, ke33, ke34, ke44)
subroutine writekc4 (in, jft, jlt, ch, kij)

Function/Subroutine Documentation

◆ cbaprojk()

subroutine cbaprojk ( integer jft,
integer jlt,
vqn,
vq,
k11,
k12,
k13,
k14,
k22,
k23,
k24,
k33,
k34,
k44,
m11,
m12,
m13,
m14,
m22,
m23,
m24,
m33,
m34,
m44,
mf11,
mf12,
mf13,
mf14,
mf22,
mf23,
mf24,
mf33,
mf34,
mf44,
fm12,
fm13,
fm14,
fm23,
fm24,
fm34,
corelv,
z1 )

Definition at line 736 of file cbasumg3.F.

743C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
744#include "implicit_f.inc"
745#include "mvsiz_p.inc"
746C-----------------------------------------------
747C D U M M Y A R G U M E N T S
748C-----------------------------------------------
749 INTEGER JFT,JLT
750 my_real
751 . k11(3,3,*),k12(3,3,*),k13(3,3,*),k14(3,3,*),
752 . k22(3,3,*),k23(3,3,*),k24(3,3,*),k33(3,3,*),
753 . m11(3,3,*),m12(3,3,*),m13(3,3,*),m14(3,3,*),
754 . m22(3,3,*),m23(3,3,*),m24(3,3,*),m33(3,3,*),
755 . mf11(3,3,*),mf12(3,3,*),mf13(3,3,*),mf14(3,3,*),
756 . mf22(3,3,*),mf23(3,3,*),mf24(3,3,*),mf33(3,3,*),
757 . fm12(3,3,*),fm13(3,3,*),fm14(3,3,*),
758 . fm23(3,3,*),fm24(3,3,*),fm34(3,3,*),
759 . k34(3,3,*),k44(3,3,*),m34(3,3,*),m44(3,3,*),
760 . mf34(3,3,*),mf44(3,3,*),
761 . corelv(mvsiz,2,4),z1(*),vqn(9,4,*),vq(9,*)
762C-----------------------------------------------
763C L O C A L V A R I A B L E S
764C-----------------------------------------------
765 INTEGER I, J, K,L,EP,IS,IAS,NF,MI,MJ,M,ND
766 my_real
767 . dr(3,3,mvsiz),
768 . r1(3,3,mvsiz),r2(3,3,mvsiz),r3(3,3,mvsiz),r4(3,3,mvsiz),
769 . di(6),z2,deta,d(6),
770 . xx,yy,zz,xy,xz,yz,abc,xxyz2,yyxz2,zzxy2
771C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
772C-------transport Mij to element local system first---------
773 DO i=jft,jlt
774 z2 = z1(i)*z1(i)
775C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
776 xx = corelv(i,1,1)*corelv(i,1,1)+corelv(i,1,2)*corelv(i,1,2)
777 1 +corelv(i,1,3)*corelv(i,1,3)+corelv(i,1,4)*corelv(i,1,4)
778 yy = corelv(i,2,1)*corelv(i,2,1)+corelv(i,2,2)*corelv(i,2,2)
779 1 +corelv(i,2,3)*corelv(i,2,3)+corelv(i,2,4)*corelv(i,2,4)
780 xy = corelv(i,1,1)*corelv(i,2,1)+corelv(i,1,2)*corelv(i,2,2)
781 1 +corelv(i,1,3)*corelv(i,2,3)+corelv(i,1,4)*corelv(i,2,4)
782 xz =(corelv(i,1,1)-corelv(i,1,2)+corelv(i,1,3)-corelv(i,1,4))
783 . *z1(i)
784 yz =(corelv(i,2,1)-corelv(i,2,2)+corelv(i,2,3)-corelv(i,2,4))
785 . *z1(i)
786 zz = four*z2
787C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
788 d(1)= yy+zz+four
789 d(2)= xx+zz+four
790 d(3)= xx+yy+four
791 d(4)= -xy
792 d(5)= -xz
793 d(6)= -yz
794 abc = d(1)*d(2)*d(3)
795 xxyz2 = d(1)*d(6)*d(6)
796 yyxz2 = d(2)*d(5)*d(5)
797 zzxy2 = d(3)*d(4)*d(4)
798 deta = abs(abc+two*d(4)*d(5)*d(6)-xxyz2-yyxz2-zzxy2)
799 deta = one/max(deta,em20)
800 di(1) = (abc-xxyz2)*deta/max(d(1),em20)
801 di(2) = (abc-yyxz2)*deta/max(d(2),em20)
802 di(3) = (abc-zzxy2)*deta/max(d(3),em20)
803 di(4) = (d(5)*d(6)-d(4)*d(3))*deta
804 di(5) = (d(6)*d(4)-d(5)*d(2))*deta
805 di(6) = (d(4)*d(5)-d(6)*d(1))*deta
806C
807 dr(1,1,i)= di(1)
808 dr(2,2,i)= di(2)
809 dr(3,3,i)= di(3)
810 dr(1,2,i)= di(4)
811 dr(1,3,i)= di(5)
812 dr(2,3,i)= di(6)
813 dr(2,1,i)= dr(1,2,i)
814 dr(3,1,i)= dr(1,3,i)
815 dr(3,2,i)= dr(2,3,i)
816 END DO
817C
818 CALL set_rsj1(r1 ,r2 ,r3 ,r4 ,z1 ,
819 . jft ,jlt ,corelv)
820C -----------PROJECTION---------
821 CALL setprojkba(dr ,r1 ,r2 ,r3 ,r4 ,
822 3 k11,k12,k13,k14,k22,k23,k24,k33,k34,k44,
823 4 m11,m12,m13,m14,m22,m23,m24,m33,m34,m44,
824 5 mf11,mf12,mf13,mf14,mf22,mf23,mf24,mf33,
825 6 mf34,mf44,fm12,fm13,fm14,fm23,fm24,fm34,
826 7 vq ,vqn ,jft ,jlt )
827C
828 RETURN
setprojkba
subroutine setprojkba(dr, r1, r2, r3, r4, k11, k12, k13, k14, k22, k23, k24, k33, k34, k44, m11, m12, m13, m14, m22, m23, m24, m33, m34, m44, mf11, mf12, mf13, mf14, mf22, mf23, mf24, mf33, mf34, mf44, fm12, fm13, fm14, fm23, fm24, fm34, vq, vqn, jft, jlt)
Definition cbasumg3.F:943
set_rsj1
subroutine set_rsj1(r1, r2, r3, r4, z1, jft, jlt, corelv)
Definition cbasumg3.F:840
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21

◆ cbasumg3()

subroutine cbasumg3 ( integer jft,
integer jlt,
vqn,
vq,
integer nplat,
integer, dimension(*) iplat,
k11,
k12,
k13,
k14,
k22,
k23,
k24,
k33,
k34,
k44,
m11,
m12,
m13,
m14,
m22,
m23,
m24,
m33,
m34,
m44,
mf11,
mf12,
mf13,
mf14,
mf22,
mf23,
mf24,
mf33,
mf34,
mf44,
fm12,
fm13,
fm14,
fm23,
fm24,
fm34,
ke11,
ke22,
ke33,
ke44,
ke12,
ke13,
ke14,
ke23,
ke24,
ke34,
vcore,
integer idril,
integer iorth )

Definition at line 35 of file cbasumg3.F.

43C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
44#include "implicit_f.inc"
45#include "mvsiz_p.inc"
46C-----------------------------------------------
47C D U M M Y A R G U M E N T S
48C-----------------------------------------------
49 INTEGER JFT,JLT,NPLAT ,IPLAT(*),IDRIL,IORTH
50 my_real
51 . vqn(mvsiz,3,3,4),vq(mvsiz,3,3)
52 my_real
53 . k11(3,3,*),k12(3,3,*),k13(3,3,*),k14(3,3,*),
54 . k22(3,3,*),k23(3,3,*),k24(3,3,*),k33(3,3,*),
55 . m11(3,3,*),m12(3,3,*),m13(3,3,*),m14(3,3,*),
56 . m22(3,3,*),m23(3,3,*),m24(3,3,*),m33(3,3,*),
57 . mf11(3,3,*),mf12(3,3,*),mf13(3,3,*),mf14(3,3,*),
58 . mf22(3,3,*),mf23(3,3,*),mf24(3,3,*),mf33(3,3,*),
59 . fm12(3,3,*),fm13(3,3,*),fm14(3,3,*),
60 . fm23(3,3,*),fm24(3,3,*),fm34(3,3,*),
61 . k34(3,3,*),k44(3,3,*),m34(3,3,*),m44(3,3,*),
62 . mf34(3,3,*),mf44(3,3,*),
63 . ke11(6,6,*),ke22(6,6,*),ke33(6,6,*),ke44(6,6,*),
64 . ke12(6,6,*),ke13(6,6,*),ke14(6,6,*),ke23(6,6,*),
65 . ke24(6,6,*),ke34(6,6,*),vcore(mvsiz,3,4)
66C-----------------------------------------------
67C L O C A L V A R I A B L E S
68C-----------------------------------------------
69 INTEGER I, J, K,EP,IS,IAS,NF,MI,MJ,M
70 my_real
71 . q(3,3,mvsiz),qn(3,3,4,mvsiz),corelv(mvsiz,2,4),z1(mvsiz)
72 DATA is/1/,ias/0/
73C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
74C---------------------------------------
75C TRANS LOCAL-->GLOBAL ET 5DDL-->6DDL w/ rigid mode projection
76C---------------------------------------
77 DO i=1,3
78 DO j=1,3
79#include "vectorize.inc"
80 DO m=jft,nplat
81 ep=iplat(m)
82 q(j,i,m)=vq(ep,i,j)
83 ENDDO
84 ENDDO
85 ENDDO
86 CALL cbatran2(jft,nplat,q,k11,q,is)
87 CALL cbatran2(jft,nplat,q,k22,q,is)
88 CALL cbatran2(jft,nplat,q,k33,q,is)
89 CALL cbatran2(jft,nplat,q,k44,q,is)
90 CALL cbatran2(jft,nplat,q,k12,q,ias)
91 CALL cbatran2(jft,nplat,q,k13,q,ias)
92 CALL cbatran2(jft,nplat,q,k14,q,ias)
93 CALL cbatran2(jft,nplat,q,k23,q,ias)
94 CALL cbatran2(jft,nplat,q,k24,q,ias)
95 CALL cbatran2(jft,nplat,q,k34,q,ias)
96 IF (iorth >0 .AND.idril>0) THEN
97 CALL cbatran3(jft,nplat,q,m11,q,is)
98 CALL cbatran3(jft,nplat,q,m22,q,is)
99 CALL cbatran3(jft,nplat,q,m33,q,is)
100 CALL cbatran3(jft,nplat,q,m44,q,is)
101 CALL cbatran3(jft,nplat,q,m12,q,ias)
102 CALL cbatran3(jft,nplat,q,m13,q,ias)
103 CALL cbatran3(jft,nplat,q,m14,q,ias)
104 CALL cbatran3(jft,nplat,q,m23,q,ias)
105 CALL cbatran3(jft,nplat,q,m24,q,ias)
106 CALL cbatran3(jft,nplat,q,m34,q,ias)
107 ELSE
108 CALL cbatran2(jft,nplat,q,m11,q,is)
109 CALL cbatran2(jft,nplat,q,m22,q,is)
110 CALL cbatran2(jft,nplat,q,m33,q,is)
111 CALL cbatran2(jft,nplat,q,m44,q,is)
112 CALL cbatran2(jft,nplat,q,m12,q,ias)
113 CALL cbatran2(jft,nplat,q,m13,q,ias)
114 CALL cbatran2(jft,nplat,q,m14,q,ias)
115 CALL cbatran2(jft,nplat,q,m23,q,ias)
116 CALL cbatran2(jft,nplat,q,m24,q,ias)
117 CALL cbatran2(jft,nplat,q,m34,q,ias)
118 END IF !(IORTH >0.AND.IDRIL>0)
119C
120 IF (iorth >0) THEN
121 CALL cbatran3(jft,nplat,q,mf11,q,ias)
122 CALL cbatran3(jft,nplat,q,mf12,q,ias)
123 CALL cbatran3(jft,nplat,q,mf13,q,ias)
124 CALL cbatran3(jft,nplat,q,mf14,q,ias)
125 CALL cbatran3(jft,nplat,q,mf22,q,ias)
126 CALL cbatran3(jft,nplat,q,mf23,q,ias)
127 CALL cbatran3(jft,nplat,q,mf24,q,ias)
128 CALL cbatran3(jft,nplat,q,mf33,q,ias)
129 CALL cbatran3(jft,nplat,q,mf34,q,ias)
130 CALL cbatran3(jft,nplat,q,mf44,q,ias)
131 CALL cbatran3(jft,nplat,q,fm12,q,ias)
132 CALL cbatran3(jft,nplat,q,fm13,q,ias)
133 CALL cbatran3(jft,nplat,q,fm14,q,ias)
134 CALL cbatran3(jft,nplat,q,fm23,q,ias)
135 CALL cbatran3(jft,nplat,q,fm24,q,ias)
136 CALL cbatran3(jft,nplat,q,fm34,q,ias)
137 ELSEIF (idril>0) THEN
138 CALL cbatran233(jft,nplat,q,mf11,q)
139 CALL cbatran233(jft,nplat,q,mf12,q)
140 CALL cbatran233(jft,nplat,q,mf13,q)
141 CALL cbatran233(jft,nplat,q,mf14,q)
142 CALL cbatran233(jft,nplat,q,mf22,q)
143 CALL cbatran233(jft,nplat,q,mf23,q)
144 CALL cbatran233(jft,nplat,q,mf24,q)
145 CALL cbatran233(jft,nplat,q,mf33,q)
146 CALL cbatran233(jft,nplat,q,mf34,q)
147 CALL cbatran233(jft,nplat,q,mf44,q)
148 CALL cbatran233(jft,nplat,q,fm12,q)
149 CALL cbatran233(jft,nplat,q,fm13,q)
150 CALL cbatran233(jft,nplat,q,fm14,q)
151 CALL cbatran233(jft,nplat,q,fm23,q)
152 CALL cbatran233(jft,nplat,q,fm24,q)
153 CALL cbatran233(jft,nplat,q,fm34,q)
154 ELSE
155 CALL cbatran232(jft,nplat,q,mf11,q)
156 CALL cbatran232(jft,nplat,q,mf12,q)
157 CALL cbatran232(jft,nplat,q,mf13,q)
158 CALL cbatran232(jft,nplat,q,mf14,q)
159 CALL cbatran232(jft,nplat,q,mf22,q)
160 CALL cbatran232(jft,nplat,q,mf23,q)
161 CALL cbatran232(jft,nplat,q,mf24,q)
162 CALL cbatran232(jft,nplat,q,mf33,q)
163 CALL cbatran232(jft,nplat,q,mf34,q)
164 CALL cbatran232(jft,nplat,q,mf44,q)
165 CALL cbatran223(jft,nplat,q,fm12,q)
166 CALL cbatran223(jft,nplat,q,fm13,q)
167 CALL cbatran223(jft,nplat,q,fm14,q)
168 CALL cbatran223(jft,nplat,q,fm23,q)
169 CALL cbatran223(jft,nplat,q,fm24,q)
170 CALL cbatran223(jft,nplat,q,fm34,q)
171 END IF
172C---------------------------------------
173C ASSEMBLAGE
174C---------------------------------------
175C---------KII --------
176 DO i=1,3
177 mi=i+3
178 DO j=i,3
179 mj=j+3
180#include "vectorize.inc"
181 DO m=jft,nplat
182 ep=iplat(m)
183 ke11(i,j,ep)=k11(i,j,m)
184 ke11(mi,mj,ep)=m11(i,j,m)
185 ke22(i,j,ep)=k22(i,j,m)
186 ke22(mi,mj,ep)=m22(i,j,m)
187 ke33(i,j,ep)=k33(i,j,m)
188 ke33(mi,mj,ep)=m33(i,j,m)
189 ke44(i,j,ep)=k44(i,j,m)
190 ke44(mi,mj,ep)=m44(i,j,m)
191 ENDDO
192 ENDDO
193 ENDDO
194C
195 DO i=1,3
196 DO j=1,3
197 mj=j+3
198#include "vectorize.inc"
199 DO m=jft,nplat
200 ep=iplat(m)
201 ke11(i,mj,ep)=mf11(i,j,m)
202 ke22(i,mj,ep)=mf22(i,j,m)
203 ke33(i,mj,ep)=mf33(i,j,m)
204 ke44(i,mj,ep)=mf44(i,j,m)
205 ENDDO
206 ENDDO
207 ENDDO
208C
209C---------KIJ --------
210 DO i=1,3
211 mi=i+3
212 DO j=1,3
213 mj=j+3
214#include "vectorize.inc"
215 DO m=jft,nplat
216 ep=iplat(m)
217 ke12(i,j,ep)=k12(i,j,m)
218 ke12(i,mj,ep)=mf12(i,j,m)
219 ke12(mi,j,ep)=fm12(i,j,m)
220 ke12(mi,mj,ep)=m12(i,j,m)
221 ke13(i,j,ep)=k13(i,j,m)
222 ke13(i,mj,ep)=mf13(i,j,m)
223 ke13(mi,j,ep)=fm13(i,j,m)
224 ke13(mi,mj,ep)=m13(i,j,m)
225 ke14(i,j,ep)=k14(i,j,m)
226 ke14(i,mj,ep)=mf14(i,j,m)
227 ke14(mi,j,ep)=fm14(i,j,m)
228 ke14(mi,mj,ep)=m14(i,j,m)
229 ke23(i,j,ep)=k23(i,j,m)
230 ke23(i,mj,ep)=mf23(i,j,m)
231 ke23(mi,j,ep)=fm23(i,j,m)
232 ke23(mi,mj,ep)=m23(i,j,m)
233 ke24(i,j,ep)=k24(i,j,m)
234 ke24(i,mj,ep)=mf24(i,j,m)
235 ke24(mi,j,ep)=fm24(i,j,m)
236 ke24(mi,mj,ep)=m24(i,j,m)
237 ke34(i,j,ep)=k34(i,j,m)
238 ke34(i,mj,ep)=mf34(i,j,m)
239 ke34(mi,j,ep)=fm34(i,j,m)
240 ke34(mi,mj,ep)=m34(i,j,m)
241 ENDDO
242 ENDDO
243 ENDDO
244C----------------warped elements--------------
245 nf=nplat+1
246 IF (nf > jlt) RETURN
247C
248 DO i=1,3
249 DO j=1,3
250#include "vectorize.inc"
251 DO m=nf,jlt
252 ep=iplat(m)
253 q(j,i,m)=vq(ep,i,j)
254 ENDDO
255 ENDDO
256 ENDDO
257C--------projection free Rigid rotation----
258 DO j=1,4
259 DO i=1,2
260#include "vectorize.inc"
261 DO m=nf,jlt
262 ep=iplat(m)
263 corelv(m,i,j)=vcore(ep,i,j)
264 ENDDO
265 ENDDO
266#include "vectorize.inc"
267 DO m=nf,jlt
268 ep=iplat(m)
269 z1(m)=vcore(ep,3,1)
270 ENDDO
271 DO i=1,3
272 DO k=1,3
273#include "vectorize.inc"
274 DO m=nf,jlt
275 ep=iplat(m)
276 qn(i,k,j,m)=vqn(ep,i,k,j)
277 ENDDO
278 ENDDO
279 ENDDO
280 END DO
281 CALL cbaprojk(
282 1 nf ,jlt ,qn ,q ,
283 3 k11,k12,k13,k14,k22,k23,k24,k33,k34,k44,
284 4 m11,m12,m13,m14,m22,m23,m24,m33,m34,m44,
285 5 mf11,mf12,mf13,mf14,mf22,mf23,mf24,mf33,
286 6 mf34,mf44,fm12,fm13,fm14,fm23,fm24,fm34,
287 7 corelv,z1 )
288C---------------------------------------
289C ASSEMBLAGE
290C---------------------------------------
291C---------KII --------
292 DO i=1,3
293 mi=i+3
294 DO j=i,3
295 mj=j+3
296#include "vectorize.inc"
297 DO m=nf,jlt
298 ep=iplat(m)
299 ke11(i,j,ep)=k11(i,j,m)
300 ke11(mi,mj,ep)=m11(i,j,m)
301 ke22(i,j,ep)=k22(i,j,m)
302 ke22(mi,mj,ep)=m22(i,j,m)
303 ke33(i,j,ep)=k33(i,j,m)
304 ke33(mi,mj,ep)=m33(i,j,m)
305 ke44(i,j,ep)=k44(i,j,m)
306 ke44(mi,mj,ep)=m44(i,j,m)
307 ENDDO
308 ENDDO
309 ENDDO
310C
311 DO i=1,3
312 DO j=1,3
313 mj=j+3
314#include "vectorize.inc"
315 DO m=nf,jlt
316 ep=iplat(m)
317 ke11(i,mj,ep)=mf11(i,j,m)
318 ke22(i,mj,ep)=mf22(i,j,m)
319 ke33(i,mj,ep)=mf33(i,j,m)
320 ke44(i,mj,ep)=mf44(i,j,m)
321 ENDDO
322 ENDDO
323 ENDDO
324C---------KIJ --------
325 DO i=1,3
326 mi=i+3
327 DO j=1,3
328 mj=j+3
329#include "vectorize.inc"
330 DO m=nf,jlt
331 ep=iplat(m)
332 ke12(i,j,ep)=k12(i,j,m)
333 ke13(i,j,ep)=k13(i,j,m)
334 ke14(i,j,ep)=k14(i,j,m)
335 ke23(i,j,ep)=k23(i,j,m)
336 ke24(i,j,ep)=k24(i,j,m)
337 ke34(i,j,ep)=k34(i,j,m)
338 ke12(i,mj,ep)=mf12(i,j,m)
339 ke13(i,mj,ep)=mf13(i,j,m)
340 ke14(i,mj,ep)=mf14(i,j,m)
341 ke23(i,mj,ep)=mf23(i,j,m)
342 ke24(i,mj,ep)=mf24(i,j,m)
343 ke34(i,mj,ep)=mf34(i,j,m)
344 ke12(mi,j,ep)=fm12(i,j,m)
345 ke13(mi,j,ep)=fm13(i,j,m)
346 ke14(mi,j,ep)=fm14(i,j,m)
347 ke23(mi,j,ep)=fm23(i,j,m)
348 ke24(mi,j,ep)=fm24(i,j,m)
349 ke34(mi,j,ep)=fm34(i,j,m)
350 ke12(mi,mj,ep)=m12(i,j,m)
351 ke13(mi,mj,ep)=m13(i,j,m)
352 ke14(mi,mj,ep)=m14(i,j,m)
353 ke23(mi,mj,ep)=m23(i,j,m)
354 ke24(mi,mj,ep)=m24(i,j,m)
355 ke34(mi,mj,ep)=m34(i,j,m)
356 ENDDO
357 ENDDO
358 ENDDO
359C
360 DO i=1,6
361 DO j=i+1,6
362 DO m=jft,jlt
363 ke11(j,i,m)=ke11(i,j,m)
364 ke22(j,i,m)=ke22(i,j,m)
365 ke33(j,i,m)=ke33(i,j,m)
366 ke44(j,i,m)=ke44(i,j,m)
367 ENDDO
368 ENDDO
369 ENDDO
370C
371 RETURN
cbatran233
subroutine cbatran233(jft, jlt, vqi, kk, vqj)
Definition cbasumg3.F:690
cbatran223
subroutine cbatran223(jft, jlt, vqi, kk, vqj)
Definition cbasumg3.F:647
cbatran3
subroutine cbatran3(jft, jlt, vqi, kk, vqj, isym)
Definition cbasumg3.F:382
cbatran232
subroutine cbatran232(jft, jlt, vqi, kk, vqj)
Definition cbasumg3.F:605
cbatran2
subroutine cbatran2(jft, jlt, vqi, kk, vqj, isym)
Definition cbasumg3.F:451
cbaprojk
subroutine cbaprojk(jft, jlt, vqn, vq, k11, k12, k13, k14, k22, k23, k24, k33, k34, k44, m11, m12, m13, m14, m22, m23, m24, m33, m34, m44, mf11, mf12, mf13, mf14, mf22, mf23, mf24, mf33, mf34, mf44, fm12, fm13, fm14, fm23, fm24, fm34, corelv, z1)
Definition cbasumg3.F:743

◆ cbatran2()

subroutine cbatran2 ( integer jft,
integer jlt,
vqi,
kk,
vqj,
integer isym )

Definition at line 450 of file cbasumg3.F.

451C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
452#include "implicit_f.inc"
453#include "mvsiz_p.inc"
454C-----------------------------------------------
455C D U M M Y A R G U M E N T S
456C-----------------------------------------------
457 INTEGER JFT,JLT
458 my_real
459 . vqi(3,3,*),vqj(3,3,*),kk(3,3,*)
460C-----------------------------------------------
461C LOCAL A R G U M E N T S
462C-----------------------------------------------
463 INTEGER I,J,EP,ISYM
464 my_real
465 . k(3,3,mvsiz)
466C-----------------------------------------------
467 IF (isym==1) THEN
468 DO i=1,3
469 DO j=i,3
470 DO ep=jft,jlt
471 k(i,j,ep)=vqi(1,i,ep)*(
472 1 kk(1,1,ep)*vqj(1,j,ep)+kk(1,2,ep)*vqj(2,j,ep))+
473 2 vqi(2,i,ep)*(
474 3 kk(1,2,ep)*vqj(1,j,ep)+kk(2,2,ep)*vqj(2,j,ep))+
475 4 vqi(3,i,ep)*kk(3,3,ep)*vqj(3,j,ep)
476 ENDDO
477 ENDDO
478 ENDDO
479C
480 DO i=1,3
481 DO j=i,3
482 DO ep=jft,jlt
483 kk(i,j,ep)= k(i,j,ep)
484 ENDDO
485 ENDDO
486 ENDDO
487 ELSE
488 DO i=1,3
489 DO j=1,3
490 DO ep=jft,jlt
491 k(i,j,ep)=vqi(1,i,ep)*(
492 1 kk(1,1,ep)*vqj(1,j,ep)+kk(1,2,ep)*vqj(2,j,ep))+
493 2 vqi(2,i,ep)*(
494 3 kk(2,1,ep)*vqj(1,j,ep)+kk(2,2,ep)*vqj(2,j,ep))+
495 4 vqi(3,i,ep)*kk(3,3,ep)*vqj(3,j,ep)
496 ENDDO
497 ENDDO
498 ENDDO
499C
500 DO i=1,3
501 DO j=1,3
502 DO ep=jft,jlt
503 kk(i,j,ep)= k(i,j,ep)
504 ENDDO
505 ENDDO
506 ENDDO
507 ENDIF
508 RETURN

◆ cbatran223()

subroutine cbatran223 ( integer jft,
integer jlt,
vqi,
kk,
vqj )

Definition at line 646 of file cbasumg3.F.

647C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
648#include "implicit_f.inc"
649#include "mvsiz_p.inc"
650C-----------------------------------------------
651C D U M M Y A R G U M E N T S
652C-----------------------------------------------
653 INTEGER JFT,JLT
654 my_real
655 . vqi(3,3,*),vqj(3,3,*),kk(3,3,*)
656C-----------------------------------------------
657C LOCAL A R G U M E N T S
658C-----------------------------------------------
659 INTEGER I,J,EP
660 my_real
661 . k(3,3,mvsiz)
662C-----------------------------------------------
663C
664 DO i=1,3
665 DO j=1,3
666 DO ep=jft,jlt
667 k(i,j,ep)=(vqi(1,i,ep)*kk(1,3,ep)+
668 1 vqi(2,i,ep)*kk(2,3,ep))*vqj(3,j,ep)
669 ENDDO
670 ENDDO
671 ENDDO
672C
673 DO i=1,3
674 DO j=1,3
675 DO ep=jft,jlt
676 kk(i,j,ep)= k(i,j,ep)
677 ENDDO
678 ENDDO
679 ENDDO
680 RETURN

◆ cbatran23()

subroutine cbatran23 ( integer jft,
integer jlt,
vqi,
kk,
vqj )

Definition at line 559 of file cbasumg3.F.

560C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
561#include "implicit_f.inc"
562#include "mvsiz_p.inc"
563C-----------------------------------------------
564C D U M M Y A R G U M E N T S
565C-----------------------------------------------
566 INTEGER JFT,JLT
567 my_real
568 . vqi(3,3,*),vqj(3,3,*),kk(3,3,*)
569C-----------------------------------------------
570C LOCAL A R G U M E N T S
571C-----------------------------------------------
572 INTEGER I,J,EP
573 my_real
574 . k(3,3,mvsiz)
575C-----------------------------------------------
576C
577 DO i=1,3
578 DO j=1,3
579 DO ep=jft,jlt
580 k(i,j,ep)=vqi(1,i,ep)*(kk(1,1,ep)*vqj(1,j,ep)+
581 1 kk(1,2,ep)*vqj(2,j,ep)+kk(1,3,ep)*vqj(3,j,ep))+
582 2 vqi(2,i,ep)*(kk(2,1,ep)*vqj(1,j,ep)+
583 3 kk(2,2,ep)*vqj(2,j,ep)+kk(2,3,ep)*vqj(3,j,ep))
584 ENDDO
585 ENDDO
586 ENDDO
587C
588 DO i=1,3
589 DO j=1,3
590 DO ep=jft,jlt
591 kk(i,j,ep)= k(i,j,ep)
592 ENDDO
593 ENDDO
594 ENDDO
595 RETURN

◆ cbatran232()

subroutine cbatran232 ( integer jft,
integer jlt,
vqi,
kk,
vqj )

Definition at line 604 of file cbasumg3.F.

605C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
606#include "implicit_f.inc"
607#include "mvsiz_p.inc"
608C-----------------------------------------------
609C D U M M Y A R G U M E N T S
610C-----------------------------------------------
611 INTEGER JFT,JLT
612 my_real
613 . vqi(3,3,*),vqj(3,3,*),kk(3,3,*)
614C-----------------------------------------------
615C LOCAL A R G U M E N T S
616C-----------------------------------------------
617 INTEGER I,J,EP
618 my_real
619 . k(3,3,mvsiz)
620C-----------------------------------------------
621 DO i=1,3
622 DO j=1,3
623 DO ep=jft,jlt
624 k(i,j,ep)=vqi(3,i,ep)*(kk(3,1,ep)*vqj(1,j,ep)+
625 1 kk(3,2,ep)*vqj(2,j,ep))
626 ENDDO
627 ENDDO
628 ENDDO
629C
630 DO i=1,3
631 DO j=1,3
632 DO ep=jft,jlt
633 kk(i,j,ep)= k(i,j,ep)
634 ENDDO
635 ENDDO
636 ENDDO
637 RETURN

◆ cbatran233()

subroutine cbatran233 ( integer jft,
integer jlt,
vqi,
kk,
vqj )

Definition at line 689 of file cbasumg3.F.

690C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
691#include "implicit_f.inc"
692#include "mvsiz_p.inc"
693C-----------------------------------------------
694C D U M M Y A R G U M E N T S
695C-----------------------------------------------
696 INTEGER JFT,JLT
697 my_real
698 . vqi(3,3,*),vqj(3,3,*),kk(3,3,*)
699C-----------------------------------------------
700C LOCAL A R G U M E N T S
701C-----------------------------------------------
702 INTEGER I,J,EP
703 my_real
704 . k(3,3,mvsiz)
705C-----------------------------------------------
706C----- QI^tKQJ K(1,3)>0,K(2,3)>0,K(3,1)>0,K(3,2)>0-------
707C
708 DO i=1,3
709 DO j=1,3
710 DO ep=jft,jlt
711 k(i,j,ep)=(vqi(1,i,ep)*kk(1,3,ep)+
712 1 vqi(2,i,ep)*kk(2,3,ep))*vqj(3,j,ep)+
713 3 vqi(3,i,ep)*(kk(3,1,ep)*vqj(1,j,ep)+
714 4 kk(3,2,ep)*vqj(2,j,ep))
715 ENDDO
716 ENDDO
717 ENDDO
718C
719 DO i=1,3
720 DO j=1,3
721 DO ep=jft,jlt
722 kk(i,j,ep)= k(i,j,ep)
723 ENDDO
724 ENDDO
725 ENDDO
726 RETURN

◆ cbatran3()

subroutine cbatran3 ( integer jft,
integer jlt,
vqi,
kk,
vqj,
integer isym )

Definition at line 381 of file cbasumg3.F.

382C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
383#include "implicit_f.inc"
384#include "mvsiz_p.inc"
385C-----------------------------------------------
386C D U M M Y A R G U M E N T S
387C-----------------------------------------------
388 INTEGER JFT,JLT,ISYM
389 my_real
390 . vqi(3,3,*), vqj(3,3,*),kk(3,3,*)
391C-----------------------------------------------
392C LOCAL A R G U M E N T S
393C-----------------------------------------------
394 INTEGER I,J,EP
395 my_real
396 . k(3,3,mvsiz)
397C-----------------------------------------------
398 IF (isym==1) THEN
399 DO i=1,3
400 DO j=i,3
401 DO ep=jft,jlt
402 k(i,j,ep)=vqi(1,i,ep)*(kk(1,1,ep)*vqj(1,j,ep)+
403 1 kk(1,2,ep)*vqj(2,j,ep)+kk(1,3,ep)*vqj(3,j,ep))+
404 2 vqi(2,i,ep)*(kk(1,2,ep)*vqj(1,j,ep)+
405 3 kk(2,2,ep)*vqj(2,j,ep)+kk(2,3,ep)*vqj(3,j,ep))+
406 4 vqi(3,i,ep)*(kk(1,3,ep)*vqj(1,j,ep)+
407 5 kk(2,3,ep)*vqj(2,j,ep)+kk(3,3,ep)*vqj(3,j,ep))
408 ENDDO
409 ENDDO
410 ENDDO
411C
412 DO i=1,3
413 DO j=i,3
414 DO ep=jft,jlt
415 kk(i,j,ep)= k(i,j,ep)
416 ENDDO
417 ENDDO
418 ENDDO
419 ELSE
420 DO i=1,3
421 DO j=1,3
422 DO ep=jft,jlt
423 k(i,j,ep)=vqi(1,i,ep)*(kk(1,1,ep)*vqj(1,j,ep)+
424 1 kk(1,2,ep)*vqj(2,j,ep)+kk(1,3,ep)*vqj(3,j,ep))+
425 2 vqi(2,i,ep)*(kk(2,1,ep)*vqj(1,j,ep)+
426 3 kk(2,2,ep)*vqj(2,j,ep)+kk(2,3,ep)*vqj(3,j,ep))+
427 4 vqi(3,i,ep)*(kk(3,1,ep)*vqj(1,j,ep)+
428 5 kk(3,2,ep)*vqj(2,j,ep)+kk(3,3,ep)*vqj(3,j,ep))
429 ENDDO
430 ENDDO
431 ENDDO
432C
433 DO i=1,3
434 DO j=1,3
435 DO ep=jft,jlt
436 kk(i,j,ep)= k(i,j,ep)
437 ENDDO
438 ENDDO
439 ENDDO
440 ENDIF
441 RETURN

◆ cbatran32()

subroutine cbatran32 ( integer jft,
integer jlt,
vqi,
kk,
vqj )

Definition at line 515 of file cbasumg3.F.

516C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
517#include "implicit_f.inc"
518#include "mvsiz_p.inc"
519C-----------------------------------------------
520C D U M M Y A R G U M E N T S
521C-----------------------------------------------
522 INTEGER JFT,JLT
523 my_real
524 . vqi(3,3,*),vqj(3,3,*),kk(3,3,*)
525C-----------------------------------------------
526C LOCAL A R G U M E N T S
527C-----------------------------------------------
528 INTEGER I,J,EP
529 my_real
530 . k(3,3,mvsiz)
531C-----------------------------------------------
532 DO i=1,3
533 DO j=1,3
534 DO ep=jft,jlt
535 k(i,j,ep)=vqi(1,i,ep)*(kk(1,1,ep)*vqj(1,j,ep)+
536 1 kk(1,2,ep)*vqj(2,j,ep))+
537 2 vqi(2,i,ep)*(kk(2,1,ep)*vqj(1,j,ep)+
538 3 kk(2,2,ep)*vqj(2,j,ep))+
539 4 vqi(3,i,ep)*(kk(3,1,ep)*vqj(1,j,ep)+
540 5 kk(3,2,ep)*vqj(2,j,ep))
541 ENDDO
542 ENDDO
543 ENDDO
544C
545 DO i=1,3
546 DO j=1,3
547 DO ep=jft,jlt
548 kk(i,j,ep)= k(i,j,ep)
549 ENDDO
550 ENDDO
551 ENDDO
552 RETURN

◆ cn4sumg3()

subroutine cn4sumg3 ( integer jft,
integer jlt,
integer, dimension(*) iplat,
k11,
k12,
k13,
k14,
k22,
k23,
k24,
k33,
k34,
k44,
m11,
m12,
m13,
m14,
m22,
m23,
m24,
m33,
m34,
m44,
mf11,
mf12,
mf13,
mf14,
mf22,
mf23,
mf24,
mf33,
mf34,
mf44,
fm12,
fm13,
fm14,
fm23,
fm24,
fm34,
ke11,
ke22,
ke33,
ke44,
ke12,
ke13,
ke14,
ke23,
ke24,
ke34 )

Definition at line 1588 of file cbasumg3.F.

1596C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
1597#include "implicit_f.inc"
1598C-----------------------------------------------
1599C D U M M Y A R G U M E N T S
1600C-----------------------------------------------
1601 INTEGER JFT,JLT,IPLAT(*)
1602 my_real
1603 . k11(3,3,*),k12(3,3,*),k13(3,3,*),k14(3,3,*),
1604 . k22(3,3,*),k23(3,3,*),k24(3,3,*),k33(3,3,*),
1605 . m11(3,3,*),m12(3,3,*),m13(3,3,*),m14(3,3,*),
1606 . m22(3,3,*),m23(3,3,*),m24(3,3,*),m33(3,3,*),
1607 . mf11(3,3,*),mf12(3,3,*),mf13(3,3,*),mf14(3,3,*),
1608 . mf22(3,3,*),mf23(3,3,*),mf24(3,3,*),mf33(3,3,*),
1609 . fm12(3,3,*),fm13(3,3,*),fm14(3,3,*),
1610 . fm23(3,3,*),fm24(3,3,*),fm34(3,3,*),
1611 . k34(3,3,*),k44(3,3,*),m34(3,3,*),m44(3,3,*),
1612 . mf34(3,3,*),mf44(3,3,*),
1613 . ke11(6,6,*),ke22(6,6,*),ke33(6,6,*),ke44(6,6,*),
1614 . ke12(6,6,*),ke13(6,6,*),ke14(6,6,*),ke23(6,6,*),
1615 . ke24(6,6,*),ke34(6,6,*)
1616C-----------------------------------------------
1617C L O C A L V A R I A B L E S
1618C-----------------------------------------------
1619 INTEGER I, J, K,EP,M,MI,MJ
1620C---------KII --------
1621 DO i=1,3
1622 mi=i+3
1623 DO j=i,3
1624 mj=j+3
1625#include "vectorize.inc"
1626 DO m=jft,jlt
1627 ep=iplat(m)
1628 ke11(i,j,ep)=k11(i,j,m)
1629 ke11(mi,mj,ep)=m11(i,j,m)
1630 ke22(i,j,ep)=k22(i,j,m)
1631 ke22(mi,mj,ep)=m22(i,j,m)
1632 ke33(i,j,ep)=k33(i,j,m)
1633 ke33(mi,mj,ep)=m33(i,j,m)
1634 ke44(i,j,ep)=k44(i,j,m)
1635 ke44(mi,mj,ep)=m44(i,j,m)
1636 ENDDO
1637 ENDDO
1638 ENDDO
1639C
1640 DO i=1,3
1641 DO j=1,3
1642 mj=j+3
1643#include "vectorize.inc"
1644 DO m=jft,jlt
1645 ep=iplat(m)
1646 ke11(i,mj,ep)=mf11(i,j,m)
1647 ke22(i,mj,ep)=mf22(i,j,m)
1648 ke33(i,mj,ep)=mf33(i,j,m)
1649 ke44(i,mj,ep)=mf44(i,j,m)
1650 ENDDO
1651 ENDDO
1652 ENDDO
1653C
1654C---------KIJ --------
1655 DO i=1,3
1656 mi=i+3
1657 DO j=1,3
1658 mj=j+3
1659#include "vectorize.inc"
1660 DO m=jft,jlt
1661 ep=iplat(m)
1662 ke12(i,j,ep)=k12(i,j,m)
1663 ke12(i,mj,ep)=mf12(i,j,m)
1664 ke12(mi,j,ep)=fm12(i,j,m)
1665 ke12(mi,mj,ep)=m12(i,j,m)
1666 ke13(i,j,ep)=k13(i,j,m)
1667 ke13(i,mj,ep)=mf13(i,j,m)
1668 ke13(mi,j,ep)=fm13(i,j,m)
1669 ke13(mi,mj,ep)=m13(i,j,m)
1670 ke14(i,j,ep)=k14(i,j,m)
1671 ke14(i,mj,ep)=mf14(i,j,m)
1672 ke14(mi,j,ep)=fm14(i,j,m)
1673 ke14(mi,mj,ep)=m14(i,j,m)
1674 ke23(i,j,ep)=k23(i,j,m)
1675 ke23(i,mj,ep)=mf23(i,j,m)
1676 ke23(mi,j,ep)=fm23(i,j,m)
1677 ke23(mi,mj,ep)=m23(i,j,m)
1678 ke24(i,j,ep)=k24(i,j,m)
1679 ke24(i,mj,ep)=mf24(i,j,m)
1680 ke24(mi,j,ep)=fm24(i,j,m)
1681 ke24(mi,mj,ep)=m24(i,j,m)
1682 ke34(i,j,ep)=k34(i,j,m)
1683 ke34(i,mj,ep)=mf34(i,j,m)
1684 ke34(mi,j,ep)=fm34(i,j,m)
1685 ke34(mi,mj,ep)=m34(i,j,m)
1686 ENDDO
1687 ENDDO
1688 ENDDO
1689C
1690 DO i=1,6
1691 DO j=i+1,6
1692 DO m=jft,jlt
1693 ke11(j,i,m)=ke11(i,j,m)
1694 ke22(j,i,m)=ke22(i,j,m)
1695 ke33(j,i,m)=ke33(i,j,m)
1696 ke44(j,i,m)=ke44(i,j,m)
1697 ENDDO
1698 ENDDO
1699 ENDDO
1700C
1701 RETURN

◆ impkctmp()

subroutine impkctmp ( integer jft,
integer jlt,
integer iugeo,
ke11,
ke12,
ke13,
ke14,
ke22,
ke23,
ke24,
ke33,
ke34,
ke44 )

Definition at line 1708 of file cbasumg3.F.

1711C
1712C-----------------------------------------------
1713C I m p l i c i t T y p e s
1714C-----------------------------------------------
1715#include "implicit_f.inc"
1716#include "mvsiz_p.inc"
1717C-----------------------------------------------
1718C D u m m y A r g u m e n t s
1719C-----------------------------------------------
1720 INTEGER JFT,JLT,IUGEO
1721C REAL
1722 my_real
1723 . ke11(6,6,*),ke22(6,6,*),ke33(6,6,*),ke44(6,6,*),
1724 . ke12(6,6,*),ke13(6,6,*),ke14(6,6,*),ke23(6,6,*),
1725 . ke24(6,6,*),ke34(6,6,*)
1726C-----------------------------------------------
1727C L o c a l V a r i a b l e s
1728C-----------------------------------------------
1729 INTEGER I,J,N,NT,IG(MVSIZ)
1730C=======================================================================
1731C SHELL
1732C=======================================================================
1733 CALL writekc4(iugeo,jft,jlt,'K11',ke11)
1734 CALL writekc4(iugeo,jft,jlt,'K12',ke12)
1735 CALL writekc4(iugeo,jft,jlt,'K13',ke13)
1736 CALL writekc4(iugeo,jft,jlt,'K14',ke14)
1737 CALL writekc4(iugeo,jft,jlt,'K22',ke22)
1738 CALL writekc4(iugeo,jft,jlt,'K23',ke23)
1739 CALL writekc4(iugeo,jft,jlt,'K24',ke24)
1740 CALL writekc4(iugeo,jft,jlt,'K33',ke33)
1741 CALL writekc4(iugeo,jft,jlt,'K34',ke34)
1742 CALL writekc4(iugeo,jft,jlt,'K44',ke44)
1743C
1744 RETURN
writekc4
subroutine writekc4(in, jft, jlt, ch, kij)
Definition cbasumg3.F:1752

◆ set_ri33()

subroutine set_ri33 ( xi,
yi,
zi,
ri,
integer jft,
integer jlt )

Definition at line 902 of file cbasumg3.F.

903C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
904#include "implicit_f.inc"
905C-----------------------------------------------
906C D U M M Y A R G U M E N T S
907C-----------------------------------------------
908 INTEGER JFT,JLT
909 my_real
910 . xi(*) ,yi(*), zi(*),ri(3,3,*)
911C-----------------------------------------------
912C LOCAL A R G U M E N T S
913C-----------------------------------------------
914 INTEGER I,J,L
915 DO i=jft,jlt
916 ri(1,2,i)=zi(i)
917 ri(1,3,i)=-yi(i)
918 ri(2,1,i)=-ri(1,2,i)
919 ri(2,3,i)=xi(i)
920 ri(3,1,i)=-ri(1,3,i)
921 ri(3,2,i)=-ri(2,3,i)
922 ENDDO
923C
924 RETURN

◆ set_rsj1()

subroutine set_rsj1 ( r1,
r2,
r3,
r4,
z1,
integer jft,
integer jlt,
corelv )

Definition at line 838 of file cbasumg3.F.

840C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
841#include "implicit_f.inc"
842#include "mvsiz_p.inc"
843C-----------------------------------------------
844C D U M M Y A R G U M E N T S
845C-----------------------------------------------
846 INTEGER JFT,JLT
847 my_real
848 . corelv(mvsiz,2,4),
849 . r1(3,3,*),r2(3,3,*),r3(3,3,*),r4(3,3,*),z1(*)
850C-----------------------------------------------
851C LOCAL A R G U M E N T S
852C-----------------------------------------------
853 INTEGER J,M,L
854 my_real
855 . s,xi(mvsiz),yi(mvsiz),zi(mvsiz)
856C-------------------------------------------------------------
857 DO m=jft,jlt
858 DO l=1,3
859 DO j=1,3
860 r1(l,j,m)=zero
861 r2(l,j,m)=zero
862 r3(l,j,m)=zero
863 r4(l,j,m)=zero
864 ENDDO
865 ENDDO
866 END DO
867C
868 DO m=jft,jlt
869 xi(m)=corelv(m,1,1)
870 yi(m)=corelv(m,2,1)
871 zi(m)=z1(m)
872 END DO
873 CALL set_ri33(xi ,yi, zi ,r1 ,jft,jlt)
874 DO m=jft,jlt
875 xi(m)=corelv(m,1,2)
876 yi(m)=corelv(m,2,2)
877 zi(m)=-z1(m)
878 END DO
879 CALL set_ri33(xi ,yi, zi ,r2 ,jft,jlt)
880 DO m=jft,jlt
881 xi(m)=corelv(m,1,3)
882 yi(m)=corelv(m,2,3)
883 zi(m)=z1(m)
884 END DO
885 CALL set_ri33(xi ,yi, zi ,r3 ,jft,jlt)
886 DO m=jft,jlt
887 xi(m)=corelv(m,1,4)
888 yi(m)=corelv(m,2,4)
889 zi(m)=-z1(m)
890 END DO
891 CALL set_ri33(xi ,yi, zi ,r4 ,jft,jlt)
892C-----------
893 RETURN
set_ri33
subroutine set_ri33(xi, yi, zi, ri, jft, jlt)
Definition cbasumg3.F:903

◆ setprojkba()

subroutine setprojkba ( dr,
r1,
r2,
r3,
r4,
k11,
k12,
k13,
k14,
k22,
k23,
k24,
k33,
k34,
k44,
m11,
m12,
m13,
m14,
m22,
m23,
m24,
m33,
m34,
m44,
mf11,
mf12,
mf13,
mf14,
mf22,
mf23,
mf24,
mf33,
mf34,
mf44,
fm12,
fm13,
fm14,
fm23,
fm24,
fm34,
vq,
vqn,
integer jft,
integer jlt )

Definition at line 937 of file cbasumg3.F.

943C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
944#include "implicit_f.inc"
945#include "mvsiz_p.inc"
946C-----------------------------------------------
947C D U M M Y A R G U M E N T S
948C-----------------------------------------------
949 INTEGER JFT,JLT
950 my_real
951 . dr(3,3,*),vq(3,3,*),vqn(3,3,4,*),
952 . r1(3,3,*),r2(3,3,*),r3(3,3,*),r4(3,3,*),
953 . k11(3,3,*),k12(3,3,*),k13(3,3,*),k14(3,3,*),
954 . k22(3,3,*),k23(3,3,*),k24(3,3,*),k33(3,3,*),
955 . m11(3,3,*),m12(3,3,*),m13(3,3,*),m14(3,3,*),
956 . m22(3,3,*),m23(3,3,*),m24(3,3,*),m33(3,3,*),
957 . mf11(3,3,*),mf12(3,3,*),mf13(3,3,*),mf14(3,3,*),
958 . mf22(3,3,*),mf23(3,3,*),mf24(3,3,*),mf33(3,3,*),
959 . fm12(3,3,*),fm13(3,3,*),fm14(3,3,*),
960 . fm23(3,3,*),fm24(3,3,*),fm34(3,3,*),
961 . k34(3,3,*),k44(3,3,*),m34(3,3,*),m44(3,3,*),
962 . mf34(3,3,*),mf44(3,3,*)
963C-----------------------------------------------
964C LOCAL A R G U M E N T S
965C-----------------------------------------------
966 INTEGER I,J,EP,IS,IAS,IT,IAT
967 my_real
968 . kl(6,6,mvsiz),kq(6,6,mvsiz),vq1(3,3,mvsiz),vq2(3,3,mvsiz),
969 . vq3(3,3,mvsiz),vq4(3,3,mvsiz)
970 DATA is/1/,ias/0/,it/1/,iat/0/
971 my_real,
972 . DIMENSION(:,:,:), ALLOCATABLE:: p,ke
973C-------------------------------------------------------------
974 ALLOCATE(p(24,24,mvsiz))
975 ALLOCATE(ke(24,24,mvsiz))
976C
977 DO i=1,3
978 DO j=1,3
979 DO ep=jft,jlt
980 vq1(i,j,ep)= vqn(j,i,1,ep)
981 vq2(i,j,ep)= vqn(j,i,2,ep)
982 vq3(i,j,ep)= vqn(j,i,3,ep)
983 vq4(i,j,ep)= vqn(j,i,4,ep)
984 ENDDO
985 ENDDO
986 ENDDO
987C-----------P11=Q1Pr11Q
988 CALL tranqikqj33(jft ,jlt ,r1 ,dr , r1 ,kl, is)
989 CALL trankl1(jft ,jlt ,kl ,is )
990 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
991 CALL tranqnkq(jft ,jlt ,vq1 ,kq )
992 DO i=1,6
993 DO j=1,6
994 DO ep=jft,jlt
995 p(i,j,ep)= kq(i,j,ep)
996 ENDDO
997 ENDDO
998 ENDDO
999 DO i=1,3
1000 DO j=i,3
1001 DO ep=jft,jlt
1002 ke(i,j,ep)= k11(i,j,ep)
1003 ke(i+3,j+3,ep)= m11(i,j,ep)
1004 ENDDO
1005 ENDDO
1006 DO j=1,3
1007 DO ep=jft,jlt
1008 ke(i,j+3,ep)= mf11(i,j,ep)
1009 ENDDO
1010 ENDDO
1011 ENDDO
1012C-----------P22=Q2Pr22Q
1013 CALL tranqikqj33(jft ,jlt ,r2 ,dr , r2 ,kl, is)
1014 CALL trankl1(jft ,jlt ,kl ,is )
1015 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
1016 CALL tranqnkq(jft ,jlt ,vq2 ,kq )
1017 DO i=1,6
1018 DO j=1,6
1019 DO ep=jft,jlt
1020 p(i+6,j+6,ep)= kq(i,j,ep)
1021 ENDDO
1022 ENDDO
1023 ENDDO
1024 DO i=1,3
1025 DO j=i,3
1026 DO ep=jft,jlt
1027 ke(i+6,j+6,ep)= k22(i,j,ep)
1028 ke(i+9,j+9,ep)= m22(i,j,ep)
1029 ENDDO
1030 ENDDO
1031 DO j=1,3
1032 DO ep=jft,jlt
1033 ke(i+6,j+9,ep)= mf22(i,j,ep)
1034 ENDDO
1035 ENDDO
1036 ENDDO
1037C-----------P33=Q3Pr33Q
1038 CALL tranqikqj33(jft ,jlt ,r3 ,dr , r3 ,kl, is)
1039 CALL trankl1(jft ,jlt ,kl ,is )
1040 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
1041 CALL tranqnkq(jft ,jlt ,vq3 ,kq )
1042 DO i=1,6
1043 DO j=1,6
1044 DO ep=jft,jlt
1045 p(i+12,j+12,ep)= kq(i,j,ep)
1046 ENDDO
1047 ENDDO
1048 ENDDO
1049 DO i=1,3
1050 DO j=i,3
1051 DO ep=jft,jlt
1052 ke(i+12,j+12,ep)= k33(i,j,ep)
1053 ke(i+15,j+15,ep)= m33(i,j,ep)
1054 ENDDO
1055 ENDDO
1056 DO j=1,3
1057 DO ep=jft,jlt
1058 ke(i+12,j+15,ep)= mf33(i,j,ep)
1059 ENDDO
1060 ENDDO
1061 ENDDO
1062C-----------P44=Q4Pr44Q
1063 CALL tranqikqj33(jft ,jlt ,r4 ,dr , r4 ,kl, is)
1064 CALL trankl1(jft ,jlt ,kl ,is )
1065 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
1066 CALL tranqnkq(jft ,jlt ,vq4 ,kq )
1067 DO i=1,6
1068 DO j=1,6
1069 DO ep=jft,jlt
1070 p(i+18,j+18,ep)= kq(i,j,ep)
1071 ENDDO
1072 ENDDO
1073 ENDDO
1074 DO i=1,3
1075 DO j=i,3
1076 DO ep=jft,jlt
1077 ke(i+18,j+18,ep)= k44(i,j,ep)
1078 ke(i+21,j+21,ep)= m44(i,j,ep)
1079 ENDDO
1080 ENDDO
1081 DO j=1,3
1082 DO ep=jft,jlt
1083 ke(i+18,j+21,ep)= mf44(i,j,ep)
1084 ENDDO
1085 ENDDO
1086 ENDDO
1087C-----------P12=Q1Pr12Q
1088 CALL tranqikqj33(jft ,jlt ,r1 ,dr , r2 ,kl, ias)
1089 CALL trankl1(jft ,jlt ,kl ,ias )
1090 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
1091 CALL tranqnkq(jft ,jlt ,vq1 ,kq )
1092 DO i=1,6
1093 DO j=1,6
1094 DO ep=jft,jlt
1095 p(i,j+6,ep)= kq(i,j,ep)
1096 ENDDO
1097 ENDDO
1098 ENDDO
1099 DO i=1,3
1100 DO j=1,3
1101 DO ep=jft,jlt
1102 ke(i,j+6,ep)= k12(i,j,ep)
1103 ke(i+3,j+9,ep)= m12(i,j,ep)
1104 ke(i,j+9,ep)= mf12(i,j,ep)
1105 ke(i+3,j+6,ep)= fm12(i,j,ep)
1106 ENDDO
1107 ENDDO
1108 ENDDO
1109C-----------P21=Q2Pr21Q
1110 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,iat )
1111 CALL tranqnkq(jft ,jlt ,vq2 ,kq )
1112 DO i=1,6
1113 DO j=1,6
1114 DO ep=jft,jlt
1115 p(i+6,j,ep)= kq(i,j,ep)
1116 ENDDO
1117 ENDDO
1118 ENDDO
1119C-----------P13=Q1Pr13Q
1120 CALL tranqikqj33(jft ,jlt ,r1 ,dr , r3 ,kl, ias)
1121 CALL trankl1(jft ,jlt ,kl ,ias )
1122 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
1123 CALL tranqnkq(jft ,jlt ,vq1 ,kq )
1124 DO i=1,6
1125 DO j=1,6
1126 DO ep=jft,jlt
1127 p(i,j+12,ep)= kq(i,j,ep)
1128 ENDDO
1129 ENDDO
1130 ENDDO
1131 DO i=1,3
1132 DO j=1,3
1133 DO ep=jft,jlt
1134 ke(i,j+12,ep)= k13(i,j,ep)
1135 ke(i+3,j+15,ep)= m13(i,j,ep)
1136 ke(i,j+15,ep)= mf13(i,j,ep)
1137 ke(i+3,j+12,ep)= fm13(i,j,ep)
1138 ENDDO
1139 ENDDO
1140 ENDDO
1141C-----------P31=Q3Pr31Q
1142 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,iat )
1143 CALL tranqnkq(jft ,jlt ,vq3 ,kq )
1144 DO i=1,6
1145 DO j=1,6
1146 DO ep=jft,jlt
1147 p(i+12,j,ep)= kq(i,j,ep)
1148 ENDDO
1149 ENDDO
1150 ENDDO
1151C-----------P14=Q1Pr14Q
1152 CALL tranqikqj33(jft ,jlt ,r1 ,dr , r4 ,kl, ias)
1153 CALL trankl1(jft ,jlt ,kl ,ias )
1154 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
1155 CALL tranqnkq(jft ,jlt ,vq1 ,kq )
1156 DO i=1,6
1157 DO j=1,6
1158 DO ep=jft,jlt
1159 p(i,j+18,ep)= kq(i,j,ep)
1160 ENDDO
1161 ENDDO
1162 ENDDO
1163 DO i=1,3
1164 DO j=1,3
1165 DO ep=jft,jlt
1166 ke(i,j+18,ep)= k14(i,j,ep)
1167 ke(i+3,j+21,ep)= m14(i,j,ep)
1168 ke(i,j+21,ep)= mf14(i,j,ep)
1169 ke(i+3,j+18,ep)= fm14(i,j,ep)
1170 ENDDO
1171 ENDDO
1172 ENDDO
1173C-----------P41=Q4P41Q
1174 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,iat )
1175 CALL tranqnkq(jft ,jlt ,vq4 ,kq )
1176 DO i=1,6
1177 DO j=1,6
1178 DO ep=jft,jlt
1179 p(i+18,j,ep)= kq(i,j,ep)
1180 ENDDO
1181 ENDDO
1182 ENDDO
1183C-----------P23=Q2Pr23Q
1184 CALL tranqikqj33(jft ,jlt ,r2 ,dr , r3 ,kl, ias)
1185 CALL trankl1(jft ,jlt ,kl ,ias )
1186 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
1187 CALL tranqnkq(jft ,jlt ,vq2 ,kq )
1188 DO i=1,6
1189 DO j=1,6
1190 DO ep=jft,jlt
1191 p(i+6,j+12,ep)= kq(i,j,ep)
1192 ENDDO
1193 ENDDO
1194 ENDDO
1195 DO i=1,3
1196 DO j=1,3
1197 DO ep=jft,jlt
1198 ke(i+6,j+12,ep)= k23(i,j,ep)
1199 ke(i+9,j+15,ep)= m23(i,j,ep)
1200 ke(i+6,j+15,ep)= mf23(i,j,ep)
1201 ke(i+9,j+12,ep)= fm23(i,j,ep)
1202 ENDDO
1203 ENDDO
1204 ENDDO
1205C-----------P32=Q3Pr32Q
1206 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,iat )
1207 CALL tranqnkq(jft ,jlt ,vq3 ,kq )
1208 DO i=1,6
1209 DO j=1,6
1210 DO ep=jft,jlt
1211 p(i+12,j+6,ep)= kq(i,j,ep)
1212 ENDDO
1213 ENDDO
1214 ENDDO
1215C-----------P24=Q2Pr24Q
1216 CALL tranqikqj33(jft ,jlt ,r2 ,dr , r4 ,kl, ias)
1217 CALL trankl1(jft ,jlt ,kl ,ias )
1218 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
1219 CALL tranqnkq(jft ,jlt ,vq2 ,kq )
1220 DO i=1,6
1221 DO j=1,6
1222 DO ep=jft,jlt
1223 p(i+6,j+18,ep)= kq(i,j,ep)
1224 ENDDO
1225 ENDDO
1226 ENDDO
1227 DO i=1,3
1228 DO j=1,3
1229 DO ep=jft,jlt
1230 ke(i+6,j+18,ep)= k24(i,j,ep)
1231 ke(i+9,j+21,ep)= m24(i,j,ep)
1232 ke(i+6,j+21,ep)= mf24(i,j,ep)
1233 ke(i+9,j+18,ep)= fm24(i,j,ep)
1234 ENDDO
1235 ENDDO
1236 ENDDO
1237C-----------P42=Q4Pr42Q
1238 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,iat )
1239 CALL tranqnkq(jft ,jlt ,vq4 ,kq )
1240 DO i=1,6
1241 DO j=1,6
1242 DO ep=jft,jlt
1243 p(i+18,j+6,ep)= kq(i,j,ep)
1244 ENDDO
1245 ENDDO
1246 ENDDO
1247C-----------P34=Q3Pr34Q
1248 CALL tranqikqj33(jft ,jlt ,r3 ,dr , r4 ,kl, ias)
1249 CALL trankl1(jft ,jlt ,kl ,ias )
1250 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
1251 CALL tranqnkq(jft ,jlt ,vq3 ,kq )
1252 DO i=1,6
1253 DO j=1,6
1254 DO ep=jft,jlt
1255 p(i+12,j+18,ep)= kq(i,j,ep)
1256 ENDDO
1257 ENDDO
1258 ENDDO
1259 DO i=1,3
1260 DO j=1,3
1261 DO ep=jft,jlt
1262 ke(i+12,j+18,ep)= k34(i,j,ep)
1263 ke(i+15,j+21,ep)= m34(i,j,ep)
1264 ke(i+12,j+21,ep)= mf34(i,j,ep)
1265 ke(i+15,j+18,ep)= fm34(i,j,ep)
1266 ENDDO
1267 ENDDO
1268 ENDDO
1269C-----------P43=Q4Pr43Q
1270 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,iat )
1271 CALL tranqnkq(jft ,jlt ,vq4 ,kq )
1272 DO i=1,6
1273 DO j=1,6
1274 DO ep=jft,jlt
1275 p(i+18,j+12,ep)= kq(i,j,ep)
1276 ENDDO
1277 ENDDO
1278 ENDDO
1279C-----------
1280 DO i=1,24
1281 DO j=i+1,24
1282 DO ep=jft,jlt
1283 ke(j,i,ep)= ke(i,j,ep)
1284 ENDDO
1285 ENDDO
1286 ENDDO
1287C-----------
1288 CALL tranqikqj(jft ,jlt ,p ,ke,p ,24 ,is )
1289C-----------after projection----
1290C-----------K11
1291 DO i=1,3
1292 DO j=i,3
1293 DO ep=jft,jlt
1294 k11(i,j,ep) =ke(i,j,ep)
1295 m11(i,j,ep) =ke(i+3,j+3,ep)
1296 ENDDO
1297 ENDDO
1298 DO j=1,3
1299 DO ep=jft,jlt
1300 mf11(i,j,ep) = ke(i,j+3,ep)
1301 ENDDO
1302 ENDDO
1303 ENDDO
1304C-----------K22
1305 DO i=1,3
1306 DO j=i,3
1307 DO ep=jft,jlt
1308 k22(i,j,ep) = ke(i+6,j+6,ep)
1309 m22(i,j,ep) = ke(i+9,j+9,ep)
1310 ENDDO
1311 ENDDO
1312 DO j=1,3
1313 DO ep=jft,jlt
1314 mf22(i,j,ep) = ke(i+6,j+9,ep)
1315 ENDDO
1316 ENDDO
1317 ENDDO
1318C-----------K33
1319 DO i=1,3
1320 DO j=i,3
1321 DO ep=jft,jlt
1322 k33(i,j,ep) = ke(i+12,j+12,ep)
1323 m33(i,j,ep) = ke(i+15,j+15,ep)
1324 ENDDO
1325 ENDDO
1326 DO j=1,3
1327 DO ep=jft,jlt
1328 mf33(i,j,ep) = ke(i+12,j+15,ep)
1329 ENDDO
1330 ENDDO
1331 ENDDO
1332C-----------K44
1333 DO i=1,3
1334 DO j=i,3
1335 DO ep=jft,jlt
1336 k44(i,j,ep) = ke(i+18,j+18,ep)
1337 m44(i,j,ep) = ke(i+21,j+21,ep)
1338 ENDDO
1339 ENDDO
1340 DO j=1,3
1341 DO ep=jft,jlt
1342 mf44(i,j,ep) = ke(i+18,j+21,ep)
1343 ENDDO
1344 ENDDO
1345 ENDDO
1346C-----------K12
1347 DO i=1,3
1348 DO j=1,3
1349 DO ep=jft,jlt
1350 k12(i,j,ep) =ke(i,j+6,ep)
1351 m12(i,j,ep) =ke(i+3,j+9,ep)
1352 mf12(i,j,ep)=ke(i,j+9,ep)
1353 fm12(i,j,ep)=ke(i+3,j+6,ep)
1354 ENDDO
1355 ENDDO
1356 ENDDO
1357C-----------K13
1358 DO i=1,3
1359 DO j=1,3
1360 DO ep=jft,jlt
1361 k13(i,j,ep) = ke(i,j+12,ep)
1362 m13(i,j,ep) = ke(i+3,j+15,ep)
1363 mf13(i,j,ep) = ke(i,j+15,ep)
1364 fm13(i,j,ep) = ke(i+3,j+12,ep)
1365 ENDDO
1366 ENDDO
1367 ENDDO
1368C-----------K14
1369 DO i=1,3
1370 DO j=1,3
1371 DO ep=jft,jlt
1372 k14(i,j,ep) =ke(i,j+18,ep)
1373 m14(i,j,ep) =ke(i+3,j+21,ep)
1374 mf14(i,j,ep)=ke(i,j+21,ep)
1375 fm14(i,j,ep)=ke(i+3,j+18,ep)
1376 ENDDO
1377 ENDDO
1378 ENDDO
1379C-----------K23
1380 DO i=1,3
1381 DO j=1,3
1382 DO ep=jft,jlt
1383 k23(i,j,ep) = ke(i+6,j+12,ep)
1384 m23(i,j,ep) = ke(i+9,j+15,ep)
1385 mf23(i,j,ep) =ke(i+6,j+15,ep)
1386 fm23(i,j,ep) =ke(i+9,j+12,ep)
1387 ENDDO
1388 ENDDO
1389 ENDDO
1390C-----------K24
1391 DO i=1,3
1392 DO j=1,3
1393 DO ep=jft,jlt
1394 k24(i,j,ep) = ke(i+6,j+18,ep)
1395 m24(i,j,ep) = ke(i+9,j+21,ep)
1396 mf24(i,j,ep) =ke(i+6,j+21,ep)
1397 fm24(i,j,ep) =ke(i+9,j+18,ep)
1398 ENDDO
1399 ENDDO
1400 ENDDO
1401C-----------K34
1402 DO i=1,3
1403 DO j=1,3
1404 DO ep=jft,jlt
1405 k34(i,j,ep) = ke(i+12,j+18,ep)
1406 m34(i,j,ep) = ke(i+15,j+21,ep)
1407 mf34(i,j,ep) =ke(i+12,j+21,ep)
1408 fm34(i,j,ep) =ke(i+15,j+18,ep)
1409 ENDDO
1410 ENDDO
1411 ENDDO
1412C-----------
1413 DEALLOCATE(p)
1414 DEALLOCATE(ke)
1415 RETURN
tranqikqj33
subroutine tranqikqj33(jft, jlt, ri, rd, rj, kd, isym)
Definition cbasumg3.F:1424
tranqnkq
subroutine tranqnkq(jft, jlt, vqn, kq)
Definition cbasumg3.F:1534
tranklq
subroutine tranklq(jft, jlt, vq, kl, kd, it)
Definition czsumg3.F:1714
trankl1
subroutine trankl1(jft, jlt, kl, is)
Definition czsumg3.F:1676
tranqikqj
subroutine tranqikqj(jft, jlt, vqi, kk, vqj, nd, isym)
Definition czsumg3.F:1602

◆ tranqikqj33()

subroutine tranqikqj33 ( integer jft,
integer jlt,
ri,
rd,
rj,
kd,
integer isym )

Definition at line 1423 of file cbasumg3.F.

1424C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
1425#include "implicit_f.inc"
1426C-----------------------------------------------
1427C D U M M Y A R G U M E N T S
1428C-----------------------------------------------
1429 INTEGER JFT,JLT,ISYM
1430 my_real
1431 . ri(3,3,*), rj(3,3,*),rd(3,3,*),kd(6,6,*)
1432C-----------------------------------------------
1433C LOCAL A R G U M E N T S
1434C-----------------------------------------------
1435 INTEGER I,J,EP,L,I1,J1
1436 my_real
1437 . k(3,3)
1438C--------------[KD]=|RI| |RD| |RJ|^t---------------------------------
1439C-------------- | I| |I |---------------------------------
1440 IF (isym==1) THEN
1441 DO i=1,3
1442 DO j=i,3
1443 DO ep=jft,jlt
1444 k(i,j)=zero
1445 DO l=1,3
1446 k(i,j)=k(i,j)+ri(i,1,ep)*rd(1,l,ep)*rj(j,l,ep)+
1447 1 ri(i,2,ep)*rd(2,l,ep)*rj(j,l,ep)+
1448 1 ri(i,3,ep)*rd(3,l,ep)*rj(j,l,ep)
1449 ENDDO
1450 kd(i,j,ep)= k(i,j)
1451 kd(j,i,ep)= k(i,j)
1452 ENDDO
1453C
1454 i1=i+3
1455 j1=j+3
1456 DO ep=jft,jlt
1457 kd(i1,j1,ep)= rd(i,j,ep)
1458 kd(j1,i1,ep)= rd(i,j,ep)
1459 ENDDO
1460 ENDDO
1461 ENDDO
1462C
1463 DO i=1,3
1464 DO j=1,3
1465 i1=i+3
1466 j1=j+3
1467 DO ep=jft,jlt
1468 k(i,j)=zero
1469 DO l=1,3
1470 k(i,j)=k(i,j)+ri(i,l,ep)*rd(l,j,ep)
1471 ENDDO
1472 kd(i,j1,ep)= k(i,j)
1473 kd(j1,i,ep)= k(i,j)
1474 ENDDO
1475 ENDDO
1476 ENDDO
1477C
1478 ELSE
1479 DO i=1,3
1480 DO j=1,3
1481 DO ep=jft,jlt
1482 k(i,j)=zero
1483 DO l=1,3
1484 k(i,j)=k(i,j)+ri(i,1,ep)*rd(1,l,ep)*rj(j,l,ep)+
1485 1 ri(i,2,ep)*rd(2,l,ep)*rj(j,l,ep)+
1486 1 ri(i,3,ep)*rd(3,l,ep)*rj(j,l,ep)
1487 ENDDO
1488 kd(i,j,ep)= k(i,j)
1489 ENDDO
1490C
1491 i1=i+3
1492 j1=j+3
1493 DO ep=jft,jlt
1494 kd(i1,j1,ep)= rd(i,j,ep)
1495 ENDDO
1496 ENDDO
1497 ENDDO
1498C
1499 DO j=1,3
1500 j1=j+3
1501 DO i=1,3
1502 DO ep=jft,jlt
1503 k(i,j)=zero
1504 DO l=1,3
1505 k(i,j)=k(i,j)+ri(i,l,ep)*rd(l,j,ep)
1506 ENDDO
1507 kd(i,j1,ep)= k(i,j)
1508 ENDDO
1509 ENDDO
1510 ENDDO
1511C
1512 DO i=1,3
1513 i1=i+3
1514 DO j=1,3
1515 DO ep=jft,jlt
1516 k(i,j)=zero
1517 DO l=1,3
1518 k(i,j)=k(i,j)+rd(i,l,ep)*rj(j,l,ep)
1519 ENDDO
1520 kd(i1,j,ep)= k(i,j)
1521 ENDDO
1522 ENDDO
1523 ENDDO
1524C
1525 ENDIF
1526 RETURN

◆ tranqnkq()

subroutine tranqnkq ( integer jft,
integer jlt,
vqn,
kq )

Definition at line 1533 of file cbasumg3.F.

1534C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
1535#include "implicit_f.inc"
1536#include "mvsiz_p.inc"
1537C-----------------------------------------------
1538C D U M M Y A R G U M E N T S
1539C-----------------------------------------------
1540 INTEGER JFT,JLT,IT
1541 my_real
1542 . vqn(3,3,*), kq(6,6,*)
1543C-----------------------------------------------
1544C LOCAL A R G U M E N T S
1545C-----------------------------------------------
1546 INTEGER I,J,EP,K,L,J1,I1
1547 my_real
1548 . kd(3,3,mvsiz),kk(3,3,mvsiz)
1549C--------------KQ<-VQ*KQ----VQ=|I 0 |
1550C------------------------------|0 VQN|---------------------
1551 DO i=1,3
1552 DO j=1,3
1553 DO ep=jft,jlt
1554 kd(i,j,ep)= zero
1555 kk(i,j,ep)= zero
1556 ENDDO
1557 ENDDO
1558 ENDDO
1559C
1560 DO j=1,3
1561 j1=j+3
1562 DO i=1,3
1563 DO ep=jft,jlt
1564 DO k=1,3
1565 kd(i,j,ep)=kd(i,j,ep)+vqn(i,k,ep)*kq(k+3,j,ep)
1566 kk(i,j,ep)=kk(i,j,ep)+vqn(i,k,ep)*kq(k+3,j1,ep)
1567 ENDDO
1568 ENDDO
1569 ENDDO
1570 ENDDO
1571C
1572 DO i=1,3
1573 i1=i+3
1574 DO j=1,3
1575 j1=j+3
1576 DO ep=jft,jlt
1577 kq(i1,j,ep)=kd(i,j,ep)
1578 kq(i1,j1,ep)=kk(i,j,ep)
1579 ENDDO
1580 ENDDO
1581 ENDDO
1582C
1583 RETURN

◆ writekc4()

subroutine writekc4 ( integer in,
integer jft,
integer jlt,
character ch,
kij )

Definition at line 1751 of file cbasumg3.F.

1752C-----------------------------------------------
1753C I m p l i c i t T y p e s
1754C-----------------------------------------------
1755#include "implicit_f.inc"
1756C-----------------------------------------------
1757C D u m m y A r g u m e n t s
1758C-----------------------------------------------
1759 INTEGER JFT,JLT,IN
1760 CHARACTER CH*3
1761C REAL
1762 my_real
1763 . kij(6,6,*)
1764C-----------------------------------------------
1765C L o c a l V a r i a b l e s
1766C-----------------------------------------------
1767 INTEGER I,J,N,NT
1768 CHARACTER KEY*10,KEY1*23
1769C-----------------------------------------------
1770 key='/SHELL_'//ch
1771 key1='#3d Shell Elements '//ch
1772 WRITE(in,'(A)') key
1773 WRITE(in,'(A)')key1
1774 WRITE(in,'(A)')
1775 . '#FORMAT: (6(/,1P6E12.5),/) '
1776 WRITE(in,'(2A)')'#SYSSHEL USRSHEL K(I,J) I=1,6;J=1,6'
1777 DO n= jft,jlt
1778 WRITE(in,'(6(/,1P6E12.5),/)'
1779 . )((kij(i,j,n),i=1,6),j=1,6)
1780 ENDDO
1781 RETURN