OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
czproj.F File Reference
#include "implicit_f.inc"
#include "mvsiz_p.inc"
#include "com01_c.inc"
#include "com08_c.inc"
#include "parit_c.inc"
#include "impl1_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine czproj1 (jft, jlt, vqn, vq, vf, vm, plat, f11, f12, f13, f14, f21, f22, f23, f24, f31, f32, f33, f34, m11, m12, m13, m14, m21, m22, m23, m24, m31, m32, m33, m34, fzero, z1, corel, di, db, corelv, idril, diz, vmz)
subroutine czmzl2g (jft, jlt, vq, mlz, m11, m12, m13, m14, m21, m22, m23, m24, m31, m32, m33, m34, vqn, plat)
subroutine czprojv (jft, jlt, vqn, vq, vf, vm, plat, f11, f12, f13, f14, f21, f22, f23, f24, f31, f32, f33, f34, m11, m12, m13, m14, m21, m22, m23, m24, m31, m32, m33, m34, fzero, z1, di, db, corelv, ifini, idril, diz, vmz)
subroutine czprojn (jft, jlt, vqn, vq, vf, vm, plat, f11, f12, f13, f14, f21, f22, f23, f24, f31, f32, f33, f34, m11, m12, m13, m14, m21, m22, m23, m24, m31, m32, m33, m34, fzero, z1, corel, di, db, ifini, idril, diz, vmz)

Function/Subroutine Documentation

◆ czmzl2g()

subroutine czmzl2g ( integer jft,
integer jlt,
vq,
mlz,
m11,
m12,
m13,
m14,
m21,
m22,
m23,
m24,
m31,
m32,
m33,
m34,
vqn,
logical, dimension(*) plat )

Definition at line 185 of file czproj.F.

190C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
191#include "implicit_f.inc"
192C-----------------------------------------------
193C G l o b a l P a r a m e t e r s
194C-----------------------------------------------
195#include "mvsiz_p.inc"
196C-----------------------------------------------
197C D U M M Y A R G U M E N T S
198C-----------------------------------------------
199 LOGICAL PLAT(*)
200 INTEGER JFT,JLT
201 my_real
202 . vqn(mvsiz,3,4),vq(mvsiz,3,3),mlz(4,*)
203 my_real
204 . m11(*), m12(*), m13(*), m14(*),
205 . m21(*), m22(*), m23(*), m24(*),
206 . m31(*), m32(*), m33(*), m34(*)
207C-----------------------------------------------
208C L O C A L V A R I A B L E S
209C-----------------------------------------------
210 INTEGER I, J, K
211 my_real
212 . vxl, vyl, vzl
213C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
214 DO k=jft,jlt
215 IF (plat(k)) THEN
216 m11(k)= m11(k)+ vq(k,1,3)*mlz(1,k)
217 m21(k)= m21(k)+ vq(k,2,3)*mlz(1,k)
218 m31(k)= m31(k)+ vq(k,3,3)*mlz(1,k)
219C
220 m12(k)= m12(k)+ vq(k,1,3)*mlz(2,k)
221 m22(k)= m22(k)+ vq(k,2,3)*mlz(2,k)
222 m32(k)= m32(k)+ vq(k,3,3)*mlz(2,k)
223C
224 m13(k)= m13(k)+ vq(k,1,3)*mlz(3,k)
225 m23(k)= m23(k)+ vq(k,2,3)*mlz(3,k)
226 m33(k)= m33(k)+ vq(k,3,3)*mlz(3,k)
227C
228 m14(k)= m14(k)+ vq(k,1,3)*mlz(4,k)
229 m24(k)= m24(k)+ vq(k,2,3)*mlz(4,k)
230 m34(k)= m34(k)+ vq(k,3,3)*mlz(4,k)
231 ELSE
232 j=1
233 vxl= vqn(k,1,j)*mlz(j,k)
234 vyl= vqn(k,2,j)*mlz(j,k)
235 vzl= vqn(k,3,j)*mlz(j,k)
236 m11(k)= m11(k)+ vq(k,1,1)*vxl+vq(k,1,2)*vyl+vq(k,1,3)*vzl
237 m21(k)= m21(k)+ vq(k,2,1)*vxl+vq(k,2,2)*vyl+vq(k,2,3)*vzl
238 m31(k)= m31(k)+ vq(k,3,1)*vxl+vq(k,3,2)*vyl+vq(k,3,3)*vzl
239C
240 j=2
241 vxl= vqn(k,1,j)*mlz(j,k)
242 vyl= vqn(k,2,j)*mlz(j,k)
243 vzl= vqn(k,3,j)*mlz(j,k)
244 m12(k)= m12(k)+ vq(k,1,1)*vxl+vq(k,1,2)*vyl+vq(k,1,3)*vzl
245 m22(k)= m22(k)+ vq(k,2,1)*vxl+vq(k,2,2)*vyl+vq(k,2,3)*vzl
246 m32(k)= m32(k)+ vq(k,3,1)*vxl+vq(k,3,2)*vyl+vq(k,3,3)*vzl
247C
248 j=3
249 vxl= vqn(k,1,j)*mlz(j,k)
250 vyl= vqn(k,2,j)*mlz(j,k)
251 vzl= vqn(k,3,j)*mlz(j,k)
252 m13(k)= m13(k)+ vq(k,1,1)*vxl+vq(k,1,2)*vyl+vq(k,1,3)*vzl
253 m23(k)= m23(k)+ vq(k,2,1)*vxl+vq(k,2,2)*vyl+vq(k,2,3)*vzl
254 m33(k)= m33(k)+ vq(k,3,1)*vxl+vq(k,3,2)*vyl+vq(k,3,3)*vzl
255C
256 j=4
257 vxl= vqn(k,1,j)*mlz(j,k)
258 vyl= vqn(k,2,j)*mlz(j,k)
259 vzl= vqn(k,3,j)*mlz(j,k)
260 m14(k)= m14(k)+ vq(k,1,1)*vxl+vq(k,1,2)*vyl+vq(k,1,3)*vzl
261 m24(k)= m24(k)+ vq(k,2,1)*vxl+vq(k,2,2)*vyl+vq(k,2,3)*vzl
262 m34(k)= m34(k)+ vq(k,3,1)*vxl+vq(k,3,2)*vyl+vq(k,3,3)*vzl
263C
264 END IF !(PLAT(K)) THEN
265 ENDDO
266
267C
268 RETURN
my_real
#define my_real
Definition cppsort.cpp:32

◆ czproj1()

subroutine czproj1 ( integer jft,
integer jlt,
vqn,
vq,
vf,
vm,
logical, dimension(*) plat,
f11,
f12,
f13,
f14,
f21,
f22,
f23,
f24,
f31,
f32,
f33,
f34,
m11,
m12,
m13,
m14,
m21,
m22,
m23,
m24,
m31,
m32,
m33,
m34,
fzero,
z1,
corel,
di,
db,
corelv,
integer idril,
diz,
vmz )

Definition at line 32 of file czproj.F.

42C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
43#include "implicit_f.inc"
44#include "mvsiz_p.inc"
45#include "com01_c.inc"
46#include "com08_c.inc"
47#include "parit_c.inc"
48C-----------------------------------------------
49C D U M M Y A R G U M E N T S
50C-----------------------------------------------
51 LOGICAL PLAT(*)
52 INTEGER JFT,JLT,IDRIL
53 my_real
54 . vqn(mvsiz,3,4),vf(mvsiz,3,4),vm(mvsiz,2,4),vq(mvsiz,3,3),
55 . corel(mvsiz,2,4),di(mvsiz,6),db(mvsiz,3,4),z1(*)
56 my_real
57 . f11(mvsiz), f12(mvsiz), f13(mvsiz), f14(mvsiz),
58 . f21(mvsiz), f22(mvsiz), f23(mvsiz), f24(mvsiz),
59 . f31(mvsiz), f32(mvsiz), f33(mvsiz), f34(mvsiz),
60 . m11(mvsiz), m12(mvsiz), m13(mvsiz), m14(mvsiz),
61 . m21(mvsiz), m22(mvsiz), m23(mvsiz), m24(mvsiz),
62 . m31(mvsiz), m32(mvsiz), m33(mvsiz), m34(mvsiz),
63C
64 . fzero(3,4,*)
65C
66 my_real
67 . corelv(mvsiz,2,4),diz(mvsiz,3),vmz(mvsiz,4)
68C=======================================================================
69c FUNCTION: Projection for internal forces and translate from local sys to Global
70c
71c Note:
72c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
73c
74c TYPE NAME FUNCTION
75c I JFT,JLT - element id limit
76c I VQN(3,4,NEL) - nodal normal vectors (basd on the local sys)
77c I VQ(3,3,NEL) - local sys (e1,e2,e3)
78c I VF(3,4,NEL),VM(2,4,NEL) - internal forces&moment (5dofs) in local system
79c for plate element(coplaner), symmetry terms in 1,3,
80c anti-symmetry terms in 2,4
81c I PLAT(NEL) - plate element (logic)
82C O Fij(NEL),Mij(NEL) - final internal forces (6dofs) in global system (j=1,4)
83C I COREL,DI,DB,Z1 - parameters for projections
84c I IDRIL - Drilling dof flag
85C-----------------------------------------------
86C L O C A L V A R I A B L E S
87C-----------------------------------------------
88 INTEGER I, J, K ,IFINI
89 my_real
90 . mm(3,4),fl(3,4),ml(2,4),c1,
91 . ar(3),ad(4),alr(3),ald(4),dbad(3),
92 . temp1, temp2, temp3
93C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
94C-----------------------------------------------
95C POUR ISIGI = 5 OU -5
96C CHANGEMENT DE REPERE DE FZERO POUR TT=DT1
97C REPERE GLOBAL ---> REPERE LOCAL
98C-----------------------------------------------
99 IF(iabs(isigi)==5.AND.ncycle==1.AND.irun==1) THEN
100 DO i=jft,jlt
101 DO j=1,4
102 temp1=fzero(1,j,i)
103 temp2=fzero(2,j,i)
104 temp3=fzero(3,j,i)
105 fzero(1,j,i)=temp1*vq(i,1,1)+temp2*vq(i,2,1)
106 . +temp3*vq(i,3,1)
107 fzero(2,j,i)=temp1*vq(i,1,2)+temp2*vq(i,2,2)
108 . +temp3*vq(i,3,2)
109 fzero(3,j,i)=temp1*vq(i,1,3)+temp2*vq(i,2,3)
110 . +temp3*vq(i,3,3)
111 ENDDO
112 ENDDO
113 ENDIF
114C-----------------------------------------------
115C POUR ISIGI = 5 OU -5
116C PRISE EN COMPTE DES FORCES D EQUILIBRAGE
117C DANS L EVALUATION DES EFFORTS INTERNES
118C-----------------------------------------------
119 IF((iabs(isigi)==5.AND.ncycle>=1.AND.irun==1).OR.
120 . (iabs(isigi)==5.AND.irun>1)) THEN
121 ifini = 1
122C
123 IF(ivector==1)THEN
124 CALL czprojv(
125 1 jft ,jlt ,vqn ,vq ,vf ,
126 2 vm ,plat ,
127 3 f11 ,f12 ,f13 ,f14 ,f21 ,
128 4 f22 ,f23 ,f24 ,f31 ,f32 ,
129 5 f33 ,f34 ,m11 ,m12 ,m13 ,
130 6 m14 ,m21 ,m22 ,m23 ,m24 ,
131 7 m31 ,m32 ,m33 ,m34 ,fzero ,
132 8 z1 ,di ,db ,corelv ,ifini ,
133 9 idril ,diz ,vmz )
134 ELSE
135C
136 CALL czprojn(
137 1 jft ,jlt ,vqn ,vq ,vf ,
138 2 vm ,plat ,
139 3 f11 ,f12 ,f13 ,f14 ,f21 ,
140 4 f22 ,f23 ,f24 ,f31 ,f32 ,
141 5 f33 ,f34 ,m11 ,m12 ,m13 ,
142 6 m14 ,m21 ,m22 ,m23 ,m24 ,
143 7 m31 ,m32 ,m33 ,m34 ,fzero ,
144 8 z1 ,corel ,di ,db ,ifini ,
145 9 idril ,diz ,vmz )
146C
147 END IF !IF(IVECTOR==1)THEN
148 ENDIF
149C
150 IF(iabs(isigi)/=5.OR.tt==0) THEN
151
152 ifini = 0
153 IF(ivector==1)THEN
154 CALL czprojv(
155 1 jft ,jlt ,vqn ,vq ,vf ,
156 2 vm ,plat ,
157 3 f11 ,f12 ,f13 ,f14 ,f21 ,
158 4 f22 ,f23 ,f24 ,f31 ,f32 ,
159 5 f33 ,f34 ,m11 ,m12 ,m13 ,
160 6 m14 ,m21 ,m22 ,m23 ,m24 ,
161 7 m31 ,m32 ,m33 ,m34 ,fzero ,
162 8 z1 ,di ,db ,corelv ,ifini ,
163 9 idril ,diz ,vmz )
164 ELSE
165C
166 CALL czprojn(
167 1 jft ,jlt ,vqn ,vq ,vf ,
168 2 vm ,plat ,
169 3 f11 ,f12 ,f13 ,f14 ,f21 ,
170 4 f22 ,f23 ,f24 ,f31 ,f32 ,
171 5 f33 ,f34 ,m11 ,m12 ,m13 ,
172 6 m14 ,m21 ,m22 ,m23 ,m24 ,
173 7 m31 ,m32 ,m33 ,m34 ,fzero ,
174 8 z1 ,corel ,di ,db ,ifini ,
175 9 idril ,diz ,vmz )
176C
177 END IF !IF(IVECTOR==1)THEN
178 ENDIF
179C
180 RETURN
czprojv
subroutine czprojv(jft, jlt, vqn, vq, vf, vm, plat, f11, f12, f13, f14, f21, f22, f23, f24, f31, f32, f33, f34, m11, m12, m13, m14, m21, m22, m23, m24, m31, m32, m33, m34, fzero, z1, di, db, corelv, ifini, idril, diz, vmz)
Definition czproj.F:285
czprojn
subroutine czprojn(jft, jlt, vqn, vq, vf, vm, plat, f11, f12, f13, f14, f21, f22, f23, f24, f31, f32, f33, f34, m11, m12, m13, m14, m21, m22, m23, m24, m31, m32, m33, m34, fzero, z1, corel, di, db, ifini, idril, diz, vmz)
Definition czproj.F:890

◆ czprojn()

subroutine czprojn ( integer jft,
integer jlt,
vqn,
vq,
vf,
vm,
logical, dimension(*) plat,
f11,
f12,
f13,
f14,
f21,
f22,
f23,
f24,
f31,
f32,
f33,
f34,
m11,
m12,
m13,
m14,
m21,
m22,
m23,
m24,
m31,
m32,
m33,
m34,
fzero,
z1,
corel,
di,
db,
integer ifini,
integer idril,
diz,
vmz )

Definition at line 880 of file czproj.F.

890C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
891C TRANSMET LES FORCES INTERNES LOCALES VF,VM ---> GLOBALES FIJ ,MIJ
892C ENTREES :
893C SORTIES : FIJ,MIJ
894C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
895#include "implicit_f.inc"
896#include "mvsiz_p.inc"
897#include "impl1_c.inc"
898C-----------------------------------------------
899C D U M M Y A R G U M E N T S
900C-----------------------------------------------
901 LOGICAL PLAT(*)
902 INTEGER JFT,JLT,IDRIL,IFINI
903 my_real
904 . vqn(mvsiz,3,4),vf(mvsiz,3,4),vm(mvsiz,2,4),vq(mvsiz,3,3),
905 . corel(mvsiz,2,4),di(mvsiz,6),db(mvsiz,3,4),z1(*)
906 my_real
907 . f11(mvsiz), f12(mvsiz), f13(mvsiz), f14(mvsiz),
908 . f21(mvsiz), f22(mvsiz), f23(mvsiz), f24(mvsiz),
909 . f31(mvsiz), f32(mvsiz), f33(mvsiz), f34(mvsiz),
910 . m11(mvsiz), m12(mvsiz), m13(mvsiz), m14(mvsiz),
911 . m21(mvsiz), m22(mvsiz), m23(mvsiz), m24(mvsiz),
912 . m31(mvsiz), m32(mvsiz), m33(mvsiz), m34(mvsiz),
913C
914 . fzero(3,4,*),diz(mvsiz,3),vmz(mvsiz,4)
915C-----------------------------------------------
916C L O C A L V A R I A B L E S
917C-----------------------------------------------
918 INTEGER I, J, K
919 my_real
920 . mm(3,4),fl(3,4),ml(2,4),c1,
921 . ar(3),ad(4),alr(3),ald(4),dbad(3),
922 . temp1, temp2, temp3,arz
923C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
924 IF(ifini > 0 )THEN
925 DO k=jft,jlt
926C
927C I=1
928 fl(1,1)= vf(k,1,1)+vf(k,1,3)
929 fl(1,2)= vf(k,1,2)+vf(k,1,4)
930 fl(1,3)=-vf(k,1,1)+vf(k,1,3)
931 fl(1,4)=-vf(k,1,2)+vf(k,1,4)
932C I=2
933 fl(2,1)= vf(k,2,1)+vf(k,2,3)
934 fl(2,2)= vf(k,2,2)+vf(k,2,4)
935 fl(2,3)=-vf(k,2,1)+vf(k,2,3)
936 fl(2,4)=-vf(k,2,2)+vf(k,2,4)
937C I=3
938 fl(3,1)= vf(k,3,1)+vf(k,3,3)
939 fl(3,2)= vf(k,3,2)+vf(k,3,4)
940 fl(3,3)=-vf(k,3,1)+vf(k,3,3)
941 fl(3,4)=-vf(k,3,2)+vf(k,3,4)
942C
943C I=1
944 fl(1,1)=fl(1,1)+fzero(1,1,k)
945 fl(1,2)=fl(1,2)+fzero(1,2,k)
946 fl(1,3)=fl(1,3)+fzero(1,3,k)
947 fl(1,4)=fl(1,4)+fzero(1,4,k)
948C I=2
949 fl(2,1)=fl(2,1)+fzero(2,1,k)
950 fl(2,2)=fl(2,2)+fzero(2,2,k)
951 fl(2,3)=fl(2,3)+fzero(2,3,k)
952 fl(2,4)=fl(2,4)+fzero(2,4,k)
953C I=3
954 fl(3,1)= fl(3,1)+fzero(3,1,k)
955 fl(3,2)= fl(3,2)+fzero(3,2,k)
956 fl(3,3)= fl(3,3)+fzero(3,3,k)
957 fl(3,4)= fl(3,4)+fzero(3,4,k)
958C
959C I=1
960 ml(1,1)= vm(k,1,1)+vm(k,1,3)
961 ml(1,2)= vm(k,1,2)+vm(k,1,4)
962 ml(1,3)=-vm(k,1,1)+vm(k,1,3)
963 ml(1,4)=-vm(k,1,2)+vm(k,1,4)
964C I=2
965 ml(2,1)= vm(k,2,1)+vm(k,2,3)
966 ml(2,2)= vm(k,2,2)+vm(k,2,4)
967 ml(2,3)=-vm(k,2,1)+vm(k,2,3)
968 ml(2,4)=-vm(k,2,2)+vm(k,2,4)
969C---------------------------------------
970C TRANS LOCAL-->GLOBAL ET 5DDL-->6DDL
971C---------------------------------------
972 IF (plat(k)) THEN
973C
974C J=1
975C I=1
976 f11(k)= vq(k,1,1)*fl(1,1)+vq(k,1,2)*fl(2,1)+vq(k,1,3)*fl(3,1)
977 m11(k)= vq(k,1,1)*ml(1,1)+vq(k,1,2)*ml(2,1)
978C I=2
979 f21(k)= vq(k,2,1)*fl(1,1)+vq(k,2,2)*fl(2,1)+vq(k,2,3)*fl(3,1)
980 m21(k)= vq(k,2,1)*ml(1,1)+vq(k,2,2)*ml(2,1)
981C I=3
982 f31(k)= vq(k,3,1)*fl(1,1)+vq(k,3,2)*fl(2,1)+vq(k,3,3)*fl(3,1)
983 m31(k)= vq(k,3,1)*ml(1,1)+vq(k,3,2)*ml(2,1)
984C
985C J=2
986C I=1
987 f12(k)= vq(k,1,1)*fl(1,2)+vq(k,1,2)*fl(2,2)+vq(k,1,3)*fl(3,2)
988 m12(k)= vq(k,1,1)*ml(1,2)+vq(k,1,2)*ml(2,2)
989C I=2
990 f22(k)= vq(k,2,1)*fl(1,2)+vq(k,2,2)*fl(2,2)+vq(k,2,3)*fl(3,2)
991 m22(k)= vq(k,2,1)*ml(1,2)+vq(k,2,2)*ml(2,2)
992C I=3
993 f32(k)= vq(k,3,1)*fl(1,2)+vq(k,3,2)*fl(2,2)+vq(k,3,3)*fl(3,2)
994 m32(k)= vq(k,3,1)*ml(1,2)+vq(k,3,2)*ml(2,2)
995C
996C J=3
997C I=1
998 f13(k)= vq(k,1,1)*fl(1,3)+vq(k,1,2)*fl(2,3)+vq(k,1,3)*fl(3,3)
999 m13(k)= vq(k,1,1)*ml(1,3)+vq(k,1,2)*ml(2,3)
1000C I=2
1001 f23(k)= vq(k,2,1)*fl(1,3)+vq(k,2,2)*fl(2,3)+vq(k,2,3)*fl(3,3)
1002 m23(k)= vq(k,2,1)*ml(1,3)+vq(k,2,2)*ml(2,3)
1003C I=3
1004 f33(k)= vq(k,3,1)*fl(1,3)+vq(k,3,2)*fl(2,3)+vq(k,3,3)*fl(3,3)
1005 m33(k)= vq(k,3,1)*ml(1,3)+vq(k,3,2)*ml(2,3)
1006C
1007C J=4
1008C I=1
1009 f14(k)= vq(k,1,1)*fl(1,4)+vq(k,1,2)*fl(2,4)+vq(k,1,3)*fl(3,4)
1010 m14(k)= vq(k,1,1)*ml(1,4)+vq(k,1,2)*ml(2,4)
1011C I=2
1012 f24(k)= vq(k,2,1)*fl(1,4)+vq(k,2,2)*fl(2,4)+vq(k,2,3)*fl(3,4)
1013 m24(k)= vq(k,2,1)*ml(1,4)+vq(k,2,2)*ml(2,4)
1014C I=3
1015 f34(k)= vq(k,3,1)*fl(1,4)+vq(k,3,2)*fl(2,4)+vq(k,3,3)*fl(3,4)
1016 m34(k)= vq(k,3,1)*ml(1,4)+vq(k,3,2)*ml(2,4)
1017C
1018 IF (idril>0) THEN
1019 m11(k)= m11(k)+ vq(k,1,3)*vmz(k,1)
1020 m21(k)= m21(k)+ vq(k,2,3)*vmz(k,1)
1021 m31(k)= m31(k)+ vq(k,3,3)*vmz(k,1)
1022C
1023 m12(k)= m12(k)+ vq(k,1,3)*vmz(k,2)
1024 m22(k)= m22(k)+ vq(k,2,3)*vmz(k,2)
1025 m32(k)= m32(k)+ vq(k,3,3)*vmz(k,2)
1026C
1027 m13(k)= m13(k)+ vq(k,1,3)*vmz(k,3)
1028 m23(k)= m23(k)+ vq(k,2,3)*vmz(k,3)
1029 m33(k)= m33(k)+ vq(k,3,3)*vmz(k,3)
1030C
1031 m14(k)= m14(k)+ vq(k,1,3)*vmz(k,4)
1032 m24(k)= m24(k)+ vq(k,2,3)*vmz(k,4)
1033 m34(k)= m34(k)+ vq(k,3,3)*vmz(k,4)
1034 END IF
1035C---------warped element------------
1036 ELSE
1037 IF (impl_s>0.AND.ikproj<=0) THEN
1038C-------------------------------------
1039C DRILLING RE-PROJECTION ONLY
1040C-------------------------------------
1041 mm(1,1)=(one-vqn(k,1,1)*vqn(k,1,1))*ml(1,1)-
1042 1 vqn(k,1,1)*vqn(k,2,1) *ml(2,1)
1043 mm(2,1)=(one-vqn(k,2,1)*vqn(k,2,1))*ml(2,1)-
1044 1 vqn(k,1,1)*vqn(k,2,1) *ml(1,1)
1045 mm(3,1)= -vqn(k,1,1)*vqn(k,3,1) *ml(1,1)-
1046 1 vqn(k,2,1)*vqn(k,3,1) *ml(2,1)
1047C
1048C J=2
1049 mm(1,2)=(one - vqn(k,1,2)*vqn(k,1,2))*ml(1,2)-
1050 1 vqn(k,1,2)*vqn(k,2,2) *ml(2,2)
1051 mm(2,2)=(one - vqn(k,2,2)*vqn(k,2,2))*ml(2,2)-
1052 1 vqn(k,1,2)*vqn(k,2,2) *ml(1,2)
1053 mm(3,2)= -vqn(k,1,2)*vqn(k,3,2) *ml(1,2)-
1054 1 vqn(k,2,2)*vqn(k,3,2) *ml(2,2)
1055C
1056C J=3
1057 mm(1,3)=(one-vqn(k,1,3)*vqn(k,1,3))*ml(1,3)-
1058 1 vqn(k,1,3)*vqn(k,2,3) *ml(2,3)
1059 mm(2,3)=(one-vqn(k,2,3)*vqn(k,2,3))*ml(2,3)-
1060 1 vqn(k,1,3)*vqn(k,2,3) *ml(1,3)
1061 mm(3,3)= -vqn(k,1,3)*vqn(k,3,3) *ml(1,3)-
1062 1 vqn(k,2,3)*vqn(k,3,3) *ml(2,3)
1063C
1064C J=4
1065 mm(1,4)=(one-vqn(k,1,4)*vqn(k,1,4))*ml(1,4)-
1066 1 vqn(k,1,4)*vqn(k,2,4) *ml(2,4)
1067 mm(2,4)=(one-vqn(k,2,4)*vqn(k,2,4))*ml(2,4)-
1068 1 vqn(k,1,4)*vqn(k,2,4) *ml(1,4)
1069 mm(3,4)= -vqn(k,1,4)*vqn(k,3,4) *ml(1,4)-
1070 1 vqn(k,2,4)*vqn(k,3,4) *ml(2,4)
1071 IF (idril>0) THEN
1072 DO j=1,4
1073 mm(1,j)=mm(1,j)+ vqn(k,1,j)*vmz(k,j)
1074 mm(2,j)=mm(2,j)+ vqn(k,2,j)*vmz(k,j)
1075 mm(3,j)=mm(3,j)+ vqn(k,3,j)*vmz(k,j)
1076 END DO !J=1,4
1077 END IF
1078 ELSE
1079C----REPROJECTION(full)------
1080 ar(1)= -z1(k)*(fl(2,1)-fl(2,2)+fl(2,3)-fl(2,4))
1081 1 +corel(k,2,1)*fl(3,1)+ml(1,1)
1082 2 +corel(k,2,2)*fl(3,2)+ml(1,2)
1083 3 +corel(k,2,3)*fl(3,3)+ml(1,3)
1084 4 +corel(k,2,4)*fl(3,4)+ml(1,4)
1085 ar(2)= z1(k)*(fl(1,1)-fl(1,2)+fl(1,3)-fl(1,4))
1086 1 -corel(k,1,1)*fl(3,1)+ml(2,1)
1087 2 -corel(k,1,2)*fl(3,2)+ml(2,2)
1088 3 -corel(k,1,3)*fl(3,3)+ml(2,3)
1089 4 -corel(k,1,4)*fl(3,4)+ml(2,4)
1090 ar(3)=-corel(k,2,1)*fl(1,1)+corel(k,1,1)*fl(2,1)
1091 1 -corel(k,2,2)*fl(1,2)+corel(k,1,2)*fl(2,2)
1092 2 -corel(k,2,3)*fl(1,3)+corel(k,1,3)*fl(2,3)
1093 3 -corel(k,2,4)*fl(1,4)+corel(k,1,4)*fl(2,4)
1094 ad(1)= vqn(k,1,1)*ml(1,1)+vqn(k,2,1)*ml(2,1)
1095 ad(2)= vqn(k,1,2)*ml(1,2)+vqn(k,2,2)*ml(2,2)
1096 ad(3)= vqn(k,1,3)*ml(1,3)+vqn(k,2,3)*ml(2,3)
1097 ad(4)= vqn(k,1,4)*ml(1,4)+vqn(k,2,4)*ml(2,4)
1098C
1099 dbad(1)= db(k,1,1)*ad(1)+db(k,1,2)*ad(2)
1100 1 +db(k,1,3)*ad(3)+db(k,1,4)*ad(4)
1101 dbad(2)= db(k,2,1)*ad(1)+db(k,2,2)*ad(2)
1102 1 +db(k,2,3)*ad(3)+db(k,2,4)*ad(4)
1103 dbad(3)= db(k,3,1)*ad(1)+db(k,3,2)*ad(2)
1104 1 +db(k,3,3)*ad(3)+db(k,3,4)*ad(4)
1105C
1106 alr(1) =di(k,1)*ar(1)+di(k,4)*ar(2)+di(k,5)*ar(3)-dbad(1)
1107 alr(2) =di(k,4)*ar(1)+di(k,2)*ar(2)+di(k,6)*ar(3)-dbad(2)
1108 alr(3) =di(k,5)*ar(1)+di(k,6)*ar(2)+di(k,3)*ar(3)-dbad(3)
1109CC
1110 ald(1) = ad(1)+vqn(k,1,1)*dbad(1)+vqn(k,2,1)*dbad(2)
1111 1 +vqn(k,3,1)*dbad(3)
1112 2 -db(k,1,1)*ar(1)-db(k,2,1)*ar(2)-db(k,3,1)*ar(3)
1113 ald(2) = ad(2)+vqn(k,1,2)*dbad(1)+vqn(k,2,2)*dbad(2)
1114 1 +vqn(k,3,2)*dbad(3)
1115 2 -db(k,1,2)*ar(1)-db(k,2,2)*ar(2)-db(k,3,2)*ar(3)
1116 ald(3) = ad(3)+vqn(k,1,3)*dbad(1)+vqn(k,2,3)*dbad(2)
1117 1 +vqn(k,3,3)*dbad(3)
1118 2 -db(k,1,3)*ar(1)-db(k,2,3)*ar(2)-db(k,3,3)*ar(3)
1119 ald(4) = ad(4)+vqn(k,1,4)*dbad(1)+vqn(k,2,4)*dbad(2)
1120 1 +vqn(k,3,4)*dbad(3)
1121 2 -db(k,1,4)*ar(1)-db(k,2,4)*ar(2)-db(k,3,4)*ar(3)
1122 IF (idril>0) THEN
1123 arz = vmz(k,1)+vmz(k,2)+vmz(k,3)+vmz(k,4)
1124 alr(1) =alr(1)+diz(k,1)*arz
1125 alr(2) =alr(2)+diz(k,2)*arz
1126 alr(3) =alr(3)+diz(k,3)*arz
1127 END IF !(IDRIL>0) THEN
1128C
1129 c1 =z1(k)*alr(2)
1130 fl(1,1)= fl(1,1)-c1+corel(k,2,1)*alr(3)
1131 fl(1,2)= fl(1,2)+c1+corel(k,2,2)*alr(3)
1132 fl(1,3)= fl(1,3)-c1+corel(k,2,3)*alr(3)
1133 fl(1,4)= fl(1,4)+c1+corel(k,2,4)*alr(3)
1134C
1135 c1 =z1(k)*alr(1)
1136 fl(2,1)= fl(2,1)+c1-corel(k,1,1)*alr(3)
1137 fl(2,2)= fl(2,2)-c1-corel(k,1,2)*alr(3)
1138 fl(2,3)= fl(2,3)+c1-corel(k,1,3)*alr(3)
1139 fl(2,4)= fl(2,4)-c1-corel(k,1,4)*alr(3)
1140C
1141 DO j=1,4
1142 fl(3,j)= fl(3,j)-corel(k,2,j)*alr(1)+corel(k,1,j)*alr(2)
1143 mm(1,j)= ml(1,j)-alr(1)-vqn(k,1,j)*ald(j)
1144 mm(2,j)= ml(2,j)-alr(2)-vqn(k,2,j)*ald(j)
1145 mm(3,j)= -alr(3)-vqn(k,3,j)*ald(j)
1146 ENDDO
1147C
1148 IF (idril>0) THEN
1149 DO j=1,4
1150 mm(3,j)= mm(3,j)+vmz(k,j)
1151 ENDDO
1152 END IF !(IDRIL>0) THEN
1153 END IF !((IMPL_S>0.AND.IKPROJ<0).OR.IDRIL>0) THEN
1154C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
1155C J=1
1156C I=1
1157 f11(k)= vq(k,1,1)*fl(1,1)+vq(k,1,2)*fl(2,1)+vq(k,1,3)*fl(3,1)
1158 m11(k)= vq(k,1,1)*mm(1,1)+vq(k,1,2)*mm(2,1)+vq(k,1,3)*mm(3,1)
1159C I=2
1160 f21(k)= vq(k,2,1)*fl(1,1)+vq(k,2,2)*fl(2,1)+vq(k,2,3)*fl(3,1)
1161 m21(k)= vq(k,2,1)*mm(1,1)+vq(k,2,2)*mm(2,1)+vq(k,2,3)*mm(3,1)
1162C I=3
1163 f31(k)= vq(k,3,1)*fl(1,1)+vq(k,3,2)*fl(2,1)+vq(k,3,3)*fl(3,1)
1164 m31(k)= vq(k,3,1)*mm(1,1)+vq(k,3,2)*mm(2,1)+vq(k,3,3)*mm(3,1)
1165C
1166C J=2
1167C I=1
1168 f12(k)= vq(k,1,1)*fl(1,2)+vq(k,1,2)*fl(2,2)+vq(k,1,3)*fl(3,2)
1169 m12(k)= vq(k,1,1)*mm(1,2)+vq(k,1,2)*mm(2,2)+vq(k,1,3)*mm(3,2)
1170C I=2
1171 f22(k)= vq(k,2,1)*fl(1,2)+vq(k,2,2)*fl(2,2)+vq(k,2,3)*fl(3,2)
1172 m22(k)= vq(k,2,1)*mm(1,2)+vq(k,2,2)*mm(2,2)+vq(k,2,3)*mm(3,2)
1173C I=3
1174 f32(k)= vq(k,3,1)*fl(1,2)+vq(k,3,2)*fl(2,2)+vq(k,3,3)*fl(3,2)
1175 m32(k)= vq(k,3,1)*mm(1,2)+vq(k,3,2)*mm(2,2)+vq(k,3,3)*mm(3,2)
1176C
1177C J=3
1178C I=1
1179 f13(k)= vq(k,1,1)*fl(1,3)+vq(k,1,2)*fl(2,3)+vq(k,1,3)*fl(3,3)
1180 m13(k)= vq(k,1,1)*mm(1,3)+vq(k,1,2)*mm(2,3)+vq(k,1,3)*mm(3,3)
1181C I=2
1182 f23(k)= vq(k,2,1)*fl(1,3)+vq(k,2,2)*fl(2,3)+vq(k,2,3)*fl(3,3)
1183 m23(k)= vq(k,2,1)*mm(1,3)+vq(k,2,2)*mm(2,3)+vq(k,2,3)*mm(3,3)
1184C I=3
1185 f33(k)= vq(k,3,1)*fl(1,3)+vq(k,3,2)*fl(2,3)+vq(k,3,3)*fl(3,3)
1186 m33(k)= vq(k,3,1)*mm(1,3)+vq(k,3,2)*mm(2,3)+vq(k,3,3)*mm(3,3)
1187C
1188C J=4
1189C I=1
1190 f14(k)= vq(k,1,1)*fl(1,4)+vq(k,1,2)*fl(2,4)+vq(k,1,3)*fl(3,4)
1191 m14(k)= vq(k,1,1)*mm(1,4)+vq(k,1,2)*mm(2,4)+vq(k,1,3)*mm(3,4)
1192C I=2
1193 f24(k)= vq(k,2,1)*fl(1,4)+vq(k,2,2)*fl(2,4)+vq(k,2,3)*fl(3,4)
1194 m24(k)= vq(k,2,1)*mm(1,4)+vq(k,2,2)*mm(2,4)+vq(k,2,3)*mm(3,4)
1195C I=3
1196 f34(k)= vq(k,3,1)*fl(1,4)+vq(k,3,2)*fl(2,4)+vq(k,3,3)*fl(3,4)
1197 m34(k)= vq(k,3,1)*mm(1,4)+vq(k,3,2)*mm(2,4)+vq(k,3,3)*mm(3,4)
1198C
1199 ENDIF
1200C
1201 ENDDO
1202C-----case w/o initial F --------------
1203C
1204 ELSE
1205 DO k=jft,jlt
1206C
1207C I=1
1208 fl(1,1)= vf(k,1,1)+vf(k,1,3)
1209 fl(1,2)= vf(k,1,2)+vf(k,1,4)
1210 fl(1,3)=-vf(k,1,1)+vf(k,1,3)
1211 fl(1,4)=-vf(k,1,2)+vf(k,1,4)
1212C I=2
1213 fl(2,1)= vf(k,2,1)+vf(k,2,3)
1214 fl(2,2)= vf(k,2,2)+vf(k,2,4)
1215 fl(2,3)=-vf(k,2,1)+vf(k,2,3)
1216 fl(2,4)=-vf(k,2,2)+vf(k,2,4)
1217C I=3
1218 fl(3,1)= vf(k,3,1)+vf(k,3,3)
1219 fl(3,2)= vf(k,3,2)+vf(k,3,4)
1220 fl(3,3)=-vf(k,3,1)+vf(k,3,3)
1221 fl(3,4)=-vf(k,3,2)+vf(k,3,4)
1222C
1223C I=1
1224 ml(1,1)= vm(k,1,1)+vm(k,1,3)
1225 ml(1,2)= vm(k,1,2)+vm(k,1,4)
1226 ml(1,3)=-vm(k,1,1)+vm(k,1,3)
1227 ml(1,4)=-vm(k,1,2)+vm(k,1,4)
1228C I=2
1229 ml(2,1)= vm(k,2,1)+vm(k,2,3)
1230 ml(2,2)= vm(k,2,2)+vm(k,2,4)
1231 ml(2,3)=-vm(k,2,1)+vm(k,2,3)
1232 ml(2,4)=-vm(k,2,2)+vm(k,2,4)
1233C---------------------------------------
1234C TRANS LOCAL-->GLOBAL ET 5DDL-->6DDL
1235C---------------------------------------
1236 IF (plat(k)) THEN
1237C
1238C J=1
1239C I=1
1240 f11(k)= vq(k,1,1)*fl(1,1)+vq(k,1,2)*fl(2,1)+vq(k,1,3)*fl(3,1)
1241 m11(k)= vq(k,1,1)*ml(1,1)+vq(k,1,2)*ml(2,1)
1242C I=2
1243 f21(k)= vq(k,2,1)*fl(1,1)+vq(k,2,2)*fl(2,1)+vq(k,2,3)*fl(3,1)
1244 m21(k)= vq(k,2,1)*ml(1,1)+vq(k,2,2)*ml(2,1)
1245C I=3
1246 f31(k)= vq(k,3,1)*fl(1,1)+vq(k,3,2)*fl(2,1)+vq(k,3,3)*fl(3,1)
1247 m31(k)= vq(k,3,1)*ml(1,1)+vq(k,3,2)*ml(2,1)
1248C
1249C J=2
1250C I=1
1251 f12(k)= vq(k,1,1)*fl(1,2)+vq(k,1,2)*fl(2,2)+vq(k,1,3)*fl(3,2)
1252 m12(k)= vq(k,1,1)*ml(1,2)+vq(k,1,2)*ml(2,2)
1253C I=2
1254 f22(k)= vq(k,2,1)*fl(1,2)+vq(k,2,2)*fl(2,2)+vq(k,2,3)*fl(3,2)
1255 m22(k)= vq(k,2,1)*ml(1,2)+vq(k,2,2)*ml(2,2)
1256C I=3
1257 f32(k)= vq(k,3,1)*fl(1,2)+vq(k,3,2)*fl(2,2)+vq(k,3,3)*fl(3,2)
1258 m32(k)= vq(k,3,1)*ml(1,2)+vq(k,3,2)*ml(2,2)
1259C
1260C J=3
1261C I=1
1262 f13(k)= vq(k,1,1)*fl(1,3)+vq(k,1,2)*fl(2,3)+vq(k,1,3)*fl(3,3)
1263 m13(k)= vq(k,1,1)*ml(1,3)+vq(k,1,2)*ml(2,3)
1264C I=2
1265 f23(k)= vq(k,2,1)*fl(1,3)+vq(k,2,2)*fl(2,3)+vq(k,2,3)*fl(3,3)
1266 m23(k)= vq(k,2,1)*ml(1,3)+vq(k,2,2)*ml(2,3)
1267C I=3
1268 f33(k)= vq(k,3,1)*fl(1,3)+vq(k,3,2)*fl(2,3)+vq(k,3,3)*fl(3,3)
1269 m33(k)= vq(k,3,1)*ml(1,3)+vq(k,3,2)*ml(2,3)
1270C
1271C J=4
1272C I=1
1273 f14(k)= vq(k,1,1)*fl(1,4)+vq(k,1,2)*fl(2,4)+vq(k,1,3)*fl(3,4)
1274 m14(k)= vq(k,1,1)*ml(1,4)+vq(k,1,2)*ml(2,4)
1275C I=2
1276 f24(k)= vq(k,2,1)*fl(1,4)+vq(k,2,2)*fl(2,4)+vq(k,2,3)*fl(3,4)
1277 m24(k)= vq(k,2,1)*ml(1,4)+vq(k,2,2)*ml(2,4)
1278C I=3
1279 f34(k)= vq(k,3,1)*fl(1,4)+vq(k,3,2)*fl(2,4)+vq(k,3,3)*fl(3,4)
1280 m34(k)= vq(k,3,1)*ml(1,4)+vq(k,3,2)*ml(2,4)
1281C
1282 IF (idril>0) THEN
1283 m11(k)= m11(k)+ vq(k,1,3)*vmz(k,1)
1284 m21(k)= m21(k)+ vq(k,2,3)*vmz(k,1)
1285 m31(k)= m31(k)+ vq(k,3,3)*vmz(k,1)
1286C
1287 m12(k)= m12(k)+ vq(k,1,3)*vmz(k,2)
1288 m22(k)= m22(k)+ vq(k,2,3)*vmz(k,2)
1289 m32(k)= m32(k)+ vq(k,3,3)*vmz(k,2)
1290C
1291 m13(k)= m13(k)+ vq(k,1,3)*vmz(k,3)
1292 m23(k)= m23(k)+ vq(k,2,3)*vmz(k,3)
1293 m33(k)= m33(k)+ vq(k,3,3)*vmz(k,3)
1294C
1295 m14(k)= m14(k)+ vq(k,1,3)*vmz(k,4)
1296 m24(k)= m24(k)+ vq(k,2,3)*vmz(k,4)
1297 m34(k)= m34(k)+ vq(k,3,3)*vmz(k,4)
1298 END IF
1299C
1300 ELSE
1301 IF (impl_s>0.AND.ikproj<=0) THEN
1302C-------------------------------------
1303C DRILLING RE-PROJECTION ONLY
1304C-------------------------------------
1305 mm(1,1)=(one-vqn(k,1,1)*vqn(k,1,1))*ml(1,1)-
1306 1 vqn(k,1,1)*vqn(k,2,1) *ml(2,1)
1307 mm(2,1)=(one-vqn(k,2,1)*vqn(k,2,1))*ml(2,1)-
1308 1 vqn(k,1,1)*vqn(k,2,1) *ml(1,1)
1309 mm(3,1)= -vqn(k,1,1)*vqn(k,3,1) *ml(1,1)-
1310 1 vqn(k,2,1)*vqn(k,3,1) *ml(2,1)
1311C
1312C J=2
1313 mm(1,2)=(one - vqn(k,1,2)*vqn(k,1,2))*ml(1,2)-
1314 1 vqn(k,1,2)*vqn(k,2,2) *ml(2,2)
1315 mm(2,2)=(one - vqn(k,2,2)*vqn(k,2,2))*ml(2,2)-
1316 1 vqn(k,1,2)*vqn(k,2,2) *ml(1,2)
1317 mm(3,2)= -vqn(k,1,2)*vqn(k,3,2) *ml(1,2)-
1318 1 vqn(k,2,2)*vqn(k,3,2) *ml(2,2)
1319C
1320C J=3
1321 mm(1,3)=(one-vqn(k,1,3)*vqn(k,1,3))*ml(1,3)-
1322 1 vqn(k,1,3)*vqn(k,2,3) *ml(2,3)
1323 mm(2,3)=(one-vqn(k,2,3)*vqn(k,2,3))*ml(2,3)-
1324 1 vqn(k,1,3)*vqn(k,2,3) *ml(1,3)
1325 mm(3,3)= -vqn(k,1,3)*vqn(k,3,3) *ml(1,3)-
1326 1 vqn(k,2,3)*vqn(k,3,3) *ml(2,3)
1327C
1328C J=4
1329 mm(1,4)=(one-vqn(k,1,4)*vqn(k,1,4))*ml(1,4)-
1330 1 vqn(k,1,4)*vqn(k,2,4) *ml(2,4)
1331 mm(2,4)=(one-vqn(k,2,4)*vqn(k,2,4))*ml(2,4)-
1332 1 vqn(k,1,4)*vqn(k,2,4) *ml(1,4)
1333 mm(3,4)= -vqn(k,1,4)*vqn(k,3,4) *ml(1,4)-
1334 1 vqn(k,2,4)*vqn(k,3,4) *ml(2,4)
1335 IF (idril>0) THEN
1336 DO j=1,4
1337 mm(1,j)=mm(1,j)+ vqn(k,1,j)*vmz(k,j)
1338 mm(2,j)=mm(2,j)+ vqn(k,2,j)*vmz(k,j)
1339 mm(3,j)=mm(3,j)+ vqn(k,3,j)*vmz(k,j)
1340 END DO !J=1,4
1341 END IF
1342 ELSE
1343C----REPROJECTION(full)------
1344 ar(1)= -z1(k)*(fl(2,1)-fl(2,2)+fl(2,3)-fl(2,4))
1345 1 +corel(k,2,1)*fl(3,1)+ml(1,1)
1346 2 +corel(k,2,2)*fl(3,2)+ml(1,2)
1347 3 +corel(k,2,3)*fl(3,3)+ml(1,3)
1348 4 +corel(k,2,4)*fl(3,4)+ml(1,4)
1349 ar(2)= z1(k)*(fl(1,1)-fl(1,2)+fl(1,3)-fl(1,4))
1350 1 -corel(k,1,1)*fl(3,1)+ml(2,1)
1351 2 -corel(k,1,2)*fl(3,2)+ml(2,2)
1352 3 -corel(k,1,3)*fl(3,3)+ml(2,3)
1353 4 -corel(k,1,4)*fl(3,4)+ml(2,4)
1354 ar(3)=-corel(k,2,1)*fl(1,1)+corel(k,1,1)*fl(2,1)
1355 1 -corel(k,2,2)*fl(1,2)+corel(k,1,2)*fl(2,2)
1356 2 -corel(k,2,3)*fl(1,3)+corel(k,1,3)*fl(2,3)
1357 3 -corel(k,2,4)*fl(1,4)+corel(k,1,4)*fl(2,4)
1358 ad(1)= vqn(k,1,1)*ml(1,1)+vqn(k,2,1)*ml(2,1)
1359 ad(2)= vqn(k,1,2)*ml(1,2)+vqn(k,2,2)*ml(2,2)
1360 ad(3)= vqn(k,1,3)*ml(1,3)+vqn(k,2,3)*ml(2,3)
1361 ad(4)= vqn(k,1,4)*ml(1,4)+vqn(k,2,4)*ml(2,4)
1362C
1363 dbad(1)= db(k,1,1)*ad(1)+db(k,1,2)*ad(2)
1364 1 +db(k,1,3)*ad(3)+db(k,1,4)*ad(4)
1365 dbad(2)= db(k,2,1)*ad(1)+db(k,2,2)*ad(2)
1366 1 +db(k,2,3)*ad(3)+db(k,2,4)*ad(4)
1367 dbad(3)= db(k,3,1)*ad(1)+db(k,3,2)*ad(2)
1368 1 +db(k,3,3)*ad(3)+db(k,3,4)*ad(4)
1369C
1370 alr(1) =di(k,1)*ar(1)+di(k,4)*ar(2)+di(k,5)*ar(3)-dbad(1)
1371 alr(2) =di(k,4)*ar(1)+di(k,2)*ar(2)+di(k,6)*ar(3)-dbad(2)
1372 alr(3) =di(k,5)*ar(1)+di(k,6)*ar(2)+di(k,3)*ar(3)-dbad(3)
1373CC
1374 ald(1) = ad(1)+vqn(k,1,1)*dbad(1)+vqn(k,2,1)*dbad(2)
1375 1 +vqn(k,3,1)*dbad(3)
1376 2 -db(k,1,1)*ar(1)-db(k,2,1)*ar(2)-db(k,3,1)*ar(3)
1377 ald(2) = ad(2)+vqn(k,1,2)*dbad(1)+vqn(k,2,2)*dbad(2)
1378 1 +vqn(k,3,2)*dbad(3)
1379 2 -db(k,1,2)*ar(1)-db(k,2,2)*ar(2)-db(k,3,2)*ar(3)
1380 ald(3) = ad(3)+vqn(k,1,3)*dbad(1)+vqn(k,2,3)*dbad(2)
1381 1 +vqn(k,3,3)*dbad(3)
1382 2 -db(k,1,3)*ar(1)-db(k,2,3)*ar(2)-db(k,3,3)*ar(3)
1383 ald(4) = ad(4)+vqn(k,1,4)*dbad(1)+vqn(k,2,4)*dbad(2)
1384 1 +vqn(k,3,4)*dbad(3)
1385 2 -db(k,1,4)*ar(1)-db(k,2,4)*ar(2)-db(k,3,4)*ar(3)
1386 IF (idril>0) THEN
1387 arz = vmz(k,1)+vmz(k,2)+vmz(k,3)+vmz(k,4)
1388 alr(1) =alr(1)+diz(k,1)*arz
1389 alr(2) =alr(2)+diz(k,2)*arz
1390 alr(3) =alr(3)+diz(k,3)*arz
1391 END IF !(idril>0) THEN
1392C
1393 c1 =z1(k)*alr(2)
1394 fl(1,1)= fl(1,1)-c1+corel(k,2,1)*alr(3)
1395 fl(1,2)= fl(1,2)+c1+corel(k,2,2)*alr(3)
1396 fl(1,3)= fl(1,3)-c1+corel(k,2,3)*alr(3)
1397 fl(1,4)= fl(1,4)+c1+corel(k,2,4)*alr(3)
1398C
1399 c1 =z1(k)*alr(1)
1400 fl(2,1)= fl(2,1)+c1-corel(k,1,1)*alr(3)
1401 fl(2,2)= fl(2,2)-c1-corel(k,1,2)*alr(3)
1402 fl(2,3)= fl(2,3)+c1-corel(k,1,3)*alr(3)
1403 fl(2,4)= fl(2,4)-c1-corel(k,1,4)*alr(3)
1404C
1405 DO j=1,4
1406 fl(3,j)= fl(3,j)-corel(k,2,j)*alr(1)+corel(k,1,j)*alr(2)
1407 mm(1,j)= ml(1,j)-alr(1)-vqn(k,1,j)*ald(j)
1408 mm(2,j)= ml(2,j)-alr(2)-vqn(k,2,j)*ald(j)
1409 mm(3,j)= -alr(3)-vqn(k,3,j)*ald(j)
1410 ENDDO
1411C
1412 IF (idril>0) THEN
1413 DO j=1,4
1414 mm(3,j)= mm(3,j)+vmz(k,j)
1415 ENDDO
1416 END IF !(IDRIL>0) THEN
1417C
1418 END IF !((IMPL_S>0.AND.IKPROJ<0).OR.IDRIL>0) THEN
1419C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
1420C J=1
1421C I=1
1422 f11(k)= vq(k,1,1)*fl(1,1)+vq(k,1,2)*fl(2,1)+vq(k,1,3)*fl(3,1)
1423 m11(k)= vq(k,1,1)*mm(1,1)+vq(k,1,2)*mm(2,1)+vq(k,1,3)*mm(3,1)
1424C I=2
1425 f21(k)= vq(k,2,1)*fl(1,1)+vq(k,2,2)*fl(2,1)+vq(k,2,3)*fl(3,1)
1426 m21(k)= vq(k,2,1)*mm(1,1)+vq(k,2,2)*mm(2,1)+vq(k,2,3)*mm(3,1)
1427C I=3
1428 f31(k)= vq(k,3,1)*fl(1,1)+vq(k,3,2)*fl(2,1)+vq(k,3,3)*fl(3,1)
1429 m31(k)= vq(k,3,1)*mm(1,1)+vq(k,3,2)*mm(2,1)+vq(k,3,3)*mm(3,1)
1430C
1431C J=2
1432C I=1
1433 f12(k)= vq(k,1,1)*fl(1,2)+vq(k,1,2)*fl(2,2)+vq(k,1,3)*fl(3,2)
1434 m12(k)= vq(k,1,1)*mm(1,2)+vq(k,1,2)*mm(2,2)+vq(k,1,3)*mm(3,2)
1435C I=2
1436 f22(k)= vq(k,2,1)*fl(1,2)+vq(k,2,2)*fl(2,2)+vq(k,2,3)*fl(3,2)
1437 m22(k)= vq(k,2,1)*mm(1,2)+vq(k,2,2)*mm(2,2)+vq(k,2,3)*mm(3,2)
1438C I=3
1439 f32(k)= vq(k,3,1)*fl(1,2)+vq(k,3,2)*fl(2,2)+vq(k,3,3)*fl(3,2)
1440 m32(k)= vq(k,3,1)*mm(1,2)+vq(k,3,2)*mm(2,2)+vq(k,3,3)*mm(3,2)
1441C
1442C J=3
1443C I=1
1444 f13(k)= vq(k,1,1)*fl(1,3)+vq(k,1,2)*fl(2,3)+vq(k,1,3)*fl(3,3)
1445 m13(k)= vq(k,1,1)*mm(1,3)+vq(k,1,2)*mm(2,3)+vq(k,1,3)*mm(3,3)
1446C I=2
1447 f23(k)= vq(k,2,1)*fl(1,3)+vq(k,2,2)*fl(2,3)+vq(k,2,3)*fl(3,3)
1448 m23(k)= vq(k,2,1)*mm(1,3)+vq(k,2,2)*mm(2,3)+vq(k,2,3)*mm(3,3)
1449C I=3
1450 f33(k)= vq(k,3,1)*fl(1,3)+vq(k,3,2)*fl(2,3)+vq(k,3,3)*fl(3,3)
1451 m33(k)= vq(k,3,1)*mm(1,3)+vq(k,3,2)*mm(2,3)+vq(k,3,3)*mm(3,3)
1452C
1453C J=4
1454C I=1
1455 f14(k)= vq(k,1,1)*fl(1,4)+vq(k,1,2)*fl(2,4)+vq(k,1,3)*fl(3,4)
1456 m14(k)= vq(k,1,1)*mm(1,4)+vq(k,1,2)*mm(2,4)+vq(k,1,3)*mm(3,4)
1457C I=2
1458 f24(k)= vq(k,2,1)*fl(1,4)+vq(k,2,2)*fl(2,4)+vq(k,2,3)*fl(3,4)
1459 m24(k)= vq(k,2,1)*mm(1,4)+vq(k,2,2)*mm(2,4)+vq(k,2,3)*mm(3,4)
1460C I=3
1461 f34(k)= vq(k,3,1)*fl(1,4)+vq(k,3,2)*fl(2,4)+vq(k,3,3)*fl(3,4)
1462 m34(k)= vq(k,3,1)*mm(1,4)+vq(k,3,2)*mm(2,4)+vq(k,3,3)*mm(3,4)
1463C
1464 ENDIF
1465C
1466 ENDDO
1467C
1468 END IF !IF(IFINI > 0 )THEN
1469C
1470 RETURN

◆ czprojv()

subroutine czprojv ( integer jft,
integer jlt,
vqn,
vq,
vf,
vm,
logical, dimension(*) plat,
f11,
f12,
f13,
f14,
f21,
f22,
f23,
f24,
f31,
f32,
f33,
f34,
m11,
m12,
m13,
m14,
m21,
m22,
m23,
m24,
m31,
m32,
m33,
m34,
fzero,
z1,
di,
db,
corelv,
integer ifini,
integer idril,
diz,
vmz )

Definition at line 275 of file czproj.F.

285C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
286C TRANSMET LES FORCES INTERNES LOCALES VF,VM ---> GLOBALES FIJ ,MIJ
287C ENTREES :
288C SORTIES : FIJ,MIJ
289C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
290#include "implicit_f.inc"
291#include "mvsiz_p.inc"
292#include "impl1_c.inc"
293C-----------------------------------------------
294C D U M M Y A R G U M E N T S
295C-----------------------------------------------
296 LOGICAL PLAT(*)
297 INTEGER JFT,JLT,IDRIL,IFINI
298 my_real
299 . vqn(mvsiz,3,4),vf(mvsiz,3,4),vm(mvsiz,2,4),vq(mvsiz,3,3),
300 . di(mvsiz,6),db(mvsiz,3,4),z1(*)
301 my_real
302 . f11(mvsiz), f12(mvsiz), f13(mvsiz), f14(mvsiz),
303 . f21(mvsiz), f22(mvsiz), f23(mvsiz), f24(mvsiz),
304 . f31(mvsiz), f32(mvsiz), f33(mvsiz), f34(mvsiz),
305 . m11(mvsiz), m12(mvsiz), m13(mvsiz), m14(mvsiz),
306 . m21(mvsiz), m22(mvsiz), m23(mvsiz), m24(mvsiz),
307 . m31(mvsiz), m32(mvsiz), m33(mvsiz), m34(mvsiz),
308C
309 . fzero(3,4,*)
310C
311 my_real
312 . corelv(mvsiz,2,4),diz(mvsiz,3),vmz(mvsiz,4)
313C-----------------------------------------------
314C L O C A L V A R I A B L E S
315C-----------------------------------------------
316 INTEGER I, J, K
317 my_real
318 . mm(3,4),fl(3,4),ml(2,4),c1,
319 . ar(3),ad(4),alr(3),ald(4),dbad(3),
320C
321 . temp1, temp2, temp3,arz
322C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
323C these could be done simply at the end, but what's done is done.
324C-----------------------------------------------
325 IF(ifini > 0) THEN
326 DO k=jft,jlt
327C I=1
328 fl(1,1)= vf(k,1,1)+vf(k,1,3)
329 fl(1,2)= vf(k,1,2)+vf(k,1,4)
330 fl(1,3)=-vf(k,1,1)+vf(k,1,3)
331 fl(1,4)=-vf(k,1,2)+vf(k,1,4)
332C I=2
333 fl(2,1)= vf(k,2,1)+vf(k,2,3)
334 fl(2,2)= vf(k,2,2)+vf(k,2,4)
335 fl(2,3)=-vf(k,2,1)+vf(k,2,3)
336 fl(2,4)=-vf(k,2,2)+vf(k,2,4)
337C I=3
338 fl(3,1)= vf(k,3,1)+vf(k,3,3)
339 fl(3,2)= vf(k,3,2)+vf(k,3,4)
340 fl(3,3)=-vf(k,3,1)+vf(k,3,3)
341 fl(3,4)=-vf(k,3,2)+vf(k,3,4)
342C
343C I=1
344 fl(1,1)=fl(1,1)+fzero(1,1,k)
345 fl(1,2)=fl(1,2)+fzero(1,2,k)
346 fl(1,3)=fl(1,3)+fzero(1,3,k)
347 fl(1,4)=fl(1,4)+fzero(1,4,k)
348C I=2
349 fl(2,1)=fl(2,1)+fzero(2,1,k)
350 fl(2,2)=fl(2,2)+fzero(2,2,k)
351 fl(2,3)=fl(2,3)+fzero(2,3,k)
352 fl(2,4)=fl(2,4)+fzero(2,4,k)
353C I=3
354 fl(3,1)= fl(3,1)+fzero(3,1,k)
355 fl(3,2)= fl(3,2)+fzero(3,2,k)
356 fl(3,3)= fl(3,3)+fzero(3,3,k)
357 fl(3,4)= fl(3,4)+fzero(3,4,k)
358C
359C I=1
360 ml(1,1)= vm(k,1,1)+vm(k,1,3)
361 ml(1,2)= vm(k,1,2)+vm(k,1,4)
362 ml(1,3)=-vm(k,1,1)+vm(k,1,3)
363 ml(1,4)=-vm(k,1,2)+vm(k,1,4)
364C I=2
365 ml(2,1)= vm(k,2,1)+vm(k,2,3)
366 ml(2,2)= vm(k,2,2)+vm(k,2,4)
367 ml(2,3)=-vm(k,2,1)+vm(k,2,3)
368 ml(2,4)=-vm(k,2,2)+vm(k,2,4)
369C---------------------------------------
370C TRANS LOCAL-->GLOBAL ET 5DDL-->6DDL
371C---------------------------------------
372 IF (plat(k)) THEN
373C
374C J=1
375C I=1
376 f11(k)= vq(k,1,1)*fl(1,1)+vq(k,1,2)*fl(2,1)+vq(k,1,3)*fl(3,1)
377 m11(k)= vq(k,1,1)*ml(1,1)+vq(k,1,2)*ml(2,1)
378C I=2
379 f21(k)= vq(k,2,1)*fl(1,1)+vq(k,2,2)*fl(2,1)+vq(k,2,3)*fl(3,1)
380 m21(k)= vq(k,2,1)*ml(1,1)+vq(k,2,2)*ml(2,1)
381C I=3
382 f31(k)= vq(k,3,1)*fl(1,1)+vq(k,3,2)*fl(2,1)+vq(k,3,3)*fl(3,1)
383 m31(k)= vq(k,3,1)*ml(1,1)+vq(k,3,2)*ml(2,1)
384C
385C J=2
386C I=1
387 f12(k)= vq(k,1,1)*fl(1,2)+vq(k,1,2)*fl(2,2)+vq(k,1,3)*fl(3,2)
388 m12(k)= vq(k,1,1)*ml(1,2)+vq(k,1,2)*ml(2,2)
389C I=2
390 f22(k)= vq(k,2,1)*fl(1,2)+vq(k,2,2)*fl(2,2)+vq(k,2,3)*fl(3,2)
391 m22(k)= vq(k,2,1)*ml(1,2)+vq(k,2,2)*ml(2,2)
392C I=3
393 f32(k)= vq(k,3,1)*fl(1,2)+vq(k,3,2)*fl(2,2)+vq(k,3,3)*fl(3,2)
394 m32(k)= vq(k,3,1)*ml(1,2)+vq(k,3,2)*ml(2,2)
395C
396C J=3
397C I=1
398 f13(k)= vq(k,1,1)*fl(1,3)+vq(k,1,2)*fl(2,3)+vq(k,1,3)*fl(3,3)
399 m13(k)= vq(k,1,1)*ml(1,3)+vq(k,1,2)*ml(2,3)
400C I=2
401 f23(k)= vq(k,2,1)*fl(1,3)+vq(k,2,2)*fl(2,3)+vq(k,2,3)*fl(3,3)
402 m23(k)= vq(k,2,1)*ml(1,3)+vq(k,2,2)*ml(2,3)
403C I=3
404 f33(k)= vq(k,3,1)*fl(1,3)+vq(k,3,2)*fl(2,3)+vq(k,3,3)*fl(3,3)
405 m33(k)= vq(k,3,1)*ml(1,3)+vq(k,3,2)*ml(2,3)
406C
407C J=4
408C I=1
409 f14(k)= vq(k,1,1)*fl(1,4)+vq(k,1,2)*fl(2,4)+vq(k,1,3)*fl(3,4)
410 m14(k)= vq(k,1,1)*ml(1,4)+vq(k,1,2)*ml(2,4)
411C I=2
412 f24(k)= vq(k,2,1)*fl(1,4)+vq(k,2,2)*fl(2,4)+vq(k,2,3)*fl(3,4)
413 m24(k)= vq(k,2,1)*ml(1,4)+vq(k,2,2)*ml(2,4)
414C I=3
415 f34(k)= vq(k,3,1)*fl(1,4)+vq(k,3,2)*fl(2,4)+vq(k,3,3)*fl(3,4)
416 m34(k)= vq(k,3,1)*ml(1,4)+vq(k,3,2)*ml(2,4)
417C
418 IF (idril>0) THEN
419 m11(k)= m11(k)+ vq(k,1,3)*vmz(k,1)
420 m21(k)= m21(k)+ vq(k,2,3)*vmz(k,1)
421 m31(k)= m31(k)+ vq(k,3,3)*vmz(k,1)
422C
423 m12(k)= m12(k)+ vq(k,1,3)*vmz(k,2)
424 m22(k)= m22(k)+ vq(k,2,3)*vmz(k,2)
425 m32(k)= m32(k)+ vq(k,3,3)*vmz(k,2)
426C
427 m13(k)= m13(k)+ vq(k,1,3)*vmz(k,3)
428 m23(k)= m23(k)+ vq(k,2,3)*vmz(k,3)
429 m33(k)= m33(k)+ vq(k,3,3)*vmz(k,3)
430C
431 m14(k)= m14(k)+ vq(k,1,3)*vmz(k,4)
432 m24(k)= m24(k)+ vq(k,2,3)*vmz(k,4)
433 m34(k)= m34(k)+ vq(k,3,3)*vmz(k,4)
434 END IF
435C
436 ELSE
437 IF (impl_s>0.AND.ikproj<=0) THEN
438C-------------------------------------
439C DRILLING RE-PROJECTION ONLY
440C-------------------------------------
441 mm(1,1)=(one-vqn(k,1,1)*vqn(k,1,1))*ml(1,1)-
442 1 vqn(k,1,1)*vqn(k,2,1) *ml(2,1)
443 mm(2,1)=(one-vqn(k,2,1)*vqn(k,2,1))*ml(2,1)-
444 1 vqn(k,1,1)*vqn(k,2,1) *ml(1,1)
445 mm(3,1)= -vqn(k,1,1)*vqn(k,3,1) *ml(1,1)-
446 1 vqn(k,2,1)*vqn(k,3,1) *ml(2,1)
447C
448C J=2
449 mm(1,2)=(one - vqn(k,1,2)*vqn(k,1,2))*ml(1,2)-
450 1 vqn(k,1,2)*vqn(k,2,2) *ml(2,2)
451 mm(2,2)=(one - vqn(k,2,2)*vqn(k,2,2))*ml(2,2)-
452 1 vqn(k,1,2)*vqn(k,2,2) *ml(1,2)
453 mm(3,2)= -vqn(k,1,2)*vqn(k,3,2) *ml(1,2)-
454 1 vqn(k,2,2)*vqn(k,3,2) *ml(2,2)
455C
456C J=3
457 mm(1,3)=(one-vqn(k,1,3)*vqn(k,1,3))*ml(1,3)-
458 1 vqn(k,1,3)*vqn(k,2,3) *ml(2,3)
459 mm(2,3)=(one-vqn(k,2,3)*vqn(k,2,3))*ml(2,3)-
460 1 vqn(k,1,3)*vqn(k,2,3) *ml(1,3)
461 mm(3,3)= -vqn(k,1,3)*vqn(k,3,3) *ml(1,3)-
462 1 vqn(k,2,3)*vqn(k,3,3) *ml(2,3)
463C
464C J=4
465 mm(1,4)=(one-vqn(k,1,4)*vqn(k,1,4))*ml(1,4)-
466 1 vqn(k,1,4)*vqn(k,2,4) *ml(2,4)
467 mm(2,4)=(one-vqn(k,2,4)*vqn(k,2,4))*ml(2,4)-
468 1 vqn(k,1,4)*vqn(k,2,4) *ml(1,4)
469 mm(3,4)= -vqn(k,1,4)*vqn(k,3,4) *ml(1,4)-
470 1 vqn(k,2,4)*vqn(k,3,4) *ml(2,4)
471 IF (idril>0) THEN
472 DO j=1,4
473 mm(1,j)=mm(1,j)+ vqn(k,1,j)*vmz(k,j)
474 mm(2,j)=mm(2,j)+ vqn(k,2,j)*vmz(k,j)
475 mm(3,j)=mm(3,j)+ vqn(k,3,j)*vmz(k,j)
476 END DO !J=1,4
477 END IF
478 ELSE
479C
480C----REPROJECTION(full)------
481 ar(1)= -z1(k)*(fl(2,1)-fl(2,2)+fl(2,3)-fl(2,4))
482 1 +corelv(k,2,1)*fl(3,1)+ml(1,1)
483 2 +corelv(k,2,2)*fl(3,2)+ml(1,2)
484 3 +corelv(k,2,3)*fl(3,3)+ml(1,3)
485 4 +corelv(k,2,4)*fl(3,4)+ml(1,4)
486 ar(2)= z1(k)*(fl(1,1)-fl(1,2)+fl(1,3)-fl(1,4))
487 1 -corelv(k,1,1)*fl(3,1)+ml(2,1)
488 2 -corelv(k,1,2)*fl(3,2)+ml(2,2)
489 3 -corelv(k,1,3)*fl(3,3)+ml(2,3)
490 4 -corelv(k,1,4)*fl(3,4)+ml(2,4)
491 ar(3)=-corelv(k,2,1)*fl(1,1)+corelv(k,1,1)*fl(2,1)
492 1 -corelv(k,2,2)*fl(1,2)+corelv(k,1,2)*fl(2,2)
493 2 -corelv(k,2,3)*fl(1,3)+corelv(k,1,3)*fl(2,3)
494 3 -corelv(k,2,4)*fl(1,4)+corelv(k,1,4)*fl(2,4)
495
496 ad(1)= vqn(k,1,1)*ml(1,1)+vqn(k,2,1)*ml(2,1)
497 ad(2)= vqn(k,1,2)*ml(1,2)+vqn(k,2,2)*ml(2,2)
498 ad(3)= vqn(k,1,3)*ml(1,3)+vqn(k,2,3)*ml(2,3)
499 ad(4)= vqn(k,1,4)*ml(1,4)+vqn(k,2,4)*ml(2,4)
500C
501 dbad(1)= db(k,1,1)*ad(1)+db(k,1,2)*ad(2)
502 1 +db(k,1,3)*ad(3)+db(k,1,4)*ad(4)
503 dbad(2)= db(k,2,1)*ad(1)+db(k,2,2)*ad(2)
504 1 +db(k,2,3)*ad(3)+db(k,2,4)*ad(4)
505 dbad(3)= db(k,3,1)*ad(1)+db(k,3,2)*ad(2)
506 1 +db(k,3,3)*ad(3)+db(k,3,4)*ad(4)
507C
508 alr(1) =di(k,1)*ar(1)+di(k,4)*ar(2)+di(k,5)*ar(3)-dbad(1)
509 alr(2) =di(k,4)*ar(1)+di(k,2)*ar(2)+di(k,6)*ar(3)-dbad(2)
510 alr(3) =di(k,5)*ar(1)+di(k,6)*ar(2)+di(k,3)*ar(3)-dbad(3)
511C
512 ald(1) = ad(1)+vqn(k,1,1)*dbad(1)+vqn(k,2,1)*dbad(2)
513 1 +vqn(k,3,1)*dbad(3)
514 2 -db(k,1,1)*ar(1)-db(k,2,1)*ar(2)-db(k,3,1)*ar(3)
515 ald(2) = ad(2)+vqn(k,1,2)*dbad(1)+vqn(k,2,2)*dbad(2)
516 1 +vqn(k,3,2)*dbad(3)
517 2 -db(k,1,2)*ar(1)-db(k,2,2)*ar(2)-db(k,3,2)*ar(3)
518 ald(3) = ad(3)+vqn(k,1,3)*dbad(1)+vqn(k,2,3)*dbad(2)
519 1 +vqn(k,3,3)*dbad(3)
520 2 -db(k,1,3)*ar(1)-db(k,2,3)*ar(2)-db(k,3,3)*ar(3)
521 ald(4) = ad(4)+vqn(k,1,4)*dbad(1)+vqn(k,2,4)*dbad(2)
522 1 +vqn(k,3,4)*dbad(3)
523 2 -db(k,1,4)*ar(1)-db(k,2,4)*ar(2)-db(k,3,4)*ar(3)
524 IF (idril>0) THEN
525 arz = vmz(k,1)+vmz(k,2)+vmz(k,3)+vmz(k,4)
526 alr(1) =alr(1)+diz(k,1)*arz
527 alr(2) =alr(2)+diz(k,2)*arz
528 alr(3) =alr(3)+diz(k,3)*arz
529 END IF !(IDRIL>0) THEN
530C
531 c1 =z1(k)*alr(2)
532 fl(1,1)= fl(1,1)-c1+corelv(k,2,1)*alr(3)
533 fl(1,2)= fl(1,2)+c1+corelv(k,2,2)*alr(3)
534 fl(1,3)= fl(1,3)-c1+corelv(k,2,3)*alr(3)
535 fl(1,4)= fl(1,4)+c1+corelv(k,2,4)*alr(3)
536C
537 c1 =z1(k)*alr(1)
538 fl(2,1)= fl(2,1)+c1-corelv(k,1,1)*alr(3)
539 fl(2,2)= fl(2,2)-c1-corelv(k,1,2)*alr(3)
540 fl(2,3)= fl(2,3)+c1-corelv(k,1,3)*alr(3)
541 fl(2,4)= fl(2,4)-c1-corelv(k,1,4)*alr(3)
542C
543 DO j=1,4
544 fl(3,j)= fl(3,j)-corelv(k,2,j)*alr(1)+corelv(k,1,j)*alr(2)
545 mm(1,j)= ml(1,j)-alr(1)-vqn(k,1,j)*ald(j)
546 mm(2,j)= ml(2,j)-alr(2)-vqn(k,2,j)*ald(j)
547 mm(3,j)= -alr(3)-vqn(k,3,j)*ald(j)
548 ENDDO
549C
550 IF (idril>0) THEN
551 DO j=1,4
552 mm(3,j)= mm(3,j) + vmz(k,j)
553 ENDDO
554 END IF !(IDRIL>0) THEN
555
556 END IF !((IMPL_S>0.AND.IKPROJ<0).OR.IDRIL>0) THEN
557C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
558C J=1
559C I=1
560 f11(k)= vq(k,1,1)*fl(1,1)+vq(k,1,2)*fl(2,1)+vq(k,1,3)*fl(3,1)
561 m11(k)= vq(k,1,1)*mm(1,1)+vq(k,1,2)*mm(2,1)+vq(k,1,3)*mm(3,1)
562C I=2
563 f21(k)= vq(k,2,1)*fl(1,1)+vq(k,2,2)*fl(2,1)+vq(k,2,3)*fl(3,1)
564 m21(k)= vq(k,2,1)*mm(1,1)+vq(k,2,2)*mm(2,1)+vq(k,2,3)*mm(3,1)
565C I=3
566 f31(k)= vq(k,3,1)*fl(1,1)+vq(k,3,2)*fl(2,1)+vq(k,3,3)*fl(3,1)
567 m31(k)= vq(k,3,1)*mm(1,1)+vq(k,3,2)*mm(2,1)+vq(k,3,3)*mm(3,1)
568C
569C J=2
570C I=1
571 f12(k)= vq(k,1,1)*fl(1,2)+vq(k,1,2)*fl(2,2)+vq(k,1,3)*fl(3,2)
572 m12(k)= vq(k,1,1)*mm(1,2)+vq(k,1,2)*mm(2,2)+vq(k,1,3)*mm(3,2)
573C I=2
574 f22(k)= vq(k,2,1)*fl(1,2)+vq(k,2,2)*fl(2,2)+vq(k,2,3)*fl(3,2)
575 m22(k)= vq(k,2,1)*mm(1,2)+vq(k,2,2)*mm(2,2)+vq(k,2,3)*mm(3,2)
576C I=3
577 f32(k)= vq(k,3,1)*fl(1,2)+vq(k,3,2)*fl(2,2)+vq(k,3,3)*fl(3,2)
578 m32(k)= vq(k,3,1)*mm(1,2)+vq(k,3,2)*mm(2,2)+vq(k,3,3)*mm(3,2)
579C
580C J=3
581C I=1
582 f13(k)= vq(k,1,1)*fl(1,3)+vq(k,1,2)*fl(2,3)+vq(k,1,3)*fl(3,3)
583 m13(k)= vq(k,1,1)*mm(1,3)+vq(k,1,2)*mm(2,3)+vq(k,1,3)*mm(3,3)
584C I=2
585 f23(k)= vq(k,2,1)*fl(1,3)+vq(k,2,2)*fl(2,3)+vq(k,2,3)*fl(3,3)
586 m23(k)= vq(k,2,1)*mm(1,3)+vq(k,2,2)*mm(2,3)+vq(k,2,3)*mm(3,3)
587C I=3
588 f33(k)= vq(k,3,1)*fl(1,3)+vq(k,3,2)*fl(2,3)+vq(k,3,3)*fl(3,3)
589 m33(k)= vq(k,3,1)*mm(1,3)+vq(k,3,2)*mm(2,3)+vq(k,3,3)*mm(3,3)
590C
591C J=4
592C I=1
593 f14(k)= vq(k,1,1)*fl(1,4)+vq(k,1,2)*fl(2,4)+vq(k,1,3)*fl(3,4)
594 m14(k)= vq(k,1,1)*mm(1,4)+vq(k,1,2)*mm(2,4)+vq(k,1,3)*mm(3,4)
595C I=2
596 f24(k)= vq(k,2,1)*fl(1,4)+vq(k,2,2)*fl(2,4)+vq(k,2,3)*fl(3,4)
597 m24(k)= vq(k,2,1)*mm(1,4)+vq(k,2,2)*mm(2,4)+vq(k,2,3)*mm(3,4)
598C I=3
599 f34(k)= vq(k,3,1)*fl(1,4)+vq(k,3,2)*fl(2,4)+vq(k,3,3)*fl(3,4)
600 m34(k)= vq(k,3,1)*mm(1,4)+vq(k,3,2)*mm(2,4)+vq(k,3,3)*mm(3,4)
601C
602 ENDIF
603C
604 ENDDO
605C------case no initial F --------------
606 ELSE
607
608 DO k=jft,jlt
609C
610C I=1
611 fl(1,1)= vf(k,1,1)+vf(k,1,3)
612 fl(1,2)= vf(k,1,2)+vf(k,1,4)
613 fl(1,3)=-vf(k,1,1)+vf(k,1,3)
614 fl(1,4)=-vf(k,1,2)+vf(k,1,4)
615C I=2
616 fl(2,1)= vf(k,2,1)+vf(k,2,3)
617 fl(2,2)= vf(k,2,2)+vf(k,2,4)
618 fl(2,3)=-vf(k,2,1)+vf(k,2,3)
619 fl(2,4)=-vf(k,2,2)+vf(k,2,4)
620C I=3
621 fl(3,1)= vf(k,3,1)+vf(k,3,3)
622 fl(3,2)= vf(k,3,2)+vf(k,3,4)
623 fl(3,3)=-vf(k,3,1)+vf(k,3,3)
624 fl(3,4)=-vf(k,3,2)+vf(k,3,4)
625C
626C I=1
627 ml(1,1)= vm(k,1,1)+vm(k,1,3)
628 ml(1,2)= vm(k,1,2)+vm(k,1,4)
629 ml(1,3)=-vm(k,1,1)+vm(k,1,3)
630 ml(1,4)=-vm(k,1,2)+vm(k,1,4)
631C I=2
632 ml(2,1)= vm(k,2,1)+vm(k,2,3)
633 ml(2,2)= vm(k,2,2)+vm(k,2,4)
634 ml(2,3)=-vm(k,2,1)+vm(k,2,3)
635 ml(2,4)=-vm(k,2,2)+vm(k,2,4)
636C---------------------------------------
637C TRANS LOCAL-->GLOBAL ET 5DDL-->6DDL
638C---------------------------------------
639 IF (plat(k)) THEN
640C
641C J=1
642C I=1
643 f11(k)= vq(k,1,1)*fl(1,1)+vq(k,1,2)*fl(2,1)+vq(k,1,3)*fl(3,1)
644 m11(k)= vq(k,1,1)*ml(1,1)+vq(k,1,2)*ml(2,1)
645C I=2
646 f21(k)= vq(k,2,1)*fl(1,1)+vq(k,2,2)*fl(2,1)+vq(k,2,3)*fl(3,1)
647 m21(k)= vq(k,2,1)*ml(1,1)+vq(k,2,2)*ml(2,1)
648C I=3
649 f31(k)= vq(k,3,1)*fl(1,1)+vq(k,3,2)*fl(2,1)+vq(k,3,3)*fl(3,1)
650 m31(k)= vq(k,3,1)*ml(1,1)+vq(k,3,2)*ml(2,1)
651C
652C J=2
653C I=1
654 f12(k)= vq(k,1,1)*fl(1,2)+vq(k,1,2)*fl(2,2)+vq(k,1,3)*fl(3,2)
655 m12(k)= vq(k,1,1)*ml(1,2)+vq(k,1,2)*ml(2,2)
656C I=2
657 f22(k)= vq(k,2,1)*fl(1,2)+vq(k,2,2)*fl(2,2)+vq(k,2,3)*fl(3,2)
658 m22(k)= vq(k,2,1)*ml(1,2)+vq(k,2,2)*ml(2,2)
659C I=3
660 f32(k)= vq(k,3,1)*fl(1,2)+vq(k,3,2)*fl(2,2)+vq(k,3,3)*fl(3,2)
661 m32(k)= vq(k,3,1)*ml(1,2)+vq(k,3,2)*ml(2,2)
662C
663C J=3
664C I=1
665 f13(k)= vq(k,1,1)*fl(1,3)+vq(k,1,2)*fl(2,3)+vq(k,1,3)*fl(3,3)
666 m13(k)= vq(k,1,1)*ml(1,3)+vq(k,1,2)*ml(2,3)
667C I=2
668 f23(k)= vq(k,2,1)*fl(1,3)+vq(k,2,2)*fl(2,3)+vq(k,2,3)*fl(3,3)
669 m23(k)= vq(k,2,1)*ml(1,3)+vq(k,2,2)*ml(2,3)
670C I=3
671 f33(k)= vq(k,3,1)*fl(1,3)+vq(k,3,2)*fl(2,3)+vq(k,3,3)*fl(3,3)
672 m33(k)= vq(k,3,1)*ml(1,3)+vq(k,3,2)*ml(2,3)
673C
674C J=4
675C I=1
676 f14(k)= vq(k,1,1)*fl(1,4)+vq(k,1,2)*fl(2,4)+vq(k,1,3)*fl(3,4)
677 m14(k)= vq(k,1,1)*ml(1,4)+vq(k,1,2)*ml(2,4)
678C I=2
679 f24(k)= vq(k,2,1)*fl(1,4)+vq(k,2,2)*fl(2,4)+vq(k,2,3)*fl(3,4)
680 m24(k)= vq(k,2,1)*ml(1,4)+vq(k,2,2)*ml(2,4)
681C I=3
682 f34(k)= vq(k,3,1)*fl(1,4)+vq(k,3,2)*fl(2,4)+vq(k,3,3)*fl(3,4)
683 m34(k)= vq(k,3,1)*ml(1,4)+vq(k,3,2)*ml(2,4)
684C
685 IF (idril>0) THEN
686 m11(k)= m11(k)+ vq(k,1,3)*vmz(k,1)
687 m21(k)= m21(k)+ vq(k,2,3)*vmz(k,1)
688 m31(k)= m31(k)+ vq(k,3,3)*vmz(k,1)
689C
690 m12(k)= m12(k)+ vq(k,1,3)*vmz(k,2)
691 m22(k)= m22(k)+ vq(k,2,3)*vmz(k,2)
692 m32(k)= m32(k)+ vq(k,3,3)*vmz(k,2)
693C
694 m13(k)= m13(k)+ vq(k,1,3)*vmz(k,3)
695 m23(k)= m23(k)+ vq(k,2,3)*vmz(k,3)
696 m33(k)= m33(k)+ vq(k,3,3)*vmz(k,3)
697C
698 m14(k)= m14(k)+ vq(k,1,3)*vmz(k,4)
699 m24(k)= m24(k)+ vq(k,2,3)*vmz(k,4)
700 m34(k)= m34(k)+ vq(k,3,3)*vmz(k,4)
701 END IF
702C
703 ELSE
704 IF (impl_s>0.AND.ikproj<=0) THEN
705C-------------------------------------
706C DRILLING RE-PROJECTION ONLY
707C-------------------------------------
708 mm(1,1)=(one-vqn(k,1,1)*vqn(k,1,1))*ml(1,1)-
709 1 vqn(k,1,1)*vqn(k,2,1) *ml(2,1)
710 mm(2,1)=(one-vqn(k,2,1)*vqn(k,2,1))*ml(2,1)-
711 1 vqn(k,1,1)*vqn(k,2,1) *ml(1,1)
712 mm(3,1)= -vqn(k,1,1)*vqn(k,3,1) *ml(1,1)-
713 1 vqn(k,2,1)*vqn(k,3,1) *ml(2,1)
714C
715C J=2
716 mm(1,2)=(one - vqn(k,1,2)*vqn(k,1,2))*ml(1,2)-
717 1 vqn(k,1,2)*vqn(k,2,2) *ml(2,2)
718 mm(2,2)=(one - vqn(k,2,2)*vqn(k,2,2))*ml(2,2)-
719 1 vqn(k,1,2)*vqn(k,2,2) *ml(1,2)
720 mm(3,2)= -vqn(k,1,2)*vqn(k,3,2) *ml(1,2)-
721 1 vqn(k,2,2)*vqn(k,3,2) *ml(2,2)
722C
723C J=3
724 mm(1,3)=(one-vqn(k,1,3)*vqn(k,1,3))*ml(1,3)-
725 1 vqn(k,1,3)*vqn(k,2,3) *ml(2,3)
726 mm(2,3)=(one-vqn(k,2,3)*vqn(k,2,3))*ml(2,3)-
727 1 vqn(k,1,3)*vqn(k,2,3) *ml(1,3)
728 mm(3,3)= -vqn(k,1,3)*vqn(k,3,3) *ml(1,3)-
729 1 vqn(k,2,3)*vqn(k,3,3) *ml(2,3)
730C
731C J=4
732 mm(1,4)=(one-vqn(k,1,4)*vqn(k,1,4))*ml(1,4)-
733 1 vqn(k,1,4)*vqn(k,2,4) *ml(2,4)
734 mm(2,4)=(one-vqn(k,2,4)*vqn(k,2,4))*ml(2,4)-
735 1 vqn(k,1,4)*vqn(k,2,4) *ml(1,4)
736 mm(3,4)= -vqn(k,1,4)*vqn(k,3,4) *ml(1,4)-
737 1 vqn(k,2,4)*vqn(k,3,4) *ml(2,4)
738 IF (idril>0) THEN
739 DO j=1,4
740 mm(1,j)=mm(1,j)+ vqn(k,1,j)*vmz(k,j)
741 mm(2,j)=mm(2,j)+ vqn(k,2,j)*vmz(k,j)
742 mm(3,j)=mm(3,j)+ vqn(k,3,j)*vmz(k,j)
743 END DO !J=1,4
744 END IF
745 ELSE
746C----REPROJECTION(full)------
747 ar(1)= -z1(k)*(fl(2,1)-fl(2,2)+fl(2,3)-fl(2,4))
748 1 +corelv(k,2,1)*fl(3,1)+ml(1,1)
749 2 +corelv(k,2,2)*fl(3,2)+ml(1,2)
750 3 +corelv(k,2,3)*fl(3,3)+ml(1,3)
751 4 +corelv(k,2,4)*fl(3,4)+ml(1,4)
752 ar(2)= z1(k)*(fl(1,1)-fl(1,2)+fl(1,3)-fl(1,4))
753 1 -corelv(k,1,1)*fl(3,1)+ml(2,1)
754 2 -corelv(k,1,2)*fl(3,2)+ml(2,2)
755 3 -corelv(k,1,3)*fl(3,3)+ml(2,3)
756 4 -corelv(k,1,4)*fl(3,4)+ml(2,4)
757 ar(3)=-corelv(k,2,1)*fl(1,1)+corelv(k,1,1)*fl(2,1)
758 1 -corelv(k,2,2)*fl(1,2)+corelv(k,1,2)*fl(2,2)
759 2 -corelv(k,2,3)*fl(1,3)+corelv(k,1,3)*fl(2,3)
760 3 -corelv(k,2,4)*fl(1,4)+corelv(k,1,4)*fl(2,4)
761
762 ad(1)= vqn(k,1,1)*ml(1,1)+vqn(k,2,1)*ml(2,1)
763 ad(2)= vqn(k,1,2)*ml(1,2)+vqn(k,2,2)*ml(2,2)
764 ad(3)= vqn(k,1,3)*ml(1,3)+vqn(k,2,3)*ml(2,3)
765 ad(4)= vqn(k,1,4)*ml(1,4)+vqn(k,2,4)*ml(2,4)
766C
767 dbad(1)= db(k,1,1)*ad(1)+db(k,1,2)*ad(2)
768 1 +db(k,1,3)*ad(3)+db(k,1,4)*ad(4)
769 dbad(2)= db(k,2,1)*ad(1)+db(k,2,2)*ad(2)
770 1 +db(k,2,3)*ad(3)+db(k,2,4)*ad(4)
771 dbad(3)= db(k,3,1)*ad(1)+db(k,3,2)*ad(2)
772 1 +db(k,3,3)*ad(3)+db(k,3,4)*ad(4)
773C
774 alr(1) =di(k,1)*ar(1)+di(k,4)*ar(2)+di(k,5)*ar(3)-dbad(1)
775 alr(2) =di(k,4)*ar(1)+di(k,2)*ar(2)+di(k,6)*ar(3)-dbad(2)
776 alr(3) =di(k,5)*ar(1)+di(k,6)*ar(2)+di(k,3)*ar(3)-dbad(3)
777CC
778 ald(1) = ad(1)+vqn(k,1,1)*dbad(1)+vqn(k,2,1)*dbad(2)
779 1 +vqn(k,3,1)*dbad(3)
780 2 -db(k,1,1)*ar(1)-db(k,2,1)*ar(2)-db(k,3,1)*ar(3)
781 ald(2) = ad(2)+vqn(k,1,2)*dbad(1)+vqn(k,2,2)*dbad(2)
782 1 +vqn(k,3,2)*dbad(3)
783 2 -db(k,1,2)*ar(1)-db(k,2,2)*ar(2)-db(k,3,2)*ar(3)
784 ald(3) = ad(3)+vqn(k,1,3)*dbad(1)+vqn(k,2,3)*dbad(2)
785 1 +vqn(k,3,3)*dbad(3)
786 2 -db(k,1,3)*ar(1)-db(k,2,3)*ar(2)-db(k,3,3)*ar(3)
787 ald(4) = ad(4)+vqn(k,1,4)*dbad(1)+vqn(k,2,4)*dbad(2)
788 1 +vqn(k,3,4)*dbad(3)
789 2 -db(k,1,4)*ar(1)-db(k,2,4)*ar(2)-db(k,3,4)*ar(3)
790 IF (idril>0) THEN
791 arz = vmz(k,1)+vmz(k,2)+vmz(k,3)+vmz(k,4)
792 alr(1) =alr(1)+diz(k,1)*arz
793 alr(2) =alr(2)+diz(k,2)*arz
794 alr(3) =alr(3)+diz(k,3)*arz
795 END IF !(IDRIL>0) THEN
796C
797 c1 =z1(k)*alr(2)
798 fl(1,1)= fl(1,1)-c1+corelv(k,2,1)*alr(3)
799 fl(1,2)= fl(1,2)+c1+corelv(k,2,2)*alr(3)
800 fl(1,3)= fl(1,3)-c1+corelv(k,2,3)*alr(3)
801 fl(1,4)= fl(1,4)+c1+corelv(k,2,4)*alr(3)
802C
803 c1 =z1(k)*alr(1)
804 fl(2,1)= fl(2,1)+c1-corelv(k,1,1)*alr(3)
805 fl(2,2)= fl(2,2)-c1-corelv(k,1,2)*alr(3)
806 fl(2,3)= fl(2,3)+c1-corelv(k,1,3)*alr(3)
807 fl(2,4)= fl(2,4)-c1-corelv(k,1,4)*alr(3)
808C
809 DO j=1,4
810 fl(3,j)= fl(3,j)-corelv(k,2,j)*alr(1)+corelv(k,1,j)*alr(2)
811 mm(1,j)= ml(1,j)-alr(1)-vqn(k,1,j)*ald(j)
812 mm(2,j)= ml(2,j)-alr(2)-vqn(k,2,j)*ald(j)
813 mm(3,j)= -alr(3)-vqn(k,3,j)*ald(j)
814 ENDDO
815C
816 IF (idril>0) THEN
817 DO j=1,4
818 mm(3,j)= mm(3,j)+vmz(k,j)
819 ENDDO
820 END IF !(IDRIL>0) THEN
821 END IF !((IMPL_S>0.AND.IKPROJ<0).OR.IDRIL>0) THEN
822C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
823C J=1
824C I=1
825 f11(k)= vq(k,1,1)*fl(1,1)+vq(k,1,2)*fl(2,1)+vq(k,1,3)*fl(3,1)
826 m11(k)= vq(k,1,1)*mm(1,1)+vq(k,1,2)*mm(2,1)+vq(k,1,3)*mm(3,1)
827C I=2
828 f21(k)= vq(k,2,1)*fl(1,1)+vq(k,2,2)*fl(2,1)+vq(k,2,3)*fl(3,1)
829 m21(k)= vq(k,2,1)*mm(1,1)+vq(k,2,2)*mm(2,1)+vq(k,2,3)*mm(3,1)
830C I=3
831 f31(k)= vq(k,3,1)*fl(1,1)+vq(k,3,2)*fl(2,1)+vq(k,3,3)*fl(3,1)
832 m31(k)= vq(k,3,1)*mm(1,1)+vq(k,3,2)*mm(2,1)+vq(k,3,3)*mm(3,1)
833C
834C J=2
835C I=1
836 f12(k)= vq(k,1,1)*fl(1,2)+vq(k,1,2)*fl(2,2)+vq(k,1,3)*fl(3,2)
837 m12(k)= vq(k,1,1)*mm(1,2)+vq(k,1,2)*mm(2,2)+vq(k,1,3)*mm(3,2)
838C I=2
839 f22(k)= vq(k,2,1)*fl(1,2)+vq(k,2,2)*fl(2,2)+vq(k,2,3)*fl(3,2)
840 m22(k)= vq(k,2,1)*mm(1,2)+vq(k,2,2)*mm(2,2)+vq(k,2,3)*mm(3,2)
841C I=3
842 f32(k)= vq(k,3,1)*fl(1,2)+vq(k,3,2)*fl(2,2)+vq(k,3,3)*fl(3,2)
843 m32(k)= vq(k,3,1)*mm(1,2)+vq(k,3,2)*mm(2,2)+vq(k,3,3)*mm(3,2)
844C
845C J=3
846C I=1
847 f13(k)= vq(k,1,1)*fl(1,3)+vq(k,1,2)*fl(2,3)+vq(k,1,3)*fl(3,3)
848 m13(k)= vq(k,1,1)*mm(1,3)+vq(k,1,2)*mm(2,3)+vq(k,1,3)*mm(3,3)
849C I=2
850 f23(k)= vq(k,2,1)*fl(1,3)+vq(k,2,2)*fl(2,3)+vq(k,2,3)*fl(3,3)
851 m23(k)= vq(k,2,1)*mm(1,3)+vq(k,2,2)*mm(2,3)+vq(k,2,3)*mm(3,3)
852C I=3
853 f33(k)= vq(k,3,1)*fl(1,3)+vq(k,3,2)*fl(2,3)+vq(k,3,3)*fl(3,3)
854 m33(k)= vq(k,3,1)*mm(1,3)+vq(k,3,2)*mm(2,3)+vq(k,3,3)*mm(3,3)
855C
856C J=4
857C I=1
858 f14(k)= vq(k,1,1)*fl(1,4)+vq(k,1,2)*fl(2,4)+vq(k,1,3)*fl(3,4)
859 m14(k)= vq(k,1,1)*mm(1,4)+vq(k,1,2)*mm(2,4)+vq(k,1,3)*mm(3,4)
860C I=2
861 f24(k)= vq(k,2,1)*fl(1,4)+vq(k,2,2)*fl(2,4)+vq(k,2,3)*fl(3,4)
862 m24(k)= vq(k,2,1)*mm(1,4)+vq(k,2,2)*mm(2,4)+vq(k,2,3)*mm(3,4)
863C I=3
864 f34(k)= vq(k,3,1)*fl(1,4)+vq(k,3,2)*fl(2,4)+vq(k,3,3)*fl(3,4)
865 m34(k)= vq(k,3,1)*mm(1,4)+vq(k,3,2)*mm(2,4)+vq(k,3,3)*mm(3,4)
866C
867 ENDIF
868C
869 ENDDO
870C
871 END IF !IF(IFINI > 0) THEN
872C
873 RETURN