*DECK TINREF
      SUBROUTINE TINREF(IPRES,IPMIC,IPMIC2,IPMIC3,NCH,NK,NX,NY,NREG,
     +         NAMCHA,NS,MS,WINT,MIX,IXN,IYN,BS,PS,ISFT,POW,MAXS,NSS,
     +         IND,IPRT,KRF,LMIC)
*
*-----------------------------------------------------------------------
*
*Purpose:
* refuel a channel according to a refuelling mode
*
*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.
* IPMIC  Adress of the L_LIBRARY in creation mode.
* IPMIC2 Adress of the fuel-map L_LIBRARY in read-only mode.
* IPMIC3 Adress of the L_LIBRARY in read-only mode, containing new 
*        fuel properties.
* NCH    Number of channels
* NK     Number of bundles per channel
* NX     Number of X-Meshes
* NY     Number of Y-Meshes
* NREG   Number of regions in fuel map geometry
* NAMCHA Name of the channel to refuel
* NS     Number of bundles inserted
* MS     Old maximum of shift + 1.
* MIX    Fuel map bundle index
* IXN    Name of the channel according to X
* IYN    Name of the channel according to Y
* POW    Power distribution.
* INDEX  Fuel type indice
* IND    Fuel type indice in the channel to refuel
* MAXS   Maximum number of power shift
* IPRT   Flag for printing level
* KRF    Type of refueling
* LMIC   =.true. for a micro-refueling
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPRES
      INTEGER     NCH,NK,NX,NY,NS,NREG,ILONG,ITYP,IX,IY,IPRT,MS,IS,
     1            MAXS,KS,NSS(NCH),NNS,IPMIC,IPMIC2,IPMIC3
      REAL        WINT(NCH,NK),BS(NCH,NK,MS),PS(NCH,NK,MS),POW(NCH,NK)
      CHARACTER   XNAM*4,YNAM*4,NAMCHA*4,TEXT4*4,CS*2
      INTEGER     MIX(NREG),IXN(NX),IYN(NY),ISFT(NCH,NK),IND(*)
      LOGICAL     LMIC
      REAL        TMPDAY(3)
*----
*  LOCAL VARIABLES
*----
      PARAMETER (NSTATE=40,IOUT=6)
      INTEGER   ISTATE(NSTATE),I,J
      INTEGER, ALLOCATABLE, DIMENSION(:) :: NW,NW2,NWU,ISONA,ISOMI,ISHF
      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INDEX,IWORK
      REAL, ALLOCATABLE, DIMENSION(:) :: DENIS,NDENS
      REAL, ALLOCATABLE, DIMENSION(:,:) :: WORK
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: WORKS
      LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASK,MASKL
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(NW(NK),NW2(NK),INDEX(NCH,NK),IWORK(NK,2))
      ALLOCATE(WORK(NK,2),WORKS(NK,MS,2))
*----
*  RECOVER SHIFT VECTOR
*----
      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
        DO 15 I=1,NK
          DO 15 J=1,NCH
            ISFT(J,I) = 0
 15     CONTINUE
      ENDIF
      DO 1 I=1,NK
       DO 1 J=1,NCH
         WINT(J,I) = 0.0
         DO 2 K=1,MS
           BS(J,I,K)=0.0
           PS(J,I,K)=0.0
  2      CONTINUE
  1   CONTINUE
*----
*  RECOVER FUEL BURNUPS
*----
      CALL LCMLEN(IPRES,'BURN-INST',ILONG,ITYP)
      IF(ILONG.EQ.0) THEN
         CALL XABORT('@TINREF: INITIAL BURNUP REQUIRED')
      ENDIF
      CALL LCMGET(IPRES,'BURN-INST',WINT)
*----
*  RECOVER FUEL INDEX
*----
      CALL LCMLEN(IPRES,'FLMIX',ILONG,ITYP)
      IF(ILONG.NE.0) THEN
         CALL LCMGET(IPRES,'FLMIX',INDEX)
      ELSE
         CALL XABORT('@TINREF: FLMIX ARE REQUIRED')
      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 LCMSIX(IPRES,' ',0)
      CALL LCMGET(IPRES,'BMIX',MIX)
*----
*  SEARCH FOR THE CHANNEL NUMBER FROM ITS NAME
*----
      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
      ICH = MIX(I)
      IF(ICH.EQ.0) CALL XABORT('@TINREF: WRONG CHANNEL NAME')
      IF(NSS(ICH).NE.0) THEN
        IF(ABS(NSS(ICH)).NE.ABS(NS)) THEN
          WRITE(6,'(14H @TINREF: ICH=,I6,5H NSS=,I6,4H NS=,I6)') ICH,
     +    NSS(ICH),NS
          CALL XABORT('@TINREF: WRONG REFUELING SCHEME')
        ENDIF
        NS = NSS(ICH)
      ENDIF
      IF( IPRT.GT.3 )THEN
        WRITE(6,*) ' REFUELING CHANNEL ',NAMCHA,' IX IY ',IX,IY
        WRITE(6,*) ' REFUELING CHANNEL ',ICH,' SCHEME ',NS
        WRITE(6,*) ' INITIAL BURNUP ',(WINT(ICH,I),I=1,NK)
      ENDIF

      NNS = ABS(NS)
      CALL TINFL(NNS,NW,NW2,NK)

      II=0
      DO 30 K=1,NK
         KK = K
         IF (NS.LT.0) THEN
            KK = NK - K + 1
         ENDIF
         KA = NW(K)
*----
*  INSERTION OF A NEW BUNDLE OR REPOSITIONNING
*----
         IF (KA.EQ.0) THEN
            II=II+1
            WORK(KK,1) = 0.0
            IWORK(KK,1)=0
            IF( KRF.EQ.1 )THEN
              IWORK(KK,2)=INDEX(ICH,KK)
            ELSE
              IWORK(KK,2)=IND(II)
            ENDIF
            IF(MAXS.GT.0) THEN
              DO 39 IS=1,MAXS
                WORKS(KK,IS,1) = 0.0
                WORKS(KK,IS,2) = 0.0
  39          CONTINUE
            ENDIF
         ELSE
            IF (NS.LT.0) THEN
               KA = NK - KA + 1
            ENDIF
            WORK(KK,1) = WINT(ICH,KA)
            WORK(KK,2) = POW(ICH,KA)
            IWORK(KK,1)= ISFT(ICH,KA)
            IWORK(KK,2)= INDEX(ICH,KA)
            IF(MAXS.GT.0) THEN
              DO 19 IS=1,MAXS
                WORKS(KK,IS,1) = BS(ICH,KA,IS)
                WORKS(KK,IS,2) = PS(ICH,KA,IS)
  19          CONTINUE
            ENDIF
         ENDIF
  30  CONTINUE

      DO 40 K=1,NK
        WINT(ICH,K) = WORK(K,1)
        POW(ICH,K) = WORK(K,2)
        ISFT(ICH,K) = IWORK(K,1)
        INDEX(ICH,K) = IWORK(K,2)
        IF(MAXS.GT.0) THEN
          DO 22 IS=1,MAXS
            BS(ICH,K,IS)=WORKS(K,IS,1)
            PS(ICH,K,IS)=WORKS(K,IS,2)
  22      CONTINUE
        ENDIF
        IF(WORK(K,1).NE.0.0) THEN
          KS=ISFT(ICH,K)+1
          BS(ICH,K,KS)=WINT(ICH,K)
          PS(ICH,K,KS)=WORK(K,2)
          ISFT(ICH,K)=KS
        ENDIF
  40  CONTINUE

      MAXS=0
      DO 12 I=1,NK
        DO 12 J=1,NCH
          MAXS=MAX(MAXS,ISFT(J,I))
  12  CONTINUE
*----
* CALL THE SUBROUTINE FOR A MICROSCOPIC REFUEL
*----
      IF(LMIC) THEN
        CALL XDISET(ISTATE,NSTATE,0)
        CALL LCMGET(IPMIC2,'STATE-VECTOR',ISTATE)
        NISO=ISTATE(2)
        NDEP=ISTATE(12)
        IF(NDEP.NE.NK*NCH) CALL XABORT('@TINREF: WRONG NUMBER OF '
     +  //'DEPLETING MIXTURES IN THE LIBRARY.')
        CALL XDISET(ISTATE,NSTATE,0)
        CALL LCMGET(IPMIC3,'STATE-VECTOR',ISTATE)
        NISO2=ISTATE(2)
        ALLOCATE(NWU(NK))
        DO I=1,NK
          IF(NS.GT.0) THEN
            NWU(I)=NW(I)
          ELSE
            NWU(I)=NW2(I)
          ENDIF
        ENDDO
        ALLOCATE(NDENS(NISO),ISHF(NK))
        CALL TINMIC(IPMIC,IPMIC2,IPMIC3,NK,NCH,NWU,ICH,NISO,NISO2,
     1  IWORK,ISHF,NDENS)
        CALL LCMPUT(IPMIC,'ISOTOPESDENS',NISO,2,NDENS)
*----
*  COMPUTE THE MACROSCOPIC X-SECTIONS
*----
        CALL LCMGET(IPMIC,'STATE-VECTOR',ISTATE)
        MAXMIX=ISTATE(1)
        NBISO=ISTATE(2)
        NGRP=ISTATE(3)
        ALLOCATE(MASK(MAXMIX),MASKL(NGRP))
        ALLOCATE(ISONA(3*NBISO),ISOMI(NBISO),DENIS(NBISO))
        CALL LCMGET(IPMIC,'ISOTOPESUSED',ISONA)
        CALL LCMGET(IPMIC,'ISOTOPESMIX',ISOMI)
        CALL LCMGET(IPMIC,'ISOTOPESDENS',DENIS)
        CALL XDLSET(MASK,MAXMIX,.FALSE.)
        CALL XDLSET(MASKL,NGRP,.TRUE.)
        DO 13 I=1,NBISO
          IBM=ISOMI(I)
          MASK(IBM)=.TRUE.
  13    CONTINUE
        ITSTMP=0
        TMPDAY(1)=0.0
        TMPDAY(2)=0.0
        TMPDAY(3)=0.0
*       COMPUTATION OF THE MACROSCOPIC XS
        CALL LIBMIX(IPMIC,MAXMIX,NGRP,NBISO,ISONA,ISOMI,DENIS,MASK,
     1  MASKL,ITSTMP,TMPDAY)
        DEALLOCATE(DENIS,ISOMI,ISONA,MASKL,MASK)
        DEALLOCATE(NWU,NDENS,ISHF)
      ENDIF

      IF( IPRT.GT.3 )THEN
        WRITE(6,*) ' SHIFTING BURNUP ',(WINT(ICH,I),I=1,NK)
      ENDIF

      CALL LCMSIX(IPRES,' ',0)
      IF(IPRT.GT.3) WRITE(6,*) ' REFUELLING TYPE DIRECT OR HOMOGENOUS'
      CALL LCMPUT(IPRES,'BURN-INST',NCH*NK,2,WINT(1,1))
      CALL LCMPUT(IPRES,'FLMIX',NCH*NK,1,INDEX(1,1))
      CALL LCMPUT(IPRES,'ISHIFT',NCH*NK,1,ISFT(1,1))

      IF(MAXS.GT.0) THEN
        DO 14 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))
 14    CONTINUE
      ENDIF
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(WORKS,WORK,IWORK,INDEX,NW2,NW)
      RETURN
      END
