*DECK TINSHU
      SUBROUTINE TINSHU(IPRES,NCH,NK,NX,NY,NREG,MS,NAMCHA,NAMCHA2,WINT,
     + MIX,BS,PS,ISFT,IXN,IYN,IPRT)
*
*-----------------------------------------------------------------------
*
*Purpose:
* compute new burnup values per channel after shuffling of two
*
*Copyright:
* Copyright (C) 2010 Ecole Polytechnique de Montreal
*
*Author(s): E. Varin, M. Guyot
*
*Parameters: input/output
*
* IPRES   Adress of the map Linked_List or XSM file.
* NAMCHA  Name of the channel to refuel
* NAMCHA2 Name of the channel to refuel
* NS      Number of bundles inserted
* MIX     Fuel map bundle index
* MS      Maximum number of power shift
*
*-----------------------------------------------------------------------
*
      USE GANLIB
      IMPLICIT NONE
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPRES
      INTEGER     NCH,NK,NX,NY,NREG,ILONG,ITYP,IX,IY,IPRT,
     1            ICH1,ICH2,ILS,ITYLCM,IS,MAXS,MS
      REAL        WINT(NCH,NK),BS(NCH,NK,MS),PS(NCH,NK,MS)
      CHARACTER   XNAM*4,YNAM*4,NAMCHA*4,NAMCHA2*4,TEXT4*4,CS*2
      INTEGER     MIX(NREG),IXN(NX),IYN(NY),ISFT(NCH,NK)
*----
*  LOCAL VARIABLES
*----
      INTEGER I,J
      REAL, ALLOCATABLE, DIMENSION(:,:) :: POOL
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(POOL(NCH,NK))
*----
*  RECOVER INFORMATIONS FROM FUEL MAP OBJECT
*----
      DO 1 I=1,NK
       DO 1 J=1,NCH
         WINT(J,I) = 0.0
         ISFT(J,I) = 0
         POOL(J,I) = 0.0
         DO 2 IS=1,MS
           BS(J,I,IS)=0.0
           PS(J,I,IS)=0.0
  2      CONTINUE
  1   CONTINUE
*----
*  RECOVER FUEL BURNUPS
*----
      CALL LCMLEN(IPRES,'BURN-INST',ILONG,ITYP)
      IF(ILONG.EQ.0) THEN
         CALL XABORT('@TINSHU: INITIAL BURNUP REQUIRED')
      ENDIF
      CALL LCMGET(IPRES,'BURN-INST',WINT(1,1))
*----
*  RECOVER SHIFT VECTOR
*----
      MAXS=0
      CALL LCMLEN(IPRES,'ISHIFT',ILS,ITYLCM)
      IF(ILS.NE.0) THEN
        CALL LCMGET(IPRES,'ISHIFT',ISFT(1,1))
        DO 17 I=1,NK
         DO 17 J=1,NCH
            MAXS=MAX(MAXS,ISFT(J,I))
 17     CONTINUE
      ELSE
        MAXS=0
      ENDIF

      IF(MAXS.GT.0) THEN
        DO 16 IS=1,MAXS
          WRITE (CS,'(I2)') IS
          CALL LCMGET(IPRES,'BSHIFT'//CS,BS(1,1,IS))
          CALL LCMGET(IPRES,'PSHIFT'//CS,PS(1,1,IS))
 16     CONTINUE
      ENDIF

      CALL LCMGET(IPRES,'BMIX',MIX)
      CALL LCMGET(IPRES,'XNAME',IXN)
      CALL LCMGET(IPRES,'YNAME',IYN)
*----
*  SEARCH FOR CHANNEL NUMBER TO MOVE
*----
      TEXT4 = NAMCHA(2:3)
      IX = 1
      IY = 1
      DO 10 I=1,NX
        WRITE(XNAM,'(A4)') IXN(I)
        IF (XNAM.EQ.TEXT4) THEN
           IX = I
           GOTO 11
        ENDIF
  10  CONTINUE
  11  TEXT4 = NAMCHA(1:1)
      DO 20 I=1,NY
        WRITE(YNAM,'(A4)') IYN(I)
        IF (YNAM.EQ.TEXT4) THEN
           IY = I
           GOTO 21
        ENDIF
  20  CONTINUE

  21  I = (IY-1)*NX + IX
      ICH1 = MIX(I)
      IF(ICH1.EQ.0) CALL XABORT('@TINSHU: WRONG CHANNEL NAME')
      IF(IPRT.GT.3) THEN
        WRITE(6,*)
        WRITE(6,*) ' SHUFFLING CHANNEL ',NAMCHA,ICH1
        WRITE(6,*) ' BEFORE ',NAMCHA,(WINT(ICH1,I),I=1,NK)
      ENDIF
*----
*  SEARCH FOR CHANNEL NUMBER WHERE TO MOVE
*----
      IF(NAMCHA2.NE.'POOL') THEN
        TEXT4 = NAMCHA2(2:3)
        IX = 1
        IY = 1
        DO 30 I=1,NX
          WRITE(XNAM,'(A4)') IXN(I)
          IF (XNAM.EQ.TEXT4) THEN
             IX = I
             GOTO 31
          ENDIF
  30    CONTINUE
  31    TEXT4 = NAMCHA2(1:1)
        DO 40 I=1,NY
          WRITE(YNAM,'(A4)') IYN(I)
          IF (YNAM.EQ.TEXT4) THEN
             IY = I
             GOTO 41
          ENDIF
  40    CONTINUE

  41    I = (IY-1)*NX + IX
        ICH2 = MIX(I)
        IF(ICH2.EQ.0) CALL XABORT('@TINSHU: WRONG CHANNEL NAME')
        IF(IPRT.GT.3) THEN
          WRITE(6,*)
          WRITE(6,*) ' SHUFFLING CHANNEL ',NAMCHA2,ICH2
          WRITE(6,*) ' BEFORE ',NAMCHA2,(WINT(ICH2,I),I=1,NK)
        ENDIF
*----
*  SHUFFLING
*----
        DO 50 I=1,NK
          IF(WINT(ICH2,I).NE.0.0) THEN
             WRITE(6,*) ' BURNUP ',WINT(ICH2,I)
             CALL XABORT('@TINSHU: WRONG POSITION TO SHUFFLE, '
     +          //'CHANNEL NOT EMPTY')
          ENDIF
          WINT(ICH2,I) = WINT(ICH1,I)
          WINT(ICH1,I) = 0.0
          ISFT(ICH2,I) = ISFT(ICH1,I)
          ISFT(ICH1,I) = 0
          IF(MAXS.GT.0) THEN
             DO 56 IS=1,MAXS
               BS(ICH2,I,IS) = BS(ICH1,I,IS)
               PS(ICH2,I,IS) = PS(ICH1,I,IS)
               BS(ICH1,I,IS) = 0.0
               PS(ICH1,I,IS) = 0.0
  56         CONTINUE
          ENDIF
  50    CONTINUE
        IF(IPRT.GT.3) THEN
          WRITE(6,*)
          WRITE(6,*) ' AFTER ',NAMCHA2,(WINT(ICH2,I),I=1,NK)
        ENDIF
      ELSE
        WRITE(6,*) ' CHANNEL TO POOL '
*----
*  RECOVER DISCHARGED FUEL BURNUPS
*----
        CALL LCMLEN(IPRES,'BURN-POOL',ILONG,ITYP)
        IF(ILONG.NE.0) THEN
           CALL LCMGET(IPRES,'BURN-POOL',POOL(1,1))
        ENDIF
        DO 51 I=1,NK
          POOL(ICH1,I) = WINT(ICH1,I)
          WINT(ICH1,I) = 0.0
  51    CONTINUE
        CALL LCMPUT(IPRES,'BURN-POOL',NCH*NK,2,POOL(1,1))
      ENDIF
      IF(IPRT.GT.3)
     +    WRITE(6,*) ' AFTER ',NAMCHA,(WINT(ICH1,I),I=1,NK)
      CALL LCMSIX(IPRES,' ',0)
      CALL LCMPUT(IPRES,'BURN-INST',NCH*NK,2,WINT(1,1))
      CALL LCMPUT(IPRES,'ISHIFT',NCH*NK,1,ISFT(1,1))
      IF(MAXS.GT.0) THEN
        DO 53 IS=1,MAXS
          WRITE (CS,'(I2)') IS
          CALL LCMPUT(IPRES,'BSHIFT'//CS,NCH*NK,2,BS(1,1,IS))
          CALL LCMPUT(IPRES,'PSHIFT'//CS,NCH*NK,2,PS(1,1,IS))
 53     CONTINUE
      ENDIF
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(POOL)
      RETURN
      END
