
      SUBROUTINE BLSHFT (SOURCE, PARITY, DIR, SENSE, DEST)
C     ------------------------------------------------------
      INTEGER     PARITY, DIR, SENSE

      INCLUDE 'qcd2.inc'

C     -----------------------------------------------------------------------
C     |       Shifts the fermion vector {source}  by one lattice spacing    |
C     |  in a given direction and sense (given by 'dir', 'sense').  The     |
C     |  shifted vector is returned in  {dest}.                             |
C     |                                                                     |
C     |  'parity' = the sites on which the original {source} is defined     |
C     |             (i.e. 'even' or 'odd').                                 |
C     |  Note that if {source} is 'even' then {dest} is 'odd', & vice versa.|
C     -----------------------------------------------------------------------
      INTEGER     TDIR,  XDIR,  YDIR,  ZDIR,  EVEN,  ODD,
     *            PSENSE,  NSENSE,  PLUS,  MINUS,  RE,  IM
      PARAMETER ( TDIR = 1,    XDIR = 2,    YDIR = 3,    ZDIR = 4,
     *            EVEN = 0,     ODD = 1, PSENSE= 0, NSENSE= 1,
     *            PLUS = 0,   MINUS = 1,      RE = 1,      IM = 2 )

      INTEGER  LEN, INTLEN, BLKLEN, NBLOCK, 
     *         A, B, X, Y, Z, I, TPAR

      DOUBLE PRECISION  SOURCE (0 : VSIZE-1), DEST (0 : VSIZE-1)


C------ work out parameters for shifts:

      IF  (DIR  .EQ.  TDIR)  THEN
          INTLEN  = (SEGT / 2) - 1
          BLKLEN  = (SEGT / 2)
          NBLOCK =  VSIZE / BLKLEN

        ELSEIF  (DIR  .EQ.  XDIR)  THEN
          LEN     =  SEGT / 2
          INTLEN  = (SEGX - 1) * LEN
          BLKLEN  =  SEGX * LEN
          NBLOCK =  VSIZE / BLKLEN

        ELSEIF  (DIR  .EQ.  YDIR)  THEN
          LEN     = (SEGT / 2) * SEGX
          INTLEN  = (SEGY - 1) * LEN
          BLKLEN  =  SEGY * LEN
          NBLOCK =  VSIZE / BLKLEN

        ELSEIF  (DIR  .EQ.  ZDIR)  THEN
          LEN     = (SEGT / 2) * SEGX * SEGY
          INTLEN  = (SEGZ - 1) * LEN
          BLKLEN  =  SEGZ * LEN
          NBLOCK =  VSIZE / BLKLEN
      ENDIF

C------ do shifts:

      IF  (DIR  .EQ.  TDIR)  THEN

          IF  (SENSE  .EQ.  PSENSE)  THEN
              DO 1 I = 0, (NBLOCK - 1) * BLKLEN, BLKLEN
                A = I / (SEGT / 2)
                X = MOD (A, SEGX)
                B = A / SEGX
                Y = MOD (B, SEGY)
                Z = B / SEGY
                TPAR = MOD (X + Y + Z + PARITY, 2)
                IF  (TPAR  .EQ.  EVEN)  THEN
                  DO 100 J = I, I + BLKLEN - 1
 100                DEST (J) = SOURCE (J)

C                 dest (i: i + blklen - 1) = source (i: i + blklen - 1)
                  ELSE
                  DO 150 J = I, I + INTLEN - 1
 150                DEST(J + 1) = SOURCE(J)

C                 dest(i + 1: i  + intlen) = source(i: i + intlen - 1)
                  DEST(I) = SOURCE(I + INTLEN)
                ENDIF
 1            CONTINUE

            ELSEIF  (SENSE  .EQ.  NSENSE)  THEN

              DO 2 I = 0, (NBLOCK - 1) * BLKLEN, BLKLEN
                A = I / (SEGT / 2)
                X = MOD (A, SEGX)
                B = A / SEGX
                Y = MOD (B, SEGY)
                Z = B / SEGY
                TPAR = MOD (X + Y + Z + PARITY, 2)
                IF  (TPAR  .EQ.  EVEN)  THEN
                  DO 200 J = I, I + INTLEN - 1
 200                DEST(J) = SOURCE(J + 1)

                  DEST(I + INTLEN) = SOURCE(I)
C                 dest(i: i + intlen - 1) = source(i + 1: i + intlen)
                ELSE
                  DO 250 J = I, I + BLKLEN - 1
 250                DEST (J) = SOURCE (J)

C                 dest (i: i + blklen - 1) = source (i: i + blklen - 1)
                ENDIF
 2            CONTINUE
          ENDIF

        ELSEIF  (DIR  .NE.  TDIR)  THEN

          IF  (SENSE  .EQ.  PSENSE)  THEN
            DO 3 I = 0, (NBLOCK - 1) * BLKLEN, BLKLEN
              DO 300 J = I, I + INTLEN - 1
 300            DEST(J + LEN) = SOURCE(J) 

C             dest(i + len: i + len + intlen -1) = 
C    *                                      source(i: i + intlen - 1)
             DO 350 J = I, I + LEN - 1
 350           DEST(J) = SOURCE(J + INTLEN)

C              dest(i: i + len - 1) =
C    *                        source(i + intlen: i + intlen + len - 1)
 3           CONTINUE

           ELSEIF  (SENSE  .EQ.  NSENSE)  THEN
             DO 4 I = 0, (NBLOCK - 1) * BLKLEN, BLKLEN
               DO 400 J = I, I + LEN - 1
 400           DEST(J + INTLEN) = SOURCE(J)

C              dest(i + intlen: i + intlen + len - 1) =
C    *                                          source(i: i + len - 1)
               DO 450 J = I, I + INTLEN - 1
 450             DEST(J) = SOURCE(J + LEN) 

C              dest(i: i + intlen - 1) =
C    *                           source(i + len: i + len + intlen - 1)
 4           CONTINUE
          ENDIF

      ENDIF

      END
