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

Go to the source code of this file.

Functions/Subroutines

subroutine czsumg3 (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, corelv, z1, idril, iorth)
subroutine cztran2 (jft, jlt, vqi, kk, vqj, isym, vq)
subroutine cztrandr (jft, jlt, vqi, kk, vqj, isym)
subroutine czprojk (jft, jlt, vqn, q, 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, corelv, z1, idril)
subroutine set_rsj (r1, r2, r3, r4, z1, jft, jlt, iplat, vqn, corelv)
subroutine set_rsj2 (r1, r2, r3, r4, z1, jft, jlt, corelv, iplat)
subroutine set_rsj33 (xi, yi, zi, ri, jft, jlt)
subroutine setprojk (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, jft, jlt)
subroutine tranqikqj67 (jft, jlt, vqi, kk, vqj, kd, isym)
subroutine tranqikqj (jft, jlt, vqi, kk, vqj, nd, isym)
subroutine trankl1 (jft, jlt, kl, is)
subroutine tranklq (jft, jlt, vq, kl, kd, it)
subroutine cztrank33 (jft, jlt, vq, k33, kk, isym)
subroutine setprojkz (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, drz, rz1, rz2, rz3, rz4, vq, jft, jlt, qn1, qn2, qn3, qn4)
subroutine trankl2 (jft, jlt, kl, qni, kr, it)
subroutine czprojkr (jft, jlt, vqn, vq, 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, corelv, z1)
subroutine setprojkz1 (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, jft, jlt, qn1, qn2, qn3, qn4)
subroutine tranklqn (jft, jlt, vq, vqn, kl, kd, it)
subroutine trankl0 (jft, jlt, kl, kr, it)
subroutine tranqikqjrz (jft, jlt, ri, rd, rj, kl, kr, it, is)

Function/Subroutine Documentation

◆ czprojk()

subroutine czprojk ( integer jft,
integer jlt,
vqn,
q,
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,
corelv,
z1,
integer idril )

Definition at line 650 of file czsumg3.F.

657C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
658#include "implicit_f.inc"
659#include "mvsiz_p.inc"
660C-----------------------------------------------
661C D U M M Y A R G U M E N T S
662C-----------------------------------------------
663 INTEGER JFT,JLT,IPLAT(*),IDRIL
664 my_real
665 . vqn(mvsiz,3,4),q(3,3,*)
666 my_real
667 . k11(3,3,*),k12(3,3,*),k13(3,3,*),k14(3,3,*),
668 . k22(3,3,*),k23(3,3,*),k24(3,3,*),k33(3,3,*),
669 . m11(3,3,*),m12(3,3,*),m13(3,3,*),m14(3,3,*),
670 . m22(3,3,*),m23(3,3,*),m24(3,3,*),m33(3,3,*),
671 . mf11(3,3,*),mf12(3,3,*),mf13(3,3,*),mf14(3,3,*),
672 . mf22(3,3,*),mf23(3,3,*),mf24(3,3,*),mf33(3,3,*),
673 . fm12(3,3,*),fm13(3,3,*),fm14(3,3,*),
674 . fm23(3,3,*),fm24(3,3,*),fm34(3,3,*),
675 . k34(3,3,*),k44(3,3,*),m34(3,3,*),m44(3,3,*),
676 . mf34(3,3,*),mf44(3,3,*),
677 . corelv(mvsiz,2,4),z1(*)
678C-----------------------------------------------
679C L O C A L V A R I A B L E S
680C-----------------------------------------------
681 INTEGER I, J, K,L,EP,IS,IAS,NF,MI,MJ,M,ND
682 my_real
683 . dr(7,7,mvsiz),drz(3,mvsiz),
684 . r1(6,7,mvsiz),r2(6,7,mvsiz),r3(6,7,mvsiz),r4(6,7,mvsiz),
685 . rz1(3,3,mvsiz),rz2(3,3,mvsiz),rz3(3,3,mvsiz),rz4(3,3,mvsiz),
686 . di(6),db(3,4),btdb(4,4),z2,deta,btb(6),d(6),
687 . xx,yy,zz,xy,xz,yz,abc,xxyz2,yyxz2,zzxy2,
688 . qn1(3,mvsiz),qn2(3,mvsiz),qn3(3,mvsiz),qn4(3,mvsiz)
689C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
690 DO m=jft,jlt
691 i=iplat(m)
692 z2 = z1(i)*z1(i)
693C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
694 xx = corelv(i,1,1)*corelv(i,1,1)+corelv(i,1,2)*corelv(i,1,2)
695 1 +corelv(i,1,3)*corelv(i,1,3)+corelv(i,1,4)*corelv(i,1,4)
696 yy = corelv(i,2,1)*corelv(i,2,1)+corelv(i,2,2)*corelv(i,2,2)
697 1 +corelv(i,2,3)*corelv(i,2,3)+corelv(i,2,4)*corelv(i,2,4)
698 xy = corelv(i,1,1)*corelv(i,2,1)+corelv(i,1,2)*corelv(i,2,2)
699 1 +corelv(i,1,3)*corelv(i,2,3)+corelv(i,1,4)*corelv(i,2,4)
700 xz =(corelv(i,1,1)-corelv(i,1,2)+corelv(i,1,3)-corelv(i,1,4))
701 . *z1(i)
702 yz =(corelv(i,2,1)-corelv(i,2,2)+corelv(i,2,3)-corelv(i,2,4))
703 . *z1(i)
704 zz = four*z2
705C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
706 IF (idril > 0) THEN
707 d(1)= yy+zz+four
708 d(2)= xx+zz+four
709 d(3)= xx+yy+four
710 d(4)= -xy
711 d(5)= -xz
712 d(6)= -yz
713 abc = d(1)*d(2)*d(3)
714 xxyz2 = d(1)*d(6)*d(6)
715 yyxz2 = d(2)*d(5)*d(5)
716 zzxy2 = d(3)*d(4)*d(4)
717 deta = abs(abc+two*d(4)*d(5)*d(6)-xxyz2-yyxz2-zzxy2)
718 deta = one/max(deta,em20)
719 di(3) = (abc-zzxy2)*deta/max(d(3),em20)
720 di(5) = (d(6)*d(4)-d(5)*d(2))*deta
721 di(6) = (d(4)*d(5)-d(6)*d(1))*deta
722C
723 drz(1,m)= di(5)
724 drz(2,m)= di(6)
725 drz(3,m)= di(3)
726 END IF !(IDRIL > 0) THEN
727 btb(1)= vqn(i,1,1)*vqn(i,1,1)+vqn(i,1,2)*vqn(i,1,2)
728 1 +vqn(i,1,3)*vqn(i,1,3)+vqn(i,1,4)*vqn(i,1,4)
729 btb(2)= vqn(i,2,1)*vqn(i,2,1)+vqn(i,2,2)*vqn(i,2,2)
730 1 +vqn(i,2,3)*vqn(i,2,3)+vqn(i,2,4)*vqn(i,2,4)
731 btb(3)= vqn(i,3,1)*vqn(i,3,1)+vqn(i,3,2)*vqn(i,3,2)
732 1 +vqn(i,3,3)*vqn(i,3,3)+vqn(i,3,4)*vqn(i,3,4)
733 btb(4)= vqn(i,1,1)*vqn(i,2,1)+vqn(i,1,2)*vqn(i,2,2)
734 1 +vqn(i,1,3)*vqn(i,2,3)+vqn(i,1,4)*vqn(i,2,4)
735 btb(5)= vqn(i,1,1)*vqn(i,3,1)+vqn(i,1,2)*vqn(i,3,2)
736 1 +vqn(i,1,3)*vqn(i,3,3)+vqn(i,1,4)*vqn(i,3,4)
737 btb(6)= vqn(i,2,1)*vqn(i,3,1)+vqn(i,2,2)*vqn(i,3,2)
738 1 +vqn(i,2,3)*vqn(i,3,3)+vqn(i,2,4)*vqn(i,3,4)
739 d(1)= yy+zz+four-btb(1)
740 d(2)= xx+zz+four-btb(2)
741 d(3)= xx+yy+four-btb(3)
742 d(4)= -xy-btb(4)
743 d(5)= -xz-btb(5)
744 d(6)= -yz-btb(6)
745 abc = d(1)*d(2)*d(3)
746 xxyz2 = d(1)*d(6)*d(6)
747 yyxz2 = d(2)*d(5)*d(5)
748 zzxy2 = d(3)*d(4)*d(4)
749 deta = abs(abc+two*d(4)*d(5)*d(6)-xxyz2-yyxz2-zzxy2)
750 deta = one/max(deta,em20)
751 di(1) = (abc-xxyz2)*deta/max(d(1),em20)
752 di(2) = (abc-yyxz2)*deta/max(d(2),em20)
753 di(3) = (abc-zzxy2)*deta/max(d(3),em20)
754 di(4) = (d(5)*d(6)-d(4)*d(3))*deta
755 di(5) = (d(6)*d(4)-d(5)*d(2))*deta
756 di(6) = (d(4)*d(5)-d(6)*d(1))*deta
757 DO j=1,4
758 db(1,j)= di(1)*vqn(i,1,j)+di(4)*vqn(i,2,j)
759 1 +di(5)*vqn(i,3,j)
760 db(2,j)= di(4)*vqn(i,1,j)+di(2)*vqn(i,2,j)
761 1 +di(6)*vqn(i,3,j)
762 db(3,j)= di(5)*vqn(i,1,j)+di(6)*vqn(i,2,j)
763 1 +di(3)*vqn(i,3,j)
764 ENDDO
765 DO l=1,4
766 DO j=l,4
767 btdb(l,j)= vqn(i,1,l)*db(1,j)+vqn(i,2,l)*db(2,j)
768 1 +vqn(i,3,l)*db(3,j)
769 ENDDO
770 ENDDO
771C
772 dr(1,1,m)= di(1)
773 dr(2,2,m)= di(2)
774 dr(3,3,m)= di(3)
775 dr(1,2,m)= di(4)
776 dr(1,3,m)= di(5)
777 dr(2,3,m)= di(6)
778 DO j=1,4
779 dr(1,j+3,m)= -db(1,j)
780 dr(2,j+3,m)= -db(2,j)
781 dr(3,j+3,m)= -db(3,j)
782 dr(j+3,j+3,m)= one+btdb(j,j)
783 DO k=j+1,4
784 dr(j+3,k+3,m)= btdb(j,k)
785 ENDDO
786 ENDDO
787 END DO !M=
788C
789 DO m=jft,jlt
790 DO l=1,7
791 DO j=l+1,7
792 dr(j,l,m)=dr(l,j,m)
793 ENDDO
794 ENDDO
795 END DO
796C
797 CALL set_rsj(r1 ,r2 ,r3 ,r4 ,z1 ,
798 . jft ,jlt ,iplat ,vqn ,corelv)
799C -----------PROJECTION---------
800 IF (idril == 0) THEN
801 CALL setprojk(dr ,r1 ,r2 ,r3 ,r4 ,
802 3 k11,k12,k13,k14,k22,k23,k24,k33,k34,k44,
803 4 m11,m12,m13,m14,m22,m23,m24,m33,m34,m44,
804 5 mf11,mf12,mf13,mf14,mf22,mf23,mf24,mf33,
805 6 mf34,mf44,fm12,fm13,fm14,fm23,fm24,fm34,
806 7 q ,jft ,jlt )
807 ELSE
808 DO m=jft,jlt
809 i=iplat(m)
810 DO j=1,3
811 qn1(j,m)= vqn(i,j,1)
812 qn2(j,m)= vqn(i,j,2)
813 qn3(j,m)= vqn(i,j,3)
814 qn4(j,m)= vqn(i,j,4)
815 ENDDO
816 END DO
817C
818 CALL set_rsj2(rz1 ,rz2 ,rz3 ,rz4 ,z1 ,
819 . jft ,jlt ,corelv ,iplat )
820C
821 CALL setprojkz(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 drz ,rz1 ,rz2 ,rz3 ,rz4 ,
827 8 q ,jft ,jlt ,qn1 ,qn2 ,qn3 ,qn4 )
828 END IF !(IDRIL == 0) THEN
829C
830 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
setprojk
subroutine setprojk(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, jft, jlt)
Definition czsumg3.F:1044
setprojkz
subroutine setprojkz(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, drz, rz1, rz2, rz3, rz4, vq, jft, jlt, qn1, qn2, qn3, qn4)
Definition czsumg3.F:1839
set_rsj2
subroutine set_rsj2(r1, r2, r3, r4, z1, jft, jlt, corelv, iplat)
Definition czsumg3.F:927
set_rsj
subroutine set_rsj(r1, r2, r3, r4, z1, jft, jlt, iplat, vqn, corelv)
Definition czsumg3.F:841
max
#define max(a, b)
Definition macros.h:21

◆ czprojkr()

subroutine czprojkr ( integer jft,
integer jlt,
vqn,
vq,
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,
corelv,
z1 )

Definition at line 2352 of file czsumg3.F.

2359C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
2360#include "implicit_f.inc"
2361#include "mvsiz_p.inc"
2362C-----------------------------------------------
2363C D U M M Y A R G U M E N T S
2364C-----------------------------------------------
2365 INTEGER JFT,JLT,IPLAT(*)
2366 my_real
2367 . k11(3,3,*),k12(3,3,*),k13(3,3,*),k14(3,3,*),
2368 . k22(3,3,*),k23(3,3,*),k24(3,3,*),k33(3,3,*),
2369 . m11(3,3,*),m12(3,3,*),m13(3,3,*),m14(3,3,*),
2370 . m22(3,3,*),m23(3,3,*),m24(3,3,*),m33(3,3,*),
2371 . mf11(3,3,*),mf12(3,3,*),mf13(3,3,*),mf14(3,3,*),
2372 . mf22(3,3,*),mf23(3,3,*),mf24(3,3,*),mf33(3,3,*),
2373 . fm12(3,3,*),fm13(3,3,*),fm14(3,3,*),
2374 . fm23(3,3,*),fm24(3,3,*),fm34(3,3,*),
2375 . k34(3,3,*),k44(3,3,*),m34(3,3,*),m44(3,3,*),
2376 . mf34(3,3,*),mf44(3,3,*),
2377 . corelv(mvsiz,2,4),z1(*),vqn(3,4,*),vq(3,3,*)
2378C-----------------------------------------------
2379C L O C A L V A R I A B L E S
2380C-----------------------------------------------
2381 INTEGER I, J, K,L,EP,IS,IAS,NF,MI,MJ,M,ND
2382 my_real
2383 . dr(3,3,mvsiz),pp(3,3,4,mvsiz),
2384 . r1(3,3,mvsiz),r2(3,3,mvsiz),r3(3,3,mvsiz),r4(3,3,mvsiz),
2385 . di(6),z2,deta,d(6),
2386 . qn1(3,3,mvsiz),qn2(3,3,mvsiz),qn3(3,3,mvsiz),qn4(3,3,mvsiz),
2387 . xx,yy,zz,xy,xz,yz,abc,xxyz2,yyxz2,zzxy2
2388C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
2389C-------transport Mij to element local system first---------
2390#include "vectorize.inc"
2391 DO m=jft,jlt
2392 i=iplat(m)
2393 z2 = z1(i)*z1(i)
2394C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
2395 xx = corelv(i,1,1)*corelv(i,1,1)+corelv(i,1,2)*corelv(i,1,2)
2396 1 +corelv(i,1,3)*corelv(i,1,3)+corelv(i,1,4)*corelv(i,1,4)
2397 yy = corelv(i,2,1)*corelv(i,2,1)+corelv(i,2,2)*corelv(i,2,2)
2398 1 +corelv(i,2,3)*corelv(i,2,3)+corelv(i,2,4)*corelv(i,2,4)
2399 xy = corelv(i,1,1)*corelv(i,2,1)+corelv(i,1,2)*corelv(i,2,2)
2400 1 +corelv(i,1,3)*corelv(i,2,3)+corelv(i,1,4)*corelv(i,2,4)
2401 xz =(corelv(i,1,1)-corelv(i,1,2)+corelv(i,1,3)-corelv(i,1,4))
2402 . *z1(i)
2403 yz =(corelv(i,2,1)-corelv(i,2,2)+corelv(i,2,3)-corelv(i,2,4))
2404 . *z1(i)
2405 zz = four*z2
2406C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
2407 d(1)= yy+zz+four
2408 d(2)= xx+zz+four
2409 d(3)= xx+yy+four
2410 d(4)= -xy
2411 d(5)= -xz
2412 d(6)= -yz
2413 abc = d(1)*d(2)*d(3)
2414 xxyz2 = d(1)*d(6)*d(6)
2415 yyxz2 = d(2)*d(5)*d(5)
2416 zzxy2 = d(3)*d(4)*d(4)
2417 deta = abs(abc+two*d(4)*d(5)*d(6)-xxyz2-yyxz2-zzxy2)
2418 deta = one/max(deta,em20)
2419 di(1) = (abc-xxyz2)*deta/max(d(1),em20)
2420 di(2) = (abc-yyxz2)*deta/max(d(2),em20)
2421 di(3) = (abc-zzxy2)*deta/max(d(3),em20)
2422 di(4) = (d(5)*d(6)-d(4)*d(3))*deta
2423 di(5) = (d(6)*d(4)-d(5)*d(2))*deta
2424 di(6) = (d(4)*d(5)-d(6)*d(1))*deta
2425C
2426 dr(1,1,m)= di(1)
2427 dr(2,2,m)= di(2)
2428 dr(3,3,m)= di(3)
2429 dr(1,2,m)= di(4)
2430 dr(1,3,m)= di(5)
2431 dr(2,3,m)= di(6)
2432 dr(2,1,m)= dr(1,2,m)
2433 dr(3,1,m)= dr(1,3,m)
2434 dr(3,2,m)= dr(2,3,m)
2435 END DO
2436C
2437 CALL set_rsj1(r1 ,r2 ,r3 ,r4 ,z1 ,
2438 . jft ,jlt ,corelv)
2439 DO j=1,4
2440#include "vectorize.inc"
2441 DO m=jft,jlt
2442 ep=iplat(m)
2443 pp(1,1,j,m)=one-vqn(1,j,ep)*vqn(1,j,ep)
2444 pp(2,2,j,m)=one-vqn(2,j,ep)*vqn(2,j,ep)
2445 pp(1,2,j,m)=-vqn(1,j,ep)*vqn(2,j,ep)
2446 pp(1,3,j,m)=-vqn(1,j,ep)*vqn(3,j,ep)
2447 pp(2,3,j,m)=-vqn(2,j,ep)*vqn(3,j,ep)
2448 pp(2,1,j,m)=pp(1,2,j,m)
2449 pp(3,1,j,m)=vqn(1,j,ep)
2450 pp(3,2,j,m)=vqn(2,j,ep)
2451 pp(3,3,j,m)=vqn(3,j,ep)
2452 ENDDO
2453 ENDDO
2454C
2455C------------------QJ=PPJ*Q-------------------
2456 DO i=1,3
2457 DO j=1,3
2458 DO ep=jft,jlt
2459 qn1(i,j,ep)=pp(i,1,1,ep)*vq(1,j,ep)+pp(i,2,1,ep)*vq(2,j,ep)+
2460 . pp(i,3,1,ep)*vq(3,j,ep)
2461 qn2(i,j,ep)=pp(i,1,2,ep)*vq(1,j,ep)+pp(i,2,2,ep)*vq(2,j,ep)+
2462 . pp(i,3,2,ep)*vq(3,j,ep)
2463 qn3(i,j,ep)=pp(i,1,3,ep)*vq(1,j,ep)+pp(i,2,3,ep)*vq(2,j,ep)+
2464 . pp(i,3,3,ep)*vq(3,j,ep)
2465 qn4(i,j,ep)=pp(i,1,4,ep)*vq(1,j,ep)+pp(i,2,4,ep)*vq(2,j,ep)+
2466 . pp(i,3,4,ep)*vq(3,j,ep)
2467 ENDDO
2468 ENDDO
2469 ENDDO
2470C -----------PROJECTION---------
2471 CALL setprojkz1(dr ,r1 ,r2 ,r3 ,r4 ,
2472 3 k11,k12,k13,k14,k22,k23,k24,k33,k34,k44,
2473 4 m11,m12,m13,m14,m22,m23,m24,m33,m34,m44,
2474 5 mf11,mf12,mf13,mf14,mf22,mf23,mf24,mf33,
2475 6 mf34,mf44,fm12,fm13,fm14,fm23,fm24,fm34,
2476 7 vq ,jft ,jlt ,qn1 ,qn2 ,qn3 ,qn4 )
2477C
2478 RETURN
set_rsj1
subroutine set_rsj1(r1, r2, r3, r4, z1, jft, jlt, corelv)
Definition cbasumg3.F:840
setprojkz1
subroutine setprojkz1(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, jft, jlt, qn1, qn2, qn3, qn4)
Definition czsumg3.F:2496

◆ czsumg3()

subroutine czsumg3 ( 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,
corelv,
z1,
integer idril,
integer iorth )

Definition at line 39 of file czsumg3.F.

48C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
49#include "implicit_f.inc"
50#include "mvsiz_p.inc"
51#include "impl1_c.inc"
52C-----------------------------------------------
53C D U M M Y A R G U M E N T S
54C-----------------------------------------------
55 INTEGER JFT,JLT,NPLAT ,IPLAT(*),IDRIL,IORTH
56 my_real
57 . vqn(mvsiz,3,4),vq(mvsiz,3,3)
58 my_real
59 . k11(3,3,*),k12(3,3,*),k13(3,3,*),k14(3,3,*),
60 . k22(3,3,*),k23(3,3,*),k24(3,3,*),k33(3,3,*),
61 . m11(3,3,*),m12(3,3,*),m13(3,3,*),m14(3,3,*),
62 . m22(3,3,*),m23(3,3,*),m24(3,3,*),m33(3,3,*),
63 . mf11(3,3,*),mf12(3,3,*),mf13(3,3,*),mf14(3,3,*),
64 . mf22(3,3,*),mf23(3,3,*),mf24(3,3,*),mf33(3,3,*),
65 . fm12(3,3,*),fm13(3,3,*),fm14(3,3,*),
66 . fm23(3,3,*),fm24(3,3,*),fm34(3,3,*),
67 . k34(3,3,*),k44(3,3,*),m34(3,3,*),m44(3,3,*),
68 . mf34(3,3,*),mf44(3,3,*),
69 . ke11(6,6,*),ke22(6,6,*),ke33(6,6,*),ke44(6,6,*),
70 . ke12(6,6,*),ke13(6,6,*),ke14(6,6,*),ke23(6,6,*),
71 . ke24(6,6,*),ke34(6,6,*),corelv(mvsiz,2,4),z1(*)
72C-----------------------------------------------
73C L O C A L V A R I A B L E S
74C-----------------------------------------------
75 INTEGER I, J, K,EP,IS,IAS,NF,MI,MJ,M
76 my_real
77 . mz11(mvsiz),mz22(mvsiz),mz33(mvsiz),mz44(mvsiz),mz12(mvsiz),
78 . mz13(mvsiz),mz14(mvsiz),mz23(mvsiz),mz24(mvsiz),mz34(mvsiz),
79 . q(3,3,mvsiz),q1(3,3,mvsiz),q2(3,3,mvsiz),
80 . q3(3,3,mvsiz),q4(3,3,mvsiz),pp(3,3,4,mvsiz)
81 DATA is/1/,ias/0/
82C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
83C---------------------------------------
84C TRANS LOCAL-->GLOBAL ET 5DDL-->6DDL
85C---------------------------------------
86 DO i=1,3
87 DO j=1,3
88#include "vectorize.inc"
89 DO m=jft,nplat
90 ep=iplat(m)
91 q(j,i,m)=vq(ep,i,j)
92 ENDDO
93 ENDDO
94 ENDDO
95C
96 CALL cbatran2(jft,nplat,q,k11,q,is)
97 CALL cbatran2(jft,nplat,q,k22,q,is)
98 CALL cbatran2(jft,nplat,q,k33,q,is)
99 CALL cbatran2(jft,nplat,q,k44,q,is)
100 CALL cbatran2(jft,nplat,q,k12,q,ias)
101 CALL cbatran2(jft,nplat,q,k13,q,ias)
102 CALL cbatran2(jft,nplat,q,k14,q,ias)
103 CALL cbatran2(jft,nplat,q,k23,q,ias)
104 CALL cbatran2(jft,nplat,q,k24,q,ias)
105 CALL cbatran2(jft,nplat,q,k34,q,ias)
106 IF (iorth >0 .AND.idril>0) THEN
107 CALL cbatran3(jft,nplat,q,m11,q,is)
108 CALL cbatran3(jft,nplat,q,m22,q,is)
109 CALL cbatran3(jft,nplat,q,m33,q,is)
110 CALL cbatran3(jft,nplat,q,m44,q,is)
111 CALL cbatran3(jft,nplat,q,m12,q,ias)
112 CALL cbatran3(jft,nplat,q,m13,q,ias)
113 CALL cbatran3(jft,nplat,q,m14,q,ias)
114 CALL cbatran3(jft,nplat,q,m23,q,ias)
115 CALL cbatran3(jft,nplat,q,m24,q,ias)
116 CALL cbatran3(jft,nplat,q,m34,q,ias)
117 ELSE
118 CALL cbatran2(jft,nplat,q,m11,q,is)
119 CALL cbatran2(jft,nplat,q,m22,q,is)
120 CALL cbatran2(jft,nplat,q,m33,q,is)
121 CALL cbatran2(jft,nplat,q,m44,q,is)
122 CALL cbatran2(jft,nplat,q,m12,q,ias)
123 CALL cbatran2(jft,nplat,q,m13,q,ias)
124 CALL cbatran2(jft,nplat,q,m14,q,ias)
125 CALL cbatran2(jft,nplat,q,m23,q,ias)
126 CALL cbatran2(jft,nplat,q,m24,q,ias)
127 CALL cbatran2(jft,nplat,q,m34,q,ias)
128 END IF !(IORTH >0.AND.IDRIL>0)
129 IF (iorth >0) THEN
130 CALL cbatran3(jft,nplat,q,mf11,q,ias)
131 CALL cbatran3(jft,nplat,q,mf12,q,ias)
132 CALL cbatran3(jft,nplat,q,mf13,q,ias)
133 CALL cbatran3(jft,nplat,q,mf14,q,ias)
134 CALL cbatran3(jft,nplat,q,mf22,q,ias)
135 CALL cbatran3(jft,nplat,q,mf23,q,ias)
136 CALL cbatran3(jft,nplat,q,mf24,q,ias)
137 CALL cbatran3(jft,nplat,q,mf33,q,ias)
138 CALL cbatran3(jft,nplat,q,mf34,q,ias)
139 CALL cbatran3(jft,nplat,q,mf44,q,ias)
140 CALL cbatran3(jft,nplat,q,fm12,q,ias)
141 CALL cbatran3(jft,nplat,q,fm13,q,ias)
142 CALL cbatran3(jft,nplat,q,fm14,q,ias)
143 CALL cbatran3(jft,nplat,q,fm23,q,ias)
144 CALL cbatran3(jft,nplat,q,fm24,q,ias)
145 CALL cbatran3(jft,nplat,q,fm34,q,ias)
146 ELSEIF (idril >0) THEN
147 CALL cbatran233(jft,nplat,q,mf11,q)
148 CALL cbatran233(jft,nplat,q,mf12,q)
149 CALL cbatran233(jft,nplat,q,mf13,q)
150 CALL cbatran233(jft,nplat,q,mf14,q)
151 CALL cbatran233(jft,nplat,q,mf22,q)
152 CALL cbatran233(jft,nplat,q,mf23,q)
153 CALL cbatran233(jft,nplat,q,mf24,q)
154 CALL cbatran233(jft,nplat,q,mf33,q)
155 CALL cbatran233(jft,nplat,q,mf34,q)
156 CALL cbatran233(jft,nplat,q,mf44,q)
157 CALL cbatran233(jft,nplat,q,fm12,q)
158 CALL cbatran233(jft,nplat,q,fm13,q)
159 CALL cbatran233(jft,nplat,q,fm14,q)
160 CALL cbatran233(jft,nplat,q,fm23,q)
161 CALL cbatran233(jft,nplat,q,fm24,q)
162 CALL cbatran233(jft,nplat,q,fm34,q)
163 ELSE
164 CALL cbatran232(jft,nplat,q,mf11,q)
165 CALL cbatran232(jft,nplat,q,mf12,q)
166 CALL cbatran232(jft,nplat,q,mf13,q)
167 CALL cbatran232(jft,nplat,q,mf14,q)
168 CALL cbatran232(jft,nplat,q,mf22,q)
169 CALL cbatran232(jft,nplat,q,mf23,q)
170 CALL cbatran232(jft,nplat,q,mf24,q)
171 CALL cbatran232(jft,nplat,q,mf33,q)
172 CALL cbatran232(jft,nplat,q,mf34,q)
173 CALL cbatran232(jft,nplat,q,mf44,q)
174 CALL cbatran223(jft,nplat,q,fm12,q)
175 CALL cbatran223(jft,nplat,q,fm13,q)
176 CALL cbatran223(jft,nplat,q,fm14,q)
177 CALL cbatran223(jft,nplat,q,fm23,q)
178 CALL cbatran223(jft,nplat,q,fm24,q)
179 CALL cbatran223(jft,nplat,q,fm34,q)
180 END IF
181C---------------------------------------
182C ASSEMBLAGE
183C---------------------------------------
184C---------KII --------
185 DO i=1,3
186 mi=i+3
187 DO j=i,3
188 mj=j+3
189#include "vectorize.inc"
190 DO m=jft,nplat
191 ep=iplat(m)
192 ke11(i,j,ep)=k11(i,j,m)
193 ke11(mi,mj,ep)=m11(i,j,m)
194 ke22(i,j,ep)=k22(i,j,m)
195 ke22(mi,mj,ep)=m22(i,j,m)
196 ke33(i,j,ep)=k33(i,j,m)
197 ke33(mi,mj,ep)=m33(i,j,m)
198 ke44(i,j,ep)=k44(i,j,m)
199 ke44(mi,mj,ep)=m44(i,j,m)
200 ENDDO
201 ENDDO
202 ENDDO
203C
204 DO i=1,3
205 DO j=1,3
206 mj=j+3
207#include "vectorize.inc"
208 DO m=jft,nplat
209 ep=iplat(m)
210 ke11(i,mj,ep)=mf11(i,j,m)
211 ke22(i,mj,ep)=mf22(i,j,m)
212 ke33(i,mj,ep)=mf33(i,j,m)
213 ke44(i,mj,ep)=mf44(i,j,m)
214 ENDDO
215 ENDDO
216 ENDDO
217C
218C---------KIJ --------
219 DO i=1,3
220 mi=i+3
221 DO j=1,3
222 mj=j+3
223#include "vectorize.inc"
224 DO m=jft,nplat
225 ep=iplat(m)
226 ke12(i,j,ep)=k12(i,j,m)
227 ke12(i,mj,ep)=mf12(i,j,m)
228 ke12(mi,j,ep)=fm12(i,j,m)
229 ke12(mi,mj,ep)=m12(i,j,m)
230 ke13(i,j,ep)=k13(i,j,m)
231 ke13(i,mj,ep)=mf13(i,j,m)
232 ke13(mi,j,ep)=fm13(i,j,m)
233 ke13(mi,mj,ep)=m13(i,j,m)
234 ke14(i,j,ep)=k14(i,j,m)
235 ke14(i,mj,ep)=mf14(i,j,m)
236 ke14(mi,j,ep)=fm14(i,j,m)
237 ke14(mi,mj,ep)=m14(i,j,m)
238 ke23(i,j,ep)=k23(i,j,m)
239 ke23(i,mj,ep)=mf23(i,j,m)
240 ke23(mi,j,ep)=fm23(i,j,m)
241 ke23(mi,mj,ep)=m23(i,j,m)
242 ke24(i,j,ep)=k24(i,j,m)
243 ke24(i,mj,ep)=mf24(i,j,m)
244 ke24(mi,j,ep)=fm24(i,j,m)
245 ke24(mi,mj,ep)=m24(i,j,m)
246 ke34(i,j,ep)=k34(i,j,m)
247 ke34(i,mj,ep)=mf34(i,j,m)
248 ke34(mi,j,ep)=fm34(i,j,m)
249 ke34(mi,mj,ep)=m34(i,j,m)
250 ENDDO
251 ENDDO
252 ENDDO
253C----------------warped elements--------------
254 nf=nplat+1
255 IF (nf > jlt) RETURN
256C
257 DO i=1,3
258 DO j=1,3
259#include "vectorize.inc"
260 DO m=nf,jlt
261 ep=iplat(m)
262 q(j,i,m)=vq(ep,i,j)
263 ENDDO
264 ENDDO
265 ENDDO
266 IF (ikproj > 0) THEN
267 CALL czprojk(
268 1 nf ,jlt ,vqn ,q ,iplat,
269 3 k11,k12,k13,k14,k22,k23,k24,k33,k34,k44,
270 4 m11,m12,m13,m14,m22,m23,m24,m33,m34,m44,
271 5 mf11,mf12,mf13,mf14,mf22,mf23,mf24,mf33,
272 6 mf34,mf44,fm12,fm13,fm14,fm23,fm24,fm34,
273 7 corelv,z1 ,idril )
274c
275 ELSE
276C-------------projection-----drilling only------------------------
277 CALL cbatran3(nf,jlt,q,k11,q,is)
278 CALL cbatran3(nf,jlt,q,k22,q,is)
279 CALL cbatran3(nf,jlt,q,k33,q,is)
280 CALL cbatran3(nf,jlt,q,k44,q,is)
281 CALL cbatran3(nf,jlt,q,k12,q,ias)
282 CALL cbatran3(nf,jlt,q,k13,q,ias)
283 CALL cbatran3(nf,jlt,q,k14,q,ias)
284 CALL cbatran3(nf,jlt,q,k23,q,ias)
285 CALL cbatran3(nf,jlt,q,k24,q,ias)
286 CALL cbatran3(nf,jlt,q,k34,q,ias)
287 DO j=1,4
288#include "vectorize.inc"
289 DO m=nf,jlt
290 ep=iplat(m)
291 pp(1,1,j,m)=one-vqn(ep,1,j)*vqn(ep,1,j)
292 pp(2,2,j,m)=one-vqn(ep,2,j)*vqn(ep,2,j)
293C PP(3,3,J,M)=VQN(3,J,EP)
294 pp(3,3,j,m)=one-vqn(ep,3,j)*vqn(ep,3,j)
295 pp(1,2,j,m)=-vqn(ep,1,j)*vqn(ep,2,j)
296 pp(1,3,j,m)=-vqn(ep,1,j)*vqn(ep,3,j)
297 pp(2,3,j,m)=-vqn(ep,2,j)*vqn(ep,3,j)
298 ENDDO
299 ENDDO
300C
301 IF (idril >0) THEN
302 DO j=1,4
303 DO m=nf,jlt
304 ep=iplat(m)
305 pp(2,1,j,m)=pp(1,2,j,m)
306 pp(3,1,j,m)=vqn(ep,1,j)
307 pp(3,2,j,m)=vqn(ep,2,j)
308 pp(3,3,j,m)=vqn(ep,3,j)
309 ENDDO
310 ENDDO
311 ELSE
312 DO j=1,4
313 DO m=nf,jlt
314 pp(2,1,j,m)=pp(1,2,j,m)
315 pp(3,1,j,m)=pp(1,3,j,m)
316 pp(3,2,j,m)=pp(2,3,j,m)
317 ENDDO
318 ENDDO
319 END IF !(IDRIL >0) THEN
320C
321C DO J=1,4
322C#include "vectorize.inc"
323C DO M=NF,JLT
324C EP=IPLAT(M)
325C PP(2,1,J,M)=PP(1,2,J,M)
326C PP(3,1,J,M)=VQN(1,J,EP)
327C PP(3,2,J,M)=VQN(2,J,EP)
328C ENDDO
329C ENDDO
330C------------------QJ=PPJ*Q-------------------
331 DO i=1,3
332 DO j=1,3
333 DO ep=nf,jlt
334 q1(i,j,ep)=pp(i,1,1,ep)*q(1,j,ep)+pp(i,2,1,ep)*q(2,j,ep)+
335 . pp(i,3,1,ep)*q(3,j,ep)
336 q2(i,j,ep)=pp(i,1,2,ep)*q(1,j,ep)+pp(i,2,2,ep)*q(2,j,ep)+
337 . pp(i,3,2,ep)*q(3,j,ep)
338 q3(i,j,ep)=pp(i,1,3,ep)*q(1,j,ep)+pp(i,2,3,ep)*q(2,j,ep)+
339 . pp(i,3,3,ep)*q(3,j,ep)
340 q4(i,j,ep)=pp(i,1,4,ep)*q(1,j,ep)+pp(i,2,4,ep)*q(2,j,ep)+
341 . pp(i,3,4,ep)*q(3,j,ep)
342 ENDDO
343 ENDDO
344 ENDDO
345C
346 IF (idril==0.AND.iorth==0) THEN
347 CALL cztran2(nf,jlt,q1,m11,q1,is,q)
348 CALL cztran2(nf,jlt,q2,m22,q2,is,q)
349 CALL cztran2(nf,jlt,q3,m33,q3,is,q)
350 CALL cztran2(nf,jlt,q4,m44,q4,is,q)
351 CALL cztran2(nf,jlt,q1,m12,q2,ias,q)
352 CALL cztran2(nf,jlt,q1,m13,q3,ias,q)
353 CALL cztran2(nf,jlt,q1,m14,q4,ias,q)
354 CALL cztran2(nf,jlt,q2,m23,q3,ias,q)
355 CALL cztran2(nf,jlt,q2,m24,q4,ias,q)
356 CALL cztran2(nf,jlt,q3,m34,q4,ias,q)
357 CALL cbatran32(nf,jlt,q,mf11,q1)
358 CALL cbatran32(nf,jlt,q,mf22,q2)
359 CALL cbatran32(nf,jlt,q,mf33,q3)
360 CALL cbatran32(nf,jlt,q,mf44,q4)
361 CALL cbatran32(nf,jlt,q,mf12,q2)
362 CALL cbatran32(nf,jlt,q,mf13,q3)
363 CALL cbatran32(nf,jlt,q,mf14,q4)
364 CALL cbatran32(nf,jlt,q,mf23,q3)
365 CALL cbatran32(nf,jlt,q,mf24,q4)
366 CALL cbatran32(nf,jlt,q,mf34,q4)
367 CALL cbatran23(nf,jlt,q1,fm12,q)
368 CALL cbatran23(nf,jlt,q1,fm13,q)
369 CALL cbatran23(nf,jlt,q1,fm14,q)
370 CALL cbatran23(nf,jlt,q2,fm23,q)
371 CALL cbatran23(nf,jlt,q2,fm24,q)
372 CALL cbatran23(nf,jlt,q3,fm34,q)
373 ELSE
374 IF (idril>0.AND.iorth>0) THEN
375 CALL cbatran3(nf,jlt,q1,m11,q1,is)
376 CALL cbatran3(nf,jlt,q2,m22,q2,is)
377 CALL cbatran3(nf,jlt,q3,m33,q3,is)
378 CALL cbatran3(nf,jlt,q4,m44,q4,is)
379 CALL cbatran3(nf,jlt,q1,m12,q2,ias)
380 CALL cbatran3(nf,jlt,q1,m13,q3,ias)
381 CALL cbatran3(nf,jlt,q1,m14,q4,ias)
382 CALL cbatran3(nf,jlt,q2,m23,q3,ias)
383 CALL cbatran3(nf,jlt,q2,m24,q4,ias)
384 CALL cbatran3(nf,jlt,q3,m34,q4,ias)
385 ELSEIF (idril==0 ) THEN
386 CALL cztran2(nf,jlt,q1,m11,q1,is,q)
387 CALL cztran2(nf,jlt,q2,m22,q2,is,q)
388 CALL cztran2(nf,jlt,q3,m33,q3,is,q)
389 CALL cztran2(nf,jlt,q4,m44,q4,is,q)
390 CALL cztran2(nf,jlt,q1,m12,q2,ias,q)
391 CALL cztran2(nf,jlt,q1,m13,q3,ias,q)
392 CALL cztran2(nf,jlt,q1,m14,q4,ias,q)
393 CALL cztran2(nf,jlt,q2,m23,q3,ias,q)
394 CALL cztran2(nf,jlt,q2,m24,q4,ias,q)
395 CALL cztran2(nf,jlt,q3,m34,q4,ias,q)
396 ELSE
397 CALL cztrandr(nf,jlt,q1,m11,q1,is)
398 CALL cztrandr(nf,jlt,q2,m22,q2,is)
399 CALL cztrandr(nf,jlt,q3,m33,q3,is)
400 CALL cztrandr(nf,jlt,q4,m44,q4,is)
401 CALL cztrandr(nf,jlt,q1,m12,q2,ias)
402 CALL cztrandr(nf,jlt,q1,m13,q3,ias)
403 CALL cztrandr(nf,jlt,q1,m14,q4,ias)
404 CALL cztrandr(nf,jlt,q2,m23,q3,ias)
405 CALL cztrandr(nf,jlt,q2,m24,q4,ias)
406 CALL cztrandr(nf,jlt,q3,m34,q4,ias)
407 END IF !IF (IDRIL>0.AND.IORTH>0) THEN
408 CALL cbatran3(nf,jlt,q,mf11,q1,ias)
409 CALL cbatran3(nf,jlt,q,mf22,q2,ias)
410 CALL cbatran3(nf,jlt,q,mf33,q3,ias)
411 CALL cbatran3(nf,jlt,q,mf44,q4,ias)
412 CALL cbatran3(nf,jlt,q,mf12,q2,ias)
413 CALL cbatran3(nf,jlt,q,mf13,q3,ias)
414 CALL cbatran3(nf,jlt,q,mf14,q4,ias)
415 CALL cbatran3(nf,jlt,q,mf23,q3,ias)
416 CALL cbatran3(nf,jlt,q,mf24,q4,ias)
417 CALL cbatran3(nf,jlt,q,mf34,q4,ias)
418 CALL cbatran3(nf,jlt,q1,fm12,q,ias)
419 CALL cbatran3(nf,jlt,q1,fm13,q,ias)
420 CALL cbatran3(nf,jlt,q1,fm14,q,ias)
421 CALL cbatran3(nf,jlt,q2,fm23,q,ias)
422 CALL cbatran3(nf,jlt,q2,fm24,q,ias)
423 CALL cbatran3(nf,jlt,q3,fm34,q,ias)
424 END IF !IF (IDRIL==0.O.AND.IORTH==0) THEN
425 END IF !(IPROJF==1) THEN
426C---------------------------------------
427C ASSEMBLAGE
428C---------------------------------------
429C---------KII --------
430 DO i=1,3
431 mi=i+3
432 DO j=i,3
433 mj=j+3
434#include "vectorize.inc"
435 DO m=nf,jlt
436 ep=iplat(m)
437 ke11(i,j,ep)=k11(i,j,m)
438 ke11(mi,mj,ep)=m11(i,j,m)
439 ke22(i,j,ep)=k22(i,j,m)
440 ke22(mi,mj,ep)=m22(i,j,m)
441 ke33(i,j,ep)=k33(i,j,m)
442 ke33(mi,mj,ep)=m33(i,j,m)
443 ke44(i,j,ep)=k44(i,j,m)
444 ke44(mi,mj,ep)=m44(i,j,m)
445 ENDDO
446 ENDDO
447 ENDDO
448C
449 DO i=1,3
450 DO j=1,3
451 mj=j+3
452#include "vectorize.inc"
453 DO m=nf,jlt
454 ep=iplat(m)
455 ke11(i,mj,ep)=mf11(i,j,m)
456 ke22(i,mj,ep)=mf22(i,j,m)
457 ke33(i,mj,ep)=mf33(i,j,m)
458 ke44(i,mj,ep)=mf44(i,j,m)
459 ENDDO
460 ENDDO
461 ENDDO
462C---------KIJ --------
463 DO i=1,3
464 mi=i+3
465 DO j=1,3
466 mj=j+3
467#include "vectorize.inc"
468 DO m=nf,jlt
469 ep=iplat(m)
470 ke12(i,j,ep)=k12(i,j,m)
471 ke13(i,j,ep)=k13(i,j,m)
472 ke14(i,j,ep)=k14(i,j,m)
473 ke23(i,j,ep)=k23(i,j,m)
474 ke24(i,j,ep)=k24(i,j,m)
475 ke34(i,j,ep)=k34(i,j,m)
476 ke12(i,mj,ep)=mf12(i,j,m)
477 ke13(i,mj,ep)=mf13(i,j,m)
478 ke14(i,mj,ep)=mf14(i,j,m)
479 ke23(i,mj,ep)=mf23(i,j,m)
480 ke24(i,mj,ep)=mf24(i,j,m)
481 ke34(i,mj,ep)=mf34(i,j,m)
482 ke12(mi,j,ep)=fm12(i,j,m)
483 ke13(mi,j,ep)=fm13(i,j,m)
484 ke14(mi,j,ep)=fm14(i,j,m)
485 ke23(mi,j,ep)=fm23(i,j,m)
486 ke24(mi,j,ep)=fm24(i,j,m)
487 ke34(mi,j,ep)=fm34(i,j,m)
488 ke12(mi,mj,ep)=m12(i,j,m)
489 ke13(mi,mj,ep)=m13(i,j,m)
490 ke14(mi,mj,ep)=m14(i,j,m)
491 ke23(mi,mj,ep)=m23(i,j,m)
492 ke24(mi,mj,ep)=m24(i,j,m)
493 ke34(mi,mj,ep)=m34(i,j,m)
494 ENDDO
495 ENDDO
496 ENDDO
497C
498 DO i=1,6
499 DO j=i+1,6
500 DO ep=jft,jlt
501 ke11(j,i,ep)=ke11(i,j,ep)
502 ke22(j,i,ep)=ke22(i,j,ep)
503 ke33(j,i,ep)=ke33(i,j,ep)
504 ke44(j,i,ep)=ke44(i,j,ep)
505 ENDDO
506 ENDDO
507 ENDDO
508C
509 RETURN
cbatran32
subroutine cbatran32(jft, jlt, vqi, kk, vqj)
Definition cbasumg3.F:516
cbatran233
subroutine cbatran233(jft, jlt, vqi, kk, vqj)
Definition cbasumg3.F:690
cbatran23
subroutine cbatran23(jft, jlt, vqi, kk, vqj)
Definition cbasumg3.F:560
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
cztrandr
subroutine cztrandr(jft, jlt, vqi, kk, vqj, isym)
Definition czsumg3.F:582
czprojk
subroutine czprojk(jft, jlt, vqn, q, 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, corelv, z1, idril)
Definition czsumg3.F:657
cztran2
subroutine cztran2(jft, jlt, vqi, kk, vqj, isym, vq)
Definition czsumg3.F:517

◆ cztran2()

subroutine cztran2 ( integer jft,
integer jlt,
vqi,
kk,
vqj,
integer isym,
vq )

Definition at line 516 of file czsumg3.F.

517C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
518#include "implicit_f.inc"
519#include "mvsiz_p.inc"
520C-----------------------------------------------
521C D U M M Y A R G U M E N T S
522C-----------------------------------------------
523 INTEGER JFT,JLT
524 my_real
525 . vqi(3,3,*),vqj(3,3,*),kk(3,3,*),vq(3,3,*)
526C-----------------------------------------------
527C LOCAL A R G U M E N T S
528C-----------------------------------------------
529 INTEGER I,J,EP,ISYM
530 my_real
531 . k(3,3,mvsiz)
532C-----------------------------------------------
533 IF (isym==1) THEN
534 DO i=1,3
535 DO j=i,3
536 DO ep=jft,jlt
537 k(i,j,ep)=vqi(1,i,ep)*(
538 1 kk(1,1,ep)*vqj(1,j,ep)+kk(1,2,ep)*vqj(2,j,ep))+
539 2 vqi(2,i,ep)*(
540 3 kk(1,2,ep)*vqj(1,j,ep)+kk(2,2,ep)*vqj(2,j,ep))+
541 4 vq(3,i,ep)*kk(3,3,ep)*vq(3,j,ep)
542 ENDDO
543 ENDDO
544 ENDDO
545C
546 DO i=1,3
547 DO j=i,3
548 DO ep=jft,jlt
549 kk(i,j,ep)= k(i,j,ep)
550 ENDDO
551 ENDDO
552 ENDDO
553 ELSE
554 DO i=1,3
555 DO j=1,3
556 DO ep=jft,jlt
557 k(i,j,ep)=vqi(1,i,ep)*(
558 1 kk(1,1,ep)*vqj(1,j,ep)+kk(1,2,ep)*vqj(2,j,ep))+
559 2 vqi(2,i,ep)*(
560 3 kk(2,1,ep)*vqj(1,j,ep)+kk(2,2,ep)*vqj(2,j,ep))+
561 4 vq(3,i,ep)*kk(3,3,ep)*vq(3,j,ep)
562 ENDDO
563 ENDDO
564 ENDDO
565C
566 DO i=1,3
567 DO j=1,3
568 DO ep=jft,jlt
569 kk(i,j,ep)= k(i,j,ep)
570 ENDDO
571 ENDDO
572 ENDDO
573 ENDIF
574 RETURN

◆ cztrandr()

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

Definition at line 581 of file czsumg3.F.

582C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
583#include "implicit_f.inc"
584#include "mvsiz_p.inc"
585C-----------------------------------------------
586C D U M M Y A R G U M E N T S
587C-----------------------------------------------
588 INTEGER JFT,JLT
589 my_real
590 . vqi(3,3,*),vqj(3,3,*),kk(3,3,*)
591C-----------------------------------------------
592C LOCAL A R G U M E N T S
593C-----------------------------------------------
594 INTEGER I,J,EP,ISYM
595 my_real
596 . k(3,3,mvsiz)
597 IF (isym==1) THEN
598 DO i=1,3
599 DO j=i,3
600 DO ep=jft,jlt
601 k(i,j,ep)=vqi(1,i,ep)*(
602 1 kk(1,1,ep)*vqj(1,j,ep)+kk(1,2,ep)*vqj(2,j,ep))+
603 2 vqi(2,i,ep)*(
604 3 kk(1,2,ep)*vqj(1,j,ep)+kk(2,2,ep)*vqj(2,j,ep))+
605 4 vqi(3,i,ep)*kk(3,3,ep)*vqj(3,j,ep)
606 ENDDO
607 ENDDO
608 ENDDO
609C
610 DO i=1,3
611 DO j=i,3
612 DO ep=jft,jlt
613 kk(i,j,ep)= k(i,j,ep)
614 ENDDO
615 ENDDO
616 ENDDO
617 ELSE
618 DO i=1,3
619 DO j=1,3
620 DO ep=jft,jlt
621 k(i,j,ep)=vqi(1,i,ep)*(
622 1 kk(1,1,ep)*vqj(1,j,ep)+kk(1,2,ep)*vqj(2,j,ep))+
623 2 vqi(2,i,ep)*(
624 3 kk(2,1,ep)*vqj(1,j,ep)+kk(2,2,ep)*vqj(2,j,ep))+
625 4 vqi(3,i,ep)*kk(3,3,ep)*vqj(3,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 ENDIF
638 RETURN

◆ cztrank33()

subroutine cztrank33 ( integer jft,
integer jlt,
vq,
k33,
kk,
integer isym )

Definition at line 1769 of file czsumg3.F.

1770C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
1771#include "implicit_f.inc"
1772#include "mvsiz_p.inc"
1773C-----------------------------------------------
1774C D U M M Y A R G U M E N T S
1775C-----------------------------------------------
1776 INTEGER JFT,JLT
1777 my_real
1778 . k33(*),kk(3,3,*),vq(3,3,*)
1779C-----------------------------------------------
1780C LOCAL A R G U M E N T S
1781C-----------------------------------------------
1782 INTEGER I,J,EP,ISYM
1783 my_real
1784 . k(3,3,mvsiz)
1785C-----------------------------------------------
1786 IF (isym==1) THEN
1787 DO i=1,3
1788 DO j=i,3
1789 DO ep=jft,jlt
1790 k(i,j,ep)= vq(3,i,ep)*k33(ep)*vq(3,j,ep)
1791 ENDDO
1792 ENDDO
1793 ENDDO
1794C
1795 DO i=1,3
1796 DO j=i,3
1797 DO ep=jft,jlt
1798 kk(i,j,ep)= kk(i,j,ep)+k(i,j,ep)
1799 ENDDO
1800 ENDDO
1801 ENDDO
1802 ELSE
1803 DO i=1,3
1804 DO j=1,3
1805 DO ep=jft,jlt
1806 k(i,j,ep)=vq(3,i,ep)*k33(ep)*vq(3,j,ep)
1807 ENDDO
1808 ENDDO
1809 ENDDO
1810C
1811 DO i=1,3
1812 DO j=1,3
1813 DO ep=jft,jlt
1814 kk(i,j,ep)= kk(i,j,ep)+k(i,j,ep)
1815 ENDDO
1816 ENDDO
1817 ENDDO
1818 ENDIF
1819 RETURN

◆ set_rsj()

subroutine set_rsj ( r1,
r2,
r3,
r4,
z1,
integer jft,
integer jlt,
integer, dimension(*) iplat,
vqn,
corelv )

Definition at line 839 of file czsumg3.F.

841C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
842#include "implicit_f.inc"
843#include "mvsiz_p.inc"
844C-----------------------------------------------
845C D U M M Y A R G U M E N T S
846C-----------------------------------------------
847 INTEGER JFT,JLT,IPLAT(*)
848 my_real
849 . vqn(mvsiz,3,4),corelv(mvsiz,2,4),
850 . r1(6,7,*),r2(6,7,*),r3(6,7,*),r4(6,7,*),z1(*)
851C-----------------------------------------------
852C LOCAL A R G U M E N T S
853C-----------------------------------------------
854 INTEGER I,J,EP,M,L
855 my_real
856 . s,xi(mvsiz),yi(mvsiz),zi(mvsiz)
857C-------------------------------------------------------------
858 DO m=jft,jlt
859 DO l=1,6
860 DO j=1,7
861 r1(l,j,m)=zero
862 r2(l,j,m)=zero
863 r3(l,j,m)=zero
864 r4(l,j,m)=zero
865 ENDDO
866 ENDDO
867 END DO
868C
869 DO m=jft,jlt
870 i=iplat(m)
871 xi(m)=corelv(i,1,1)
872 yi(m)=corelv(i,2,1)
873 zi(m)=z1(i)
874 END DO
875 CALL set_rsj33(xi ,yi, zi ,r1 ,jft,jlt)
876 DO m=jft,jlt
877 i=iplat(m)
878 xi(m)=corelv(i,1,2)
879 yi(m)=corelv(i,2,2)
880 zi(m)=-z1(i)
881 END DO
882 CALL set_rsj33(xi ,yi, zi ,r2 ,jft,jlt)
883 DO m=jft,jlt
884 i=iplat(m)
885 xi(m)=corelv(i,1,3)
886 yi(m)=corelv(i,2,3)
887 zi(m)=z1(i)
888 END DO
889 CALL set_rsj33(xi ,yi, zi ,r3 ,jft,jlt)
890 DO m=jft,jlt
891 i=iplat(m)
892 xi(m)=corelv(i,1,4)
893 yi(m)=corelv(i,2,4)
894 zi(m)=-z1(i)
895 END DO
896 CALL set_rsj33(xi ,yi, zi ,r4 ,jft,jlt)
897 DO m=jft,jlt
898 DO l=1,3
899 r1(3+l,l,m) = one
900 r2(3+l,l,m) = one
901 r3(3+l,l,m) = one
902 r4(3+l,l,m) = one
903 END DO
904 END DO
905C
906 DO m=jft,jlt
907 i=iplat(m)
908 DO j=1,3
909 r1(3+j,4,m)=vqn(i,j,1)
910 r2(3+j,5,m)=vqn(i,j,2)
911 r3(3+j,6,m)=vqn(i,j,3)
912 r4(3+j,7,m)=vqn(i,j,4)
913 END DO
914 END DO
915C-----------
916 RETURN
set_rsj33
subroutine set_rsj33(xi, yi, zi, ri, jft, jlt)
Definition czsumg3.F:992

◆ set_rsj2()

subroutine set_rsj2 ( r1,
r2,
r3,
r4,
z1,
integer jft,
integer jlt,
corelv,
integer, dimension(*) iplat )

Definition at line 925 of file czsumg3.F.

927C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
928#include "implicit_f.inc"
929#include "mvsiz_p.inc"
930C-----------------------------------------------
931C D U M M Y A R G U M E N T S
932C-----------------------------------------------
933 INTEGER JFT,JLT,IPLAT(*)
934 my_real
935 . corelv(mvsiz,2,4),
936 . r1(3,3,*),r2(3,3,*),r3(3,3,*),r4(3,3,*),z1(*)
937C-----------------------------------------------
938C LOCAL A R G U M E N T S
939C-----------------------------------------------
940 INTEGER I,J,EP,M,L
941 my_real
942 . s,xi(mvsiz),yi(mvsiz),zi(mvsiz)
943C-------------------------------------------------------------
944 DO m=jft,jlt
945 DO l=1,3
946 DO j=1,3
947 r1(l,j,m)=zero
948 r2(l,j,m)=zero
949 r3(l,j,m)=zero
950 r4(l,j,m)=zero
951 ENDDO
952 ENDDO
953 END DO
954C
955 DO m=jft,jlt
956 i=iplat(m)
957 xi(m)=corelv(i,1,1)
958 yi(m)=corelv(i,2,1)
959 zi(m)=z1(i)
960 END DO
961 CALL set_ri33(xi ,yi, zi ,r1 ,jft,jlt)
962 DO m=jft,jlt
963 i=iplat(m)
964 xi(m)=corelv(i,1,2)
965 yi(m)=corelv(i,2,2)
966 zi(m)=-z1(i)
967 END DO
968 CALL set_ri33(xi ,yi, zi ,r2 ,jft,jlt)
969 DO m=jft,jlt
970 i=iplat(m)
971 xi(m)=corelv(i,1,3)
972 yi(m)=corelv(i,2,3)
973 zi(m)=z1(i)
974 END DO
975 CALL set_ri33(xi ,yi, zi ,r3 ,jft,jlt)
976 DO m=jft,jlt
977 i=iplat(m)
978 xi(m)=corelv(i,1,4)
979 yi(m)=corelv(i,2,4)
980 zi(m)=-z1(i)
981 END DO
982 CALL set_ri33(xi ,yi, zi ,r4 ,jft,jlt)
983C-----------
984 RETURN
set_ri33
subroutine set_ri33(xi, yi, zi, ri, jft, jlt)
Definition cbasumg3.F:903

◆ set_rsj33()

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

Definition at line 991 of file czsumg3.F.

992C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
993#include "implicit_f.inc"
994C-----------------------------------------------
995C D U M M Y A R G U M E N T S
996C-----------------------------------------------
997 INTEGER JFT,JLT
998 my_real
999 . xi(*) ,yi(*), zi(*),ri(6,7,*)
1000C-----------------------------------------------
1001C LOCAL A R G U M E N T S
1002C-----------------------------------------------
1003 INTEGER I,J,L
1004C--------------RI=Q*RSI-------------------------------
1005C DO I=JFT,JLT
1006C RI(1,1,I)=-VQ(1,2,I)*ZI(I)+VQ(1,3,I)*YI(I)
1007C RI(1,2,I)=VQ(1,1,I)*ZI(I)-VQ(1,3,I)*XI(I)
1008C RI(1,3,I)=-VQ(1,1,I)*YI(I)+VQ(1,2,I)*XI(I)
1009C RI(2,1,I)=-VQ(2,2,I)*ZI(I)+VQ(2,3,I)*YI(I)
1010C RI(2,2,I)=VQ(2,1,I)*ZI(I)-VQ(2,3,I)*XI(I)
1011C RI(2,3,I)=-VQ(2,1,I)*YI(I)+VQ(2,2,I)*XI(I)
1012C RI(3,1,I)=-VQ(3,2,I)*ZI(I)+VQ(3,3,I)*YI(I)
1013C RI(3,2,I)=VQ(3,1,I)*ZI(I)-VQ(3,3,I)*XI(I)
1014C RI(3,3,I)=-VQ(3,1,I)*YI(I)+VQ(3,2,I)*XI(I)
1015C ENDDO
1016 DO i=jft,jlt
1017 ri(1,2,i)=zi(i)
1018 ri(1,3,i)=-yi(i)
1019 ri(2,1,i)=-ri(1,2,i)
1020 ri(2,3,i)=xi(i)
1021 ri(3,1,i)=-ri(1,3,i)
1022 ri(3,2,i)=-ri(2,3,i)
1023 ENDDO
1024C
1025 RETURN

◆ setprojk()

subroutine setprojk ( 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,
integer jft,
integer jlt )

Definition at line 1038 of file czsumg3.F.

1044C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
1045#include "implicit_f.inc"
1046#include "mvsiz_p.inc"
1047C-----------------------------------------------
1048C D U M M Y A R G U M E N T S
1049C-----------------------------------------------
1050 INTEGER JFT,JLT
1051 my_real
1052 . dr(7,7,*),vq(3,3,*),
1053 . r1(6,7,*),r2(6,7,*),r3(6,7,*),r4(6,7,*),
1054 . k11(3,3,*),k12(3,3,*),k13(3,3,*),k14(3,3,*),
1055 . k22(3,3,*),k23(3,3,*),k24(3,3,*),k33(3,3,*),
1056 . m11(3,3,*),m12(3,3,*),m13(3,3,*),m14(3,3,*),
1057 . m22(3,3,*),m23(3,3,*),m24(3,3,*),m33(3,3,*),
1058 . mf11(3,3,*),mf12(3,3,*),mf13(3,3,*),mf14(3,3,*),
1059 . mf22(3,3,*),mf23(3,3,*),mf24(3,3,*),mf33(3,3,*),
1060 . fm12(3,3,*),fm13(3,3,*),fm14(3,3,*),
1061 . fm23(3,3,*),fm24(3,3,*),fm34(3,3,*),
1062 . k34(3,3,*),k44(3,3,*),m34(3,3,*),m44(3,3,*),
1063 . mf34(3,3,*),mf44(3,3,*)
1064C-----------------------------------------------
1065C LOCAL A R G U M E N T S
1066C-----------------------------------------------
1067 INTEGER I,J,EP,IS,IAS,IT,IAT
1068 my_real
1069 . kl(6,6,mvsiz),kq(6,6,mvsiz),
1070 . mz11(mvsiz),mz22(mvsiz),mz33(mvsiz),mz44(mvsiz),mz12(mvsiz),
1071 . mz13(mvsiz),mz14(mvsiz),mz23(mvsiz),mz24(mvsiz),mz34(mvsiz)
1072 DATA is/1/,ias/0/,it/1/,iat/0/
1073 my_real,
1074 . DIMENSION(:,:,:), ALLOCATABLE:: p,ke
1075C-------------------------------------------------------------
1076 ALLOCATE(p(24,24,mvsiz))
1077 ALLOCATE(ke(24,24,mvsiz))
1078
1079C---Save Mij(3,3) prevent singularity-----
1080 DO ep=jft,jlt
1081 mz11(ep)= m11(3,3,ep)
1082 mz22(ep)= m22(3,3,ep)
1083 mz33(ep)= m33(3,3,ep)
1084 mz44(ep)= m44(3,3,ep)
1085 mz12(ep)= m12(3,3,ep)
1086 mz13(ep)= m13(3,3,ep)
1087 mz14(ep)= m14(3,3,ep)
1088 mz23(ep)= m23(3,3,ep)
1089 mz24(ep)= m24(3,3,ep)
1090 mz34(ep)= m34(3,3,ep)
1091 m11(3,3,ep) =zero
1092 m22(3,3,ep) =zero
1093 m33(3,3,ep) =zero
1094 m44(3,3,ep) =zero
1095 m12(3,3,ep) =zero
1096 m13(3,3,ep) =zero
1097 m14(3,3,ep) =zero
1098 m23(3,3,ep) =zero
1099 m24(3,3,ep) =zero
1100 m34(3,3,ep) =zero
1101 ENDDO
1102 CALL tranqikqj67(jft ,jlt ,r1 ,dr , r1 ,kl, is)
1103 CALL trankl1(jft ,jlt ,kl ,is )
1104 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
1105C-----------P11Q
1106 DO i=1,6
1107 DO j=1,6
1108 DO ep=jft,jlt
1109 p(i,j,ep)= kq(i,j,ep)
1110 ENDDO
1111 ENDDO
1112 ENDDO
1113 DO i=1,3
1114 DO j=i,3
1115 DO ep=jft,jlt
1116 ke(i,j,ep)= k11(i,j,ep)
1117 ke(i+3,j+3,ep)= m11(i,j,ep)
1118 ENDDO
1119 ENDDO
1120 DO j=1,3
1121 DO ep=jft,jlt
1122 ke(i,j+3,ep)= mf11(i,j,ep)
1123 ENDDO
1124 ENDDO
1125 ENDDO
1126 CALL tranqikqj67(jft ,jlt ,r2 ,dr , r2 ,kl, is)
1127 CALL trankl1(jft ,jlt ,kl ,is )
1128 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
1129C-----------P22Q
1130 DO i=1,6
1131 DO j=1,6
1132 DO ep=jft,jlt
1133 p(i+6,j+6,ep)= kq(i,j,ep)
1134 ENDDO
1135 ENDDO
1136 ENDDO
1137 DO i=1,3
1138 DO j=i,3
1139 DO ep=jft,jlt
1140 ke(i+6,j+6,ep)= k22(i,j,ep)
1141 ke(i+9,j+9,ep)= m22(i,j,ep)
1142 ENDDO
1143 ENDDO
1144 DO j=1,3
1145 DO ep=jft,jlt
1146 ke(i+6,j+9,ep)= mf22(i,j,ep)
1147 ENDDO
1148 ENDDO
1149 ENDDO
1150 CALL tranqikqj67(jft ,jlt ,r3 ,dr , r3 ,kl, is)
1151 CALL trankl1(jft ,jlt ,kl ,is )
1152 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
1153C-----------P33Q
1154 DO i=1,6
1155 DO j=1,6
1156 DO ep=jft,jlt
1157 p(i+12,j+12,ep)= kq(i,j,ep)
1158 ENDDO
1159 ENDDO
1160 ENDDO
1161 DO i=1,3
1162 DO j=i,3
1163 DO ep=jft,jlt
1164 ke(i+12,j+12,ep)= k33(i,j,ep)
1165 ke(i+15,j+15,ep)= m33(i,j,ep)
1166 ENDDO
1167 ENDDO
1168 DO j=1,3
1169 DO ep=jft,jlt
1170 ke(i+12,j+15,ep)= mf33(i,j,ep)
1171 ENDDO
1172 ENDDO
1173 ENDDO
1174 CALL tranqikqj67(jft ,jlt ,r4 ,dr , r4 ,kl, is)
1175 CALL trankl1(jft ,jlt ,kl ,is )
1176 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
1177C-----------P44Q
1178 DO i=1,6
1179 DO j=1,6
1180 DO ep=jft,jlt
1181 p(i+18,j+18,ep)= kq(i,j,ep)
1182 ENDDO
1183 ENDDO
1184 ENDDO
1185 DO i=1,3
1186 DO j=i,3
1187 DO ep=jft,jlt
1188 ke(i+18,j+18,ep)= k44(i,j,ep)
1189 ke(i+21,j+21,ep)= m44(i,j,ep)
1190 ENDDO
1191 ENDDO
1192 DO j=1,3
1193 DO ep=jft,jlt
1194 ke(i+18,j+21,ep)= mf44(i,j,ep)
1195 ENDDO
1196 ENDDO
1197 ENDDO
1198 CALL tranqikqj67(jft ,jlt ,r1 ,dr , r2 ,kl, ias)
1199 CALL trankl1(jft ,jlt ,kl ,ias )
1200 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
1201C-----------P12Q
1202 DO i=1,6
1203 DO j=1,6
1204 DO ep=jft,jlt
1205 p(i,j+6,ep)= kq(i,j,ep)
1206 ENDDO
1207 ENDDO
1208 ENDDO
1209 DO i=1,3
1210 DO j=1,3
1211 DO ep=jft,jlt
1212 ke(i,j+6,ep)= k12(i,j,ep)
1213 ke(i+3,j+9,ep)= m12(i,j,ep)
1214 ke(i,j+9,ep)= mf12(i,j,ep)
1215 ke(i+3,j+6,ep)= fm12(i,j,ep)
1216 ENDDO
1217 ENDDO
1218 ENDDO
1219 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,iat )
1220C-----------P21Q
1221 DO i=1,6
1222 DO j=1,6
1223 DO ep=jft,jlt
1224 p(i+6,j,ep)= kq(i,j,ep)
1225 ENDDO
1226 ENDDO
1227 ENDDO
1228 CALL tranqikqj67(jft ,jlt ,r1 ,dr , r3 ,kl, ias)
1229 CALL trankl1(jft ,jlt ,kl ,ias )
1230 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
1231C-----------P13Q
1232 DO i=1,6
1233 DO j=1,6
1234 DO ep=jft,jlt
1235 p(i,j+12,ep)= kq(i,j,ep)
1236 ENDDO
1237 ENDDO
1238 ENDDO
1239 DO i=1,3
1240 DO j=1,3
1241 DO ep=jft,jlt
1242 ke(i,j+12,ep)= k13(i,j,ep)
1243 ke(i+3,j+15,ep)= m13(i,j,ep)
1244 ke(i,j+15,ep)= mf13(i,j,ep)
1245 ke(i+3,j+12,ep)= fm13(i,j,ep)
1246 ENDDO
1247 ENDDO
1248 ENDDO
1249 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,iat )
1250C-----------P31Q
1251 DO i=1,6
1252 DO j=1,6
1253 DO ep=jft,jlt
1254 p(i+12,j,ep)= kq(i,j,ep)
1255 ENDDO
1256 ENDDO
1257 ENDDO
1258 CALL tranqikqj67(jft ,jlt ,r1 ,dr , r4 ,kl, ias)
1259 CALL trankl1(jft ,jlt ,kl ,ias )
1260 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
1261C-----------P14Q
1262 DO i=1,6
1263 DO j=1,6
1264 DO ep=jft,jlt
1265 p(i,j+18,ep)= kq(i,j,ep)
1266 ENDDO
1267 ENDDO
1268 ENDDO
1269 DO i=1,3
1270 DO j=1,3
1271 DO ep=jft,jlt
1272 ke(i,j+18,ep)= k14(i,j,ep)
1273 ke(i+3,j+21,ep)= m14(i,j,ep)
1274 ke(i,j+21,ep)= mf14(i,j,ep)
1275 ke(i+3,j+18,ep)= fm14(i,j,ep)
1276 ENDDO
1277 ENDDO
1278 ENDDO
1279 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,iat )
1280C-----------P41Q
1281 DO i=1,6
1282 DO j=1,6
1283 DO ep=jft,jlt
1284 p(i+18,j,ep)= kq(i,j,ep)
1285 ENDDO
1286 ENDDO
1287 ENDDO
1288 CALL tranqikqj67(jft ,jlt ,r2 ,dr , r3 ,kl, ias)
1289 CALL trankl1(jft ,jlt ,kl ,ias )
1290 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
1291C-----------P23Q
1292 DO i=1,6
1293 DO j=1,6
1294 DO ep=jft,jlt
1295 p(i+6,j+12,ep)= kq(i,j,ep)
1296 ENDDO
1297 ENDDO
1298 ENDDO
1299 DO i=1,3
1300 DO j=1,3
1301 DO ep=jft,jlt
1302 ke(i+6,j+12,ep)= k23(i,j,ep)
1303 ke(i+9,j+15,ep)= m23(i,j,ep)
1304 ke(i+6,j+15,ep)= mf23(i,j,ep)
1305 ke(i+9,j+12,ep)= fm23(i,j,ep)
1306 ENDDO
1307 ENDDO
1308 ENDDO
1309 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,iat )
1310C-----------P32Q
1311 DO i=1,6
1312 DO j=1,6
1313 DO ep=jft,jlt
1314 p(i+12,j+6,ep)= kq(i,j,ep)
1315 ENDDO
1316 ENDDO
1317 ENDDO
1318 CALL tranqikqj67(jft ,jlt ,r2 ,dr , r4 ,kl, ias)
1319 CALL trankl1(jft ,jlt ,kl ,ias )
1320 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
1321C-----------P24Q
1322 DO i=1,6
1323 DO j=1,6
1324 DO ep=jft,jlt
1325 p(i+6,j+18,ep)= kq(i,j,ep)
1326 ENDDO
1327 ENDDO
1328 ENDDO
1329 DO i=1,3
1330 DO j=1,3
1331 DO ep=jft,jlt
1332 ke(i+6,j+18,ep)= k24(i,j,ep)
1333 ke(i+9,j+21,ep)= m24(i,j,ep)
1334 ke(i+6,j+21,ep)= mf24(i,j,ep)
1335 ke(i+9,j+18,ep)= fm24(i,j,ep)
1336 ENDDO
1337 ENDDO
1338 ENDDO
1339 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,iat )
1340C-----------P42Q
1341 DO i=1,6
1342 DO j=1,6
1343 DO ep=jft,jlt
1344 p(i+18,j+6,ep)= kq(i,j,ep)
1345 ENDDO
1346 ENDDO
1347 ENDDO
1348 CALL tranqikqj67(jft ,jlt ,r3 ,dr , r4 ,kl, ias)
1349 CALL trankl1(jft ,jlt ,kl ,ias )
1350 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,it )
1351C-----------P34Q
1352 DO i=1,6
1353 DO j=1,6
1354 DO ep=jft,jlt
1355 p(i+12,j+18,ep)= kq(i,j,ep)
1356 ENDDO
1357 ENDDO
1358 ENDDO
1359 DO i=1,3
1360 DO j=1,3
1361 DO ep=jft,jlt
1362 ke(i+12,j+18,ep)= k34(i,j,ep)
1363 ke(i+15,j+21,ep)= m34(i,j,ep)
1364 ke(i+12,j+21,ep)= mf34(i,j,ep)
1365 ke(i+15,j+18,ep)= fm34(i,j,ep)
1366 ENDDO
1367 ENDDO
1368 ENDDO
1369 CALL tranklq(jft ,jlt ,vq ,kl ,kq ,iat )
1370C-----------P43Q
1371 DO i=1,6
1372 DO j=1,6
1373 DO ep=jft,jlt
1374 p(i+18,j+12,ep)= kq(i,j,ep)
1375 ENDDO
1376 ENDDO
1377 ENDDO
1378C-----------
1379 DO i=1,24
1380 DO j=i+1,24
1381 DO ep=jft,jlt
1382c P(J,I,EP)= P(I,J,EP)
1383 ke(j,i,ep)= ke(i,j,ep)
1384 ENDDO
1385 ENDDO
1386 ENDDO
1387C-----------
1388 CALL tranqikqj(jft ,jlt ,p ,ke,p ,24 ,is )
1389C-----------after projection----
1390C-----------K11
1391 DO i=1,3
1392 DO j=i,3
1393 DO ep=jft,jlt
1394 k11(i,j,ep) =ke(i,j,ep)
1395 m11(i,j,ep) =ke(i+3,j+3,ep)
1396 ENDDO
1397 ENDDO
1398 DO j=1,3
1399 DO ep=jft,jlt
1400 mf11(i,j,ep) = ke(i,j+3,ep)
1401 ENDDO
1402 ENDDO
1403 ENDDO
1404C-----------K22
1405 DO i=1,3
1406 DO j=i,3
1407 DO ep=jft,jlt
1408 k22(i,j,ep) = ke(i+6,j+6,ep)
1409 m22(i,j,ep) = ke(i+9,j+9,ep)
1410 ENDDO
1411 ENDDO
1412 DO j=1,3
1413 DO ep=jft,jlt
1414 mf22(i,j,ep) = ke(i+6,j+9,ep)
1415 ENDDO
1416 ENDDO
1417 ENDDO
1418C-----------K33
1419 DO i=1,3
1420 DO j=i,3
1421 DO ep=jft,jlt
1422 k33(i,j,ep) = ke(i+12,j+12,ep)
1423 m33(i,j,ep) = ke(i+15,j+15,ep)
1424 ENDDO
1425 ENDDO
1426 DO j=1,3
1427 DO ep=jft,jlt
1428 mf33(i,j,ep) = ke(i+12,j+15,ep)
1429 ENDDO
1430 ENDDO
1431 ENDDO
1432C-----------K44
1433 DO i=1,3
1434 DO j=i,3
1435 DO ep=jft,jlt
1436 k44(i,j,ep) = ke(i+18,j+18,ep)
1437 m44(i,j,ep) = ke(i+21,j+21,ep)
1438 ENDDO
1439 ENDDO
1440 DO j=1,3
1441 DO ep=jft,jlt
1442 mf44(i,j,ep) = ke(i+18,j+21,ep)
1443 ENDDO
1444 ENDDO
1445 ENDDO
1446C-----------K12
1447 DO i=1,3
1448 DO j=1,3
1449 DO ep=jft,jlt
1450 k12(i,j,ep) =ke(i,j+6,ep)
1451 m12(i,j,ep) =ke(i+3,j+9,ep)
1452 mf12(i,j,ep)=ke(i,j+9,ep)
1453 fm12(i,j,ep)=ke(i+3,j+6,ep)
1454 ENDDO
1455 ENDDO
1456 ENDDO
1457C-----------K13
1458 DO i=1,3
1459 DO j=1,3
1460 DO ep=jft,jlt
1461 k13(i,j,ep) = ke(i,j+12,ep)
1462 m13(i,j,ep) = ke(i+3,j+15,ep)
1463 mf13(i,j,ep) = ke(i,j+15,ep)
1464 fm13(i,j,ep) = ke(i+3,j+12,ep)
1465 ENDDO
1466 ENDDO
1467 ENDDO
1468C-----------K14
1469 DO i=1,3
1470 DO j=1,3
1471 DO ep=jft,jlt
1472 k14(i,j,ep) =ke(i,j+18,ep)
1473 m14(i,j,ep) =ke(i+3,j+21,ep)
1474 mf14(i,j,ep)=ke(i,j+21,ep)
1475 fm14(i,j,ep)=ke(i+3,j+18,ep)
1476 ENDDO
1477 ENDDO
1478 ENDDO
1479C-----------K23
1480 DO i=1,3
1481 DO j=1,3
1482 DO ep=jft,jlt
1483 k23(i,j,ep) = ke(i+6,j+12,ep)
1484 m23(i,j,ep) = ke(i+9,j+15,ep)
1485 mf23(i,j,ep) =ke(i+6,j+15,ep)
1486 fm23(i,j,ep) =ke(i+9,j+12,ep)
1487 ENDDO
1488 ENDDO
1489 ENDDO
1490C-----------K24
1491 DO i=1,3
1492 DO j=1,3
1493 DO ep=jft,jlt
1494 k24(i,j,ep) = ke(i+6,j+18,ep)
1495 m24(i,j,ep) = ke(i+9,j+21,ep)
1496 mf24(i,j,ep) =ke(i+6,j+21,ep)
1497 fm24(i,j,ep) =ke(i+9,j+18,ep)
1498 ENDDO
1499 ENDDO
1500 ENDDO
1501C-----------K34
1502 DO i=1,3
1503 DO j=1,3
1504 DO ep=jft,jlt
1505 k34(i,j,ep) = ke(i+12,j+18,ep)
1506 m34(i,j,ep) = ke(i+15,j+21,ep)
1507 mf34(i,j,ep) =ke(i+12,j+21,ep)
1508 fm34(i,j,ep) =ke(i+15,j+18,ep)
1509 ENDDO
1510 ENDDO
1511 ENDDO
1512C---prevent singularity-----
1513 CALL cztrank33(jft ,jlt ,vq ,mz11,m11 ,is)
1514 CALL cztrank33(jft ,jlt ,vq ,mz22,m22 ,is)
1515 CALL cztrank33(jft ,jlt ,vq ,mz33,m33 ,is)
1516 CALL cztrank33(jft ,jlt ,vq ,mz44,m44 ,is)
1517 CALL cztrank33(jft ,jlt ,vq ,mz12,m12 ,ias)
1518 CALL cztrank33(jft ,jlt ,vq ,mz13,m13 ,ias)
1519 CALL cztrank33(jft ,jlt ,vq ,mz14,m14 ,ias)
1520 CALL cztrank33(jft ,jlt ,vq ,mz23,m23 ,ias)
1521 CALL cztrank33(jft ,jlt ,vq ,mz24,m24 ,ias)
1522 CALL cztrank33(jft ,jlt ,vq ,mz34,m34 ,ias)
1523C-----------
1524 DEALLOCATE(p)
1525 DEALLOCATE(ke)
1526 RETURN
tranklq
subroutine tranklq(jft, jlt, vq, kl, kd, it)
Definition czsumg3.F:1714
trankl1
subroutine trankl1(jft, jlt, kl, is)
Definition czsumg3.F:1676
tranqikqj67
subroutine tranqikqj67(jft, jlt, vqi, kk, vqj, kd, isym)
Definition czsumg3.F:1535
tranqikqj
subroutine tranqikqj(jft, jlt, vqi, kk, vqj, nd, isym)
Definition czsumg3.F:1602
cztrank33
subroutine cztrank33(jft, jlt, vq, k33, kk, isym)
Definition czsumg3.F:1770

◆ setprojkz()

subroutine setprojkz ( 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,
drz,
rz1,
rz2,
rz3,
rz4,
vq,
integer jft,
integer jlt,
qn1,
qn2,
qn3,
qn4 )

Definition at line 1832 of file czsumg3.F.

1839C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
1840#include "implicit_f.inc"
1841#include "mvsiz_p.inc"
1842C-----------------------------------------------
1843C D U M M Y A R G U M E N T S
1844C-----------------------------------------------
1845 INTEGER JFT,JLT
1846 my_real
1847 . dr(7,7,*),vq(3,3,*),drz(3,*),
1848 . r1(6,7,*),r2(6,7,*),r3(6,7,*),r4(6,7,*),
1849 . rz1(3,3,*),rz2(3,3,*),rz3(3,3,*),rz4(3,3,*),
1850 . k11(3,3,*),k12(3,3,*),k13(3,3,*),k14(3,3,*),
1851 . k22(3,3,*),k23(3,3,*),k24(3,3,*),k33(3,3,*),
1852 . m11(3,3,*),m12(3,3,*),m13(3,3,*),m14(3,3,*),
1853 . m22(3,3,*),m23(3,3,*),m24(3,3,*),m33(3,3,*),
1854 . mf11(3,3,*),mf12(3,3,*),mf13(3,3,*),mf14(3,3,*),
1855 . mf22(3,3,*),mf23(3,3,*),mf24(3,3,*),mf33(3,3,*),
1856 . fm12(3,3,*),fm13(3,3,*),fm14(3,3,*),
1857 . fm23(3,3,*),fm24(3,3,*),fm34(3,3,*),
1858 . k34(3,3,*),k44(3,3,*),m34(3,3,*),m44(3,3,*),
1859 . mf34(3,3,*),mf44(3,3,*),qn1(3,*),qn2(3,*),qn3(3,*),qn4(3,*)
1860C-----------------------------------------------
1861C LOCAL A R G U M E N T S
1862C-----------------------------------------------
1863 INTEGER I,J,EP,IS,IAS,IT,IAT
1864 my_real
1865 . kl(6,6,mvsiz),kq(6,6,mvsiz),kr(6,6,mvsiz)
1866 DATA is/1/,ias/0/,it/1/,iat/0/
1867 my_real,
1868 . DIMENSION(:,:,:), ALLOCATABLE:: p,ke
1869C-------------------------------------------------------------
1870 ALLOCATE(p(24,24,mvsiz))
1871 ALLOCATE(ke(24,24,mvsiz))
1872C-----------P11Q---------
1873 CALL tranqikqj67(jft ,jlt ,r1 ,dr , r1 ,kl, is)
1874 CALL trankl1(jft ,jlt ,kl ,is )
1875 CALL tranqikqjrz(jft ,jlt ,rz1 ,drz ,rz1,kl ,kr ,it ,is )
1876 CALL tranklq(jft ,jlt ,vq ,kr ,kq ,it )
1877 DO i=1,6
1878 DO j=1,6
1879 DO ep=jft,jlt
1880 p(i,j,ep)= kq(i,j,ep)
1881 ENDDO
1882 ENDDO
1883 ENDDO
1884 DO i=1,3
1885 DO j=i,3
1886 DO ep=jft,jlt
1887 ke(i,j,ep)= k11(i,j,ep)
1888 ke(i+3,j+3,ep)= m11(i,j,ep)
1889 ENDDO
1890 ENDDO
1891 DO j=1,3
1892 DO ep=jft,jlt
1893 ke(i,j+3,ep)= mf11(i,j,ep)
1894 ENDDO
1895 ENDDO
1896 ENDDO
1897C-----------P22Q
1898 CALL tranqikqj67(jft ,jlt ,r2 ,dr , r2 ,kl, is)
1899 CALL trankl1(jft ,jlt ,kl ,is )
1900 CALL tranqikqjrz(jft ,jlt ,rz2 ,drz ,rz2,kl ,kr ,it ,is )
1901 CALL tranklq(jft ,jlt ,vq ,kr ,kq ,it )
1902 DO i=1,6
1903 DO j=1,6
1904 DO ep=jft,jlt
1905 p(i+6,j+6,ep)= kq(i,j,ep)
1906 ENDDO
1907 ENDDO
1908 ENDDO
1909 DO i=1,3
1910 DO j=i,3
1911 DO ep=jft,jlt
1912 ke(i+6,j+6,ep)= k22(i,j,ep)
1913 ke(i+9,j+9,ep)= m22(i,j,ep)
1914 ENDDO
1915 ENDDO
1916 DO j=1,3
1917 DO ep=jft,jlt
1918 ke(i+6,j+9,ep)= mf22(i,j,ep)
1919 ENDDO
1920 ENDDO
1921 ENDDO
1922C-----------P33Q
1923 CALL tranqikqj67(jft ,jlt ,r3 ,dr , r3 ,kl, is)
1924 CALL trankl1(jft ,jlt ,kl ,is )
1925 CALL tranqikqjrz(jft ,jlt ,rz3 ,drz ,rz3,kl ,kr ,it ,is )
1926 CALL tranklq(jft ,jlt ,vq ,kr ,kq ,it )
1927 DO i=1,6
1928 DO j=1,6
1929 DO ep=jft,jlt
1930 p(i+12,j+12,ep)= kq(i,j,ep)
1931 ENDDO
1932 ENDDO
1933 ENDDO
1934 DO i=1,3
1935 DO j=i,3
1936 DO ep=jft,jlt
1937 ke(i+12,j+12,ep)= k33(i,j,ep)
1938 ke(i+15,j+15,ep)= m33(i,j,ep)
1939 ENDDO
1940 ENDDO
1941 DO j=1,3
1942 DO ep=jft,jlt
1943 ke(i+12,j+15,ep)= mf33(i,j,ep)
1944 ENDDO
1945 ENDDO
1946 ENDDO
1947C-----------P44Q
1948 CALL tranqikqj67(jft ,jlt ,r4 ,dr , r4 ,kl, is)
1949 CALL trankl1(jft ,jlt ,kl ,is )
1950 CALL tranqikqjrz(jft ,jlt ,rz4 ,drz ,rz4,kl ,kr ,it ,is )
1951 CALL tranklq(jft ,jlt ,vq ,kr ,kq ,it )
1952 DO i=1,6
1953 DO j=1,6
1954 DO ep=jft,jlt
1955 p(i+18,j+18,ep)= kq(i,j,ep)
1956 ENDDO
1957 ENDDO
1958 ENDDO
1959 DO i=1,3
1960 DO j=i,3
1961 DO ep=jft,jlt
1962 ke(i+18,j+18,ep)= k44(i,j,ep)
1963 ke(i+21,j+21,ep)= m44(i,j,ep)
1964 ENDDO
1965 ENDDO
1966 DO j=1,3
1967 DO ep=jft,jlt
1968 ke(i+18,j+21,ep)= mf44(i,j,ep)
1969 ENDDO
1970 ENDDO
1971 ENDDO
1972C-----------P12Q
1973 CALL tranqikqj67(jft ,jlt ,r1 ,dr , r2 ,kl, ias)
1974 CALL trankl1(jft ,jlt ,kl ,ias )
1975 CALL tranqikqjrz(jft ,jlt ,rz1 ,drz ,rz2,kl ,kr ,it ,ias)
1976 CALL tranklq(jft ,jlt ,vq ,kr ,kq ,it )
1977 DO i=1,6
1978 DO j=1,6
1979 DO ep=jft,jlt
1980 p(i,j+6,ep)= kq(i,j,ep)
1981 ENDDO
1982 ENDDO
1983 ENDDO
1984 DO i=1,3
1985 DO j=1,3
1986 DO ep=jft,jlt
1987 ke(i,j+6,ep)= k12(i,j,ep)
1988 ke(i+3,j+9,ep)= m12(i,j,ep)
1989 ke(i,j+9,ep)= mf12(i,j,ep)
1990 ke(i+3,j+6,ep)= fm12(i,j,ep)
1991 ENDDO
1992 ENDDO
1993 ENDDO
1994C-----------P21Q
1995 CALL tranqikqjrz(jft ,jlt ,rz1 ,drz ,rz2,kl ,kr ,iat ,ias)
1996 CALL tranklq(jft ,jlt ,vq ,kr ,kq ,iat )
1997 DO i=1,6
1998 DO j=1,6
1999 DO ep=jft,jlt
2000 p(i+6,j,ep)= kq(i,j,ep)
2001 ENDDO
2002 ENDDO
2003 ENDDO
2004C-----------P13Q
2005 CALL tranqikqj67(jft ,jlt ,r1 ,dr , r3 ,kl, ias)
2006 CALL trankl1(jft ,jlt ,kl ,ias )
2007 CALL tranqikqjrz(jft ,jlt ,rz1 ,drz ,rz3,kl ,kr ,it ,ias)
2008 CALL tranklq(jft ,jlt ,vq ,kr ,kq ,it )
2009 DO i=1,6
2010 DO j=1,6
2011 DO ep=jft,jlt
2012 p(i,j+12,ep)= kq(i,j,ep)
2013 ENDDO
2014 ENDDO
2015 ENDDO
2016 DO i=1,3
2017 DO j=1,3
2018 DO ep=jft,jlt
2019 ke(i,j+12,ep)= k13(i,j,ep)
2020 ke(i+3,j+15,ep)= m13(i,j,ep)
2021 ke(i,j+15,ep)= mf13(i,j,ep)
2022 ke(i+3,j+12,ep)= fm13(i,j,ep)
2023 ENDDO
2024 ENDDO
2025 ENDDO
2026C-----------P31Q
2027 CALL tranqikqjrz(jft ,jlt ,rz1 ,drz ,rz3,kl ,kr ,iat ,ias)
2028 CALL tranklq(jft ,jlt ,vq ,kr ,kq ,iat )
2029 DO i=1,6
2030 DO j=1,6
2031 DO ep=jft,jlt
2032 p(i+12,j,ep)= kq(i,j,ep)
2033 ENDDO
2034 ENDDO
2035 ENDDO
2036C-----------P14Q
2037 CALL tranqikqj67(jft ,jlt ,r1 ,dr , r4 ,kl, ias)
2038 CALL trankl1(jft ,jlt ,kl ,ias )
2039 CALL tranqikqjrz(jft ,jlt ,rz1 ,drz ,rz4,kl ,kr ,it ,ias)
2040 CALL tranklq(jft ,jlt ,vq ,kr ,kq ,it )
2041 DO i=1,6
2042 DO j=1,6
2043 DO ep=jft,jlt
2044 p(i,j+18,ep)= kq(i,j,ep)
2045 ENDDO
2046 ENDDO
2047 ENDDO
2048 DO i=1,3
2049 DO j=1,3
2050 DO ep=jft,jlt
2051 ke(i,j+18,ep)= k14(i,j,ep)
2052 ke(i+3,j+21,ep)= m14(i,j,ep)
2053 ke(i,j+21,ep)= mf14(i,j,ep)
2054 ke(i+3,j+18,ep)= fm14(i,j,ep)
2055 ENDDO
2056 ENDDO
2057 ENDDO
2058C-----------P41Q
2059 CALL tranqikqjrz(jft ,jlt ,rz1 ,drz ,rz4,kl ,kr ,iat ,ias)
2060 CALL tranklq(jft ,jlt ,vq ,kr ,kq ,iat )
2061 DO i=1,6
2062 DO j=1,6
2063 DO ep=jft,jlt
2064 p(i+18,j,ep)= kq(i,j,ep)
2065 ENDDO
2066 ENDDO
2067 ENDDO
2068C-----------P23Q
2069 CALL tranqikqj67(jft ,jlt ,r2 ,dr , r3 ,kl, ias)
2070 CALL trankl1(jft ,jlt ,kl ,ias )
2071 CALL tranqikqjrz(jft ,jlt ,rz2 ,drz ,rz3,kl ,kr ,it ,ias)
2072 CALL tranklq(jft ,jlt ,vq ,kr ,kq ,it )
2073 DO i=1,6
2074 DO j=1,6
2075 DO ep=jft,jlt
2076 p(i+6,j+12,ep)= kq(i,j,ep)
2077 ENDDO
2078 ENDDO
2079 ENDDO
2080 DO i=1,3
2081 DO j=1,3
2082 DO ep=jft,jlt
2083 ke(i+6,j+12,ep)= k23(i,j,ep)
2084 ke(i+9,j+15,ep)= m23(i,j,ep)
2085 ke(i+6,j+15,ep)= mf23(i,j,ep)
2086 ke(i+9,j+12,ep)= fm23(i,j,ep)
2087 ENDDO
2088 ENDDO
2089 ENDDO
2090C-----------P32Q
2091 CALL tranqikqjrz(jft ,jlt ,rz2 ,drz ,rz3,kl ,kr ,iat ,ias)
2092 CALL tranklq(jft ,jlt ,vq ,kr ,kq ,iat )
2093 DO i=1,6
2094 DO j=1,6
2095 DO ep=jft,jlt
2096 p(i+12,j+6,ep)= kq(i,j,ep)
2097 ENDDO
2098 ENDDO
2099 ENDDO
2100C-----------P24Q
2101 CALL tranqikqj67(jft ,jlt ,r2 ,dr , r4 ,kl, ias)
2102 CALL trankl1(jft ,jlt ,kl ,ias )
2103 CALL tranqikqjrz(jft ,jlt ,rz2 ,drz ,rz4,kl ,kr ,it ,ias)
2104 CALL tranklq(jft ,jlt ,vq ,kr ,kq ,it )
2105 DO i=1,6
2106 DO j=1,6
2107 DO ep=jft,jlt
2108 p(i+6,j+18,ep)= kq(i,j,ep)
2109 ENDDO
2110 ENDDO
2111 ENDDO
2112 DO i=1,3
2113 DO j=1,3
2114 DO ep=jft,jlt
2115 ke(i+6,j+18,ep)= k24(i,j,ep)
2116 ke(i+9,j+21,ep)= m24(i,j,ep)
2117 ke(i+6,j+21,ep)= mf24(i,j,ep)
2118 ke(i+9,j+18,ep)= fm24(i,j,ep)
2119 ENDDO
2120 ENDDO
2121 ENDDO
2122C-----------P42Q
2123 CALL tranqikqjrz(jft ,jlt ,rz2 ,drz ,rz4,kl ,kr ,iat ,ias)
2124 CALL tranklq(jft ,jlt ,vq ,kr ,kq ,iat )
2125 DO i=1,6
2126 DO j=1,6
2127 DO ep=jft,jlt
2128 p(i+18,j+6,ep)= kq(i,j,ep)
2129 ENDDO
2130 ENDDO
2131 ENDDO
2132C-----------P34Q
2133 CALL tranqikqj67(jft ,jlt ,r3 ,dr , r4 ,kl ,ias)
2134 CALL trankl1(jft ,jlt ,kl ,ias )
2135 CALL tranqikqjrz(jft ,jlt ,rz3 ,drz ,rz4,kl ,kr ,it ,ias)
2136 CALL tranklq(jft ,jlt ,vq ,kr ,kq ,it )
2137 DO i=1,6
2138 DO j=1,6
2139 DO ep=jft,jlt
2140 p(i+12,j+18,ep)= kq(i,j,ep)
2141 ENDDO
2142 ENDDO
2143 ENDDO
2144 DO i=1,3
2145 DO j=1,3
2146 DO ep=jft,jlt
2147 ke(i+12,j+18,ep)= k34(i,j,ep)
2148 ke(i+15,j+21,ep)= m34(i,j,ep)
2149 ke(i+12,j+21,ep)= mf34(i,j,ep)
2150 ke(i+15,j+18,ep)= fm34(i,j,ep)
2151 ENDDO
2152 ENDDO
2153 ENDDO
2154C-----------P43Q
2155 CALL tranqikqjrz(jft ,jlt ,rz3 ,drz ,rz4,kl ,kr ,iat ,ias)
2156 CALL tranklq(jft ,jlt ,vq ,kr ,kq ,iat )
2157 DO i=1,6
2158 DO j=1,6
2159 DO ep=jft,jlt
2160 p(i+18,j+12,ep)= kq(i,j,ep)
2161 ENDDO
2162 ENDDO
2163 ENDDO
2164C-----------
2165 DO i=1,24
2166 DO j=i+1,24
2167 DO ep=jft,jlt
2168 ke(j,i,ep)= ke(i,j,ep)
2169 ENDDO
2170 ENDDO
2171 ENDDO
2172C-----------
2173 CALL tranqikqj(jft ,jlt ,p ,ke,p ,24 ,is )
2174C-----------after projection----
2175C-----------K11
2176 DO i=1,3
2177 DO j=i,3
2178 DO ep=jft,jlt
2179 k11(i,j,ep) =ke(i,j,ep)
2180 m11(i,j,ep) =ke(i+3,j+3,ep)
2181 ENDDO
2182 ENDDO
2183 DO j=1,3
2184 DO ep=jft,jlt
2185 mf11(i,j,ep) = ke(i,j+3,ep)
2186 ENDDO
2187 ENDDO
2188 ENDDO
2189C-----------K22
2190 DO i=1,3
2191 DO j=i,3
2192 DO ep=jft,jlt
2193 k22(i,j,ep) = ke(i+6,j+6,ep)
2194 m22(i,j,ep) = ke(i+9,j+9,ep)
2195 ENDDO
2196 ENDDO
2197 DO j=1,3
2198 DO ep=jft,jlt
2199 mf22(i,j,ep) = ke(i+6,j+9,ep)
2200 ENDDO
2201 ENDDO
2202 ENDDO
2203C-----------K33
2204 DO i=1,3
2205 DO j=i,3
2206 DO ep=jft,jlt
2207 k33(i,j,ep) = ke(i+12,j+12,ep)
2208 m33(i,j,ep) = ke(i+15,j+15,ep)
2209 ENDDO
2210 ENDDO
2211 DO j=1,3
2212 DO ep=jft,jlt
2213 mf33(i,j,ep) = ke(i+12,j+15,ep)
2214 ENDDO
2215 ENDDO
2216 ENDDO
2217C-----------K44
2218 DO i=1,3
2219 DO j=i,3
2220 DO ep=jft,jlt
2221 k44(i,j,ep) = ke(i+18,j+18,ep)
2222 m44(i,j,ep) = ke(i+21,j+21,ep)
2223 ENDDO
2224 ENDDO
2225 DO j=1,3
2226 DO ep=jft,jlt
2227 mf44(i,j,ep) = ke(i+18,j+21,ep)
2228 ENDDO
2229 ENDDO
2230 ENDDO
2231C-----------K12
2232 DO i=1,3
2233 DO j=1,3
2234 DO ep=jft,jlt
2235 k12(i,j,ep) =ke(i,j+6,ep)
2236 m12(i,j,ep) =ke(i+3,j+9,ep)
2237 mf12(i,j,ep)=ke(i,j+9,ep)
2238 fm12(i,j,ep)=ke(i+3,j+6,ep)
2239 ENDDO
2240 ENDDO
2241 ENDDO
2242C-----------K13
2243 DO i=1,3
2244 DO j=1,3
2245 DO ep=jft,jlt
2246 k13(i,j,ep) = ke(i,j+12,ep)
2247 m13(i,j,ep) = ke(i+3,j+15,ep)
2248 mf13(i,j,ep) = ke(i,j+15,ep)
2249 fm13(i,j,ep) = ke(i+3,j+12,ep)
2250 ENDDO
2251 ENDDO
2252 ENDDO
2253C-----------K14
2254 DO i=1,3
2255 DO j=1,3
2256 DO ep=jft,jlt
2257 k14(i,j,ep) =ke(i,j+18,ep)
2258 m14(i,j,ep) =ke(i+3,j+21,ep)
2259 mf14(i,j,ep)=ke(i,j+21,ep)
2260 fm14(i,j,ep)=ke(i+3,j+18,ep)
2261 ENDDO
2262 ENDDO
2263 ENDDO
2264C-----------K23
2265 DO i=1,3
2266 DO j=1,3
2267 DO ep=jft,jlt
2268 k23(i,j,ep) = ke(i+6,j+12,ep)
2269 m23(i,j,ep) = ke(i+9,j+15,ep)
2270 mf23(i,j,ep) =ke(i+6,j+15,ep)
2271 fm23(i,j,ep) =ke(i+9,j+12,ep)
2272 ENDDO
2273 ENDDO
2274 ENDDO
2275C-----------K24
2276 DO i=1,3
2277 DO j=1,3
2278 DO ep=jft,jlt
2279 k24(i,j,ep) = ke(i+6,j+18,ep)
2280 m24(i,j,ep) = ke(i+9,j+21,ep)
2281 mf24(i,j,ep) =ke(i+6,j+21,ep)
2282 fm24(i,j,ep) =ke(i+9,j+18,ep)
2283 ENDDO
2284 ENDDO
2285 ENDDO
2286C-----------K34
2287 DO i=1,3
2288 DO j=1,3
2289 DO ep=jft,jlt
2290 k34(i,j,ep) = ke(i+12,j+18,ep)
2291 m34(i,j,ep) = ke(i+15,j+21,ep)
2292 mf34(i,j,ep) =ke(i+12,j+21,ep)
2293 fm34(i,j,ep) =ke(i+15,j+18,ep)
2294 ENDDO
2295 ENDDO
2296 ENDDO
2297C-----------
2298 DEALLOCATE(p)
2299 DEALLOCATE(ke)
2300 RETURN
tranqikqjrz
subroutine tranqikqjrz(jft, jlt, ri, rd, rj, kl, kr, it, is)
Definition czsumg3.F:3049

◆ setprojkz1()

subroutine setprojkz1 ( 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,
integer jft,
integer jlt,
qn1,
qn2,
qn3,
qn4 )

Definition at line 2490 of file czsumg3.F.

2496C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
2497#include "implicit_f.inc"
2498#include "mvsiz_p.inc"
2499C-----------------------------------------------
2500C D U M M Y A R G U M E N T S
2501C-----------------------------------------------
2502 INTEGER JFT,JLT
2503 my_real
2504 . dr(3,3,*),vq(3,3,*),
2505 . r1(3,3,*),r2(3,3,*),r3(3,3,*),r4(3,3,*),
2506 . k11(3,3,*),k12(3,3,*),k13(3,3,*),k14(3,3,*),
2507 . k22(3,3,*),k23(3,3,*),k24(3,3,*),k33(3,3,*),
2508 . m11(3,3,*),m12(3,3,*),m13(3,3,*),m14(3,3,*),
2509 . m22(3,3,*),m23(3,3,*),m24(3,3,*),m33(3,3,*),
2510 . mf11(3,3,*),mf12(3,3,*),mf13(3,3,*),mf14(3,3,*),
2511 . mf22(3,3,*),mf23(3,3,*),mf24(3,3,*),mf33(3,3,*),
2512 . fm12(3,3,*),fm13(3,3,*),fm14(3,3,*),
2513 . fm23(3,3,*),fm24(3,3,*),fm34(3,3,*),
2514 . k34(3,3,*),k44(3,3,*),m34(3,3,*),m44(3,3,*),
2515 . mf34(3,3,*),mf44(3,3,*),
2516 . qn1(3,3,*),qn2(3,3,*),qn3(3,3,*),qn4(3,3,*)
2517C-----------------------------------------------
2518C LOCAL A R G U M E N T S
2519C-----------------------------------------------
2520 INTEGER I,J,EP,IS,IAS,IT,IAT
2521 my_real
2522 . kl(6,6,mvsiz),kq(6,6,mvsiz),kr(6,6,mvsiz)
2523 DATA is/1/,ias/0/,it/1/,iat/0/
2524 my_real,
2525 . DIMENSION(:,:,:), ALLOCATABLE:: p,ke
2526C-------------------------------------------------------------
2527 ALLOCATE(p(24,24,mvsiz))
2528 ALLOCATE(ke(24,24,mvsiz))
2529
2530C-----------P11=Pr11Q(QN1)
2531 CALL tranqikqj33(jft ,jlt ,r1 ,dr , r1 ,kl, is)
2532 CALL trankl1(jft ,jlt ,kl ,is )
2533 CALL tranklqn(jft ,jlt ,vq ,qn1 ,kl ,kq ,it )
2534 DO i=1,6
2535 DO j=1,6
2536 DO ep=jft,jlt
2537 p(i,j,ep)= kq(i,j,ep)
2538 ENDDO
2539 ENDDO
2540 ENDDO
2541 DO i=1,3
2542 DO j=i,3
2543 DO ep=jft,jlt
2544 ke(i,j,ep)= k11(i,j,ep)
2545 ke(i+3,j+3,ep)= m11(i,j,ep)
2546 ENDDO
2547 ENDDO
2548 DO j=1,3
2549 DO ep=jft,jlt
2550 ke(i,j+3,ep)= mf11(i,j,ep)
2551 ENDDO
2552 ENDDO
2553 ENDDO
2554C-----------P22=Pr22Q(QN2)
2555 CALL tranqikqj33(jft ,jlt ,r2 ,dr , r2 ,kl, is)
2556 CALL trankl1(jft ,jlt ,kl ,is )
2557 CALL tranklqn(jft ,jlt ,vq ,qn2 ,kl ,kq ,it )
2558 DO i=1,6
2559 DO j=1,6
2560 DO ep=jft,jlt
2561 p(i+6,j+6,ep)= kq(i,j,ep)
2562 ENDDO
2563 ENDDO
2564 ENDDO
2565 DO i=1,3
2566 DO j=i,3
2567 DO ep=jft,jlt
2568 ke(i+6,j+6,ep)= k22(i,j,ep)
2569 ke(i+9,j+9,ep)= m22(i,j,ep)
2570 ENDDO
2571 ENDDO
2572 DO j=1,3
2573 DO ep=jft,jlt
2574 ke(i+6,j+9,ep)= mf22(i,j,ep)
2575 ENDDO
2576 ENDDO
2577 ENDDO
2578C-----------P33=Pr33Q(QN3)
2579 CALL tranqikqj33(jft ,jlt ,r3 ,dr , r3 ,kl, is)
2580 CALL trankl1(jft ,jlt ,kl ,is )
2581 CALL tranklqn(jft ,jlt ,vq ,qn3 ,kl ,kq ,it )
2582 DO i=1,6
2583 DO j=1,6
2584 DO ep=jft,jlt
2585 p(i+12,j+12,ep)= kq(i,j,ep)
2586 ENDDO
2587 ENDDO
2588 ENDDO
2589 DO i=1,3
2590 DO j=i,3
2591 DO ep=jft,jlt
2592 ke(i+12,j+12,ep)= k33(i,j,ep)
2593 ke(i+15,j+15,ep)= m33(i,j,ep)
2594 ENDDO
2595 ENDDO
2596 DO j=1,3
2597 DO ep=jft,jlt
2598 ke(i+12,j+15,ep)= mf33(i,j,ep)
2599 ENDDO
2600 ENDDO
2601 ENDDO
2602C-----------P44=Pr44Q(QN4)
2603 CALL tranqikqj33(jft ,jlt ,r4 ,dr , r4 ,kl, is)
2604 CALL trankl1(jft ,jlt ,kl ,is )
2605 CALL tranklqn(jft ,jlt ,vq ,qn4 ,kl ,kq ,it )
2606 DO i=1,6
2607 DO j=1,6
2608 DO ep=jft,jlt
2609 p(i+18,j+18,ep)= kq(i,j,ep)
2610 ENDDO
2611 ENDDO
2612 ENDDO
2613 DO i=1,3
2614 DO j=i,3
2615 DO ep=jft,jlt
2616 ke(i+18,j+18,ep)= k44(i,j,ep)
2617 ke(i+21,j+21,ep)= m44(i,j,ep)
2618 ENDDO
2619 ENDDO
2620 DO j=1,3
2621 DO ep=jft,jlt
2622 ke(i+18,j+21,ep)= mf44(i,j,ep)
2623 ENDDO
2624 ENDDO
2625 ENDDO
2626C-----------P12=Pr12Q(QN1)
2627 CALL tranqikqj33(jft ,jlt ,r1 ,dr , r2 ,kl, ias)
2628 CALL trankl1(jft ,jlt ,kl ,ias )
2629 CALL tranklqn(jft ,jlt ,vq ,qn1 ,kl ,kq ,it )
2630 DO i=1,6
2631 DO j=1,6
2632 DO ep=jft,jlt
2633 p(i,j+6,ep)= kq(i,j,ep)
2634 ENDDO
2635 ENDDO
2636 ENDDO
2637 DO i=1,3
2638 DO j=1,3
2639 DO ep=jft,jlt
2640 ke(i,j+6,ep)= k12(i,j,ep)
2641 ke(i+3,j+9,ep)= m12(i,j,ep)
2642 ke(i,j+9,ep)= mf12(i,j,ep)
2643 ke(i+3,j+6,ep)= fm12(i,j,ep)
2644 ENDDO
2645 ENDDO
2646 ENDDO
2647C-----------P21=Pr21Q(QN2)
2648 CALL tranklqn(jft ,jlt ,vq ,qn2 ,kl ,kq ,iat )
2649 DO i=1,6
2650 DO j=1,6
2651 DO ep=jft,jlt
2652 p(i+6,j,ep)= kq(i,j,ep)
2653 ENDDO
2654 ENDDO
2655 ENDDO
2656C-----------P13=Pr13Q(QN1)
2657 CALL tranqikqj33(jft ,jlt ,r1 ,dr , r3 ,kl, ias)
2658 CALL trankl1(jft ,jlt ,kl ,ias )
2659 CALL tranklqn(jft ,jlt ,vq ,qn1 ,kl ,kq ,it )
2660 DO i=1,6
2661 DO j=1,6
2662 DO ep=jft,jlt
2663 p(i,j+12,ep)= kq(i,j,ep)
2664 ENDDO
2665 ENDDO
2666 ENDDO
2667 DO i=1,3
2668 DO j=1,3
2669 DO ep=jft,jlt
2670 ke(i,j+12,ep)= k13(i,j,ep)
2671 ke(i+3,j+15,ep)= m13(i,j,ep)
2672 ke(i,j+15,ep)= mf13(i,j,ep)
2673 ke(i+3,j+12,ep)= fm13(i,j,ep)
2674 ENDDO
2675 ENDDO
2676 ENDDO
2677C-----------P31=Pr31Q(QN3)
2678 CALL tranklqn(jft ,jlt ,vq ,qn3 ,kl ,kq ,iat )
2679 DO i=1,6
2680 DO j=1,6
2681 DO ep=jft,jlt
2682 p(i+12,j,ep)= kq(i,j,ep)
2683 ENDDO
2684 ENDDO
2685 ENDDO
2686C-----------P14=Pr14Q(QN1)
2687 CALL tranqikqj33(jft ,jlt ,r1 ,dr , r4 ,kl, ias)
2688 CALL trankl1(jft ,jlt ,kl ,ias )
2689 CALL tranklqn(jft ,jlt ,vq ,qn1 ,kl ,kq ,it )
2690 DO i=1,6
2691 DO j=1,6
2692 DO ep=jft,jlt
2693 p(i,j+18,ep)= kq(i,j,ep)
2694 ENDDO
2695 ENDDO
2696 ENDDO
2697 DO i=1,3
2698 DO j=1,3
2699 DO ep=jft,jlt
2700 ke(i,j+18,ep)= k14(i,j,ep)
2701 ke(i+3,j+21,ep)= m14(i,j,ep)
2702 ke(i,j+21,ep)= mf14(i,j,ep)
2703 ke(i+3,j+18,ep)= fm14(i,j,ep)
2704 ENDDO
2705 ENDDO
2706 ENDDO
2707C-----------P41=P41Q(QN4)
2708 CALL tranklqn(jft ,jlt ,vq ,qn4 ,kl ,kq ,iat )
2709 DO i=1,6
2710 DO j=1,6
2711 DO ep=jft,jlt
2712 p(i+18,j,ep)= kq(i,j,ep)
2713 ENDDO
2714 ENDDO
2715 ENDDO
2716C-----------P23=Pr23Q(QN2)
2717 CALL tranqikqj33(jft ,jlt ,r2 ,dr , r3 ,kl, ias)
2718 CALL trankl1(jft ,jlt ,kl ,ias )
2719 CALL tranklqn(jft ,jlt ,vq ,qn2 ,kl ,kq ,it )
2720 DO i=1,6
2721 DO j=1,6
2722 DO ep=jft,jlt
2723 p(i+6,j+12,ep)= kq(i,j,ep)
2724 ENDDO
2725 ENDDO
2726 ENDDO
2727 DO i=1,3
2728 DO j=1,3
2729 DO ep=jft,jlt
2730 ke(i+6,j+12,ep)= k23(i,j,ep)
2731 ke(i+9,j+15,ep)= m23(i,j,ep)
2732 ke(i+6,j+15,ep)= mf23(i,j,ep)
2733 ke(i+9,j+12,ep)= fm23(i,j,ep)
2734 ENDDO
2735 ENDDO
2736 ENDDO
2737C-----------P32=Pr32Q(QN3)
2738 CALL tranklqn(jft ,jlt ,vq ,qn3 ,kl ,kq ,iat )
2739 DO i=1,6
2740 DO j=1,6
2741 DO ep=jft,jlt
2742 p(i+12,j+6,ep)= kq(i,j,ep)
2743 ENDDO
2744 ENDDO
2745 ENDDO
2746C-----------P24=Pr24Q(QN2)
2747 CALL tranqikqj33(jft ,jlt ,r2 ,dr , r4 ,kl, ias)
2748 CALL trankl1(jft ,jlt ,kl ,ias )
2749 CALL tranklqn(jft ,jlt ,vq ,qn2 ,kl ,kq ,it )
2750 DO i=1,6
2751 DO j=1,6
2752 DO ep=jft,jlt
2753 p(i+6,j+18,ep)= kq(i,j,ep)
2754 ENDDO
2755 ENDDO
2756 ENDDO
2757 DO i=1,3
2758 DO j=1,3
2759 DO ep=jft,jlt
2760 ke(i+6,j+18,ep)= k24(i,j,ep)
2761 ke(i+9,j+21,ep)= m24(i,j,ep)
2762 ke(i+6,j+21,ep)= mf24(i,j,ep)
2763 ke(i+9,j+18,ep)= fm24(i,j,ep)
2764 ENDDO
2765 ENDDO
2766 ENDDO
2767C-----------P42=Pr42Q(QN4)
2768 CALL tranklqn(jft ,jlt ,vq ,qn4 ,kl ,kq ,iat )
2769 DO i=1,6
2770 DO j=1,6
2771 DO ep=jft,jlt
2772 p(i+18,j+6,ep)= kq(i,j,ep)
2773 ENDDO
2774 ENDDO
2775 ENDDO
2776C-----------P34=Pr34Q(QN3)
2777 CALL tranqikqj33(jft ,jlt ,r3 ,dr , r4 ,kl, ias)
2778 CALL trankl1(jft ,jlt ,kl ,ias )
2779 CALL tranklqn(jft ,jlt ,vq ,qn3 ,kl ,kq ,it )
2780 DO i=1,6
2781 DO j=1,6
2782 DO ep=jft,jlt
2783 p(i+12,j+18,ep)= kq(i,j,ep)
2784 ENDDO
2785 ENDDO
2786 ENDDO
2787 DO i=1,3
2788 DO j=1,3
2789 DO ep=jft,jlt
2790 ke(i+12,j+18,ep)= k34(i,j,ep)
2791 ke(i+15,j+21,ep)= m34(i,j,ep)
2792 ke(i+12,j+21,ep)= mf34(i,j,ep)
2793 ke(i+15,j+18,ep)= fm34(i,j,ep)
2794 ENDDO
2795 ENDDO
2796 ENDDO
2797C-----------P43=Pr43Q(QN4)
2798 CALL tranklqn(jft ,jlt ,vq ,qn4 ,kl ,kq ,iat )
2799 DO i=1,6
2800 DO j=1,6
2801 DO ep=jft,jlt
2802 p(i+18,j+12,ep)= kq(i,j,ep)
2803 ENDDO
2804 ENDDO
2805 ENDDO
2806C-----------
2807 DO i=1,24
2808 DO j=i+1,24
2809 DO ep=jft,jlt
2810 ke(j,i,ep)= ke(i,j,ep)
2811 ENDDO
2812 ENDDO
2813 ENDDO
2814C-----------
2815 CALL tranqikqj(jft ,jlt ,p ,ke,p ,24 ,is )
2816C-----------after projection----
2817C-----------K11
2818 DO i=1,3
2819 DO j=i,3
2820 DO ep=jft,jlt
2821 k11(i,j,ep) =ke(i,j,ep)
2822 m11(i,j,ep) =ke(i+3,j+3,ep)
2823 ENDDO
2824 ENDDO
2825 DO j=1,3
2826 DO ep=jft,jlt
2827 mf11(i,j,ep) = ke(i,j+3,ep)
2828 ENDDO
2829 ENDDO
2830 ENDDO
2831C-----------K22
2832 DO i=1,3
2833 DO j=i,3
2834 DO ep=jft,jlt
2835 k22(i,j,ep) = ke(i+6,j+6,ep)
2836 m22(i,j,ep) = ke(i+9,j+9,ep)
2837 ENDDO
2838 ENDDO
2839 DO j=1,3
2840 DO ep=jft,jlt
2841 mf22(i,j,ep) = ke(i+6,j+9,ep)
2842 ENDDO
2843 ENDDO
2844 ENDDO
2845C-----------K33
2846 DO i=1,3
2847 DO j=i,3
2848 DO ep=jft,jlt
2849 k33(i,j,ep) = ke(i+12,j+12,ep)
2850 m33(i,j,ep) = ke(i+15,j+15,ep)
2851 ENDDO
2852 ENDDO
2853 DO j=1,3
2854 DO ep=jft,jlt
2855 mf33(i,j,ep) = ke(i+12,j+15,ep)
2856 ENDDO
2857 ENDDO
2858 ENDDO
2859C-----------K44
2860 DO i=1,3
2861 DO j=i,3
2862 DO ep=jft,jlt
2863 k44(i,j,ep) = ke(i+18,j+18,ep)
2864 m44(i,j,ep) = ke(i+21,j+21,ep)
2865 ENDDO
2866 ENDDO
2867 DO j=1,3
2868 DO ep=jft,jlt
2869 mf44(i,j,ep) = ke(i+18,j+21,ep)
2870 ENDDO
2871 ENDDO
2872 ENDDO
2873C-----------K12
2874 DO i=1,3
2875 DO j=1,3
2876 DO ep=jft,jlt
2877 k12(i,j,ep) =ke(i,j+6,ep)
2878 m12(i,j,ep) =ke(i+3,j+9,ep)
2879 mf12(i,j,ep)=ke(i,j+9,ep)
2880 fm12(i,j,ep)=ke(i+3,j+6,ep)
2881 ENDDO
2882 ENDDO
2883 ENDDO
2884C-----------K13
2885 DO i=1,3
2886 DO j=1,3
2887 DO ep=jft,jlt
2888 k13(i,j,ep) = ke(i,j+12,ep)
2889 m13(i,j,ep) = ke(i+3,j+15,ep)
2890 mf13(i,j,ep) = ke(i,j+15,ep)
2891 fm13(i,j,ep) = ke(i+3,j+12,ep)
2892 ENDDO
2893 ENDDO
2894 ENDDO
2895C-----------K14
2896 DO i=1,3
2897 DO j=1,3
2898 DO ep=jft,jlt
2899 k14(i,j,ep) =ke(i,j+18,ep)
2900 m14(i,j,ep) =ke(i+3,j+21,ep)
2901 mf14(i,j,ep)=ke(i,j+21,ep)
2902 fm14(i,j,ep)=ke(i+3,j+18,ep)
2903 ENDDO
2904 ENDDO
2905 ENDDO
2906C-----------K23
2907 DO i=1,3
2908 DO j=1,3
2909 DO ep=jft,jlt
2910 k23(i,j,ep) = ke(i+6,j+12,ep)
2911 m23(i,j,ep) = ke(i+9,j+15,ep)
2912 mf23(i,j,ep) =ke(i+6,j+15,ep)
2913 fm23(i,j,ep) =ke(i+9,j+12,ep)
2914 ENDDO
2915 ENDDO
2916 ENDDO
2917C-----------K24
2918 DO i=1,3
2919 DO j=1,3
2920 DO ep=jft,jlt
2921 k24(i,j,ep) = ke(i+6,j+18,ep)
2922 m24(i,j,ep) = ke(i+9,j+21,ep)
2923 mf24(i,j,ep) =ke(i+6,j+21,ep)
2924 fm24(i,j,ep) =ke(i+9,j+18,ep)
2925 ENDDO
2926 ENDDO
2927 ENDDO
2928C-----------K34
2929 DO i=1,3
2930 DO j=1,3
2931 DO ep=jft,jlt
2932 k34(i,j,ep) = ke(i+12,j+18,ep)
2933 m34(i,j,ep) = ke(i+15,j+21,ep)
2934 mf34(i,j,ep) =ke(i+12,j+21,ep)
2935 fm34(i,j,ep) =ke(i+15,j+18,ep)
2936 ENDDO
2937 ENDDO
2938 ENDDO
2939C-----------
2940 DEALLOCATE(p)
2941 DEALLOCATE(ke)
2942 RETURN
tranqikqj33
subroutine tranqikqj33(jft, jlt, ri, rd, rj, kd, isym)
Definition cbasumg3.F:1424
tranklqn
subroutine tranklqn(jft, jlt, vq, vqn, kl, kd, it)
Definition czsumg3.F:2950

◆ trankl0()

subroutine trankl0 ( integer jft,
integer jlt,
kl,
kr,
integer it )

Definition at line 3005 of file czsumg3.F.

3006C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
3007#include "implicit_f.inc"
3008C-----------------------------------------------
3009C D U M M Y A R G U M E N T S
3010C-----------------------------------------------
3011 INTEGER JFT,JLT,IT
3012 my_real
3013 . kl(6,6,*),kr(6,6,*)
3014C-----------------------------------------------
3015C LOCAL A R G U M E N T S
3016C-----------------------------------------------
3017 INTEGER I,EP,J,K
3018C--------------update KL(6,j)=0,j=4,6------------------------
3019 DO i=1,6
3020 DO j=1,6
3021 DO ep=jft,jlt
3022 kr(i,j,ep)= kl(i,j,ep)
3023 ENDDO
3024 ENDDO
3025 ENDDO
3026C
3027 IF (it == 1 )THEN
3028 DO j=1,6
3029 DO ep=jft,jlt
3030 kr(6,j,ep)= zero
3031 ENDDO
3032 ENDDO
3033 ELSE
3034 DO j=1,6
3035 DO ep=jft,jlt
3036 kr(j,6,ep)= zero
3037 ENDDO
3038 ENDDO
3039 END IF !(IT == 1 )THEN
3040 RETURN

◆ trankl1()

subroutine trankl1 ( integer jft,
integer jlt,
kl,
integer is )

Definition at line 1675 of file czsumg3.F.

1676C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
1677#include "implicit_f.inc"
1678C-----------------------------------------------
1679C D U M M Y A R G U M E N T S
1680C-----------------------------------------------
1681 INTEGER JFT,JLT,IS
1682 my_real
1683 . kl(6,6,*)
1684C-----------------------------------------------
1685C LOCAL A R G U M E N T S
1686C-----------------------------------------------
1687 INTEGER I,J,EP,K,L
1688C--------------KL=1-KL--------------------------
1689 DO i=1,6
1690 DO j=1,6
1691 DO ep=jft,jlt
1692 kl(i,j,ep)= -kl(i,j,ep)
1693 ENDDO
1694 ENDDO
1695 ENDDO
1696 IF (is==1) THEN
1697 DO i=1,6
1698 DO ep=jft,jlt
1699 kl(i,i,ep)= kl(i,i,ep) + one
1700 ENDDO
1701 ENDDO
1702 END IF
1703C
1704 RETURN

◆ trankl2()

subroutine trankl2 ( integer jft,
integer jlt,
kl,
qni,
kr,
integer it )

Definition at line 2305 of file czsumg3.F.

2306C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
2307#include "implicit_f.inc"
2308C-----------------------------------------------
2309C D U M M Y A R G U M E N T S
2310C-----------------------------------------------
2311 INTEGER JFT,JLT,IT
2312 my_real
2313 . kl(6,6,*),qni(3,*),kr(6,6,*)
2314C-----------------------------------------------
2315C LOCAL A R G U M E N T S
2316C-----------------------------------------------
2317 INTEGER I,EP,J,K
2318C--------------update KL(6,j),j=4,6--by QNI------------------------
2319 DO i=1,6
2320 DO j=1,6
2321 DO ep=jft,jlt
2322 kr(i,j,ep)= kl(i,j,ep)
2323 ENDDO
2324 ENDDO
2325 ENDDO
2326C
2327 IF (it == 1 )THEN
2328 DO j=4,6
2329 k=j-3
2330 DO ep=jft,jlt
2331 kr(6,k,ep)= zero
2332 kr(6,j,ep)= qni(k,ep)
2333 ENDDO
2334 ENDDO
2335 ELSE
2336 DO j=4,6
2337 k=j-3
2338 DO ep=jft,jlt
2339 kr(k,6,ep)= zero
2340 kr(j,6,ep)= qni(k,ep)
2341 ENDDO
2342 ENDDO
2343 END IF !(IT == 1 )THEN
2344 RETURN

◆ tranklq()

subroutine tranklq ( integer jft,
integer jlt,
vq,
kl,
kd,
integer it )

Definition at line 1713 of file czsumg3.F.

1714C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
1715#include "implicit_f.inc"
1716C-----------------------------------------------
1717C D U M M Y A R G U M E N T S
1718C-----------------------------------------------
1719 INTEGER JFT,JLT,IT
1720 my_real
1721 . vq(3,3,*), kl(6,6,*), kd(6,6,*)
1722C-----------------------------------------------
1723C LOCAL A R G U M E N T S
1724C-----------------------------------------------
1725 INTEGER I,J,EP,K,L
1726C--------------KQ=KL*VQ-------IT=0-> KQ=KL^t*VQ--------------------------
1727 DO i=1,6
1728 DO j=1,6
1729 DO ep=jft,jlt
1730 kd(i,j,ep)= zero
1731 ENDDO
1732 ENDDO
1733 ENDDO
1734C
1735 IF (it==1) THEN
1736 DO i=1,3
1737 DO j=1,3
1738 DO ep=jft,jlt
1739 DO k=1,3
1740 kd(i,j,ep)=kd(i,j,ep)+kl(i,k,ep)*vq(k,j,ep)
1741 kd(i+3,j+3,ep)=kd(i+3,j+3,ep)+kl(i+3,k+3,ep)*vq(k,j,ep)
1742 kd(i,j+3,ep)=kd(i,j+3,ep)+kl(i,k+3,ep)*vq(k,j,ep)
1743 kd(i+3,j,ep)=kd(i+3,j,ep)+kl(i+3,k,ep)*vq(k,j,ep)
1744 ENDDO
1745 ENDDO
1746 ENDDO
1747 ENDDO
1748 ELSE
1749 DO i=1,3
1750 DO j=1,3
1751 DO ep=jft,jlt
1752 DO k=1,3
1753 kd(i,j,ep)=kd(i,j,ep)+kl(k,i,ep)*vq(k,j,ep)
1754 kd(i+3,j+3,ep)=kd(i+3,j+3,ep)+kl(k+3,i+3,ep)*vq(k,j,ep)
1755 kd(i,j+3,ep)=kd(i,j+3,ep)+kl(k+3,i,ep)*vq(k,j,ep)
1756 kd(i+3,j,ep)=kd(i+3,j,ep)+kl(k,i+3,ep)*vq(k,j,ep)
1757 ENDDO
1758 ENDDO
1759 ENDDO
1760 ENDDO
1761 END IF
1762 RETURN

◆ tranklqn()

subroutine tranklqn ( integer jft,
integer jlt,
vq,
vqn,
kl,
kd,
integer it )

Definition at line 2949 of file czsumg3.F.

2950C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
2951#include "implicit_f.inc"
2952C-----------------------------------------------
2953C D U M M Y A R G U M E N T S
2954C-----------------------------------------------
2955 INTEGER JFT,JLT,IT
2956 my_real
2957 . vq(3,3,*), vqn(3,3,*), kl(6,6,*), kd(6,6,*)
2958C-----------------------------------------------
2959C LOCAL A R G U M E N T S
2960C-----------------------------------------------
2961 INTEGER I,J,EP,K,L,J1,I1
2962C--------------KQ=KL*Q-- --Q=|VQ 0 |--IT=0-> KQ=KL^t*Q
2963C----------------------------|0 VQN|---------------------
2964 DO i=1,6
2965 DO j=1,6
2966 DO ep=jft,jlt
2967 kd(i,j,ep)= zero
2968 ENDDO
2969 ENDDO
2970 ENDDO
2971C
2972 IF (it==1) THEN
2973 DO i=1,3
2974 DO j=1,3
2975 DO ep=jft,jlt
2976 DO k=1,3
2977 kd(i,j,ep)=kd(i,j,ep)+kl(i,k,ep)*vq(k,j,ep)
2978 kd(i+3,j+3,ep)=kd(i+3,j+3,ep)+kl(i+3,k+3,ep)*vqn(k,j,ep)
2979 kd(i,j+3,ep)=kd(i,j+3,ep)+kl(i,k+3,ep)*vqn(k,j,ep)
2980 kd(i+3,j,ep)=kd(i+3,j,ep)+kl(i+3,k,ep)*vq(k,j,ep)
2981 ENDDO
2982 ENDDO
2983 ENDDO
2984 ENDDO
2985 ELSE
2986 DO i=1,3
2987 DO j=1,3
2988 DO ep=jft,jlt
2989 DO k=1,3
2990 kd(i,j,ep)=kd(i,j,ep)+kl(k,i,ep)*vq(k,j,ep)
2991 kd(i+3,j+3,ep)=kd(i+3,j+3,ep)+kl(k+3,i+3,ep)*vqn(k,j,ep)
2992 kd(i,j+3,ep)=kd(i,j+3,ep)+kl(k+3,i,ep)*vqn(k,j,ep)
2993 kd(i+3,j,ep)=kd(i+3,j,ep)+kl(k,i+3,ep)*vq(k,j,ep)
2994 ENDDO
2995 ENDDO
2996 ENDDO
2997 ENDDO
2998 END IF
2999C
3000 RETURN

◆ tranqikqj()

subroutine tranqikqj ( integer jft,
integer jlt,
vqi,
kk,
vqj,
integer nd,
integer isym )

Definition at line 1601 of file czsumg3.F.

1602C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
1603#include "implicit_f.inc"
1604#include "mvsiz_p.inc"
1605C-----------------------------------------------
1606C D U M M Y A R G U M E N T S
1607C-----------------------------------------------
1608 INTEGER JFT,JLT,ISYM,ND
1609 my_real
1610 . vqi(nd,nd,*), vqj(nd,nd,*),kk(nd,nd,*)
1611C-----------------------------------------------
1612C LOCAL A R G U M E N T S
1613C-----------------------------------------------
1614 INTEGER I,J,EP,K,L
1615 my_real,
1616 . DIMENSION(:,:,:), ALLOCATABLE:: kd
1617C--------------QI^tKKQJ---------------------------------
1618 ALLOCATE(kd(nd,nd,mvsiz))
1619 IF (isym==1) THEN
1620 DO i=1,nd
1621 DO j=i,nd
1622 DO ep=jft,jlt
1623 kd(i,j,ep)=zero
1624 DO k=1,nd
1625 DO l=1,nd
1626 kd(i,j,ep)=kd(i,j,ep)+vqi(k,i,ep)*kk(k,l,ep)*vqj(l,j,ep)
1627 ENDDO
1628 ENDDO
1629 ENDDO
1630 ENDDO
1631 ENDDO
1632C
1633 DO i=1,nd
1634 DO j=i,nd
1635 DO ep=jft,jlt
1636 kk(i,j,ep)= kd(i,j,ep)
1637 kk(j,i,ep)= kd(i,j,ep)
1638 ENDDO
1639 ENDDO
1640 ENDDO
1641 ELSE
1642 DO i=1,nd
1643 DO j=1,nd
1644 DO ep=jft,jlt
1645 kd(i,j,ep)=zero
1646 DO k=1,nd
1647 DO l=1,nd
1648 kd(i,j,ep)=kd(i,j,ep)+vqi(k,i,ep)*kk(k,l,ep)*vqj(l,j,ep)
1649 ENDDO
1650 ENDDO
1651 ENDDO
1652 ENDDO
1653 ENDDO
1654C
1655 DO i=1,nd
1656 DO j=1,nd
1657 DO ep=jft,jlt
1658 kk(i,j,ep)= kd(i,j,ep)
1659 ENDDO
1660 ENDDO
1661 ENDDO
1662 ENDIF
1663C
1664 DEALLOCATE(kd)
1665 RETURN

◆ tranqikqj67()

subroutine tranqikqj67 ( integer jft,
integer jlt,
vqi,
kk,
vqj,
kd,
integer isym )

Definition at line 1534 of file czsumg3.F.

1535C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
1536#include "implicit_f.inc"
1537C-----------------------------------------------
1538C D U M M Y A R G U M E N T S
1539C-----------------------------------------------
1540 INTEGER JFT,JLT,ISYM
1541 my_real
1542 . vqi(6,7,*), vqj(6,7,*),kk(7,7,*),kd(6,6,*)
1543C-----------------------------------------------
1544C LOCAL A R G U M E N T S
1545C-----------------------------------------------
1546 INTEGER I,J,EP,L
1547 my_real
1548 . k(6,6)
1549C--------------QI(6,7)KK(7,7)QJ^t(7,6)---------------------------------
1550 IF (isym==1) THEN
1551 DO i=1,6
1552 DO j=i,6
1553 DO ep=jft,jlt
1554 k(i,j)=zero
1555 DO l=1,7
1556 k(i,j)=k(i,j)+vqi(i,1,ep)*kk(1,l,ep)*vqj(j,l,ep)+
1557 1 vqi(i,2,ep)*kk(2,l,ep)*vqj(j,l,ep)+
1558 1 vqi(i,3,ep)*kk(3,l,ep)*vqj(j,l,ep)+
1559 1 vqi(i,4,ep)*kk(4,l,ep)*vqj(j,l,ep)+
1560 1 vqi(i,5,ep)*kk(5,l,ep)*vqj(j,l,ep)+
1561 1 vqi(i,6,ep)*kk(6,l,ep)*vqj(j,l,ep)+
1562 1 vqi(i,7,ep)*kk(7,l,ep)*vqj(j,l,ep)
1563 ENDDO
1564 kd(i,j,ep)= k(i,j)
1565 kd(j,i,ep)= k(i,j)
1566 ENDDO
1567 ENDDO
1568 ENDDO
1569C
1570 ELSE
1571 DO i=1,6
1572 DO j=1,6
1573 DO ep=jft,jlt
1574 k(i,j)=zero
1575 DO l=1,7
1576 k(i,j)=k(i,j)+vqi(i,1,ep)*kk(1,l,ep)*vqj(j,l,ep)+
1577 1 vqi(i,2,ep)*kk(2,l,ep)*vqj(j,l,ep)+
1578 1 vqi(i,3,ep)*kk(3,l,ep)*vqj(j,l,ep)+
1579 1 vqi(i,4,ep)*kk(4,l,ep)*vqj(j,l,ep)+
1580 1 vqi(i,5,ep)*kk(5,l,ep)*vqj(j,l,ep)+
1581 1 vqi(i,6,ep)*kk(6,l,ep)*vqj(j,l,ep)+
1582 1 vqi(i,7,ep)*kk(7,l,ep)*vqj(j,l,ep)
1583 ENDDO
1584 kd(i,j,ep)= k(i,j)
1585 ENDDO
1586 ENDDO
1587 ENDDO
1588C
1589 ENDIF
1590 RETURN

◆ tranqikqjrz()

subroutine tranqikqjrz ( integer jft,
integer jlt,
ri,
rd,
rj,
kl,
kr,
integer it,
integer is )

Definition at line 3047 of file czsumg3.F.

3049C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
3050#include "implicit_f.inc"
3051C-----------------------------------------------
3052C D U M M Y A R G U M E N T S
3053C-----------------------------------------------
3054 INTEGER JFT,JLT,IT,IS
3055 my_real
3056 . ri(3,3,*), rj(3,3,*),rd(3,*),kl(6,6,*),kr(6,6,*)
3057C-----------------------------------------------
3058C LOCAL A R G U M E N T S
3059C-----------------------------------------------
3060 INTEGER I,J,EP,L,I1,J1
3061 my_real
3062 . kij
3063C--------------[KR]=|RI| |RD| |RJ|^t---and [KR]=I-[KD]------
3064C-------------- | I| |I |--only for KR(6,j),KR(j,6)-for IT=0----
3065 DO i=1,6
3066 DO j=1,6
3067 DO ep=jft,jlt
3068 kr(i,j,ep)= kl(i,j,ep)
3069 ENDDO
3070 ENDDO
3071 ENDDO
3072C
3073C
3074 IF (it == 1) THEN
3075 DO j=1,3
3076 DO ep=jft,jlt
3077 kij=zero
3078 DO l=1,3
3079 kij=kij+rd(l,ep)*rj(j,l,ep)
3080 ENDDO
3081 kr(6,j,ep)= -kij
3082 ENDDO
3083 ENDDO
3084C
3085 DO j=1,3
3086 DO ep=jft,jlt
3087 kr(6,j+3,ep)= -rd(j,ep)
3088 ENDDO
3089 ENDDO
3090C
3091 ELSE
3092 DO j=1,3
3093 DO ep=jft,jlt
3094 kij=zero
3095 DO l=1,3
3096 kij=kij+ri(j,l,ep)*rd(l,ep)
3097 ENDDO
3098 kr(j,6,ep)= -kij
3099 ENDDO
3100 ENDDO
3101C
3102 DO j=1,3
3103 DO ep=jft,jlt
3104 kr(j+3,6,ep)= -rd(j,ep)
3105 ENDDO
3106 ENDDO
3107 END IF !(IT == 1) THEN
3108
3109 IF (is == 1) THEN
3110 DO ep=jft,jlt
3111 kr(6,6,ep)= one+kr(6,6,ep)
3112 ENDDO
3113 END IF !(IS == 1) THEN
3114C
3115 RETURN