1 files changed, 82 insertions, 0 deletions
diff --git a/Donjon/src/RESCEL.f b/Donjon/src/RESCEL.f
new file mode 100644
index 0000000..90f14c1
--- /dev/null
+++ b/Donjon/src/RESCEL.f
@@ -0,0 +1,82 @@
+*DECK RESCEL
+      SUBROUTINE RESCEL(IPMAP,NCH,NK,ALCH)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Compute fuel bundle burnups from the age pattern ALCH between 
+* begin-of-cyle burnups BINI and end-of-cycle burnups BFIN
+*
+*Copyright:
+* Copyright (C) 2002 Ecole Polytechnique de Montreal
+* This library is free software; you can redistribute it and/or
+* modify it under the terms of the GNU Lesser General Public
+* License as published by the Free Software Foundation; either
+* version 2.1 of the License, or (at your option) any later version
+*
+*Author(s): 
+* routine partly recovered from OPTEX-4 (coef3e)
+*
+*Parameters: input
+* IPMAP  address of the MAP linked list or xsm file
+* NCH    number of channels
+* NK     number of bundles per channel
+* ALCH   integer representing channel age. 
+*
+*Parameters: output
+* IPMAP  address of the MAP linked list or xsm file
+*
+*Reference:
+* J. Tajmouati, "Optimisation de la gestion du combustible enrichi d'un
+* reacteur CANDU avec prise en compte des parametres locaux", These
+* Ph. D., Ecole Polytechnique de Montreal (1993). Voir Eq. (4.7).
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPMAP
+      INTEGER     NCH,NK,ALCH(NCH)
+      REAL, ALLOCATABLE, DIMENSION(:) :: F
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: WINT,BINI,BFIN
+*----
+*  LOCAL VARIABLES
+*----
+      INTEGER     I,J,ILONG,ITYP
+*----
+*  SCRATCH STORAGE ALLOCATION
+*   BINI   initial burnup map
+*   BFIN   final burnup map
+*   WINT   instantaneous burnup
+*   F      age values in real
+*----
+      ALLOCATE(WINT(NCH,NK),BINI(NCH,NK),BFIN(NCH,NK),F(NCH))
+*
+* RECOVER FUEL BURNUPS
+      CALL LCMLEN(IPMAP,'BURN-BEG',ILONG,ITYP)
+      IF(ILONG.EQ.0) THEN
+         CALL XABORT('SHIFTB: INITIAL BURNUP REQUIRED')
+      ENDIF
+      CALL LCMGET(IPMAP,'BURN-BEG',BINI)
+      CALL LCMLEN(IPMAP,'BURN-END',ILONG,ITYP)
+      IF(ILONG.EQ.0) THEN
+         CALL XABORT('SHIFTB: FINAL BURNUP REQUIRED')
+      ENDIF
+      CALL LCMGET(IPMAP,'BURN-END',BFIN)
+*
+      DO 10 I=1,NCH
+        F(I) = (FLOAT(ALCH(I)) - 0.5) / FLOAT(NCH)
+        IF( ALCH(I).EQ.0 ) F(I) = 0.0
+        DO 11 J=1,NK
+          WINT(I,J) = BINI(I,J) + F(I) * (BFIN(I,J) - BINI(I,J))
+ 11     CONTINUE
+ 10   CONTINUE
+      CALL LCMPUT(IPMAP,'BURN-INST',NCH*NK,2,WINT)
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(F,BFIN,BINI,WINT)
+      RETURN
+      END