      SUBROUTINE MODIN(ICOM,IOPT,DEP,DRIL,AOM)
c      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*4 ABUF,BUF,WW,QQ,CG1
      INTEGER*2 NN,LL,NVEC,NN0
      CHARACTER*80 IGNO
      DIMENSION SR(1000),PR(1000),QR(1000),D(100),CC(1000),ET(1000)
      DIMENSION EIT(1000),c(1000),ui(1000)
      COMMON/BITS/PI,RN,VN,WN,GN,FL,FL1,FL2,FL3,SFL3,JCOM
      COMMON/EIGEN/AS(600),AP(600),AQ(600),CT(600),UU(600),Q(600)
     *,TT(600)
      COMMON/RINDX/NIC,NOC,NSL,NICP1,NOCP1,NSLP1,N
      COMMON/EIFX/A(6,600)
      COMMON/BUF$/NN,LL,WW,QQ,CG1,BUF(1338)
      COMMON/MODD/TB(600),R(600),NRAD,NMOD,MOD(20),NTOT,EIP(600)
     *,NF(4),NLA(4)
      COMMON/FRER/QI(600)
      DIMENSION ABUF(1342)
c     EQUIVALENCE(NN,ABUF)
      DATA NVEC/1342/,IFST/1/
      DATA RHOBAR/5515.0/
      PI=3.1415926535
      TPI=2.*PI
      JCOM=ICOM
      RD=6371.E3-DEP*1.E3
      IP=1
      NN0=MOD(1)
c      NVEC=2*NRAD+4
       NVEC=2*NRAD
      IOB=9
c      IF(JCOM.EQ.3) NVEC=6*NRAD+4
      IF(JCOM.EQ.3) NVEC=6*NRAD
      print*,'MODE NUMBER'
      READ(5,*)IMOD
	print*,'imod',imod
      print*,'ENTER EIGENFUNCTION FILENAME'
      READ(5,'(a80)')igno
1001      FORMAT(18A2)
	write(6,'(a80)')igno
      OPEN(9,FILE=IGNO,form='unformatted')
5     CONTINUE
      READ(IOB,END=900) rnn,rll,ww,qq,cg1,(buf(i),i=1,nvec)
	print*,'rnn rll ww',rnn,rll,ww
      TT(IP)=2.*PI/WW
      CC(IP)=WW*6371./(rll+0.5)
      UU(IP)=CG1
      EIT(IP)=QQ
      ET(IP)=PI/TT(IP)/EIT(IP)/UU(IP)
      EIP(IP)=QQ/ET(IP)
      IF(TT(IP).GT.TB(1))GO TO 5
      IF(TT(IP).LT.TB(NTOT))GO TO 900
	ll=rll
c     WRITE(6,205)TT(IP),CC(IP),cg1,qq
205     FORMAT(F10.3,3f8.3)
500      CONTINUE
      IFLAG=0
      W=WW/WN
      WSQ=W*W
      NORD=rNN
      L=rLL
      CG=CG1
      QINV=QQ
      FL=L
      FL1=FL+1.D0
      FL2=FL+FL1
      FL3=FL*FL1
      SFL3=SQRT(FL3)
      DO 10 I=1,NRAD
      A(1,I)=BUF(I)
      J=I+NRAD
      A(2,I)=BUF(J)
      IF(JCOM.NE.3) GOTO 10
      J=J+NRAD
      A(3,I)=BUF(J)
      J=J+NRAD
      A(4,I)=BUF(J)
      J=J+NRAD
      A(5,I)=BUF(J)
      J=J+NRAD
      A(6,I)=BUF(J)
C      PRINT 999,I,(A(J,I),J=1,6)
  999 FORMAT(I3,6G12.4)
   10 CONTINUE
      K=0
C     FAC=SQRT(FLOAT(2*L+1)/4./PI)/2./CG1
       FAC=100.*FLOAT(2*L+1)/4./PI
      FAC1=-RN/CG1*SQRT(PI/FLOAT(2*L+1))*1.E-3
      IF(IOPT.EQ.2)FAC1=1.
C     WRITE(1,111)L,CG1,FAC,FAC1
111    FORMAT(' L=',I5,' CG1= ',F9.3,' FAC=',E12.3,' FAC1 ',E12.3)
      F1=1.
      F2=1.
      IF(IOPT.EQ.1)F1=FL3
      IF(IOPT.EQ.1)F2=SFL3
      DO 20 I=1,NRAD
C     WRITE(1,988)I,K,A(1,I),A(2,I),A(3,I),A(4,I)
988    FORMAT(' I K A',2I5,4E12.5)
      IF(R(I).LE.RD)GO TO 20
      U=A(1,I)
      UP=A(2,I)
      V=A(3,I)/SFL3
      VP=A(4,I)/SFL3
C     WRITE(1,223)U,V,UP,VP
223    FORMAT(' U V VP R AX',9E12.5)
C     IF(I.EQ.NRAD)WRITE(1,99)I,U
      IF(I.EQ.NRAD)U0=U
C     WRITE(1,99)I,U,UP,V,VP,R(I)
99     FORMAT(1X,'I=',I5,' U UP V VP R',5E12.5)
      K=K+1
      X=R(I)/6371.E+3
      AS(K)=UP-(U-FL3/2.*V)/X
      IF(IOPT.EQ.2)AS(K)=-AS(K)
      AS(K)=2.*AS(K)
      F=1.
      AP(K)=F1*V/X
C     WRITE(1,222)K,IP,U,V,VP,X,QR(K,IP)
222   FORMAT(' K I U V VP X',2I5,5E12.5)
      AQ(K)=F2*(VP+(U-V)/X)
C      WRITE(1,222)K,IP,U,V,VP,X,QR(K,IP)
      DD=6371000.-R(I)
      DD=DD*1.E-3
C      WRITE(1,996)DD,SR(K,IP),PR(K,IP),QR(K,IP),X,F
996      FORMAT(' X',F9.3,' SR PR QR',5E12.5)
      D(K)=6371.-R(I)*1.E-3
20       CONTINUE
C      WRITE(1,555)FAC
555      FORMAT(' FAC',E12.3)
      NDEP=K
      U0=U0*FAC*FAC1*1.E+20/RN**4/RHOBAR/WN**2
1005     FORMAT(' RN RHOBAR WN UU=',4E12.3)
      SR(IP)=U0*YNTERP(D,AS,DEP,NDEP,0)
      PR(IP)=U0*YNTERP(D,AP,DEP,NDEP,0)
      QR(IP)=U0*YNTERP(D,AQ,DEP,NDEP,0)
C     PRINT*,'SR PR QR',SR(IP),PR(IP),QR(IP),LL
      IP=IP+1
      GO TO 5
900      CONTINUE
      NPER=IP-1
      WRITE(6,554)NPER
554    FORMAT(' NPER',I5)
      DO 30 L=1,NTOT
      PER=TB(L)
      AS(L)=YNTERP(TT,SR,PER,NPER,0)
      AP(L)=YNTERP(TT,PR,PER,NPER,0)
      AQ(L)=YNTERP(TT,QR,PER,NPER,0)
      Q(L)=YNTERP(TT,ET,PER,NPER,0)
      QI(L)=YNTERP(TT,EIT,PER,NPER,0)
	c(l)=ynterp(tt,cc,per,nper,0)
	ui(l)=ynterp(tt,uu,per,nper,0)
c 	print*,'t c q u',tb(l),c(l),qi(l),ui(l),as(l),ap(l),aq(l)
206       FORMAT(' TK Q AS AP AQ',2F9.3,3E12.5)
30      CONTINUE
       close(9)
      RETURN
      END
C      SUBROUTINE RADPAT(XM,NSTAT)
C     IMPLICIT REAL*8 (A-H,O-Z)
C      DIMENSION SR1R(1),QR1R(1),PR1R(1),XM(1)
C     COMMON/SPECTR/RER(5,200),AIMR(5,200),X(5,200),XX(5,200),XM0
C     COMMON/MODD/TK(200),R(200),NRAD,NMOD,MOD(20),NT0,AK(200)
C     COMMON/DATA/ASS(5,200),FAIS(5,200),DIST(50),AZ(50),TB(200),
C    *AM(50),DT(50),NTOT
C     COMMON/EIGEN/AS(200),AP(200),AQ(200),CT(200),UU(200),Q(200)
C    *,TT(200),ETA(200),CFO(200),CF1(200),CF2(200)
C      DRAD=0.0174532                                                   1160
C     PI=3.1415926535D0
C     DO 5 I=1,NSTAT                                                    1170
C      THETA=DRAD*(180.-AZ(I))
C100   FORMAT(' THETA',F8.2)                                            1190
C      S2=DSIN(2.*THETA)                                                 1200
C      C2=DCOS(2.*THETA)                                                 1210
C      S=SIN(THETA)                                                     1220
C      C=COS(THETA)                                                     1230
CC    WRITE(1,2500)C,S,C2,S2,(XM(I),I=1,6)
C2500C   FORMAT(' C..',4E12.5)
C       DO 10 L=1,NT0                                                    1240
CC     WRITE(1,2000)L,AP(L),AS(L),AQ(L)
C2000     FORMAT(' L P S Q',I5,3E12.5)
C       A=-AP(L)*XM(6)*S2
C       B=AP(L)*(XM(3)-XM(2))*C2/2.                                               1260
C      CK=AS(L)*XM(1)/2.
C       D=AQ(L)*XM(4)*C
C       E=AQ(L)*XM(5)*S
CC       WRITE(1,1000)A,B,C,D,E                                           1300
C1000      FORMAT(' ABCDE',5E12.3)                                        1310
C      RER(I,L)=A+B+CK                                                  1320
C      AIMR(I,L)=D+E                                                    1330
C10      CONTINUE                                                       1340
C1500C      FORMAT(2X,6E12.3)                                            1350
C5      CONTINUE                                                        1360
CC    DO 20 I=1,NSTAT
C20C   WRITE(1,2020)(RER(I,L),AIMR(I,L),L=1,NTOT)
C2020C     FORMAT(' RER AIMR',6E12.5)
C      RETURN                                                           1370
C     END
      SUBROUTINE RADPAT(XM,NSTAT,STRK)
c      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION XM(1)
      COMMON/SPECTR/RER(5,600),AIMR(5,600),X(5,600),XX(5,600),XM0
      COMMON/EIGEN/AS(600),AP(600),AQ(600),ET(600),UU(600),Q(600)
     *,TT(600)
      COMMON/MODD/TB(600),R(600),NRAD,NMOD,MOD(20),NTOT,EIP(600)
     *,NF(4),NLA(4)
      COMMON/DATA/ASS(5,600),FAIS(5,600),DIST(50),AZ(50)
     *,AM(50),DT(50)
       DRAD=0.0174532                                                   1160
      DO 5 I=1,NSTAT                                                    1170
      THETA=DRAD*(STRK-AZ(I))
100    FORMAT(' THETA',E12.5)                                            1190
C     WRITE(1,100)THETA
       S2=SIN(2.*THETA)                                                 1200
       C2=COS(2.*THETA)                                                  1210
       S=SIN(THETA)                                                       1220
       C=COS(THETA)                                                       1230
C     WRITE(1,200)(XM(I),I=1,5)
200     FORMAT(' XM',5E12.5)
       DO 10 L=1,NTOT                                                    1240
C     WRITE(1,300)AP(L),AQ(L),AS(L)
C     AP(L)=1.
C     AQ(L)=1.
C     AS(L)=1.
C     WRITE(1,300)AP(L),AQ(L),AS(L)
300      FORMAT(' AP AQ AS',3E12.5)
       A0=AP(L)*XM(3)*S2                                                1300
       B=AP(L)*XM(2)*C2
       CC=AS(L)*XM(1)
       D=AQ(L)*XM(4)*C
       E=AQ(L)*XM(5)*S
1000      FORMAT(' ABCDE',5F8.3)                                        1310
       RER(I,L)=A0+B+CC                                                  1320
       AIMR(I,L)=D+E                                                    1330
C     PRINT*,'TB RER AIMR',TB(L),RER(I,L),AIMR(I,L)
10       CONTINUE                                                       1340
1500       FORMAT(2X,6E12.3)                                            1350
5       CONTINUE                                                        1360
C      PRINT*,'RER',RER(1,1),'AIMR',AIMR(1,1)
      PRINT*,'A B C D E',A0,B,CC,D,E
       RETURN                                                           1370
      END
      SUBROUTINE MOMENT(STRK,DIP,SLIP,XM)
c      IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION XM(1)                                                 0920
      COMMON/SPECTR/RER(5,600),AIMR(5,600),X(5,600),XX(5,600),XM0
      DRAD=0.0174532                                                    0930
      FI=STRK*DRAD                                                      0940
      D=DIP*DRAD                                                        0950
      XL=SLIP*DRAD                                                      0960
      CL=COS(XL)                                                         0970
      SL=SIN(XL)                                                         0980
      CD=COS(D)                                                          0990
      SD=SIN(D)                                                          1000
       XM(1)=SL*SD*CD                                                   1010
      XM(2)=-SL*SD*CD                                                   1020
      XM(3)=CL*SD                                                       1030
      XM(4)=CL*CD                                                       1040
      XM(5)=SL*(2.*CD*CD-1.)                                            1050
C     XM(2)=-XM(2)
C     XM(4)=-XM(4)
C     XM(5)=-XM(5)
      WRITE(1,1400)(XM(I),I=1,5)
1400     FORMAT(' INITIAL MOMENT',6E12.3)
1000  FORMAT(2X,'XM ',5F8.3)                                            1070
      DO 20 I=1,5
20    XM(I)=XM(I)*XM0
      WRITE(6,1400)(XM(I),I=1,5)
      RETURN                                                            1100
      END                                                               1110
      FUNCTION YNTERP(X,Y,XI,N,ND)
C X(I) MUST BE ALL DIFFERENT
C HIROO KANAMORI AUG.4 1978
c      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION X(1), Y(1)
      I=1
      J=N
      K=1
      IF ( X(1) .GT. X(N) ) GO TO 11
1     IF( XI-X(K)) 2,2,3
2     J=K
      GO TO 4
3     I=K
4     K=(I+J)/2
      IF(K.NE.I) GO TO 1
      IF( XI.GT.X(N)) J=N+1
      GO TO 21
11    IF( X(K)-XI) 12,12,13
12    J=K
      GO TO 14
13    I=K
14    K=(I+J)/2
      IF(K.NE.I) GO TO 11
      IF( XI.LT. X(N)) J=N+1
21    IF ( J.EQ. 1) GO TO 23
      IF(J.EQ.N+1) GO TO 24
      YNTERP=Y(J-1)+(Y(J)-Y(J-1))*(XI-X(J-1))/(X(J)-X(J-1))
      RETURN
23    YNTERP=Y(1)
      RETURN
24    YNTERP=Y(N)
      RETURN
      END
C
      SUBROUTINE CHOICE(CKNO,AM,T1,T2,IO)
C
c      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION CKNO(1),DW(250),FATT(10)
      COMMON/SINELLO/E(600,20),F1(600)
      COMMON/OUF/D(600),XM(6),TC(600),CC(600),P(600),CV(600,20)
      COMMON/MODD/TK(600),R(600),NRAD,NMOD,MOD(20),NT0,EIP(600)
     *,NF(4),NLA(4)
      COMMON/EIGEN/AS(600),AP(600),AQ(600),CT(600),UU(600),Q(600)
     *,TT(600)
      COMMON/VIEL/DWGC(4,600),VPGC(4,600),ER(4),TIMP,IWQ
C
      PI=3.1415926535
      ISSY=AM+1
      PRINT*,'NT0',NT0,TK(1)
      DO 20 I=1,NT0
20    F1(I)=0.
      IGU=0
      DO 2 IUY=1,10
      DO 1 KTY=1,NT0
      IF(TK(KTY).GT.T2)GO TO 1
      IF(IGU.EQ.0)NF(IO)=KTY
      IF(TK(KTY).LT.T1)GO TO 2
      IGU=IGU+1
      F1(IUY)=ABS(CV(KTY,IUY)-CT(KTY))+F1(IUY)
      E(KTY,IUY)=CV(KTY,IUY)-CT(KTY)
1     CONTINUE
2     CONTINUE
      NLA(IO)=KTY-1
      PRINT*,'NF NLA',NF(IO),NLA(IO)
      CALL MAXMIN(F1,1,10,AMAX,AMIN,K1MAX)
      PRINT*,'CHOICE'
      IKO=0
      DO 4 KTO=NF(IO),NLA(IO)
      DO 5 IOT=1,10
5     FATT(IOT)=ABS(E(KTO,IOT))
      CALL MAXMIN(FATT,1,10,AMAX,AMIN,KMAX)
C     IF(KMAX.NE.K1MAX)GO TO 4
C     IF(KMAX.NE.K1MAX)THEN
C                      K2MAX=KMAX
C                      ELSE
C                      K2MAX=K1MAX
C     ENDIF
      DIW=2.*PI/TK(KTO)*E(KTO,K1MAX)*UU(KTO)
      DW(KTO)=DIW/CT(KTO)/CT(KTO)
      DIW=DW(KTO)/E(KTO,K1MAX)
      DWGC(ISSY,KTO)=DIW
      VPGC(ISSY,KTO)=CV(KTO,K1MAX)
C     PRINT*,'K KTO CV',K1MAX,KTO,CV(KTO,K1MAX)
4     CONTINUE
      PRINT*,'ISSY',ISSY
      NOC=NLA(IO)-NF(IO)+1
C     WRITE(13,11)NOC
C     DO 7 KRI=NF(IO),NLA(IO)
C     WRITE(13,10)TK(KRI),CT(KRI),E(KRI,K1MAX),DW(KRI),K1MAX
C7     CONTINUE
10    FORMAT((1X,F6.2,3E12.3,I4))
11    FORMAT(I5)
      PRINT*,'CHOICE'
      RETURN
      END
C
      SUBROUTINE MAXMIN(X,N1,N2,AMAX,AMIN,KMIN)
C
c      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION X(1)
      AMAX=X(1)
      AMIN=AMAX
      KMAX=1
      KMIN=1
      DO 1100 K=N1,N2
      AK=X(K)
      IF(AK-AMAX) 120,120,115
115   AMAX=AK
      KMAX=K
      GO TO 1100
120   IF(AK-AMIN) 125, 1100,1100
125      AMIN=AK
      KMIN=K
1100  CONTINUE
      RETURN
      END
      SUBROUTINE COPOLE(GTHE,PHIMP,DEL)
C
c      IMPLICIT REAL*8 (A-H,O-Z)
C     DOUBLE PRECISION CTHE,STHE
      COMMON/COP/GLATE,GL1,GLATS,GL2
      PI=3.1415926535
      C1=0.0174533
      GL=GL2-GL1
      TRY1=GLATE
      TRY2=GLATS
      GLATE=(90.-GLATE)*C1
      GLATS=(90.-GLATS)*C1
      GL=GL*C1
      CTHE=COS(GLATE)*COS(GLATS)
      CTHE=CTHE+SIN(gLATE)*SIN(GLATS)
     1*COS(GL)
      STHE=SQRT(1.D+0-CTHE*CTHE)
      DEL=ATAN2(STHE,CTHE)
      CTHE=SIN(GLATS)*SIN(GL)
      CTHE=CTHE/SIN(DEL)*SIN(GLATE)
      STHE=SQRT(1.D+0-CTHE*CTHE)
      IF(STHE.LT.0.D-20)THEN
                        THETA=PI/2.
                        GTHE=0.
                        PHIMP=0.
                        GO TO 40
      ENDIF
      GTHE=ATAN2(STHE,CTHE)
C     XLAS=PI/2.-GTHE
C     GTHE=PI/2.-ABS(XLAS)
      PRINT*,'GTHE',GTHE
      STHE=SIN(GLATS)*SIN(GL)/SIN(DEL)
      CTHE=SQRT(1.D0-STHE*STHE)
C     PRINT*,'COSPHIE',CTHE
      STHE=COS(DEL/2)*COS(GLATE)
      STHE=STHE+SIN(DEL/2)*SIN(GLATE)*CTHE
C     PRINT*,'COSLMDM',STHE
      STHE=STHE/SIN(GTHE)
C     PRINT*,'COSPSI',STHE
      CTHE=STHE*SIN(GTHE)*COS(DEL/2)
      CTHE=(COS(GLATS)-CTHE)/SIN(GTHE)
      X=COS(GLATS)
C     PRINT*,'INTER',CTHE,'COSLATS',X
      CTHE=CTHE/SIN(DEL/2)
C     PRINT*,'SINPSI',CTHE
      PHIMP=ATAN2(CTHE,STHE)
40    GLATE=TRY1
      GLATS=TRY2
      RETURN
      END
      SUBROUTINE TDKI(P,TKI1,TKI2,TKI3)
C
c      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/TDKP/TOUL(20),QI1(20),QI2(20),JOY,RAP(20)
      C0=1000.
      TKI1=0.
      TKI2=0.
      TKI3=0.
      RUOE1=1.
      IF(P.GT.500..OR.P.LT.100.)GO TO 100
      RUOE=YNTERP(TOUL,RAP,P,JOY,1)
      TKI1=YNTERP(TOUL,QI1,P,JOY,1)
      TKI1=TKI1/C0/RUOE1
      TKI2=YNTERP(TOUL,QI2,P,JOY,1)
      TKI3=TKI2*RUOE/C0
      TKI2=TKI2/C0/RUOE1
C100   PRINT*,'PER',P,'C0/U0',RUOE
100   CONTINUE
      RETURN
      END
