*DECK D2PRFL
      SUBROUTINE D2PRFL(  IPDAT, IPMIC , IPRINT,    NBU,   NGP,   NBMIX,
     >                    NANI,   NVAR,  STAIDX)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Recover macroscopic and microscopic cross sections from a microlib
* object and write cross sections for one branch at a fixed burnup point
* in the INFO data block.
* WARNING: 04/2014 The information recovered by this routine is exactly
* the same than GET_MACROLIB_XS but is used for reflector case, in this
* case the following reactions are set to zero :
*  DET(IGR) = 0
*  SFI(IGR) = 0
*  KAPPA_FI(IGR)= 0
*  FLUX(IGR) = 0
*  VELINV(IGR) = 0
*  CHI_SPEC(IGR) = 0
*  X_NU_FI(IGR) = 0
*  KAPPA_FI(IGR) = 0
*  XENG(IGR)=0
*  SMNG(IGR)=0
* NB : for reflector case, the upscattering is fixed to zero
*
*Author(s): J. Taforeau
*
* parameters: input
* IPDAT       address of info data block
* IPMIC       address of the microlib object
* NBU         number of burnup points
* NBMIX       number of mixturess
* NGP         number of energy groups
* NANI        number of anisotropy
* NVAR        number of state variables
* STAIDX      table of states index order
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPDAT,IPMIC
      INTEGER STAIDX(NVAR)
      INTEGER NBU,NVAR,NBMIX,NGP,NANI
*----
*  LOCAL VARIABLES
*----
      TYPE(C_PTR) JPMIC,KPMIC,IPTH,KPTH
      INTEGER NSCAT,MIX
      INTEGER IJJ(NBMIX),NJJ(NBMIX),IPOS(NBMIX)
      REAL GAR2(NGP,NGP,NBMIX,NANI),GAR3(NBMIX*NGP)
      REAL XSECT(NGP,NBMIX)          ! TOTAL CROSS SECTIONS
      REAL KAPPA_FI(NGP)             ! KAPPA FISSION CROSS SECTIONS
      REAL X_NU_FI(NGP)              ! NU SIGMA FISSION CROSS SECTIONS
      REAL XTR(NGP)                  ! TRANSPORT CROSS SECTIONS
      REAL DIFF(NGP,NBMIX)           ! DIFFUSION COEFF
      REAL SCAT(NGP,NBMIX)           ! SCATTERING CROSS SECTIONS
      REAL DET(NGP)                  ! DETECTOR CROSS SECTIONS
      REAL SFI(NGP)                  ! FISSION CROSS SECTIONS
      REAL ABSORPTION(NGP)           ! ABSORPTION CROSS SECTIONS
      REAL SCAT_MAT(NGP*NGP)         ! SCATTERING MATRIX
      REAL SCAT_TMP(NGP,NGP,NBMIX,NANI)  ! TEMPORARY SCATTERING MATRIX
      REAL FLUX(NGP)
      REAL VELINV(NGP)
      REAL XENG(NGP)
      REAL CHI_SPEC(NGP)
      REAL SMNG(NGP)
      CHARACTER CM*2

      IF(IPRINT > 0)  THEN
        WRITE(6,*)
        WRITE(6,*) "****** RECOVER REFLECTOR cross sections ******"
      ENDIF

      CALL LCMSIX(IPDAT,' ',0)
      CALL LCMSIX(IPDAT,'SAPHYB_INFO',1)
      CALL LCMGET(IPDAT,'MIX',MIX)
      CALL LCMSIX(IPDAT,' ',0)
      CALL LCMSIX(IPMIC,' ',0)
      CALL LCMSIX(IPMIC,'MACROLIB',1)

      JPMIC=LCMGID(IPMIC,'GROUP')

      !  RECOVER CROSS SECTIONS INFORMATION
      DO IGR=1,NGP
       WRITE(6,'(/28H PROCESS ENERGY GROUP NUMBER,I4)') IGR
       KPMIC=LCMGIL(JPMIC,IGR)
       CALL LCMLEN(KPMIC,'NTOT0',ILONG,ITYLCM)
       IF(ILONG.NE.NBMIX) THEN
         CALL XABORT('D2P: MORE THAN ONE MIXTURE IN SAPHYB')
       ENDIF
       CALL LCMGET(KPMIC,'NTOT0',XSECT(IGR,1:NBMIX))
       CALL LCMGET(KPMIC,'SIGS00',SCAT(IGR,1:NBMIX))
       CALL LCMGET(KPMIC,'DIFF',DIFF(IGR,1:NBMIX))
       ABSORPTION(IGR)=XSECT(IGR,MIX)-SCAT(IGR,MIX)
       DET(IGR) = 0
       SFI(IGR) = 0
       KAPPA_FI(IGR)= 0
       FLUX(IGR) = 0
       VELINV(IGR) = 0
       CHI_SPEC(IGR) = 0
       X_NU_FI(IGR) = 0
       KAPPA_FI(IGR) = 0
       XENG(IGR)=0
       SMNG(IGR)=0
       XTR(IGR)=1/(3*DIFF(IGR,MIX))

       CALL XDRSET(GAR2,NGP*NGP*NBMIX*NANI,0.0)
       DO IL=1,NANI
          WRITE(CM,'(I2.2)') IL-1
          LENGTH=1
          IF(IL.GT.1) CALL LCMLEN(KPMIC,'SCAT'//CM,LENGTH,ITYLCM)
          IF(LENGTH.GT.0) THEN
           CALL LCMGET(KPMIC,'SCAT'//CM,GAR3)
           CALL LCMGET(KPMIC,'NJJS'//CM,NJJ)
           CALL LCMGET(KPMIC,'IJJS'//CM,IJJ)
           CALL LCMGET(KPMIC,'IPOS'//CM,IPOS)
           DO IMIL=1,NBMIX
            IPOSDE=IPOS(IMIL)
            DO JGR=IJJ(IMIL),IJJ(IMIL)-NJJ(IMIL)+1,-1
             GAR2(IGR,JGR,IMIL,IL)=GAR3(IPOSDE) ! IGR <-- JGR
             SCAT_TMP(IGR,JGR,IMIL,IL)=GAR2(IGR,JGR,IMIL,IL)
             IPOSDE=IPOSDE+1
            ENDDO
           ENDDO
          ENDIF
         ENDDO
      ENDDO

      NSCAT=1
      DO J=1, NGP
         DO I=1, NGP
          SCAT_MAT(NSCAT)=SCAT_TMP(I,J,MIX,1) ! I <-- J
          IF(NSCAT==3) SCAT_MAT(NSCAT)=0
          NSCAT=NSCAT+1
         ENDDO
      ENDDO

      CALL LCMSIX(IPDAT,' ',0)
      CALL LCMSIX(IPDAT,'BRANCH_INFO',1)
      IF(STAIDX(NVAR)==1) THEN
        IPTH=LCMLID(IPDAT,'CROSS_SECT',NBU)
      ELSE
        IPTH=LCMGID(IPDAT,'CROSS_SECT')
      ENDIF

      KPTH=LCMDIL(IPTH,STAIDX(NVAR))
      CALL LCMSIX(KPTH,'MICROLIB_XS',1)

      CALL LCMPUT(KPTH,'XENG',NGP,2,XENG)
      CALL LCMPUT(KPTH,'SMNG',NGP,2,SMNG)

      CALL LCMSIX(KPTH,' ',2)
      CALL LCMSIX(KPTH,'MACROLIB_XS',1)

      CALL LCMPUT(KPTH,'XTR',NGP,2,XTR)
      CALL LCMPUT(KPTH,'ABSORPTION',NGP,2,ABSORPTION)
      CALL LCMPUT(KPTH,'X_NU_FI',NGP,2,X_NU_FI)
      CALL LCMPUT(KPTH,'KAPPA_FI',NGP,2,KAPPA_FI)
      CALL LCMPUT(KPTH,'SFI',NGP,2,SFI)
      CALL LCMPUT(KPTH,'DET',NGP,2,DET)
      CALL LCMPUT(KPTH,'SCAT',NGP*NGP,2,SCAT_MAT)

      IF(IPRINT>1) THEN
         WRITE(6,*)
         WRITE(6,*) "**** MACROSCOPIC cross sections (1:NGP) ****"
         WRITE(6,*) "TOTALE                  :",XSECT
         WRITE(6,*) "TRANSPORT               :",XTR
         WRITE(6,*) "ABSORPTION              :",ABSORPTION
         WRITE(6,*) "NU FISSION              :",X_NU_FI
         WRITE(6,*) "KAPPA FISSION           :",KAPPA_FI
         WRITE(6,*) "DETECTOR                :",DET
         WRITE(6,*) "SCATTERING (g to g')    :",SCAT_MAT
      ENDIF
      END
