您所在位置：主题：求问CVF6.5程序改成 Gfortran 程序！
zqt27
[专家分：0] 发布于 2011-05-04 13:57:00
大家好，我初用gfortran，在把以前用cvf6.5编的程序放上去算的时候，编译出错，我不太熟悉gfortran 求问高手在把cvf程序改成gfortran程序是要改哪些地方，谢谢了。我把我的程序贴在下面
PROGRAM SPINCURRENT
IMPLICIT NONE
REAL(8) :: EF, V1=210._8, V2=210._8,V3=5._8, V4=-5._8, PHI1, PI=3.1415925_8 ,KY,ISPINU=0._8 ,ISPIND=0._8,ISPINT,ICHARGE
REAL(8) :: L1=-125._8, L2=-95._8, L3=-95._8, L4=-15._8, L5=-15._8, L6=15._8, L7=15._8, L8=95._8, L9=95._8, L10=125._8
REAL(8) :: DV=0.0001_8
COMPLEX(8) :: I1, I2
COMPLEX(8) :: SA(4) , SBU(4), SBD(4), SC(4)
COMPLEX(8) :: SAF(4),SCF(4)
COMPLEX(8) :: SEU(4), SEUF(4), SEU1F(4), SED(4), SEDF(4), SED1F(4)
COMPLEX(8) :: SGU(4), SGD(4), SH(4), SHF(4)
COMPLEX(8) :: SIU(4), SIUF(4), SIU1F(4), SID(4), SIDF(4), SID1F(4)
COMPLEX(8) :: SAF1(4),SCF1(4),SEUF1(4), SEU1F1(4), SEDF1(4), SED1F1(4), SHF1(4),SIUF1(4), SIU1F1(4), SIDF1(4), SID1F1(4)
OPEN (10, FILE = 'D:\SPINCURRENT.TXT')
OPEN (12, FILE = 'D:\SPINCURRENT2.TXT')
LOOP1: DO EF =0.11_8, 210._8, 0.1_8
LOOP2: DO KY=-EF,EF, EF/5000._8
! IF(ABS(KY/EF)>1.) CYCLE LOOP2
IF(KY/EF>1._8)THEN
PHI1=3.1415925_8/2._8
ELSEIF(KY/EF<-1._8)THEN
PHI1=-3.1415925_8/2._8
ELSE
PHI1=dASIN(KY/(EF))
ENDIF
!SCATTERING MATRIX OF EVERY BARRIER
CALL F1(L1,L2,EF,V1,PHI1,SA)
CALL F1(L3,L4,EF,V3,PHI1,SBU)
CALL F1(L3,L4,EF,V4,PHI1,SBD)
CALL F1(L5,L6,EF,V2,PHI1,SC)
CALL F1(L1,L2,EF,V1+DV,PHI1,SAF)
CALL F1(L5,L6,EF,V2+DV,PHI1,SCF)
CALL F1(L1,L2,EF,V1-DV,PHI1,SAF1)
CALL F1(L5,L6,EF,V2-DV,PHI1,SCF1)
!SCATTERING MATRIX FOR TWO NEW BARRIERS
CALL F1(L7,L8,EF,V3,PHI1,SGU)
CALL F1(L7,L8,EF,V4,PHI1,SGD)
CALL F1(L9,L10,EF,V1,PHI1,SH)
CALL F1(L9,L10,EF,V1+DV,PHI1,SHF)
CALL F1(L9,L10,EF,V1-DV,PHI1,SHF1)
CALL F(SA,SBU,SC,SGD,SH,SIU)
CALL F(SAF,SBU,SC,SGD,SHF,SIUF)
CALL F(SA,SBU,SCF,SGD,SH,SIU1F)
CALL F(SAF1,SBU,SC,SGD,SHF1,SIUF1)
CALL F(SA,SBU,SCF1,SGD,SH,SIU1F1)
CALL F(SA,SBD,SC,SGU,SH,SID)
CALL F(SAF,SBD,SC,SGU,SHF,SIDF)
CALL F(SA,SBD,SCF,SGU,SH,SID1F)
CALL F(SAF1,SBD,SC,SGU,SHF1,SIDF1)
CALL F(SA,SBD,SCF1,SGU,SH,SID1F1)
I1=((DCONJG(SIUF(1)-SIUF1(1)))/(2._8*DV))*( SIU1F(1)- SIU1F1(1))/(2._8*DV)+((dCONJG(SIUF(2)- SIUF1(2)))/(2._8*DV))*( SIU1F(2)- SIU1F1(2))/(2._8*DV)
ISPINU=ISPINU+dIMAG(I1)*EF/5000._8
I2=((dCONJG(SIDF(1)-SIDF1(1)))/(2._8*DV))*( SID1F(1)- SID1F1(1))/(2._8*DV)+((dCONJG(SIDF(2)- SIDF1(2)))/(2._8*DV))*( SID1F(2)- SID1F1(2))/(2._8*DV)
ISPIND=ISPIND+dIMAG(I2)*EF/5000._8
ISPINT=ISPINU-ISPIND
ICHARGE=ISPINU+ISPIND
! WRITE(10,20) PHI1, 10000._8*ISPINT, 10000._8*ICHARGE !SA !ISPINT, ICHARGE
END DO LOOP2
WRITE(*,*) EF, 0.484*4._8*ISPINT,0.484*4._8*ICHARGE
WRITE(10,*) EF, 0.484*4._8*ISPINT, 0.484*4._8*ICHARGE
! 20 format(5f10.6)
ISPINU=0._8
ISPIND=0._8
END DO LOOP1
END
!SUBROUTINE F COMBINE THREE BARRIERS TOGETHER
SUBROUTINE F(SA, SB, SC, SD, SE, SK)
IMPLICIT NONE
COMPLEX(8), INTENT(OUT)::SK(4)
COMPLEX(8), INTENT(IN):: SA(4), SB(4), SC(4), SD(4), SE(4)
COMPLEX(8):: SF(4), SG(4), SH(4)
SF(3)=SB(3)*SA(3)/(1._8-SA(4)*SB(1))
SF(1)=SA(1)+SA(2)*SB(1)*SA(3)/(1._8-SA(4)*SB(1))
SF(2)=SA(2)*SB(2)/(1._8-SB(1)*SA(4))
SF(4)=SB(4)+SB(3)*SA(4)*SB(2)/(1._8-SA(4)*SB(1))
SG(3)=SC(3)*SF(3)/(1._8-SF(4)*SC(1))
SG(1)=SF(1)+SF(2)*SC(1)*SF(3)/(1._8-SF(4)*SC(1))
SG(2)=SF(2)*SC(2)/(1._8-SC(1)*SF(4))
SG(4)=SC(4)+SC(3)*SF(4)*SC(2)/(1._8-SF(4)*SC(1))
SH(3)=SD(3)*SG(3)/(1._8-SG(4)*SD(1))
SH(1)=SG(1)+SG(2)*SD(1)*SG(3)/(1._8-SG(4)*SD(1))
SH(2)=SG(2)*SD(2)/(1._8-SD(1)*SG(4))
SH(4)=SD(4)+SD(3)*SG(4)*SD(2)/(1._8-SG(4)*SD(1))
SK(3)=SE(3)*SH(3)/(1._8-SH(4)*SE(1))
SK(1)=SH(1)+SH(2)*SE(1)*SH(3)/(1._8-SH(4)*SE(1))
SK(2)=SH(2)*SE(2)/(1._8-SE(1)*SH(4))
SK(4)=SE(4)+SE(3)*SH(4)*SE(2)/(1._8-SH(4)*SE(1))
END SUBROUTINE F
!SUBROUTINE F1 SUPPLYING S-MATRIX FOR UP SPIN FM BARRIER, AND S-MATRIX FOR UP SPIN AND DOWN SPIN POTENTIAL BARRIER1 AND BARRIER3
SUBROUTINE F1(L1,L2,EF,V1,PHI1,SA)
IMPLICIT NONE
COMPLEX(8), INTENT(OUT):: SA(4)
REAL(8), INTENT(IN) :: EF, V1, PHI1, L1, L2
REAL(8), PARAMETER :: CONS = 1.5172D-3
REAL(8) :: Q1, Q2, PHI2,BETA, RHO,DELTA,KX,KY, CM,PHIC
REAL(8):: S, SP
complex(8) :: M,N,P,Q,U,V,H,G,K,LA
CM=dABS(EF/(EF-V1))
S=EF/dABS(EF)
SP=(EF-V1)/dABS(EF-V1)
IF(CM <=1._8) THEN
KY = dABS(EF)*dSIN(PHI1)
PHI2 = dASIN(KY/dABS(V1 - EF))
Q1 = dABS(EF)*dCOS(PHI1)
Q2 = dABS(V1 - EF)*dCOS(PHI2)
M=cdEXP(dCMPLX(0._8, CONS*Q1*L1))
N=cdEXP(dCMPLX(0._8, CONS*Q2*L1))
P=cdEXP(dCMPLX(0._8, CONS*Q2*L2))
Q=cdEXP(dCMPLX(0._8, CONS*Q1*L2))
U=cdEXP(dCMPLX(0._8,PHI1))
V=cdEXP(dCMPLX(0._8,PHI2))
SA(1)=(M*M*(N*N-P*P)*U*(S*S*U*U*V-S*U*(-1._8+V*V)*SP-V*SP*SP))/((N*N-P*P)*S*S*U*V+S*(P*P*(U*U+V*V)+N*N*(1._8+U*U*V*V))*SP+(N*N-P*P)*U*V*SP*SP)
SA(2)=M*N*P*S*(1._8+U*U)*(1._8+V*V)*SP/(Q*((N*N-P*P)*S*S*U*V+S*(P*P*(U*U+V*V)+N*N*(1._8+U*U*V*V))*SP+(N*N-P*P)*U*V*SP*SP))
SA(3)=M*N*P*S*(1._8+U*U)*(1._8+V*V)*SP/(Q*((N*N-P*P)*S*S*U*V+S*(P*P*(U*U+V*V)+N*N*(1._8+U*U*V*V))*SP+(N*N-P*P)*U*V*SP*SP))
SA(4)=(N*N-P*P)*(S*S*V+S*U*(-1._8+V*V)*SP-U*U*V*SP*SP)/(Q*Q*U*((N*N-P*P)*S*S*U*V+S*(P*P*(U*U+V*V)+N*N*(1._8+U*U*V*V))*SP+(N*N-P*P)*U*V*SP*SP))
ELSEIF(CM>1._8) THEN
PHIC=dASIN(dABS((EF-V1)/EF))
IF(dABS(PHI1) <=dABS(PHIC)) THEN
KY = dABS(EF)*dSIN(PHI1)
PHI2 = dASIN(KY/dABS(V1 - EF))
Q1 = dABS(EF)*dCOS(PHI1)
Q2 = dABS(V1 - EF)*dCOS(PHI2)
M=cdEXP(dCMPLX(0._8, CONS*Q1*L1))
N=cdEXP(dCMPLX(0._8, CONS*Q2*L1))
P=cdEXP(dCMPLX(0._8, CONS*Q2*L2))
Q=cdEXP(dCMPLX(0._8, CONS*Q1*L2))
U=cdEXP(dCMPLX(0._8,PHI1))
V=cdEXP(dCMPLX(0._8,PHI2))
SA(1)=(M*M*(N*N-P*P)*U*(S*S*U*U*V-S*U*(-1._8+V*V)*SP-V*SP*SP))/((N*N-P*P)*S*S*U*V+S*(P*P*(U*U+V*V)+N*N*(1._8+U*U*V*V))*SP+(N*N-P*P)*U*V*SP*SP)
SA(2)=M*N*P*S*(1._8+U*U)*(1._8+V*V)*SP/(Q*((N*N-P*P)*S*S*U*V+S*(P*P*(U*U+V*V)+N*N*(1._8+U*U*V*V))*SP+(N*N-P*P)*U*V*SP*SP))
SA(3)=M*N*P*S*(1._8+U*U)*(1._8+V*V)*SP/(Q*((N*N-P*P)*S*S*U*V+S*(P*P*(U*U+V*V)+N*N*(1._8+U*U*V*V))*SP+(N*N-P*P)*U*V*SP*SP))
SA(4)=(N*N-P*P)*(S*S*V+S*U*(-1._8+V*V)*SP-U*U*V*SP*SP)/(Q*Q*U*((N*N-P*P)*S*S*U*V+S*(P*P*(U*U+V*V)+N*N*(1._8+U*U*V*V))*SP+(N*N-P*P)*U*V*SP*SP))
ELSEIF(dABS(PHI1)>dABS(PHIC)) THEN
KX=dABS(EF)*dCOS(PHI1)
KY=dABS(EF)*dSIN(PHI1)
BETA = dSQRT(dABS(KY*KY - (V1 - EF)*(V1- EF)))
DELTA = (dABS(V1 - EF))/(KY + BETA)
RHO = (dABS(V1 - EF))/(KY - BETA)
M=cdEXP(dCMPLX(0._8, CONS*KX*L1))
P=dCMPLX(0._8, DELTA)
U= cdEXP(dCMPLX(0._8, PHI1))
H=dCMPLX(0._8, RHO)
K=cdEXP(dCMPLX(0._8, CONS*KX*L2))
LA=dEXP(CONS*BETA*(L2-L1))
SA(1)=M*M*(LA*LA-1._8)*U*(S*U-H*SP)*(S*U-P*SP)/( (LA*LA-1._8)*S*S*U+S*(H*(1._8+LA*LA*U*U)-P*(LA*LA+ U*U))*SP+H*(-LA*LA+1._8)*P*U*SP*SP)
SA(2)=LA*M*(H-P)*S*(1._8+U*U)*SP/(K*((LA*LA-1._8)*S*S*U+S*(H*(1._8+LA*LA*U*U)-P*(LA*LA+U*U))*SP+H*(-LA*LA+1._8)*P*U*SP*SP))
SA(3)=LA*M*(H-P)*S*(1._8+U*U)*SP/(K*((LA*LA-1._8)*S*S*U+S*(H*(1._8+LA*LA*U*U)-P*(LA*LA+U*U))*SP+H*(-LA*LA+1._8)*P*U*SP*SP))
SA(4)=(LA*LA-1._8)*(S+H*U*SP)*(S+P*U*SP)/(K*K*U*((LA*LA-1._8)*S*S*U+S*(H*(1._8+LA*LA*U*U)-P*(LA*LA+ U*U))*SP+H*(-LA*LA+1._8)*P*U*SP*SP))
ENDIF
ENDIF
END SUBROUTINE F1
PROGRAM SPINCURRENT
IMPLICIT NONE
REAL(8) :: EF, V1=210._8, V2=210._8,V3=5._8, V4=-5._8, PHI1, PI=3.1415925_8 ,KY,ISPINU=0._8 ,ISPIND=0._8,ISPINT,ICHARGE
REAL(8) :: L1=-125._8, L2=-95._8, L3=-95._8, L4=-15._8, L5=-15._8, L6=15._8, L7=15._8, L8=95._8, L9=95._8, L10=125._8
REAL(8) :: DV=0.0001_8
COMPLEX(8) :: I1, I2
COMPLEX(8) :: SA(4) , SBU(4), SBD(4), SC(4)
COMPLEX(8) :: SAF(4),SCF(4)
COMPLEX(8) :: SEU(4), SEUF(4), SEU1F(4), SED(4), SEDF(4), SED1F(4)
COMPLEX(8) :: SGU(4), SGD(4), SH(4), SHF(4)
COMPLEX(8) :: SIU(4), SIUF(4), SIU1F(4), SID(4), SIDF(4), SID1F(4)
COMPLEX(8) :: SAF1(4),SCF1(4),SEUF1(4), SEU1F1(4), SEDF1(4), SED1F1(4), SHF1(4),SIUF1(4), SIU1F1(4), SIDF1(4), SID1F1(4)
OPEN (10, FILE = 'D:\SPINCURRENT.TXT')
OPEN (12, FILE = 'D:\SPINCURRENT2.TXT')
LOOP1: DO EF =0.11_8, 210._8, 0.1_8
LOOP2: DO KY=-EF,EF, EF/5000._8
! IF(ABS(KY/EF)>1.) CYCLE LOOP2
IF(KY/EF>1._8)THEN
PHI1=3.1415925_8/2._8
ELSEIF(KY/EF<-1._8)THEN
PHI1=-3.1415925_8/2._8
ELSE
PHI1=dASIN(KY/(EF))
ENDIF
!SCATTERING MATRIX OF EVERY BARRIER
CALL F1(L1,L2,EF,V1,PHI1,SA)
CALL F1(L3,L4,EF,V3,PHI1,SBU)
CALL F1(L3,L4,EF,V4,PHI1,SBD)
CALL F1(L5,L6,EF,V2,PHI1,SC)
CALL F1(L1,L2,EF,V1+DV,PHI1,SAF)
CALL F1(L5,L6,EF,V2+DV,PHI1,SCF)
CALL F1(L1,L2,EF,V1-DV,PHI1,SAF1)
CALL F1(L5,L6,EF,V2-DV,PHI1,SCF1)
!SCATTERING MATRIX FOR TWO NEW BARRIERS
CALL F1(L7,L8,EF,V3,PHI1,SGU)
CALL F1(L7,L8,EF,V4,PHI1,SGD)
CALL F1(L9,L10,EF,V1,PHI1,SH)
CALL F1(L9,L10,EF,V1+DV,PHI1,SHF)
CALL F1(L9,L10,EF,V1-DV,PHI1,SHF1)
CALL F(SA,SBU,SC,SGD,SH,SIU)
CALL F(SAF,SBU,SC,SGD,SHF,SIUF)
CALL F(SA,SBU,SCF,SGD,SH,SIU1F)
CALL F(SAF1,SBU,SC,SGD,SHF1,SIUF1)
CALL F(SA,SBU,SCF1,SGD,SH,SIU1F1)
CALL F(SA,SBD,SC,SGU,SH,SID)
CALL F(SAF,SBD,SC,SGU,SHF,SIDF)
CALL F(SA,SBD,SCF,SGU,SH,SID1F)
CALL F(SAF1,SBD,SC,SGU,SHF1,SIDF1)
CALL F(SA,SBD,SCF1,SGU,SH,SID1F1)
I1=((DCONJG(SIUF(1)-SIUF1(1)))/(2._8*DV))*( SIU1F(1)- SIU1F1(1))/(2._8*DV)+((dCONJG(SIUF(2)- SIUF1(2)))/(2._8*DV))*( SIU1F(2)- SIU1F1(2))/(2._8*DV)
ISPINU=ISPINU+dIMAG(I1)*EF/5000._8
I2=((dCONJG(SIDF(1)-SIDF1(1)))/(2._8*DV))*( SID1F(1)- SID1F1(1))/(2._8*DV)+((dCONJG(SIDF(2)- SIDF1(2)))/(2._8*DV))*( SID1F(2)- SID1F1(2))/(2._8*DV)
ISPIND=ISPIND+dIMAG(I2)*EF/5000._8
ISPINT=ISPINU-ISPIND
ICHARGE=ISPINU+ISPIND
! WRITE(10,20) PHI1, 10000._8*ISPINT, 10000._8*ICHARGE !SA !ISPINT, ICHARGE
END DO LOOP2
WRITE(*,*) EF, 0.484*4._8*ISPINT,0.484*4._8*ICHARGE
WRITE(10,*) EF, 0.484*4._8*ISPINT, 0.484*4._8*ICHARGE
! 20 format(5f10.6)
ISPINU=0._8
ISPIND=0._8
END DO LOOP1
END
!SUBROUTINE F COMBINE THREE BARRIERS TOGETHER
SUBROUTINE F(SA, SB, SC, SD, SE, SK)
IMPLICIT NONE
COMPLEX(8), INTENT(OUT)::SK(4)
COMPLEX(8), INTENT(IN):: SA(4), SB(4), SC(4), SD(4), SE(4)
COMPLEX(8):: SF(4), SG(4), SH(4)
SF(3)=SB(3)*SA(3)/(1._8-SA(4)*SB(1))
SF(1)=SA(1)+SA(2)*SB(1)*SA(3)/(1._8-SA(4)*SB(1))
SF(2)=SA(2)*SB(2)/(1._8-SB(1)*SA(4))
SF(4)=SB(4)+SB(3)*SA(4)*SB(2)/(1._8-SA(4)*SB(1))
SG(3)=SC(3)*SF(3)/(1._8-SF(4)*SC(1))
SG(1)=SF(1)+SF(2)*SC(1)*SF(3)/(1._8-SF(4)*SC(1))
SG(2)=SF(2)*SC(2)/(1._8-SC(1)*SF(4))
SG(4)=SC(4)+SC(3)*SF(4)*SC(2)/(1._8-SF(4)*SC(1))
SH(3)=SD(3)*SG(3)/(1._8-SG(4)*SD(1))
SH(1)=SG(1)+SG(2)*SD(1)*SG(3)/(1._8-SG(4)*SD(1))
SH(2)=SG(2)*SD(2)/(1._8-SD(1)*SG(4))
SH(4)=SD(4)+SD(3)*SG(4)*SD(2)/(1._8-SG(4)*SD(1))
SK(3)=SE(3)*SH(3)/(1._8-SH(4)*SE(1))
SK(1)=SH(1)+SH(2)*SE(1)*SH(3)/(1._8-SH(4)*SE(1))
SK(2)=SH(2)*SE(2)/(1._8-SE(1)*SH(4))
SK(4)=SE(4)+SE(3)*SH(4)*SE(2)/(1._8-SH(4)*SE(1))
END SUBROUTINE F
!SUBROUTINE F1 SUPPLYING S-MATRIX FOR UP SPIN FM BARRIER, AND S-MATRIX FOR UP SPIN AND DOWN SPIN POTENTIAL BARRIER1 AND BARRIER3
SUBROUTINE F1(L1,L2,EF,V1,PHI1,SA)
IMPLICIT NONE
COMPLEX(8), INTENT(OUT):: SA(4)
REAL(8), INTENT(IN) :: EF, V1, PHI1, L1, L2
REAL(8), PARAMETER :: CONS = 1.5172D-3
REAL(8) :: Q1, Q2, PHI2,BETA, RHO,DELTA,KX,KY, CM,PHIC
REAL(8):: S, SP
complex(8) :: M,N,P,Q,U,V,H,G,K,LA
CM=dABS(EF/(EF-V1))
S=EF/dABS(EF)
SP=(EF-V1)/dABS(EF-V1)
IF(CM <=1._8) THEN
KY = dABS(EF)*dSIN(PHI1)
PHI2 = dASIN(KY/dABS(V1 - EF))
Q1 = dABS(EF)*dCOS(PHI1)
Q2 = dABS(V1 - EF)*dCOS(PHI2)
M=cdEXP(dCMPLX(0._8, CONS*Q1*L1))
N=cdEXP(dCMPLX(0._8, CONS*Q2*L1))
P=cdEXP(dCMPLX(0._8, CONS*Q2*L2))
Q=cdEXP(dCMPLX(0._8, CONS*Q1*L2))
U=cdEXP(dCMPLX(0._8,PHI1))
V=cdEXP(dCMPLX(0._8,PHI2))
SA(1)=(M*M*(N*N-P*P)*U*(S*S*U*U*V-S*U*(-1._8+V*V)*SP-V*SP*SP))/((N*N-P*P)*S*S*U*V+S*(P*P*(U*U+V*V)+N*N*(1._8+U*U*V*V))*SP+(N*N-P*P)*U*V*SP*SP)
SA(2)=M*N*P*S*(1._8+U*U)*(1._8+V*V)*SP/(Q*((N*N-P*P)*S*S*U*V+S*(P*P*(U*U+V*V)+N*N*(1._8+U*U*V*V))*SP+(N*N-P*P)*U*V*SP*SP))
SA(3)=M*N*P*S*(1._8+U*U)*(1._8+V*V)*SP/(Q*((N*N-P*P)*S*S*U*V+S*(P*P*(U*U+V*V)+N*N*(1._8+U*U*V*V))*SP+(N*N-P*P)*U*V*SP*SP))
SA(4)=(N*N-P*P)*(S*S*V+S*U*(-1._8+V*V)*SP-U*U*V*SP*SP)/(Q*Q*U*((N*N-P*P)*S*S*U*V+S*(P*P*(U*U+V*V)+N*N*(1._8+U*U*V*V))*SP+(N*N-P*P)*U*V*SP*SP))
ELSEIF(CM>1._8) THEN
PHIC=dASIN(dABS((EF-V1)/EF))
IF(dABS(PHI1) <=dABS(PHIC)) THEN
KY = dABS(EF)*dSIN(PHI1)
PHI2 = dASIN(KY/dABS(V1 - EF))
Q1 = dABS(EF)*dCOS(PHI1)
Q2 = dABS(V1 - EF)*dCOS(PHI2)
M=cdEXP(dCMPLX(0._8, CONS*Q1*L1))
N=cdEXP(dCMPLX(0._8, CONS*Q2*L1))
P=cdEXP(dCMPLX(0._8, CONS*Q2*L2))
Q=cdEXP(dCMPLX(0._8, CONS*Q1*L2))
U=cdEXP(dCMPLX(0._8,PHI1))
V=cdEXP(dCMPLX(0._8,PHI2))
SA(1)=(M*M*(N*N-P*P)*U*(S*S*U*U*V-S*U*(-1._8+V*V)*SP-V*SP*SP))/((N*N-P*P)*S*S*U*V+S*(P*P*(U*U+V*V)+N*N*(1._8+U*U*V*V))*SP+(N*N-P*P)*U*V*SP*SP)
SA(2)=M*N*P*S*(1._8+U*U)*(1._8+V*V)*SP/(Q*((N*N-P*P)*S*S*U*V+S*(P*P*(U*U+V*V)+N*N*(1._8+U*U*V*V))*SP+(N*N-P*P)*U*V*SP*SP))
SA(3)=M*N*P*S*(1._8+U*U)*(1._8+V*V)*SP/(Q*((N*N-P*P)*S*S*U*V+S*(P*P*(U*U+V*V)+N*N*(1._8+U*U*V*V))*SP+(N*N-P*P)*U*V*SP*SP))
SA(4)=(N*N-P*P)*(S*S*V+S*U*(-1._8+V*V)*SP-U*U*V*SP*SP)/(Q*Q*U*((N*N-P*P)*S*S*U*V+S*(P*P*(U*U+V*V)+N*N*(1._8+U*U*V*V))*SP+(N*N-P*P)*U*V*SP*SP))
ELSEIF(dABS(PHI1)>dABS(PHIC)) THEN
KX=dABS(EF)*dCOS(PHI1)
KY=dABS(EF)*dSIN(PHI1)
BETA = dSQRT(dABS(KY*KY - (V1 - EF)*(V1- EF)))
DELTA = (dABS(V1 - EF))/(KY + BETA)
RHO = (dABS(V1 - EF))/(KY - BETA)
M=cdEXP(dCMPLX(0._8, CONS*KX*L1))
P=dCMPLX(0._8, DELTA)
U= cdEXP(dCMPLX(0._8, PHI1))
H=dCMPLX(0._8, RHO)
K=cdEXP(dCMPLX(0._8, CONS*KX*L2))
LA=dEXP(CONS*BETA*(L2-L1))
SA(1)=M*M*(LA*LA-1._8)*U*(S*U-H*SP)*(S*U-P*SP)/( (LA*LA-1._8)*S*S*U+S*(H*(1._8+LA*LA*U*U)-P*(LA*LA+ U*U))*SP+H*(-LA*LA+1._8)*P*U*SP*SP)
SA(2)=LA*M*(H-P)*S*(1._8+U*U)*SP/(K*((LA*LA-1._8)*S*S*U+S*(H*(1._8+LA*LA*U*U)-P*(LA*LA+U*U))*SP+H*(-LA*LA+1._8)*P*U*SP*SP))
SA(3)=LA*M*(H-P)*S*(1._8+U*U)*SP/(K*((LA*LA-1._8)*S*S*U+S*(H*(1._8+LA*LA*U*U)-P*(LA*LA+U*U))*SP+H*(-LA*LA+1._8)*P*U*SP*SP))
SA(4)=(LA*LA-1._8)*(S+H*U*SP)*(S+P*U*SP)/(K*K*U*((LA*LA-1._8)*S*S*U+S*(H*(1._8+LA*LA*U*U)-P*(LA*LA+ U*U))*SP+H*(-LA*LA+1._8)*P*U*SP*SP))
ENDIF
ENDIF
END SUBROUTINE F1