SUBROUTINE COEF(STU,UC,ITRANS) C C ROUTINE FOR THE COMPUTATION OF REFLECTION/TRANSMISSION COEFFICIENTS C FOR GENERAL ISOTROPIC/ANISOTROPIC MEDIA C C INPUT PARAMETERS: C STU(1-3)... CARTESIAN COMPONENTS OF THE DISPLACEMENT VECTOR C STU(4-6)... CARTESIAN COMPONETS OF THE TRACTION VECTOR C ITRANS... ITRANS=O: REFLECTION C ITRANS=1: TRANSMISSION C ITRANS=999: SURFACE CONVERSION C C OUTPUT PARAMETERS: C UC(1-3)... RAY-CENTERED COMPONENTS OF THE DISPLACEMENT VECTOR C COMPLEX A(6,6),C(6,6),COA(3,3),COC(3,3),AA(6),TAU(3),P(3),U(3), 1CP1,CP2,CP3,DETA,DETC,UC(3),STU(6),cab DIMENSION Y(18),UN(3) COMMON /AUXI/IANI(20),INTR,INT1,IOUT,KRE,IREFR,LAY,NDER,IPRINT, 1 MPRINT,NTR,ISQRT,NAUX,ISOUR,MAUX,MREG,MDIM,IPOL,MSCON,LOUT, 2 IAMP,MTRNS,ICOEF,IAD,IRHO,ISHEAR,IAC,IRT,mori INTEGER CODE COMMON /COD/CODE(50,2),KREF,KC,ITYPE COMPLEX PS COMMON /RAY/ AY(28,400),DS(20,20),KINT(20),HHH(3,3),tmax, 1 PS(3,7,20),IS(8,20),DINC,DTOLD,N,IREF,IND,IND1 COMMON /ZERO/ RNULL C INDI=0 IF(ITRANS.Eq.999) THEN ITRANS=0 INDI=1 END IF I1=1 I2=3 LAY1=IS(1,IREF) LAY=IS(7,IREF) DO 910 K=1,6 IF(K.GT.3) GOTO 900 UN(K)=DS(K,IREF) 900 Y(K)=AY(K+1,N) 910 CONTINUE IF(ICOEF.GT.0) 1WRITE(LOUT,'(A,/,3(3F14.7,/),3I5)')'COEF: Y(1)-Y(6),UN,IREF,LAY, 2ITYPE',(Y(K),K=1,6),UN,IREF,LAY,ITYPE CALL PARDIS (Y,0) C C DISPLACEMENT AND STRESS VECTOR OF INCIDENT WAVE C BSTU=SQRT(REAL(STU(1)*CONJG(STU(1))+STU(2)*CONJG(STU(2)) 1 +STU(3)*CONJG(STU(3)))) do 950 k=1,3 P(k)=PS(k,7,IREF) STU(k)=STU(k)/BSTU U(k)=STU(k) 950 continue CALL STRESS (P,UN,U,TAU) do 960 k=1,3 STU(k+3)=TAU(k) 960 continue IF(ICOEF.GT.0) 1WRITE(LOUT,'(A,/,6(2F14.7,/))') 'COEF: INCIDENT U,TAU',U,TAU 1000 IF(IANI(LAY).EQ.0) GOTO 3000 C C COMPUTATION OF STRESS-DISPLACEMENT-VECTORS FOR GENERATED WAVES C C ANISOTROPIC CASE C 1010 IF(I1.GT.3)CALL PARDIS(Y,0) DO 1020 K=I1,I2 DO 1030 L=1,3 P(L)=PS(L,K,IREF) 1030 CONTINUE C C EVALUATION OF DISPLACEMENT VECTOR (MAY BE COMPLEX) C IF(I1.LE.3)MC=IS(5,IREF) IF(I1.GT.3)MC=IS(6,IREF) CALL DISPL(P,U,K) CALL STRESS(P,UN,U,TAU) IF(ICOEF.GT.0)WRITE(LOUT,'(A,/,9(2F14.7,/))')'COEF: P,U,TAU' 1,P,U,TAU DO 1060 L=1,3 A(K,L)=U(L) A(K,L+3)=TAU(L) 1060 CONTINUE 1020 CONTINUE IF(INDI.EQ.1) GOTO 5000 IF(I2.EQ.6) GOTO 4000 I1=4 I2=6 LAY=IS(8,IREF) IF(LAY.EQ.0) GOTO 5000 IF(IANI(LAY).NE.0) GOTO 1010 C C ISOTROPIC CASE C 3000 IF(I1.GT.3) CALL PARDIS(Y,0) IF(I1.LE.3) MC=IS(5,IREF) IF(I1.GT.3) MC=IS(6,IREF) DO 3010 L=1,3 P(L)=PS(L,I1,IREF) 3010 CONTINUE CP1=P(1) CP2=P(2) ivert=0 if(cabs(cp1).lt..0000001.and.cabs(cp2).lt..0000001)ivert=1 if(ivert.eq.1)then u(1)=1. u(2)=0. u(3)=0. go to 3020 end if cp3=-(CP1*CP1+CP2*CP2) CP1=cP1*p(3) CP2=cP2*p(3) cab=SQRT(REAL(cp1*CONJG(cp1)+cp2*CONJG(cp2)+cp3*CONJG(cp3))) U(1)=CP1/cab U(2)=CP2/cab U(3)=cp3/cab 3020 continue CALL STRESS(P,UN,U,TAU) IF(ICOEF.GT.0)WRITE(LOUT,'(A,/,9(2F14.7/))')'COEF: P,U,TAU' 1,P,U,TAU DO 3030 L=1,3 A(I1,L)=U(L) A(I1,L+3)=TAU(L) 3030 CONTINUE if(ivert.eq.1)then u(1)=0. u(2)=1. if(real(p(3)).lt.0.)u(2)=-1. u(3)=0. go to 3040 end if CP1=-P(2) CP2=P(1) CP3=CMPLX(0.,0.) cab=SQRT(REAL(cp1*CONJG(cp1)+cp2*CONJG(cp2)+cp3*CONJG(cp3))) U(1)=CP1/cab U(2)=CP2/cab U(3)=cp3/cab 3040 continue CALL STRESS (P,UN,U,TAU) IF(ICOEF.GT.0)WRITE(LOUT,'(A,/,9(2F14.7/))')'COEF: P,U,TAU' 1,P,U,TAU DO 3050 L=1,3 A(I1+1,L)=U(L) A(I1+1,L+3)=TAU(L) 3050 CONTINUE DO 3210 L=1,3 P(L)=PS(L,I2,IREF) 3210 CONTINUE CP1=P(1) CP2=P(2) CP3=P(3) cab=SQRT(REAL(cp1*CONJG(cp1)+cp2*CONJG(cp2)+cp3*CONJG(cp3))) U(1)=CP1/cab U(2)=CP2/cab U(3)=cp3/cab CALL STRESS (P,UN,U,TAU) IF(ICOEF.GT.0)WRITE(LOUT,'(A,/,9(2F14.7/))')'COEF: P,U,TAU' 1,P,U,TAU DO 3220 L=1,3 A(I2,L)=U(L) A(I2,L+3)=TAU(L) 3220 CONTINUE IF(INDI.EQ.1) GOTO 5000 IF(I2.EQ.6)GOTO 4000 I1=4 I2=6 LAY=IS(8,IREF) IF(LAY.EQ.0) GOTO 5000 GOTO 1000 C C REVERSE OF SIGNS FOR REFLECTIONS C 4000 DO 4010 L=1,3 DO 4010 K=1,6 A(L,K)=-A(L,K) 4010 CONTINUE IF(ICOEF.EQ.0) GOTO 4012 WRITE(LOUT,'(//,A)') 'COEF: MATRIX A' DO 4011 K=1,6 WRITE(LOUT,'(6(12F10.5))') (A(L,K),L=1,6) 4011 CONTINUE C C SOLUTION OF SYSTEM OF LINAER EQUATIONS ( CRAMERS METHOD ) C 4012 CALL DET6(A,DETA) do 4020 k=1,3 UC(k)=CMPLX(0.,0.) 4020 continue IF(CABS(DETA).LT.1.E-20) THEN WRITE(LOUT,'(A)') 1 'COEF: MATRIX A IS SINGULAR, PROGRAM TERMINATES' RETURN END IF IF(IANI(LAY1).NE.0.OR.ITYPE.EQ.3)THEN L1=ITYPE IF(ITRANS.NE.0)L1=L1+3 L2=L1 END IF IF(IANI(LAY1).EQ.0.AND.ITYPE.NE.3)THEN L1=1 IF(ITRANS.NE.0)L1=L1+3 L2=L1+1 END IF IF(ICOEF.NE.0) WRITE(LOUT,'(A,2I5)')'COEF: L1,L2',L1,L2 DO 4044 L=L1,L2 DO 4043 J=1,6 DO 4042 K=1,6 C(J,K)=A(J,K) IF(L.EQ.J)C(J,K)=STU(K) 4042 CONTINUE 4043 CONTINUE CALL DET6(C,DETC) AA(L)=DETC/DETA IF(ICOEF.GT.0)WRITE(LOUT,'(A,2F12.6)') 'COEF: AA=',AA(L) 4044 CONTINUE DO 4100 L=L1,L2 LL=L IF(ITRANS.NE.0)LL=L-3 UC(LL)=AA(L)*BSTU 4100 CONTINUE RETURN C C INTERACTION WITH THE FREE SURFACE C 5000 DO 5010 L=1,3 DO 5010 K=1,3 COA(L,K)=-A(L,K+3) 5010 CONTINUE IF(ICOEF.EQ.0)GO TO 5012 WRITE(LOUT,'(//,A)')'COEF: MATRIX COA' WRITE(LOUT,'(3(6F10.5/))')((COA(L,K),L=1,3),K=1,3) C C SOLUTION OF SYSTEM OF 3 LINEAR EQUATIONS (CRAMER'S METHOD) C 5012 CALL DET3(COA,DETA) IF(CABS(DETA).LT.1.-09)THEN WRITE(LOUT,'(A)')'COEF: MATRIX COA IS SINGULAR, 1 PROGRAM TERMINATES' STOP END IF DO 5044 L=1,3 DO 5043 J=1,3 DO 5042 K=1,3 COC(J,K)=COA(J,K) IF(L.EQ.J)COC(J,K)=STU(K+3) 5042 CONTINUE 5043 CONTINUE CALL DET3(COC,DETC) AA(L)=DETC/DETA IF(ICOEF.GT.0) 1WRITE(LOUT,'(A,2F12.6)')'COEF: AA=',AA(L) 5044 CONTINUE if(indi.ne.1)GO TO 5200 C C CONVERSION AT THE FREE SURFACE C do 5100 k=1,3 U(k)=CMPLX(0.,0.) DO 5050 J=1,3 U(k)=AA(J)*A(J,k)+U(k) 5050 CONTINUE UC(k)=U(k)+STU(k) 5100 continue IF(ICOEF.GT.0)WRITE(LOUT,'(A,/,3(2F12.5/))') 'COEF: 1 NORMALIZED CONVERSION-VECTOR',UC do 5150 k=1,3 UC(k)=UC(k)*BSTU 5150 continue IF(ICOEF.GT.0)WRITE(LOUT,'(A,/,3(2F12.5/))') 'COEF: 1 CONVERSION-VECTOR',UC RETURN C C REFLECTION FROM THE FREE SURFACE C 5200 L1=1 IF(ITYPE.EQ.3)L1=3 L2=2 IF(ITYPE.EQ.3)L2=3 do 5250 k=1,3 UC(k)=CMPLX(0.,0.) 5250 continue DO 5300 L=L1,L2 UC(L)=AA(L)*BSTU 5300 CONTINUE RETURN END