*DECK D2PMAC
      SUBROUTINE D2PMAC(  IPDAT, IPMIC , IPRINT,    NBU,   NGP,   NBMIX,
     >                     NADD,   NANI,  NVAR,  STAIDX,  LADF,    NADF)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Recover macroscopic cross sections from a microlib object and write
* cross sections for one branch at a fixed burnup point in the INFO
* data block.
*
*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
* NBISO   number of isotopes
* NGP     number of energy groups
* NADD    number of additional cross sections
* NDEL    number of delayed neutron groups
* NANI    number of anisotropy
* NVAR    number of state variables
* STAIDX  table of states index order
* LADF    flag for assembly discontinuity factor
* NADF    number of assembly discontinuity factor per energy groups
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPDAT,IPMIC
      INTEGER STAIDX(NVAR)
      INTEGER NBU,NADD,NVAR,NBMIX,NGP,NANI,NADF
      LOGICAL LADF
*----
*  LOCAL VARIABLES
*----
      TYPE(C_PTR) JPMIC,KPMIC,IPTH,KPTH
      INTEGER NSCAT,ITYLCM,IADF
      INTEGER IJJ(NBMIX),NJJ(NBMIX),IPOS(NBMIX)
      REAL GAR2(NGP,NGP,NBMIX,NANI),GAR3(NBMIX*NGP)
      REAL XSECT(NGP)                ! 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)                 ! DIFFUSION COEFF
      REAL SCAT(NGP)                 ! SCATTERING CROSS SECTIONS
      REAL DET(NGP)                  ! DETECTOR CROSS SECTIONS
      REAL TRANC(NGP)                ! TRANSPORT CORRECTION
      REAL ABSORPTION(NGP)           ! ABSORPTION CROSS SECTIONS
      REAL SCAT_MAT(NGP*NGP)         ! SCATTERING MATRIX
      REAL SCAT_TMP(NGP,NGP,NBMIX,NANI)  ! TEMPORARY SCATTERING MATRIX
      REAL SIGW00(NGP)
      ! AVERAGE HOMOGENE SURFACIC FLUX (FLUX-INTG/VOLUME) and
      ! HETEROGENE
      REAL FLXHOM(NGP),FLXHET(NADF,NGP)
      REAL VOLUME
      CHARACTER(len=8) ADD_XS_NAME(NADD)
      CHARACTER CM*2,ADF_T*3
      CHARACTER(LEN=8) HADF(NADF)     ! ADF NAME IN MACROLIB
      REAL ADF(NADF,NGP)              ! ASSEMBLY DISCONTINUITY FACTORS
      CALL LCMSIX(IPMIC,' ',0)
      CALL LCMSIX(IPMIC,'MACROLIB',1)
      CALL LCMGET(IPMIC,'VOLUME',VOLUME)
      CALL LCMGTC(IPMIC,'ADDXSNAME-P0',8,NADD,ADD_XS_NAME)
      IF(NBMIX.NE.1) THEN
         ! SAPHYB MUST CONTAIN ONLY ONE MIXTURES
         CALL XABORT('D2PMAC: MORE THAN ONE MIXTURE IN SAPHYB')
      ENDIF
      JPMIC=LCMGID(IPMIC,'GROUP')

      ! LOOP OVER ENERGY GROUPS
      DO IGR=1,NGP
        KPMIC=LCMGIL(JPMIC,IGR)
        CALL LCMLEN(KPMIC,'NTOT0',ILONG,ITYLCM)
        IF(ILONG.NE.NBMIX) THEN
          CALL XABORT('D2PMAC: MORE THAN ONE MIXTURE IN SAPHYB')
        ENDIF
        ! RECOVER CROSS SECTIONS INFORMATION
        CALL LCMGET(KPMIC,'NTOT0',XSECT(IGR))
        CALL LCMGET(KPMIC,'SIGS00',SCAT(IGR))
        CALL LCMGET(KPMIC,'SIGW00',SIGW00(IGR))
        CALL LCMGET(KPMIC,'TRANC',TRANC(IGR))
        CALL LCMGET(KPMIC,'NUSIGF',X_NU_FI(IGR))
        CALL LCMGET(KPMIC,'H-FACTOR',KAPPA_FI(IGR))
        CALL LCMGET(KPMIC,'DIFF',DIFF(IGR))
        CALL LCMGET(KPMIC,'FLUX-INTG',FLXHOM(IGR))

        ! ABOSPTION = TOTAL - SCATTERING
        ABSORPTION(IGR)=XSECT(IGR)-SCAT(IGR)
        ! DEFAULT DETECTOR RESPONSE
        DET(IGR) = 1E-15
        ! KAPPA FISSION ( HFACTOR IN MICROLIB)
        ! TRANSPORT CROSS SECTIONS = 1/3DIFF
        XTR(IGR)=1/(3*DIFF(IGR))

        ! RECOVER SCATTERING MATRIX ELEMENT
        ! INITIALIZATION OF GAR2 VECTOR
        CALL XDRSET(GAR2,NGP*NGP*NBMIX*NANI,0.0)
        ! LOOP OVER ANISOTROPY COMPONENT
        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)
            ! LOOP OVER MIXTRURE
            DO IMIL=1,NBMIX
             IPOSDE=IPOS(IMIL)
             ! LOOP OVER ENERGY GROUPS
             DO JGR=IJJ(IMIL),IJJ(IMIL)-NJJ(IMIL)+1,-1
              GAR2(IGR,JGR,IMIL,IL)=GAR3(IPOSDE) ! IGR <-- JGR
              ! ELEMENTS OF THE SCATTERING MATRIX
              SCAT_TMP(IGR,JGR,IMIL,IL)=GAR2(IGR,JGR,IMIL,IL)
              IPOSDE=IPOSDE+1
             ENDDO
            ENDDO
          ENDIF
        ENDDO
      ENDDO

      ! STORE THE SCATTERING MATRIX CORRESPONDING TO L=0 AND MIX=1
      ! IN SCAT_MAT
      NSCAT=1
      DO J=1, NGP
         DO I=1, NGP
          SCAT_MAT(NSCAT)=SCAT_TMP(I,J,1,1) ! I <-- J
          IF(I==J) THEN
!          TRANSPORT CORRECTION IS COMMENTED
!          SCAT_MAT(NSCAT)=SCAT_MAT(NSCAT)-TRANC(I)
           SCAT_MAT(NSCAT)=SCAT_MAT(NSCAT)
          ENDIF
          NSCAT=NSCAT+1
         ENDDO
      ENDDO
      IF(NGP .NE. 2) THEN
        CALL XABORT("@D2PMAC: NUMBER OF ENERGY GROUPS MUST BE 2")
      ELSE
        ABSORPTION(1)=XSECT(1)-SCAT_MAT(1)-SCAT_MAT(2)
        ABSORPTION(2)=XSECT(2)-SCAT_MAT(3)-SCAT_MAT(4)
      ENDIF

      ! STORE CROSS SECTIONS IN INFO/CROSS_SECT/MACROLIB_XS
      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,'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,'DET',NGP,2,DET)
      CALL LCMPUT(KPTH,'SCAT',NGP*NGP,2,SCAT_MAT)

      ! RECOVER THE ASSEMBLY DISCONTINUITY FACTOR IF ADF DRA IS SET
      ! BY THE USER
      IF(LADF) THEN
        FLXHOM(:)=FLXHOM(:) / VOLUME
        CALL LCMSIX (IPDAT,' ',0)
        CALL LCMSIX (IPDAT,'SAPHYB_INFO',1)
        CALL LCMGTC(IPDAT,'ADF',3,1,ADF_T)
        IF(ADF_T .EQ. 'DRA') THEN
          CALL LCMSIX(IPMIC,' ',0)
          CALL LCMSIX(IPMIC,'MACROLIB',1)
          CALL LCMSIX(IPMIC,'ADF',1)
          CALL LCMGTC(IPMIC,'HADF',8,NADF,HADF)

          DO IADF=1,NADF
            CALL LCMGET(IPMIC,HADF(IADF),FLXHET(IADF,:))
          ENDDO
          DO IGR=1, NGP
            ADF(:,IGR)= FLXHOM(IGR)/FLXHET(:,IGR)
          ENDDO
          CALL LCMPUT(KPTH,'ADF',NADF*NGP,2,ADF)

          IF(IPRINT>1) THEN
            WRITE(6,*)
            WRITE(6,*)"ADF                     :",ADF
          ENDIF
        ENDIF
      ENDIF

      CALL LCMSIX(KPTH,' ',0)
      CALL LCMSIX(IPDAT,' ',0)

      IF(IPRINT>1) THEN
         WRITE(6,*)
         WRITE(6,*) "SIGWWOO                 :",SIGW00
         WRITE(6,*) "SIGSOO                  :",SCAT
         WRITE(6,*) "TOTALE                  :",XSECT
         WRITE(6,*) "DIFF                    :",DIFF
         WRITE(6,*) "TRANSPORT               :",XTR
         WRITE(6,*) "TRANSPORT CORRECTION    :",TRANC
         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
