Initial commit from Polytechnique Montreal

1 files changed, 772 insertions, 0 deletions

diff --git a/Donjon/src/RESPAR.f b/Donjon/src/RESPAR.f
new file mode 100644
index 0000000..e2abcdb
--- /dev/null
+++ b/Donjon/src/RESPAR.f
@@ -0,0 +1,772 @@
+*DECK RESPAR
+      SUBROUTINE RESPAR(IPMAP,NCH,NB,NFUEL,NCOMB,NPARM,NX,NY,NZ,NSTATE,
+     1 ISTATE,IMPX,NASB,LMAP2,IPMP2)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Read and store the data related to global and local parameters.
+*
+*Copyright:
+* Copyright (C) 2007 Ecole Polytechnique de Montreal.
+*
+*Author(s): 
+* D. Sekki, R. Chambon, M. Guyot, V. Descotes, B. Toueg
+*
+*Parameters: input/output
+* IPMAP   pointer to fuel-map information.
+* NCH     number of reactor channels.
+* NB      number of fuel bundles per channel.
+* NFUEL   number of fuel types.
+* NCOMB   number of combustion zones.
+* NX      number of elements along x-axis in fuel map.
+* NY      number of elements along y-axis in fuel map.
+* NZ      number of elements along z-axis in fuel map.
+* NSTATE  maximum number of state-vector records.
+* IMPX    printing index (=0 for no print).
+* NASB    total number of assembly
+* LMAP2   flag to set if second fuel-map information is used to
+*         recover burnup information
+* IPMP2   pointer to the second fuel-map information.
+*
+*Parameters: output
+* ISTATE  updated state-vector.
+* NPARM   total number of recorded parameters.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPMAP,IPMP2
+      INTEGER NCH,NB,NFUEL,NCOMB,NPARM,NX,NY,NZ,NSTATE,ISTATE(NSTATE),
+     1 IMPX
+      LOGICAL LMAP2
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER(IOUT=6)
+      INTEGER INAME(3),IZONE(NCH),IVECT(NCOMB,NB),NSCH(NCH),
+     1 IBSH(NCOMB),IPAT(NCOMB),SHPAT(NCOMB),SHDIR(NCOMB),MIX(NX*NY*NZ),
+     2 FMIX(NCH,NB),IAZ(NCH),ISTAT2(NSTATE),SHREF,DIRREF(NCOMB)
+      REAL VALUE(NCH,NB),POWER(NCH,NB),FPOWER(NB)
+      CHARACTER CVALUE(NCH,NB)*12
+      DOUBLE PRECISION DFLOT
+      CHARACTER TEXT*12,TEXT12*12,PNAME*12,KEYN*12,PNAME2*12
+      LOGICAL LRSCH,LBURN
+      TYPE(C_PTR) JPMAP,KPMAP,ZPMAP,JPMP2,KPMP2
+*----
+*  ALLOCATABLE STATEMENTS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: ALCH,NUM,IND,VPAT
+      REAL, ALLOCATABLE, DIMENSION(:) :: DENSMOD,BRN,BASS,VAL2,ZZ,VB
+*----
+*  READ INPUT DATA
+*----
+      LRSCH=.FALSE.
+      LBURN=.FALSE.
+      PTOT=0.0
+      CALL LCMGET(IPMAP,'FLMIX',FMIX)
+   10 CALL REDGET(ITYP,NITMA,FLOT,TEXT12,DFLOT)
+      IF(ITYP.NE.3)CALL XABORT('@RESPAR: CHARACT'
+     1 //'ER DATA EXPECTED ('//TEXT12//').')
+      IF(TEXT12.EQ.';')THEN
+        GOTO 500
+*     PRINTING INDEX
+      ELSEIF(TEXT12.EQ.'EDIT')THEN
+        CALL REDGET(ITYP,NITMA,FLOT,TEXT12,DFLOT)
+        IF(ITYP.NE.1)CALL XABORT('@RESPAR: INTEGER DA'
+     1   //'TA FOR EDIT EXPECTED.')
+        IMPX=MAX(0,NITMA)
+*----
+*  ADD NEW PARAMETER
+*----
+      ELSEIF(TEXT12.EQ.'ADD-PARAM')THEN
+        CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+        IF(TEXT.NE.'PNAME')CALL XABORT('@RESPAR: KEY'
+     1   //'WORD PNAME EXPECTED.')
+*       READ PARAMETER NAME
+        CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+        IF(ITYP.NE.3)CALL XABORT('@RESPAR: CHARACTER'
+     1   //' DATA FOR PARAMETER NAME EXPECTED.')
+        IF(IMPX.GT.0)WRITE(IOUT,1000)TEXT
+        IF(NPARM.GT.0)THEN
+          JPMAP=LCMGID(IPMAP,'PARAM')
+          DO IPAR=1,NPARM
+            KPMAP=LCMGIL(JPMAP,IPAR)
+            CALL LCMGET(KPMAP,'P-NAME',INAME)
+            WRITE(PNAME,'(3A4)') (INAME(I),I=1,3)
+            IF(PNAME.EQ.TEXT)CALL XABORT('@RESPAR: THE '
+     1       //'PARAMETER '//TEXT//' ALREADY EXISTS.')
+          ENDDO
+        ENDIF
+        NPARM=NPARM+1
+        JPMAP=LCMLID(IPMAP,'PARAM',NPARM)
+        KPMAP=LCMDIL(JPMAP,NPARM)
+        READ(TEXT,'(3A4)') (INAME(I),I=1,3)
+        CALL LCMPUT(KPMAP,'P-NAME',3,3,INAME)
+*       READ PARKEY NAME
+        CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+        IF(TEXT.NE.'PARKEY')CALL XABORT('@RESPAR: KEY'
+     1   //'WORD PARKEY EXPECTED.')
+        CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+        IF(ITYP.NE.3)CALL XABORT('@RESPAR: CHARACTER'
+     1   //' DATA FOR PARKEY NAME EXPECTED.')
+        READ(TEXT,'(3A4)') (INAME(I),I=1,3)
+        CALL LCMPUT(KPMAP,'PARKEY',3,3,INAME)
+*       READ PARAMETER TYPE
+        CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+        IF(TEXT.EQ.'GLOBAL')THEN
+          IPTYP=1
+        ELSEIF(TEXT.EQ.'LOCAL')THEN
+          IPTYP=2
+        ELSE
+          CALL XABORT('@RESPAR: INVALID KEYWORD '//TEXT)
+        ENDIF
+        CALL LCMPUT(KPMAP,'P-TYPE',1,1,IPTYP)
+        ISTATE(8)=NPARM
+*----
+*  SET PARAMETER VALUES
+*----
+      ELSEIF(TEXT12.EQ.'SET-PARAM')THEN
+        IF(NPARM.EQ.0)CALL XABORT('@RESPAR: PARAM'
+     1   //'ETER NOT YET DEFINED NPARM=0')
+        CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+        IF(ITYP.NE.3)CALL XABORT('@RESPAR: CHARACT'
+     1   //'ER DATA FOR PARAMETER NAME EXPECTED.')
+*       RECOVER PARAMETER
+        JPMAP=LCMGID(IPMAP,'PARAM')
+        DO IPAR=1,NPARM
+          KPMAP=LCMGIL(JPMAP,IPAR)
+          CALL LCMGET(KPMAP,'P-NAME',INAME)
+          WRITE(PNAME,'(3A4)') (INAME(I),I=1,3)
+          IF(PNAME.EQ.TEXT)THEN
+            CALL LCMGET(KPMAP,'P-TYPE',IPTYP)
+            GOTO 30
+          ENDIF
+        ENDDO
+        CALL XABORT('@RESPAR: UNABLE TO FIND PARAME'
+     1   //'TER WITH PNAME '//TEXT)
+   20   IF(IMPX.GT.0)WRITE(IOUT,1001)TEXT
+   30   IF(IPTYP.EQ.1)THEN
+*         GLOBAL PARAMETER
+          CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+          IF((ITYP.EQ.3).AND.(TEXT.EQ.'OLDMAP')) THEN
+            IPTYP=11
+            GOTO 20
+          ENDIF
+          IF(ITYP.NE.2)CALL XABORT('@RESPAR: REAL'
+     1     //' DATA or OLDMAP keyword FOR VALUE EXPECTED.')
+          CALL LCMPUT(KPMAP,'P-VALUE',1,2,FLOT)
+        ELSE
+*         LOCAL PARAMETER
+          VALUE(:NCH,:NB)=0.0
+          IF(IPTYP.NE.11) CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+          IF(TEXT.EQ.'SAME')THEN
+            CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+            DO ICH=1,NCH
+              DO IB=1,NB
+                IF(FMIX(ICH,IB).NE.0) THEN
+                  IF(ITYP.EQ.2)VALUE(ICH,IB)=FLOT
+                  IF(ITYP.EQ.3)CVALUE(ICH,IB)=TEXT
+                ENDIF
+              ENDDO
+            ENDDO
+*
+          ELSEIF(TEXT.EQ.'CHAN')THEN
+            DO ICH=1,NCH
+              CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+              IF(ITYP.NE.2)CALL XABORT('@RESPAR: REAL'
+     1         //' DATA FOR VALUE EXPECTED.')
+              DO 40 IB=1,NB
+              IF(FMIX(ICH,IB).NE.0) VALUE(ICH,IB)=FLOT
+   40         CONTINUE
+            ENDDO
+*
+          ELSEIF(TEXT.EQ.'BUND')THEN
+            DO 55 IB=1,NB
+            DO 50 ICH=1,NCH
+              IF(FMIX(ICH,IB).EQ.0) GO TO 50
+              CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+              IF(ITYP.EQ.2)VALUE(ICH,IB)=FLOT
+              IF(ITYP.EQ.3)CVALUE(ICH,IB)=TEXT
+   50       CONTINUE
+   55       CONTINUE
+          ELSEIF(TEXT.EQ.'TIMES')THEN
+! try to find the parameters called DMOD
+            CALL REDGET(ITYP,NITMA,FLOT,KEYN,DFLOT)
+            IF(ITYP.NE.3)CALL XABORT('@RESPAR: CHARACTER'
+     1       //' DATA FOR VALUE EXPECTED.')
+            JPMAP=LCMGID(IPMAP,'PARAM')
+            DO IPAR=1,NPARM
+              ZPMAP=LCMGIL(JPMAP,IPAR)
+              CALL LCMGET(ZPMAP,'P-NAME',INAME)
+              WRITE(PNAME,'(3A4)') (INAME(I),I=1,3)
+              IF(PNAME.EQ.KEYN)THEN
+                CALL LCMGET(ZPMAP,'P-TYPE',IPTYP)
+                GOTO 60
+              ENDIF
+            ENDDO
+            CALL XABORT('@RESPAR: UNABLE TO FIND PARAME'
+     1        //'TER WITH PNAME '//KEYN)
+   60       CONTINUE
+            ALLOCATE(DENSMOD(NCH*NB))
+            CALL LCMGET(ZPMAP,'P-VALUE',DENSMOD)
+            CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+            IF(ITYP.NE.3.OR.TEXT.NE.'SAME')CALL XABORT('@RESPAR:'
+     1       //' KEYWORD SAME EXPECTED.')
+            CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+            IF(ITYP.NE.2) CALL XABORT('@RESPAR: REAL DATA EXPECTED.')
+            DO IB=1,NB
+              DO ICH=1,NCH
+                IF(FMIX(ICH,IB).NE.0) THEN
+                  VALUE(ICH,IB)=FLOT*DENSMOD(ICH+(IB-1)*NCH)
+                ENDIF
+              ENDDO
+            ENDDO
+            DEALLOCATE(DENSMOD)
+*  R. Chambon - begin
+          ELSEIF(TEXT.EQ.'OLDMAP')THEN
+            IF(.NOT.LMAP2) CALL XABORT('@RESPAR: SECOND'
+     1        //' L_MAP EXPECTED.')
+            CALL LCMGET(IPMP2,'STATE-VECTOR',ISTAT2)
+            NPARM2=ISTAT2(8)
+            JPMP2=LCMGID(IPMP2,'PARAM')
+            DO IPAR=1,NPARM2
+              KPMP2=LCMGIL(JPMP2,IPAR)
+              CALL LCMGET(KPMP2,'P-NAME',INAME)
+              WRITE(PNAME2,'(3A4)') (INAME(I),I=1,3)
+              IF(PNAME.EQ.PNAME2)THEN
+                GOTO 70
+              ENDIF
+            ENDDO
+            CALL XABORT('@RESPAR: UNABLE TO FIND PARAME'
+     1       //'TER WITH PNAME in second L_MAP '//TEXT)
+   70       CALL LCMLEN(KPMP2,'P-VALUE',NITMA,INDIC)
+            IF(NITMA.EQ.0) CALL XABORT('@RESPAR: Record BURN-INST in '
+     1        //'SECOND L_MAP EXPECTED.')
+            ALLOCATE(VAL2(NITMA))
+            CALL LCMGET(KPMP2,'P-VALUE',VAL2)
+*         global parameter
+            IF(NITMA.EQ.1) THEN
+              VALUE(1,1)=VAL2(1)
+*         recovered from previous calculation with the same geometry
+*         but not the same initialization part
+*         example: homogeneous calculation followed by a pin power
+*         reconstruction
+            ELSEIF(NITMA.EQ.NCH*NB) THEN
+              DO ICH=1,NCH
+                DO IB=1,NB
+                  I=ICH+(IB-1)*NCH
+                  VALUE(ICH,IB)=VAL2(I)
+                ENDDO
+              ENDDO
+*         recovered from previous calculation with a different geometry
+*         the second geometry must correspond to the assembly geometry
+*         of the new geometry
+*         examples: homogeneous calculation followed by a heterogeneous
+*                   calculation
+*                   homogeneous calculation followed by a pin power
+*                   calculation
+            ELSEIF(NITMA.EQ.NASB*NB) THEN
+              CALL LCMGET(IPMAP,'A-ZONE',IAZ)
+              DO ICH=1,NCH
+                DO IB=1,NB
+                  VALUE(ICH,IB)=VAL2(IAZ(ICH)+(IB-1)*NCH)
+                ENDDO
+              ENDDO
+            ENDIF
+            DEALLOCATE(VAL2)
+*  R. Chambon - End
+          ELSEIF(TEXT.EQ.'LEVEL')THEN
+*           move a control rod over each channel
+            ITOP=1
+   75       CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+            IF(ITYP.NE.3)CALL XABORT('@RESPAR: CHARACTER DATA H+, H-,'
+     1       //'SAME OR CHAN EXPECTED.')
+            IF(TEXT.EQ.'H+')THEN
+*             PWR-type moving rod
+              ITOP=1
+              GO TO 75
+            ELSEIF(TEXT.EQ.'H-')THEN
+*             BWR-type moving rod
+              ITOP=-1
+              GO TO 75
+            ELSEIF(TEXT.EQ.'SAME') THEN
+              CALL REDGET(ITYP,NITMA,ZLEVEL,TEXT,DFLOT)
+              IF(ITYP.NE.2) CALL XABORT('@RESPAR: REAL DATA EXPECTED.')
+            ENDIF
+            JPMAP=LCMGID(IPMAP,'GEOMAP')
+            CALL LCMGET(JPMAP,'STATE-VECTOR',ISTAT2)
+            NX=ISTAT2(3)
+            NY=ISTAT2(4)
+            NZ=ISTAT2(5)
+            NEL=ISTAT2(6)
+            IF((ISTAT2(1).EQ.9).AND.(NY.EQ.0)) NY=1
+            ALLOCATE(ZZ(NZ+1),NUM(NEL),IND(NZ),VB(NB))
+            CALL LCMGET(JPMAP,'MESHZ',ZZ)
+            CALL LCMGET(IPMAP,'BMIX',NUM)
+            ICH=0
+            DO 105 IY=1,NY
+            DO 100 IX=1,NX
+            IEL=(IY-1)*NX+IX
+            DO 80 IZ=1,NZ
+            IF(NUM((IZ-1)*NX*NY+IEL).NE.0) GO TO 90
+   80       CONTINUE
+            GO TO 100
+   90       ICH=ICH+1
+            IF(TEXT.EQ.'CHAN') THEN
+              CALL REDGET(ITYP,NITMA,ZLEVEL,TEXT,DFLOT)
+              IF(ITYP.NE.2) CALL XABORT('@RESPAR: REAL DATA EXPECTED.')
+            ENDIF
+            IF((ZLEVEL.LT.0.0).OR.(ZLEVEL.GT.1.0)) THEN
+              CALL XABORT('@RESPAR: 0<=LEVEL<=1 EXPECTED.')
+            ENDIF
+            IB=0
+            DO IZ=1,NZ
+              IND(IZ)=0
+              IF(NUM((IZ-1)*NX*NY+IEL).EQ.0) CYCLE
+              IB=IB+1
+              IND(IZ)=IB
+            ENDDO
+            IF(IB.NE.NB) CALL XABORT('@RESPAR: INVALID NUMBER OF BUNDL'
+     1      //'ES.')
+            CALL RESROD(NB,NZ,ZZ,IND,ZLEVEL,ITOP,VB)
+            DO IB=1,NB
+              IF(FMIX(ICH,IB).NE.0) VALUE(ICH,IB)=VB(IB)
+            ENDDO
+  100       CONTINUE
+  105       CONTINUE
+            IF(ICH.NE.NCH) CALL XABORT('@RESPAR: INVALID NUMBER OF CHA'
+     1      //'NNELS.')
+            DEALLOCATE(VB,IND,NUM,ZZ)
+          ELSE
+            CALL XABORT('@RESPAR: INVALID KEYWORD '//TEXT)
+          ENDIF
+          IF(ITYP.EQ.2)CALL LCMPUT(KPMAP,'P-VALUE',NCH*NB,2,VALUE)
+          IF(ITYP.EQ.3)CALL LCMPTC(KPMAP,'P-VALUE',12,NCH*NB,CVALUE)
+          IF(ITYP.EQ.11)CALL LCMPUT(KPMAP,'P-VALUE',1,2,VALUE(1,1))
+        ENDIF
+*----
+*  CHANNEL REFUELLING SCHEMES
+*----
+      ELSEIF(TEXT12.EQ.'REF-SHIFT')THEN
+        IF(IMPX.GT.0)WRITE(IOUT,1002)
+*       BUNDLE-SHIFT NUMBERS, BIDIRECTIONAL 
+        IBSH(:NCOMB)=0
+        DIRREF(:NCOMB)=-1
+        CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+        IF(ITYP.EQ.1)THEN
+          IF(NITMA.LE.0.OR.NITMA.GT.NB)CALL XABORT('@RESPAR:'
+     1     //' BUNDLE-SHIFT MUST BE POSITIVE AND NON-ZERO NUMBER'
+     1     //' AND MAX EQUAL TO NUMBER OF FUEL BUNDLES PER CHANNEL')
+          DO 110 ICZ=1,NCOMB
+          IBSH(ICZ)=NITMA
+  110     CONTINUE
+        ELSEIF((ITYP.EQ.3).AND.(TEXT.EQ.'COMB'))THEN
+          DO ICZ=1,NCOMB
+            CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+            IF(ITYP.NE.1)CALL XABORT('@RESPAR: INTEGER BUNDLE'
+     1      //'-SHIFT NUMBER PER COMBUSTION-ZONE EXPECTED.')
+            IF(NITMA.LE.0.OR.NITMA.GT.NB)CALL XABORT('@RESPAR:'
+     1      //' BUNDLE-SHIFT MUST BE POSITIVE AND NON-ZERO NUMBER.'
+     1      //' AND MAX EQUAL TO NUMBER OF FUEL BUNDLES PER CHANNEL')
+            IBSH(ICZ)=NITMA
+          ENDDO
+* I. Trancart begin
+        ELSEIF((ITYP.EQ.3).AND.(TEXT.EQ.'SHUFF'))THEN
+          IPAT(:NCOMB)=0
+          MPAT=0
+          DO ICZ=1,NCOMB
+            CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+            IF(ITYP.NE.1)CALL XABORT('@RESPAR: INTEGER SHUFFLING'
+     1      //' PATTERN INDEX PER COMBUSTION-ZONE EXPECTED.')
+            IF(NITMA.LE.0.OR.NITMA.GT.NCOMB)CALL XABORT('@RESPAR:'
+     1      //' SHUFFLING PATTERN INDEX MUST BE POSITIVE AND NON-ZERO '
+     1      //'NUMBER AND MAX EQUAL TO NUMBER OF COMBUSTION ZONES.')
+            IPAT(ICZ)=NITMA
+            IF(NITMA.GT.MPAT)THEN
+              MPAT=NITMA
+            ENDIF
+          ENDDO
+          IF(IMPX.GT.0)WRITE(IOUT,1010)MPAT
+          ALLOCATE(VPAT(MPAT*NB))
+          SHPAT(:MPAT)=0
+          SHDIR(:MPAT)=0
+          DO ICP=1,MPAT
+            CALL REDGET(ITYP,NITMA,FLOT,TEXT12,DFLOT)
+            IF(ITYP.NE.3)CALL XABORT('@RESPAR: CHARACTER PATTERN'
+     1      //' EXPECTED ('//TEXT12//'). NOT ENOUGH PATTERN ADDED '
+     2      //' OR MISSING BUNDLES ON PREVIOUS PATTERN.')
+            IF(TEXT12.NE.'PATTERN')CALL XABORT('@RESPAR: KEYWORD PAT'
+     1      //'TERN EXPECTED ('//TEXT12//').')
+            SHREF=0
+            DO IREF=1,NB
+              CALL REDGET(ITYP,NITMA,FLOT,TEXT12,DFLOT)
+              IF(ITYP.NE.1)CALL XABORT('@RESPAR: INTEGER DATA '
+     1        //' EXPECTED FOR SHUFFLING.')
+              IF(NITMA.LT.0.OR.NITMA.GT.NB)CALL XABORT('@RESPAR: '
+     1        //' WRONG REFUELLING POSITION FOR BUNDLE SHUFFLING. ')
+              VPAT((ICP-1)*NB+IREF)=NITMA
+              IF(NITMA.EQ.0)THEN
+                SHREF=SHREF+1
+              ENDIF
+            ENDDO
+            CALL REDGET(ITYP,NITMA,FLOT,TEXT12,DFLOT)
+            IF(ITYP.NE.3)CALL XABORT('@RESPAR: CHARACTER DATA '
+     1      //' EXPECTED FOR COOLANT FLOW.')
+            IF(TEXT12.EQ.'UNIDIR')THEN
+              SHDIR(ICP)=1
+              IF(IMPX.GT.1)WRITE(IOUT,1009)
+            ELSEIF(TEXT12.EQ.'BIDIR')THEN
+              SHDIR(ICP)=-1
+            ELSE
+              CALL XABORT('@RESPAR: UNIDIR OR BIDIR INFORMATION'
+     1        //' EXPECTED FOR COOLANT FLOW.')
+            ENDIF 
+            SHPAT(ICP)=SHREF
+          ENDDO
+          IVECT(:NCOMB,:NB)=0
+          IBSH(:NCOMB)=0
+          DO IB=1,NB
+          DO ICZ=1,NCOMB
+          IVECT(ICZ,IB)=VPAT((IPAT(ICZ)-1)*NB+IB)
+          IBSH(ICZ)=SHPAT(IPAT(ICZ))
+          DIRREF(ICZ)=SHDIR(IPAT(ICZ))
+          ENDDO
+          ENDDO
+          DEALLOCATE(VPAT)
+          GO TO 125
+* I. Trancart end
+        ELSE
+          CALL XABORT('@RESPAR: INVALID INPUT FOR REF-SHIFT.')
+        ENDIF
+*       REFUELLING VECTOR
+        IVECT(:NCOMB,:NB)=0
+        DO 120 ICZ=1,NCOMB
+        ISHIFT=IBSH(ICZ)
+        IF(ISHIFT.EQ.NB)GOTO 120
+        NREF=NB-ISHIFT
+        DO IREF=1,NREF
+          IPOS=ISHIFT+IREF
+          IVECT(ICZ,IPOS)=IREF
+        ENDDO
+  120   CONTINUE
+  125   CALL LCMPUT(IPMAP,'REF-SHIFT',NCOMB,1,IBSH)
+        CALL LCMPUT(IPMAP,'REF-VECTOR',NCOMB*NB,1,IVECT)
+*       CHANNEL REFUELLING SCHEMES
+        CALL LCMGET(IPMAP,'B-ZONE',IZONE)
+        CALL LCMGET(IPMAP,'BMIX',MIX)
+        NSCH(:NCH)=0
+        IEL=0
+        ICH=0
+        DO 135 IY=1,NY
+        DO 130 IX=1,NX
+        IEL=IEL+1
+        IF(MIX(IEL).EQ.0)GOTO 130
+        ICH=ICH+1
+        ISHIFT=IBSH(IZONE(ICH))
+        NSCH(ICH)=((DIRREF(IZONE(ICH)))**(IEL+IY-1))*ISHIFT
+  130   CONTINUE
+  135   CONTINUE
+        CALL LCMPUT(IPMAP,'REF-SCHEME',NCH,1,NSCH)
+        LRSCH=.TRUE.
+*----
+*  BURNUP INTERPOLATION TYPE
+*----
+      ELSEIF(TEXT12.EQ.'BTYPE')THEN
+        CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+        IF(ITYP.NE.3)CALL XABORT('@RESPAR: BURN'
+     1   //'UP INTERPOLATION OPTION EXPECTED.')
+        IBTYP=0
+        IF(TEXT.EQ.'TIMAV-BURN')THEN
+          IBTYP=1
+        ELSEIF(TEXT.EQ.'INST-BURN')THEN
+          IBTYP=2
+        ELSE
+          CALL XABORT('@RESPAR: INVALID INPUT FOR BTYPE.')
+        ENDIF
+        ISTATE(5)=IBTYP
+*----
+*  AVERAGE EXIT BURNUPS
+*----
+      ELSEIF(TEXT12.EQ.'TIMAV-BVAL')THEN
+        IF(IMPX.GT.0)WRITE(IOUT,1003)
+        ALLOCATE(BRN(NCOMB))
+        BRN(:NCOMB)=0.0
+        DO ICZ=1,NCOMB
+          CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+          IF(ITYP.NE.2)CALL XABORT('@RESPAR: REAL DATA'
+     1     //' FOR BURNUP VALUE EXPECTED(1).')
+          IF(FLOT.LE.0.)CALL XABORT('@RESPAR: INVALID'
+     1     //' DATA FOR AVERAGE BURNUP VALUE =0.')
+          BRN(ICZ)=FLOT
+        ENDDO
+        CALL LCMPUT(IPMAP,'BURN-AVG',NCOMB,2,BRN)
+        DEALLOCATE(BRN)
+        LBURN=.TRUE.
+*----
+*  INSTANTANEOUS BURNUPS
+*----
+      ELSEIF(TEXT12.EQ.'INST-BVAL')THEN
+        IF(IMPX.GT.0)WRITE(IOUT,1004)
+        VALUE(:NCH,:NB)=0.0
+        CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+        IF(ITYP.NE.3)CALL XABORT('@RESPAR: KEYWORD'
+     1   //' SAME|CHAN|BUND EXPECTED (1).')
+        IF(TEXT.EQ.'BUND')THEN
+          DO IB=1,NB
+            DO ICH=1,NCH
+              IF(FMIX(ICH,IB).NE.0) THEN
+                CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+                IF(ITYP.NE.2)CALL XABORT('@RESPAR: REAL DATA'
+     1            //' FOR BURNUP VALUE EXPECTED(2).')
+                IF(FLOT.LT.0.)CALL XABORT('@RESPAR: INVALID DA'
+     1            //'TA FOR BURNUP VALUE <0.')
+                VALUE(ICH,IB)=FLOT
+              ENDIF
+            ENDDO
+          ENDDO
+        ELSEIF(TEXT.EQ.'CHAN')THEN
+          DO ICH=1,NCH
+            CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+            IF(ITYP.NE.2)CALL XABORT('@RESPAR: REAL DATA'
+     1        //' FOR BURNUP VALUE EXPECTED(2).')
+            IF(FLOT.LT.0.)CALL XABORT('@RESPAR: INVALID DA'
+     1        //'TA FOR BURNUP VALUE <0.')
+            DO IB=1,NB
+              IF(FMIX(ICH,IB).NE.0) VALUE(ICH,IB)=FLOT
+            ENDDO
+          ENDDO
+        ELSEIF(TEXT.EQ.'ASBL')THEN
+          IF(NASB.EQ.0)CALL XABORT('@RESPAR: ASSEMBLY'
+     1        //' NOT DEFINED.')
+          ALLOCATE(BASS(NASB))
+          DO IASS=1,NASB
+            CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+            IF(ITYP.NE.2)CALL XABORT('@RESPAR: REAL DATA'
+     1        //' FOR BURNUP VALUE EXPECTED(2).')
+            IF(FLOT.LT.0.)CALL XABORT('@RESPAR: INVALID DA'
+     1        //'TA FOR BURNUP VALUE <0.')
+            BASS(IASS)=FLOT
+          ENDDO
+          CALL LCMGET(IPMAP,'A-ZONE',IAZ)
+          DO ICH=1,NCH
+            DO IB=1,NB
+              VALUE(ICH,IB)=BASS(IAZ(ICH))
+            ENDDO
+          ENDDO
+          DEALLOCATE(BASS)
+        ELSEIF(TEXT.EQ.'SAME')THEN
+          CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+          IF(ITYP.NE.2)CALL XABORT('@RESPAR: REAL DATA'
+     1      //' FOR BURNUP VALUE EXPECTED(2).')
+          IF(FLOT.LT.0.)CALL XABORT('@RESPAR: INVALID DA'
+     1      //'TA FOR BURNUP VALUE <0.')
+          DO ICH=1,NCH
+            DO IB=1,NB
+              IF(FMIX(ICH,IB).NE.0) VALUE(ICH,IB)=FLOT
+            ENDDO
+          ENDDO
+*  R. Chambon - begin
+        ELSEIF(TEXT.EQ.'OLDMAP')THEN
+          IF(.NOT.LMAP2) CALL XABORT('@RESPAR: SECOND'
+     1      //' L_MAP EXPECTED.')
+          CALL LCMLEN(IPMP2,'BURN-INST',NITMA,INDIC)
+          IF(NITMA.EQ.0) CALL XABORT('@RESPAR: Record BURN-INST in '
+     1      //'SECOND L_MAP EXPECTED.')
+          ALLOCATE(VAL2(NITMA))
+          CALL LCMGET(IPMP2,'BURN-INST',VAL2)
+*         recovered from previous calculation with the same geometry but
+*         not the same initialization part
+*         example: homogeneous calculation followed by a pin power
+*         reconstruction
+          IF(NITMA.EQ.NCH*NB) THEN
+            DO ICH=1,NCH
+              DO IB=1,NB
+                I=ICH+(IB-1)*NCH
+                VALUE(ICH,IB)=VAL2(I)
+              ENDDO
+            ENDDO
+*         recovered from previous calculation with a different geometry
+*         the second geometry must correspond to the assembly geometry
+*         of the new geometry
+*         examples: homogeneous calculation followed by a heterogeneous
+*                   calculation
+*                   homogeneous calculation followed by a pin power
+*                   calculation
+          ELSEIF(NITMA.EQ.NASB*NB) THEN
+            CALL LCMGET(IPMAP,'A-ZONE',IAZ)
+            DO ICH=1,NCH
+              DO IB=1,NB
+                VALUE(ICH,IB)=VAL2(IAZ(ICH)+(IB-1)*NCH)
+              ENDDO
+            ENDDO
+          ENDIF
+          DEALLOCATE(VAL2)
+*  R. Chambon - End
+        ELSEIF(TEXT.EQ.'SMOOTH')THEN
+* EACH 'BURN-INST' WILL HAVE THE SAME BURNUP AS THEIR FIRST INDEX IN 'FLMIX'
+          CALL LCMGET(IPMAP,'BURN-INST',VALUE)
+          DO ICH=1,NCH
+            DO IB=1,NB
+              JBKEEP=0
+              DO JCH=1,NCH
+                DO JB=1,NB
+* FIRST INDEX OF FMIX(ICH,IB) IS AT JCH,JB
+                  JBKEEP=JB
+                  IF(FMIX(ICH,IB).EQ.FMIX(JCH,JB)) GOTO 140
+                ENDDO
+              ENDDO
+              CALL XABORT('@RESPAR: ASSERTION ERROR (NO FIRST INDEX)')
+  140         VALUE(ICH,IB)=VALUE(JCH,JBKEEP)
+            ENDDO
+          ENDDO
+        ELSE
+          CALL XABORT('@RESPAR: KEYWORD'
+     1      //' SAME|CHAN|BUND|ASBL|OLDMAP|SMOOTH EXPECTED (2).')
+        ENDIF
+        CALL LCMPUT(IPMAP,'BURN-INST',NCH*NB,2,VALUE)
+*----
+*  BUNDLE POWERS IN KW
+*----
+      ELSEIF(TEXT12.EQ.'BUNDLE-POW')THEN
+        IF(IMPX.GT.0)WRITE(IOUT,1006)
+        POWER(:NCH,:NB)=0.0
+        CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+        IF(ITYP.NE.3)CALL XABORT('@RESPAR: KEYWORD'
+     1   //' BUND|CHAN|SAME EXPECTED (3).')
+        IF(TEXT.EQ.'BUND')THEN
+          DO IB=1,NB
+            DO ICH=1,NCH
+              IF(FMIX(ICH,IB).NE.0) THEN
+                CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+                IF(ITYP.NE.2)CALL XABORT('@RESPAR: REAL DATA'
+     1            //' FOR POWER VALUE EXPECTED(1).')
+                IF(FLOT.LT.0.)CALL XABORT('@RESPAR: INVALID DA'
+     1            //'TA FOR POWER VALUE <0.')
+                POWER(ICH,IB)=FLOT
+              ENDIF
+            ENDDO
+          ENDDO
+        ELSEIF(TEXT.EQ.'CHAN')THEN
+          DO ICH=1,NCH
+            CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+            IF(ITYP.NE.2)CALL XABORT('@RESPAR: REAL DATA'
+     1        //' FOR POWER VALUE EXPECTED(2).')
+            IF(FLOT.LT.0.)CALL XABORT('@RESPAR: INVALID DA'
+     1        //'TA FOR POWER VALUE <0.')
+            DO IB=1,NB
+              IF(FMIX(ICH,IB).NE.0) POWER(ICH,IB)=FLOT
+            ENDDO
+          ENDDO
+        ELSEIF(TEXT.EQ.'SAME')THEN
+          CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+          IF(ITYP.NE.2)CALL XABORT('@RESPAR: REAL DATA'
+     1      //' FOR BURNUP VALUE EXPECTED(2).')
+          IF(FLOT.LT.0.)CALL XABORT('@RESPAR: INVALID DA'
+     1      //'TA FOR POWER VALUE <0.')
+          DO ICH=1,NCH
+            DO IB=1,NB
+              IF(FMIX(ICH,IB).NE.0) POWER(ICH,IB)=FLOT
+            ENDDO
+          ENDDO
+        ELSE
+          CALL XABORT('@RESPAR: KEYWORD SAME|CHAN|BUND EXPECTED (4).')
+        ENDIF
+        CALL LCMPUT(IPMAP,'BUND-PW',NCH*NB,2,POWER)
+        PTOT=0.0
+        DO ICH=1,NCH
+          DO IB=1,NB
+            PTOT=PTOT+POWER(ICH,IB)
+          ENDDO
+        ENDDO
+        PTOT=PTOT/1.0E3
+        CALL LCMPUT(IPMAP,'REACTOR-PW',1,2,PTOT)
+*----
+*  AXIAL POWERS FORM FACTORS
+*----
+      ELSEIF(TEXT12.EQ.'AXIAL-PFORM')THEN
+        IF(IMPX.GT.0)WRITE(IOUT,1007)
+        IF(PTOT.EQ.0.0)CALL XABORT('@RESPAR: FULL REACTOR POWER NOT S'
+     1  //'ET.')
+        FPOWER(:NB)=0.0
+        DO IB=1,NB
+          CALL REDGET(ITYP,NITMA,FPOWER(IB),TEXT,DFLOT)
+          IF(ITYP.NE.2)CALL XABORT('@RESPAR: REAL DATA FOR POWERS FOR'
+     1      //'M FACTORS VALUE EXPECTED.')
+          IF(FPOWER(IB).LT.0.)CALL XABORT('@RESPAR: INVALID DATA FOR '
+     1      //'POWERS FORM FACTORS VALUE <0.')
+        ENDDO
+        CALL LCMPUT(IPMAP,'AXIAL-FPW',NB,2,FPOWER)
+        DSUM=0.0
+        DO IB=1,NB
+          DSUM=DSUM+FPOWER(IB)
+        ENDDO
+        DO ICH=1,NCH
+          DO IB=1,NB
+            POWER(ICH,IB)=FPOWER(IB)*PTOT*1.0E3/(DSUM*REAL(NCH))
+          ENDDO
+        ENDDO
+        CALL LCMPUT(IPMAP,'BUND-PW',NCH*NB,2,POWER)
+*----
+*  FULL REACTOR POWER IN MW
+*----
+      ELSEIF(TEXT12.EQ.'REACTOR-POW')THEN
+        IF(IMPX.GT.0)WRITE(IOUT,1008)
+        CALL REDGET(ITYP,NITMA,PTOT,TEXT,DFLOT)
+        IF(ITYP.NE.2)CALL XABORT('@RESPAR: REAL DATA'
+     1    //' FOR FULL REACTOR POWER VALUE EXPECTED.')
+        IF(PTOT.LT.0.)CALL XABORT('@RESPAR: INVALID DA'
+     1    //'TA FOR FULL REACTOR POWER VALUE <0.')
+        CALL LCMPUT(IPMAP,'REACTOR-PW',1,2,PTOT)
+*----
+*  FUEL-TYPE DATA
+*----
+      ELSEIF(TEXT12.EQ.'FUEL')THEN
+        CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+        IF(ITYP.NE.3)CALL XABORT('@RESPAR: KEYWO'
+     1   //'RD FOR FUEL-TYPE PARAMETER EXPECTED.')
+        IF((TEXT.NE.'WEIGHT').AND.(TEXT.NE.'ENRICH').AND.
+     1   (TEXT.NE.'POISON'))CALL XABORT('@RESPAR: INVAL'
+     2   //'ID INPUT FOR FUEL.')
+        IF(IMPX.GT.0)WRITE(IOUT,1005)TEXT
+        JPMAP=LCMLID(IPMAP,'FUEL',NFUEL)
+        DO IFUEL=1,NFUEL
+          CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+          IF(ITYP.NE.2)CALL XABORT('@RESPAR: REAL'
+     1     //' DATA PER EACH FUEL-TYPE EXPECTED.')
+          KPMAP=LCMDIL(JPMAP,IFUEL)
+          CALL LCMPUT(KPMAP,TEXT,1,2,FLOT)
+          IF(IMPX.GT.0)CALL LCMLIB(KPMAP)
+        ENDDO
+      ELSEIF(TEXT12.EQ.'CELL')THEN
+        ALLOCATE(ALCH(NCH))
+        DO 150 I=1,NCH
+          CALL REDGET(INDIC,ALCH(I),FLOTT,TEXT12,DFLOT)
+          IF(INDIC.NE.1) CALL XABORT('@RESPAR: INTEGER DATA EXPECTED.')
+  150   CONTINUE
+        CALL RESCEL(IPMAP,NCH,NB,ALCH)
+        DEALLOCATE(ALCH)
+        ISTATE(5)=2
+      ELSE
+        CALL XABORT('@RESPAR: WRONG KEYWORD '//TEXT12)
+      ENDIF
+      GOTO 10
+  500 IF(LRSCH.OR.LBURN)CALL RESBRN(IPMAP,NCH,NB,NCOMB,
+     1 NX,NY,NZ,LRSCH,IMPX)
+      RETURN
+*
+ 1000 FORMAT(/1X,'INPUT OF NEW PARAMETER: ',A12)
+ 1001 FORMAT(/1X,'READING VALUES FOR PARAMETER: ',A12)
+ 1002 FORMAT(/1X,'READING INPUT FOR REF-SHIFT')
+ 1003 FORMAT(/1X,'READING AVERAGE EXIT BURNUPS')
+ 1004 FORMAT(/1X,'READING INSTANTANEOUS BURNUPS')
+ 1005 FORMAT(/1X,'READING DATA FOR FUEL-TYPE PARAMETER: ',A12)
+ 1006 FORMAT(/1X,'READING BUNDLE POWERS IN KW')
+ 1007 FORMAT(/1X,'READING BUNDLE POWERS FORM FACTORS')
+ 1008 FORMAT(/1X,'READING FULL REACTOR POWER IN MW')
+ 1009 FORMAT(/5X,'UNIDIRECTIONAL REFUELLING FOR PATTERN: ',I3)
+ 1010 FORMAT(/5X,'READING SHUFFLING PATTERNS: ',I3)
+      END