*DECK D2PMIC
      SUBROUTINE D2PMIC(  IPDAT, IPMIC , IPRINT,    NGP, NBMIX, NBISO,
     >                    NVAR, STAIDX                        )
*
*-----------------------------------------------------------------------
*
*Purpose:
* Recover microscopic 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
* NBMIX       number of mixturess
* NBISO       number of isotopes
* NGP         number of energy groups
* NVAR        number of state variables
* STAIDX      table of states index order
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPDAT,IPMIC
      INTEGER NBMIX,NBISO,NGP,NVAR
      INTEGER STAIDX(NVAR)
*----
*  LOCAL VARIABLES
*----
      TYPE(C_PTR) IPTH,KPTH
      INTEGER :: iXE = 0
      INTEGER :: iSM = 0
      INTEGER :: IMR = 0
      REAL XEND,SMND,MRND
      REAL XSECT(NGP),XENG(NGP),SMNG(NGP),SCAT(NGP)
      REAL NFTOT(NGP)
      REAL DEN(NBISO)
      CHARACTER(LEN=12) HUSE(NBISO)
      ! RECOVER ONLY EIGHT FIRST CHARACTER OF ISOTOPES
      CHARACTER(LEN=8) ISOTOPES(2)

      CALL LCMSIX (IPDAT,' ',0)
      CALL LCMSIX (IPDAT,'SAPHYB_INFO',1)
      CALL LCMSIX (IPDAT,'ISOTOPES',1)
      CALL LCMGTC (IPDAT,'XE135',12,1,ISOTOPES(1))
      CALL LCMGTC (IPDAT,'SM149',12,1,ISOTOPES(2))

      IF(NBMIX.NE.1) THEN
        CALL XABORT('@D2P: MORE THAN ONE MIXTRURE IN SAPHYB')
      ENDIF

      CALL LCMSIX(IPMIC,' ',0)
      CALL LCMGET(IPMIC,'ISOTOPESDENS',DEN)
      CALL LCMGTC(IPMIC,'ISOTOPESUSED',12,NBISO,HUSE)

      ! CHECK THE EXISTENCE OF XE AND SM ISOTOPES
      DO I=1,NBISO
        IF(INDEX(HUSE(I),ISOTOPES(1))>0) iXE=I
        IF(INDEX(HUSE(I),ISOTOPES(2))>0) iSM=I
        IF(INDEX(HUSE(I),'*MAC*RES')>0) iMR=I
      ENDDO
      IF(iXE==0) THEN
        CALL XABORT('@D2PMIC: XE MUST BE A PARTICULARIZED ISOTOPE')
      ELSE IF(iSM==0) THEN
        CALL XABORT('@D2PMIC: SM MUST BE A PARTICULARIZED ISOTOPE')
      ENDIF
      XEND=DEN(iXE)
      SMND=DEN(iSM)
      MRND=DEN(iMR)

      ! PROCESS MICROSCOPIC TOTAL XS INFORMATION FOR XE
      CALL LCMSIX(IPMIC,HUSE(iXE),1)
      CALL LCMLEN(IPMIC,'NTOT0',ILONG,ITYLCM)
      IF(ILONG.NE.NGP) THEN
        CALL XABORT('@D2PMIC: MORE THAN ONE MIXTRURE IN SAPHYB')
      ENDIF

      ! CALCULATION OF MICROSCOPIC ABSORPTION CROSS SECTIONS OF XE
      CALL LCMGET(IPMIC,'NTOT0',XSECT)
      CALL LCMGET(IPMIC,'SIGS00',SCAT)
      DO I=1, NGP
        XENG(I)=(XSECT(I)-SCAT(I))
      ENDDO

      ! PROCESS MICROSCOPIC TOTAL XS INFORMATION FOR SM
      CALL LCMSIX(IPMIC,' ',2)
      CALL LCMSIX(IPMIC,HUSE(iSM),1)
      CALL LCMLEN(IPMIC,'NTOT0',ILONG,ITYLCM)
      IF(ILONG.NE.NGP) THEN
        CALL XABORT('@D2PMIC: MORE THAN ONE MIXTRURE IN SAPHYB')
      ENDIF
      CALL XDISET(XSECT,NGP,0)
      CALL XDISET(SCAT,NGP,0)

      ! CALCULATION OF MICROSCOPIC ABSORPTION CROSS SECTIONS OF SM
      CALL LCMGET(IPMIC,'NTOT0',XSECT)
      CALL LCMGET(IPMIC,'SIGS00',SCAT)
      DO I=1, NGP
        SMNG(I)=(XSECT(I)-SCAT(I))
      ENDDO

      ! RECOVER FISSION CROSS SECTION OF MACROSCOPIC RESIDUAL
      CALL LCMSIX(IPMIC,' ',2)
      CALL LCMSIX(IPMIC,'*MAC*RES0001',1)
      CALL LCMLEN(IPMIC,'NFTOT',ILONG,ITYLCM)

      IF(ILONG.NE.NGP) THEN
        CALL XABORT('@D2PMIC: MORE THAN ONE MIXTRURE IN SAPHYB')
      ENDIF

      CALL XDISET(NFTOT,NGP,0)
      CALL LCMGET(IPMIC,'NFTOT',NFTOT)

      NFTOT(:)=NFTOT(:)*MRND

      CALL LCMSIX(IPDAT,' ',0)
      CALL LCMSIX(IPDAT,'BRANCH_INFO',1)
      IPTH=LCMGID(IPDAT,'CROSS_SECT')
      KPTH=LCMDIL(IPTH,STAIDX(NVAR))

      CALL LCMSIX(KPTH,'MACROLIB_XS',1)
      CALL LCMPUT(KPTH,'SFI',NGP,2,NFTOT)
      CALL LCMSIX(KPTH,' ',2)
      CALL LCMSIX(KPTH,'MICROLIB_XS',1)
      CALL LCMPUT(KPTH,'XENG',NGP,2,XENG)
      CALL LCMPUT(KPTH,'SMNG',NGP,2,SMNG)
      CALL LCMPUT(KPTH,'XEND',1,2,XEND)
      CALL LCMPUT(KPTH,'SMND',1,2,SMND)
      CALL LCMSIX(KPTH,' ',0)

      IF(IPRINT > 1)  THEN
         WRITE(6,*)
         WRITE(6,*) "**************************************************"
         WRITE(6,*) "*                     SUMMARY                    *"
         WRITE(6,*) "**************************************************"
         WRITE(6,*)
         WRITE(6,*) "****      MICROSCOPIC cross sections       ****"
         WRITE(6,*) "XENON ABSORPTION        :",XENG
         WRITE(6,*) "SAMARIUM ABSORPTION     :",SMNG
         WRITE(6,*) "XENON NUMBER DENSITY    :",XEND
         WRITE(6,*) "SAMARIUM NUMBER DENSITY :",SMND
         WRITE(6,*)
         WRITE(6,*) "****  MACROSCOPIC cross sections(1:NGP) ****"
         WRITE(6,*) "FISSION                 :",NFTOT
      ENDIF
      END
