      SUBROUTINE TPICM (KAPPA)
C *** SEE R H LANDAU, PROGRAM LPOTT, 1981
C     SUBROUTINE TPICM CALCS  ON-SHELL PIN  C.M. AMPLITUDE
C     KAPPA= PI-NUCLEON C.M. MOMENTUM
C     INTIALIZE IF PHASE SHIFTS  CHANGE
      IMPLICIT REAL*8 (A-H,I,K,M,O-Z)
      DIMENSION NIFTY(20), ECM(100), D(14,100), ETA(14,100), KAP(100), T
     1(14), TX(14), BN(16), BNUC(20), REWAVE(14,100), IMWAVE(14,100),
     2 BNF(16), 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     NEW FIT TO LOW ENERGY PHASE SHIFTS,USING MARTIN SALOMON S FIT UP T
C     AND RHL FIT TO D AND F WAVES (ETA==1,OK TILL CA 150MEV/C)
C     A*S ARE DUMMY VARIABLES,PROPRTNAL TO ALPHA (.5(EXP(2IDELTA)-1))/2
C     CODE FOR BN, BNF, BNUC, BNUCF
C     ALL FOR PI PLUS, REAARANGE FOR PI MINUS LATTER
C     1 RES,P 2 IMSP    3 RES,N        4 IMSN
C     5 REP,P 6IMP,P    4 REP,N        8 IMP,N
C     9 RED,P 10IMD,P   11 RED,N       12 IMD,N
C     13 REF,P          14 IMF,P       15 REF,N  16 IMF,N
C     17 REG,P          18 IMG,P       19 REG,N  20 IMG,N
C     B(PI+P)=SUM(J) (J+1/2))T3/2(J)
C     B(PI+N)=SUM(J) (J+1/2)*(T3/2(J)/3. + 2*R1/2(J)/3)
C     FLIP
C     BJ(PI+P)=T3/2(J=L+1/2)- T3/2(-)
C     BF(PI+N)=1/3 (T3/2(+) -T3/2(-)) +2/3 (T1/2(+) -T1/2(-)
C     SPIN FLIP AMPKITUDES BNF HAVE THE SAME CODE(1-4==0)
C     T(PI+P)= T(PI-N)  , T(PI+N)=T(PI-P)
C     TWAVE(NWAVE,NE) = CONTRBTN TO PARTL WVE T MATRX ELEMENT FROM WAVE
C     AT PI-N C.M. ENERGY KAP(NE)
C        NWAVE CODE
C     1-----S31     2-----P31     3-----P33     4-----S11
C     5-----P11     6-----P13     7-----D33     8-----D35
C     9-----F35     10----F37     11----D13     12----D15
C     13----F15     14----F17
C
      DATA NDATA/1/
      IF (KAPPA.LE.-100.) NDATA = 1
      KAPPA = ABS(KAPPA)
      IF (NDATA.EQ.0) GO TO 110
      KAPPA = ABS(KAPPA)
      IF (NIFTY(8).NE.2.AND.NIFTY(8).NE.3) GO TO 100
C     NIFTY(8) .EQ. 2,OR 3 READ IN PHASE SHIFTS,CALS T*S,STORE
C     IF FOLDING,SCATTERING LENGTHS/MS USED FOR VERY LOW E
C     TMATRIX(UNFOLDED) FOR THIS NUCELES,T FOLDERD LATTER
C     AMPLITUDES FROM INPUT PHASE SHIFTS AND ENRGY
C     ECM IN MEV, DELTA (D) READ IN IN DEGREES, F CALCULATED IN MEV-1
C     ETA=EXP(-2 IMDELTA)  , IF READ IN AS 0 THEN SET TO 1.
C
      NEI = 1
      IF (NIFTY(8).NE.1.AND.NIFTY(8).NE.3) GO TO 30
C     NIFTY(8) =1OR 3 1,SET UP LOW E DELTA   NEEDED FOR FOLDING
      NEI = 26
      NES = NES+25
      READ (1,170) ECM(1)
      REWIND 1
      S = ECM(1)**2
      KAPPA = SQRT((S-(MN+MPI)*(MN+MPI))*(S-(MN-MPI)*(MN-MPI))/4./S)
      IF (KAPPA.LE.5.) KAPPA = 6.
      KAPH = (KAPPA-5.)/20.
      KAPPA = 0.
      DO 20 NKAP=1,25
         KAPPA = KAPPA+KAPH
         IF (NKAP.LE.6) KAPPA = (NKAP*1.5)
         DO 10 NI=1,14
            CALL TPIRSL (KAPPA,NI,DDUM,W,TR,TI)
            ETA(NI,NKAP) = 1.
            D(NI,NKAP) = DDUM*180./PI
            T(NI) = TR
            TX(NI) = TI
 10      CONTINUE
         ECM(NKAP) = W
 20   CONTINUE
 30   WRITE (6,180) NES,NWAVES
      READ (1,170) (ECM(NE),(ETA(NWAVE,NE),D(NWAVE,NE),NWAVE=1,NWAVES),
     1NE=NEI,NES)
      REWIND 1
      WRITE (6,190) (ECM(NE),(ETA(NWAVE,NE),D(NWAVE,NE),NWAVE=1,NWAVES),
     1NE=1,NES)
C     -------      CALCULATE KINEMATICS
      DO 60 NE=1,NES
         S = ECM(NE)*ECM(NE)
         SQARG=(S-(MN+MPI)*(MN+MPI))*(S-(MN-MPI)*(MN-MPI))/4./S
	 IF (SQARG.LE.0) SQARG=1.1
         KAP(NE) = SQRT(SQARG)
C     -----------COMPUTE ALPHAS AND CONVERT DELTAS
         KK = KAP(NE)
         EPIKAP = SQRT(MPI*MPI+KK*KK)
         ENKAP = SQRT(MN*MN+KK*KK)
         FTOT = -(EPIKAP+ENKAP)/4./PI/PI/EPIKAP/ENKAP
         FACTOR = FTOT/KK
         DO 50 NWAVE=1,14
            ETADUM = ETA(NWAVE,NE)
            DDUM = D(NWAVE,NE)*PI/180.
            IF (ETADUM.LE.0.) ETADUM = 1.
            REWAVE(NWAVE,NE) = 0.
            IMWAVE(NWAVE,NE) = 0.
            IF (NWAVE.GT.NWAVES) GO TO 50
            REWAVE(NWAVE,NE) = .5*ETADUM*SIN(2.*DDUM)*FACTOR
            IMWAVE(NWAVE,NE) = .5*(1.-ETADUM*COS(2.*DDUM))*FACTOR
 50      CONTINUE
 60   CONTINUE
C     STORE UNFOLDEF AMPLITUDED ON UNIT 3,CAN FOLD LATTER/
      REWIND 3
      WRITE (3,205) NES
      WRITE (3,200) (KAP(NE),(REWAVE(NWAVE,NE),IMWAVE(NWAVE,NE),NWAVE=1,
     114),NE=1,NES)
      REWIND 3
      NDATA = 0
      WRITE (6,210) NES,NWAVES
      WRITE (6,230) (ECM(NE),KAP(NE),(REWAVE(NWAVE,NE),IMWAVE(NWAVE,NE),
     1NWAVE=1,14),NE=1,NES)
      DO 90 NE=1,NES
         DO 70 NWAVE=1,14
            T(NWAVE) = REWAVE(NWAVE,NE)
            TX(NWAVE) = IMWAVE(NWAVE,NE)
 70      CONTINUE
C     FORM PARTIAL WAVE DECOMP OF PI+P,PI+N AMPLIT UDES
         CALL MIXUP (BN,BNF,T,TX,NIFTY(1))
C     TEMP STORAGE FOR PRINTOUT
         DO 80 NWAVE=1,14
            D(NWAVE,NE) = BN(NWAVE)
            IF (NWAVE.LE.12) ETA(NWAVE+2,NE) = BNF(NWAVE+4)
 80      CONTINUE
         ETA(1,NE) = BN(15)
         ETA(2,NE) = BN(16)
 90   CONTINUE
      RHL1 = 0.
      WRITE (6,240)
      WRITE (6,250) (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,260)
      WRITE (6,250) (KAP(NE),RHL1,RHL1,(ETA(NWAVE,NE),NWAVE=3,13,2),RHL1
     1,RHL1,(ETA(NWAV,NE),NWAV=4,14,2),NE=1,NES)
C     -----AMPLITUDES ALL STORED, INTERPOLATE ON KAPPA,USING 2 POINT LAG
C     AMPLITUDES ALL STORED ON 3, READ BACK
 100  CONTINUE
      NDATA = 0
      READ (3,205) NSTORE
      READ (3,200) (KAP(NE),(REWAVE(NWAVE,NE),IMWAVE(NWAVE,NE),NWAVE=1,
     114),NE=1,NSTORE)
      REWIND 3
      IF (NES.LE.NSTORE) GO TO 110
      WRITE (6,220) NSTORE
      NES = NSTORE
 110  CONTINUE
      X = KAPPA
      IF (KAPPA.GT.KAP(NES)) X = KAP(NES)
      IF (KAPPA.GT.KAP(1)) GO TO 130
C     USE SCATTERING LENGTHS TO CALC LOW E DELTS, ONLY S+P NE 0,ETA==1
      DO 120 NWAVE=1,14
         CALL TPIRSL (KAPPA,NWAVE,DDUM,W,TR,TI)
         T(NWAVE) = TR
         TX(NWAVE) = TI
 120  CONTINUE
      GO TO 140
C     HERE T AND TX REFER TO INTERPOLATED VALUES OF REWAVE AND IMWAVE
 130  CALL LAGRNG (X,KAP,T,REWAVE,NES,14,2,100,14)
      CALL LAGRNG (X,KAP,TX,IMWAVE,NES,14,2,100,14)
 140  CONTINUE
C     CHECK FOR SET OF 2 BODY AMPLITUDES TO ZERO
      IF ((NIFTY(7).NE.1).AND.(NIFTY(7).NE.2)) GO TO 160
C     NIFTY(7)=1, SET P, D, F.. WAVES TO 0   N(7)=2, ONLY D,F =0
      NI = 5
      IF (NIFTY(7).EQ.2) NI = 9
      DO 150 NL=NI,16
         BN(NL) = 0.
         BNF(NL) = 0.
 150  CONTINUE
      RETURN
 160  CALL MIXUP (BN,BNF,T,TX,NIFTY(1))
      RETURN
C     -----FORMATS
C
 170  FORMAT (13F6.1/8F6.1/8F6.1)
 180  FORMAT (49H0 INPUT PION-NUCLEON PHASE SHIFTS ECM,(ETA,DELTA),  
     1  19H SEE TPICM FOR CODE,/,34H IF FOLDING,25 E S INSERTED BEFOre,
     2  50H FIRST READ IN VALUE WITH ROWE,SALOMON,LANDAU FITS ,/,
     3  12H NES NWAVES=,2I5,//)
 190  FORMAT (1H ,13F8.2/8F8.2/8F8.2)
 200  FORMAT (7E11.4/6E11.4/6E11.4/6E11.4/4E11.4)
 205  FORMAT(I5)
 210  FORMAT (55H NON FOLDED EIGENCHANNEL TMATRIX AS STORED ON TAPE3 FOR
     1,I5,8HENERGIES/26H REL AND IM PARTS FOR ALL ,I3,9H CHANNELS/)
 220  FORMAT (25H ********NES .GT. NSTORE=,I5,21HNES SET =NSTORE *****,/
     1/)
 230  FORMAT (9H,ECM KAP=,2F10.2/14X,8E11.4/14X,10E11.4/14X,10E11.4)
 240  FORMAT (103H0SEPARATE PI**PLUS*  PROTON  AND NEUTRON PARTIAL WAVE
     1---NON-FLIP ---( T MATRICES AT C.M. MOMEMTUM KAP ,/41H 1ST LINE RE
     2AL   PARTS, SECOND LINE IMAG /80H KAP   SWAVE P    SWAVEN    PWAVE
     3 P    PWAVE N DWAVE P DWAVE N FWAFE P FWAVE N  //)
 250  FORMAT (F8.2,10X,8E12.4,/18X,8E12.4)
 260  FORMAT (104H0SEPARATE PI**PLUS*  PROTON  AND NEUTRON PARTIAL WAVE
     1--- SPIN-FLIP--- T MATRICES AT C.M. MOMEMTUM  KAP ,/40H 1ST LINE R
     2EAL  PARTS, SECOND LINE IMAG /80H KAP   SWAVE P    SWAVEN    PWAVE
     3 P    PWAVE N DWAVE P DWAVE N FWAFE P FWAVE N  //)
      END
