      SUBROUTINE TKCM (KAPO)
C *** SEE R H LANDAU, PROGRAM LPOTT, 1981
C     SUBROUTINE TO CALCULATE AND STORE KN AMPLITUDES
C     AUTHOR. MANUEL PAEZ
C     SEE TKPMAR FOR EIGENCHANNEL CODE, SAME PARTIAL WAVE CODE AS PIONS
      IMPLICIT REAL*8(A-H,I,K,M,O-Z)
      DIMENSION NIFTY(20), D(14,100), ETA(14,100), KAP(100), T(14), TX
     1(14), BN(16), BNUC(20), REWAVE(14,100), IMWAVE(14,100), BNF(16),
     2 BNUCF(20)
      COMMON /SEC2/ BNUC,BN,BNUCF,BNF,T,TX,HBARC,PI,MPI,MN,NZ,NES,NWAVES
     1,NIFTY,NA
      COMMON /NLSPFL/ GIN(14,100),KAPG(100),DENOM(14,25),ECMDEN(25),FMN,
     1REWAVE,IMWAVE,KAP,NKAPGS,NECMS
      EQUIVALENCE (REWAVE(1,1),D(1,1)), (IMWAVE(1,1),ETA(1,1))
C
      DATA NDATA/1/
      KAP0 = KAPO
      IF (KAPO.LE.-100.) NDATA = 1
      KAPO = ABS(KAPO)
      IF (NIFTY(8).LT.2) GO TO 90
      IF (NIFTY(8).EQ.4) GO TO 90
      IF (NDATA.EQ.0) GO TO 90
C     SET UP TABLE OF T MATRICES 73 ENERGIES FROM 0 TO QMAX=730MEV/C
      NES = 73
      QMAX = 730.
      KAPH = QMAX/NES
C       USE WATTS PHASES,ONLY GOOD FOR PL GT 700
C       YET,ONLY STORE STARTING AT 700-SO WILL USE
C     INTIALIZE
      NES = 13
      NWAVES = 14
      KAPH = 50
      REWIND 1
      RHL = 4*PI*PI
      WRITE (6,160) NES,NWAVES
      KAPPA = 0.
      REWIND 3
      WRITE (3,190) NES
C     DO LOOP OVER TABULATES MOMEMTA, USE TKNM FOR T
      DO 50 NKAP=1,NES
         IF (NKAP.GT.12.AND.NIFTY(8).NE.5) GO TO 10
         KAPPA = KAPH*NKAP
         IF (NKAP.EQ.1) KAPPA = 1.
         KAP(NKAP) = KAPPA
         CALL TKPMAR (KAPPA)
         GO TO 30
C     READ IN PHASES FROM CARDS,NOW SEP FOR WATTS
 10      READ (1,150) KAP(NKAP),(ETA(NWAVE,NKAP),D(NWAVE,NKAP),NWAVE=1,
     1   NWAVES)
         WRITE (6,170) KAP(NKAP),(ETA(NWAVE,NKAP),D(NWAVE,NKAP),NWAVE=1,
     1   NWAVES)
         KK = KAP(NKAP)
         KAPPA = KK
         EPIKAP = SQRT(MPI*MPI+KK*KK)
         ENKAP = SQRT(MN*MN+KK*KK)
         FTOT = -(EPIKAP+ENKAP)/RHL/EPIKAP/ENKAP
         FACTOR = FTOT/KK
         DO 20 NWAVE=1,NWAVES
            ET = ETA(NWAVE,NKAP)
            DD = D(NWAVE,NKAP)*PI/180.
            T(NWAVE) = 0.5*ET*SIN(2.*DD)*FACTOR
            TX(NWAVE) = 0.5*(1.-ET*COS(2.*DD))*FACTOR
 20      CONTINUE
 30      DO 40 NWAVE=1,NWAVES
            REWAVE(NWAVE,NKAP) = T(NWAVE)
            IMWAVE(NWAVE,NKAP) = TX(NWAVE)
 40      CONTINUE
C     STORE T S ON UNIT 3,FOLD LATTER.
         WRITE (3,180) KAPPA,(T(NWAVE),TX(NWAVE),NWAVE=1,14)
 50   CONTINUE
      REWIND 3
C     TABULATION DONE, PRINT OUT INTERPOLATES IF NEEDED
      WRITE (6,190) NES,NWAVES
      WRITE (6,210) (KAP(NE),(REWAVE(NWAVE,NE),IMWAVE(NWAVE,NE),NWAVE=1,
     114),NE=1,NES)
      DO 80 NE=1,NES
         DO 60 NWAVE=1,14
            T(NWAVE) = REWAVE(NWAVE,NE)
            TX(NWAVE) = IMWAVE(NWAVE,NE)
 60      CONTINUE
C     FORM PARTIAL WAVE DECOMP OF K+P,K+N AMPLITUDES
         CALL KMIXUP (BN,BNF,T,TX)
C     TEMP SORTEAGE FOR PRINT OUT
         DO 70 NWAVE=1,14
            D(NWAVE,NE) = BN(NWAVE)
            IF (NWAVE.LE.12) ETA(NWAVE+2,NE) = BNF(NWAVE+4)
 70      CONTINUE
         ETA(1,NE) = BN(15)
         ETA(2,NE) = BN(16)
 80   CONTINUE
      RHL1 = 0.
      WRITE (6,220)
      WRITE (6,230) (KAP(NE),(D(NWAVE,NE),NWAVE=1,13,2),ETA(1,NE),(D
     1(NWAV,NE),NWAV=2,14,2),ETA(2,NE),NE=1,NES)
      WRITE (6,240)
      WRITE (6,230) (KAP(NE),RHL1,RHL1,(ETA(NWAVE,NE),NWAVE=3,13,2),RHL1
     1,RHL1,(ETA(NWAV,NE),NWAV=4,14,2),NE=1,NES)
 90   KAPPA = KAPO
      IF (NDATA.EQ.0) GO TO 100
      NDATA = 0
      IF (NIFTY(8).EQ.4) GO TO 110
C     AMPLITUDES ALL STORED, INTERPOLATE ON KAPPA, USING 2 POINT
C     LAGRA. AMPLITUDES ALL STORED ON 3, READ BACK
      READ (3,190) NSTORE
      READ (3,180) (KAP(NE),(REWAVE(NWAVE,NE),IMWAVE(NWAVE,NE),NWAVE=1,
     114),NE=1,NSTORE)
      REWIND 3
      IF (NES.LE.NSTORE) GO TO 100
      WRITE (6,200) NSTORE
      NES = NSTORE
 100  CONTINUE
      IF(NIFTY(8).EQ.4)GO TO 110
      X = KAPPA
C       IF KAP LT KAP(1) ,INTERP WILL USE FIRST VALUE
      IF (KAPPA.LE.KAP(1)) GO TO 120
      IF (KAPPA.GT.KAP(NES)) X = KAP(NES)
      IF (KAPPA.GT.KAP(1)) GO TO 120
C     KAPPA LT 1ST TABULATED,OR NIFTY(8)=4,USE FORMULA
 110  CALL TKPMAR (KAPPA)
      CALL KMIXUP (BN,BNF,T,TX)
      RETURN
C     HERE T AND TX REFER TO INTERPOLATES VALUES OF REWAVE AND IMWAVE
 120  CALL LAGRNG (X,KAP,T,REWAVE,NES,14,2,100,14)
      CALL LAGRNG (X,KAP,TX,IMWAVE,NES,14,2,100,14)
C     CHECK FOR SETTING 2 BODY AMPLTDS =0
      IF ((NIFTY(7).NE.1).AND.(NIFTY(7).NE.2)) GO TO 140
C     NIF(7)=1,SET P,D,F=0   NIF(7)=2, SET D,F=0
      NI = 5
      IF (NIFTY(7).EQ.2) NI = 9
      DO 130 NL=NI,16
         BN(NL) = 0.
         BNF(NL) = 0.
 130  CONTINUE
      RETURN
 140  CALL KMIXUP (BN,BNF,T,TX)
      RETURN
C     -----FORMATS
C
 150  FORMAT (13F6.1/8F6.1/8F6.1)
 160  FORMAT (51H0 CALCULATION OF KAON- NUCLEON AMPLITUDES FROM READ,
     1 23H IN PHASES ,NES,NWAVES=,2I10//)
 170  FORMAT (1H ,13F8.2/8F8.2/8F8.2)
 180  FORMAT (7E11.4/6E11.4/6E11.4/6E11.4/4E11.4)
 190  FORMAT (2I5)
 200  FORMAT (23H ********NES.GT.NSTORE=,I5,20HNES SET =NSTORE*****,//)
 210  FORMAT (5H KAP=,F10.2,10E11.4/14X,10E11.4/14X,8E11.4)
 220  FORMAT (1x,'SEPARATE K*+ PROTON AND NEUTRON PARTIAL WAVE,
     1  ---NON-FLIP --- T MATRICES AT C.M. MOMENTUM KAP'/1x,
     2  '1ST LINE REAL PARTS,SECOND LINE IMAG'/1x,
     3  'KAP SWAVE P SWAVE N PWAVE P PWAVE N,
     4   DWAVE P DWAVE N FWAFE P FWAVE N   '//)
 230  FORMAT (F8.2,10X,8E12.4,/18X,8E12.4)
 240  FORMAT (1x,'SEPARATE K*+ PROTON AND NEUTRON PARTIAL WAVE,
     1   ---SPIN-FLIP ---(T MATRICES AT C.M. MOMENTUM KAP'/1x,
     2   '1ST LINE REAL PARTS,SECOND LINE IMAG'/1x,
     3   'KAP SWAVE P SWAVE N PWAVE P PWAVE N,
     4   DWAVE P DWAVE N FWAFE P FWAVE N   '//)
      END
