switch.f

Go to the documentation of this file.

      SUBROUTINE switch(Y)
*
*
*       Switching of chain.
*       -------------------
*
      include 'commonc.h'
      include 'common2.h'
      LOGICAL  kslow,kcoll,itest
      REAL*8  y(nmx8),xcnew(nmx3),ksch,ksnew(nmx)
      common/slow1/   tk2(0:nmx),ejump,ksch(nmx),kslow,kcoll
      INTEGER  iold(nmx)
*
*
*       Copy Y-array to COMMON.
      CALL ysave(y)
*
*   First transform to chain coordinates.
      DO i=1,n-1
      l1=3*(i-1)+1
      ks1=4*(i-1)+1
      CALL ksphys(q(ks1),p(ks1),xc(l1),wc(l1))
      END DO
*
      l2=3*(iname(1)-1)
      DO k=1,3
      x(l2+k)=0.0
      END DO
*
*       Set X for determining new chain indices.
      DO i=1,n-1
      l=3*(i-1)
      l1=l2
      l2=3*(iname(i+1)-1)
      DO k=1,3
      x(l2+k)=x(l1+k)+xc(l+k)
      END DO
      END DO
*
*   Save the old chain indices.
      DO i=1,n
      iold(i)=iname(i)
      END DO
*
*       Select new indices.
      CALL SELECT
*
*       EXit if chain vectors are unchanged.
      isw=0
      DO i=1,n
      IF(iname(i).NE.iold(i))isw=isw+1
      END DO
      IF(isw.EQ.0)RETURN
*
*   Transform chain momenta.
      l1=3*(iold(1)-1)
      ln=3*(iold(n)-1)
      l=3*(n-2)
      DO k=1,3
      pi(l1+k)=-wc(k)
      pi(ln+k)=wc(l+k)
      END DO
      DO i=2,n-1
      l=3*(i-1)
      li=3*(iold(i)-1)
      DO k=1,3
      pi(li+k)=wc(l+k-3)-wc(l+k)
      END DO
      END DO
      l1=3*(iname(1)-1)
      ln=3*(iname(n)-1)
      l=3*(n-2)
      DO k=1,3
      wc(k)=-pi(l1+k)
      wc(l+k)=pi(ln+k)
      END DO
      DO i=2,n-2
      l=3*(i-1)
      li=3*(iname(i)-1)
      DO k=1,3
      wc(l+k)=wc(l+k-3)-pi(li+k)
      END DO
      END DO
*
*       Construct new chain coordinates.
      DO i=1,3*(n-1)
      xcnew(i)=0.0
      END DO
*       Transformation matrix (old to new) has only coefficients -1, 0 or +1.
      DO icnew=1,n-1
*       Find K0 & K1 for IOLD(K0) = INAME(ICNEW) & IOLD(K1) = INAME(ICNEW+1).
      lnew=3*(icnew-1)
      DO i=1,n
      IF(iold(i).EQ.iname(icnew))k0=i
      IF(iold(i).EQ.iname(icnew+1))k1=i
      END DO
      DO icold=1,n-1
      lold=3*(icold-1)
      IF((k1.GT.icold).AND.(k0.LE.icold))THEN
*       Add.
      DO k=1,3
      xcnew(lnew+k)=xcnew(lnew+k)+xc(lold+k)
      END DO
      ELSE IF((k1.LE.icold).AND.(k0.GT.icold))THEN
*   Subtract.
      DO k=1,3
      xcnew(lnew+k)=xcnew(lnew+k)-xc(lold+k)
      END DO
      END IF
      END DO
      END DO
*
*   Perform KS-transformations and update chain coordinates & RINV.
      DO i=1,n-1
      l1=3*(i-1)+1
      ks1=4*(i-1)+1
      CALL physks(xcnew(l1),wc(l1),q(ks1),p(ks1))
      DO k=1,3
      xc(l1+k-1)=xcnew(l1+k-1)
      END DO
      rinv(i)=1.0/(q(ks1)**2+q(ks1+1)**2+q(ks1+2)**2+q(ks1+3)**2)
      END DO
*
*       Swop Ksch acording to Iold and Iname.
      do i=1,n-1
          ksnew(i)=1.0
      end do
      do i=1,n-1
          if(ksch(i).ne.1.0d0)then
              i1=iold(i)
              i2=iold(i+1)
              do j=1,n-1
              itest=((i1.eq.iname(j)).and.(i2.eq.iname(j+1))).or.
     &              ((i2.eq.iname(j)).and.(i1.eq.iname(j+1)))
              if(itest)then
                  ksnew(j)=ksch(i)
              end if
              end do
          end if
      end do
      do i=1,n-1
          ksch(i)=ksnew(i)
      end do
*       Define auxiliary quantities.
      mass=0.0
      DO i=1,n
      l=3*(i-1)
      mc(i)=m(iname(i))
      mass=mass+mc(i)
      END DO
*
      do i=1,n
          tk1(i)=-1./mc(i)
      end do
      do i=1,n-1
          if(ksch(i).ne.1.0d0)then
              tk1(i)=tk1(i)/ksch(i)
              tk1(i+1)=tk1(i+1)/ksch(i)
          end if
      end do
      DO i=1,n-1
          tkk(i)=.5d0*(-tk1(i)-tk1(i+1))
          mkk(i)=mc(i)*mc(i+1)/ksch(i)
          DO j=i+1,n
              mij(i,j)=mc(i)*mc(j)
              mij(j,i)=mij(i,j)
           END DO
      END DO
      do i=1,n-1
          m12=mc(i)+mc(i+1)
          dt12=0.5d0*(1.d0-1.d0/ksch(i))/m12
          if(i.gt.1) tkk(i-1)=tkk(i-1)+dt12
          if(i.lt.n-1) tkk(i+1)=tkk(i+1)+dt12
          if(i.gt.1.and.i.lt.n-1) tk2(i)=-2.0d0*dt12
      end do
*       Note: TK2(0) & TK2(N) should be zero but never used.
      tk2(0) = 0.0
      tk2(n) = 0.0
*
*       Copy Y-array from COMMON.
      CALL ycopy(y)
*
      RETURN
      END