*DECK D2PXSA
      SUBROUTINE D2PXSA(IPDAT,IPSAP,ICAL,IPRINT,NGP,NREA,NISO,NMAC,
     1 NMIL,NANI,NVAR,STAIDX,B2,ADF_T,NSF,LABS,SCAT,LADF)
*
*-----------------------------------------------------------------------
*
*Purpose:
* recover FISSION cross sections of an elementary calculation and store
* in INFO/BRANCH_INFO/MACROLIB_XS/SFI.
* WARNING: the GET_SFI_XS subroutine cannot recover FISSION XS in the
* case where cross sections are ineterpolated by the SCR: module
*
*Author(s): J. Taforeau
*
* parameters: input
* IPDAT   address of the INFO data block
* ICAL    number of the elementary calculation in which fission cross
*         sections is to be recovered
* IPSAP   address of the Saphyb object
* NGP     number of group energies in Saphyb
* NREA    number of reactions in Saphyb
* NISO    number of isotopes in Saphyb
* NMAC    number of macros in Saphyb
* NMIL    number of mixtures in Saphyb
* NANI    number of Legendre orders in Saphyb
* STAIDX  index of current branch state values
* NSF     number of elements of the tranfert matrix
* LABS    content of absorption xs LABS(1) : ABS XS = TOTAL - SIGS00 ;
*         LABS(2) abs xs recovered from sap ; LABS (3)  abs xs recovered
*         from SAP minus excess xs

*parameters: output
* SFI     fission cross sections of the current BRANCH:
*         INFO/BRANCH_INFO/MACROLIB_XS/SFI
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPDAT,IPSAP
      INTEGER ICAL,IPRINT,NGP,NREA,NISO,NMAC, NMIL,NANI,NVAR,
     1 STAIDX(NVAR),NSF
      REAL B2
      CHARACTER*3 ADF_T
      LOGICAL LABS(3),SCAT,LADF
*----
*  LOCAL VARIABLES
*----
      TYPE(C_PTR) IPTH,KPTH
      ! order numbers of current : reaction , isotope, macro
      INTEGER iprf,isot,imil,imac,iabs,iexc,idif,itra
      INTEGER idifc
      INTEGER ani, il, nj, ii, it, i1,i2, j1, j2, iadc,g
      INTEGER ND
      ! location of excess cross sections in RDATAX
      INTEGER ADR_EXC
      ! location of absorption cross sections in RDATAX
      INTEGER ADR_ABS
      ! location of profil cross sections in RDATAX
      INTEGER ADR_PRF
      ! location of TRANSFERT cross sections in RDATAX
      INTEGER ADR_TRA
      INTEGER ADR_DIF
      ! number of group energies in Saphyb
      INTEGER NG
      ! type of data recovered from GANLIB subroutines
      INTEGER ITYLCM
      ! name of : isotopes, macros
      CHARACTER(LEN=8) NOM_MAC(NMAC)
      ! name of reactions
      CHARACTER(LEN=10) NOM_REA(NREA)
      ! residual macro
      INTEGER RESMAC(NMIL)
      ! 3rd index of ADRX
      INTEGER ISADRX(NMIL)
      ! number of elements in RADATAX
      INTEGER LENGDX(NMIL)
      ! name of total macro
      INTEGER TOTMAC(NMIL)
      ! number of elements in IDATAP
      INTEGER LENGDP(NMIL)
      ! contains the adress of the 1st element in RDATAX
      INTEGER ADRX (NREA+2,NISO+NMAC,NMIL)
      REAL ABSORPTION(NGP)
      REAL TRANSFERT (NANI,NGP*NGP)
      REAL DIFC(NGP)
      CHARACTER(LEN=12) CALDIR
      INTEGER fagg, lagg,fdgg,wgal,fag,lag   ! CF SAPHTOOL MANUAL
      INTEGER fdg(NGP),adr(NGP+1)            ! CF SAPHTOOL MANUAL
      INTEGER NSCAT
      REAL CURRN(NSF,NGP,2)
      REAL SRFLX(NSF,NGP)
      REAL ZAFLX(NMIL,NGP)
      DOUBLE PRECISION RPAR (6,NSF)
      INTEGER IPAR (3,NSF)
      REAL ADF(NGP,NSF,10)
      REAL SCAT_MAT(NGP*NGP)
      ! transfert matrix
      INTEGER ,ALLOCATABLE, DIMENSION(:) :: IDATAP
      ! contains values of cross sections of an elementary calculation
      REAL,ALLOCATABLE, DIMENSION(:) :: RDATAX

      TRANSFERT(:,:) = 0

      ! name of the elementary calculation
      WRITE(CALDIR,'("calc", I8)') ICAL
      CALL LCMSIX(IPSAP,' ',0)
      CALL LCMSIX(IPSAP,'contenu',1)
      IF(NMIL.NE.1) THEN
        ! the number of mixtures must be equal to one for converting
        ! Saphyb into PMAXS format
        CALL XABORT('@D2P: MORE THAN ONE MIXTRURE IN SAPHYB')
      ENDIF
      ! RECOVER SAPHYB INFORMATION
      CALL LCMGTC(IPSAP,'NOMREA',10,NREA,NOM_REA)
      CALL LCMGTC(IPSAP,'NOMMAC',8,NMAC,NOM_MAC)
      CALL LCMGET(IPSAP,'RESMAC',RESMAC)
      CALL LCMGET(IPSAP,'TOTMAC',TOTMAC)
      CALL LCMSIX(IPSAP,' ',0)
      CALL LCMSIX(IPSAP,'adresses',1)
      CALL LCMGET(IPSAP,'ADRX',ADRX)
      CALL LCMSIX(IPSAP,' ',0)
      CALL LCMSIX(IPSAP,CALDIR,1)
      CALL LCMSIX(IPSAP,'info',1)
      CALL LCMGET(IPSAP,'ISADRX',ISADRX)
      CALL LCMGET(IPSAP,'LENGDX',LENGDX)
      CALL LCMGET(IPSAP,'LENGDP',LENGDP)

      ALLOCATE (RDATAX(LENGDX(1)),IDATAP(LENGDP(1)))

      imac=0
      IF(RESMAC(1).NE.0) THEN
        imac=RESMAC(1)      ! recover name of residual macro
      ELSE IF(TOTMAC(1).NE.0) THEN
        imac=TOTMAC(1)      ! recover name of total macro
      ELSE
        CALL XABORT('@D2P: NO MACRO DEFINED')
      ENDIF
      isot=NISO+imac     ! we interest in macro fission cross sections
      imil=1             ! set the mixtures number to 1
      iprf=0
      iexc=0
      iabs=0
      idif=0
      iadc=0
      itra=0
      idifc=0
      NSCAT=1

      ! LOOP over reactions
      DO ir=1,NREA
        ! store the order numbers of PROFIL matrix
        IF((SCAT) .and. NOM_REA(ir)=="PROFIL") iprf=ir
        IF((SCAT) .and. NOM_REA(ir)=="DIFFUSION") idif=ir
        IF((SCAT) .and. NOM_REA(ir)=="TRANSFERT") itra=ir
        IF(NOM_REA(ir)=="ABSORPTION") iabs=ir
        ! store the order numbers of EXCESS matrix
        IF(LABS(3).and. NOM_REA(ir)=="EXCESS")  iexc=ir
        IF((LADF) .and. NOM_REA(ir)=="FUITES") idifc=ir
      ENDDO
      IF(iabs==0) CALL XABORT ('@D2P: NO ABSORPTION XS AVAILABLE')
      IF(LABS(3).and.iexc==0) THEN
        CALL XABORT('@D2P: NO EXCESS XS AVAILABLE')
      ENDIF
      IF(SCAT .and. iprf==0) THEN
        CALL XABORT('@D2P: NO PROFIL XS AVAILABLE')
      ENDIF
      IF(SCAT .and. idif==0) THEN
        CALL XABORT('@D2P: NO DIFFUSION XS AVAILABLE')
      ENDIF
      IF(SCAT .and. itra==0) THEN
        CALL XABORT('@D2P: NO TRANSFERT XS AVAILABLE')
      ENDIF
      IF((LADF) .and. idifc==0) THEN
        CALL XABORT('@D2P: NO FUITES XS AVAILABLE')
      ENDIF
      NANI=ADRX(NREA+2,isot,ISADRX(imil))-1
      ND=ADRX(NREA+1,isot,ISADRX(imil))
      IF(MOD(idif,NREA+1).GT.0  .AND. ND.GE.1) THEN
        iadc=ADRX(idif,isot,ISADRX(imil))+NGP
      ENDIF
      ! address in RDATAX of ABSORPTION XS
      ADR_ABS=ADRX(iabs,isot,ISADRX(imil))

      ! address in RDATAX of EXCESS XS
      ADR_EXC=0
      IF(LABS(3)) ADR_EXC=ADRX(iexc,isot,ISADRX(imil))
      ! address in RDATAX of PROFIL XS
      ADR_PRF=0
      IF(SCAT) ADR_PRF=ADRX(iprf,isot,ISADRX(imil))
      ! address in RDATAX of TRANSFERT XS
      ADR_TRA=0
      IF(SCAT) ADR_TRA=ADRX(itra,isot,ISADRX(imil))
      ! address in RDATAX of FUITES XS
      ADR_DIF=0
      IF(LADF) ADR_DIF=ADRX(idifc,isot,ISADRX(imil))

      ! moving in the saphyyb object to recover RDATAX information
      CALL LCMSIX(IPSAP,' ',0)
      CALL LCMSIX(IPSAP,CALDIR,1)
      CALL LCMSIX(IPSAP,'mili       1',1)
      CALL LCMGET(IPSAP,'RDATAX',RDATAX)
      CALL LCMGET(IPSAP,'IDATAP',IDATAP)

      ! LOOP over energy groups
      DO ig=1, NGP
       ABSORPTION(ig)=RDATAX(ADR_ABS+ig-1)
       IF(LADF) DIFC(ig)=RDATAX(ADR_DIF+ig-1)
       IF(LABS(3)) THEN
         ABSORPTION(ig)=ABSORPTION(ig)-RDATAX(ADR_EXC+ig-1)
       ENDIF
      ENDDO

      IF(SCAT)THEN   ! recover the scattering XS from Saphyb
         ii = ADR_PRF
         nj = IDATAP(ii+6+2*NGP)-1

        DO ani=0, NANI
         il = ADR_TRA + (ani) * nj
         fagg =IDATAP(ii)
         lagg =IDATAP(ii+1)
         fdgg =IDATAP(ii+2)
         wgal =IDATAP(ii+3)
         fag  =IDATAP(ii+4)
         lag  =IDATAP(ii+5)
         fdg  =IDATAP(ii+6:ii+5+NGP)
         adr  =IDATAP(ii+6+NGP:ii+6+2*NGP)
         IF(wgal.GT.0)THEN
          it=il
          DO g=fagg,lagg
           i1=(g-1)*NGP+fdgg
           i2=(g-1)*NGP+fdgg+wgal-1
           TRANSFERT(ani+1,i1:i2)=RDATAX(it:it+wgal-1)
           it=it+wgal
          ENDDO
         ENDIF
         DO g=fag,lag
          i1=(g-1)*NGP+fdg(g)
          i2=(g-1)*NGP+fdg(g)+adr(g+1)-adr(g)-1
          j1=il-1+adr(g)
          j2=il-1+adr(g+1)-1
          TRANSFERT(ani+1,i1:i2)=RDATAX(j1:j2)
         ENDDO
        ENDDO
        IF(iadc.NE.0)THEN
         NG=NGP
!         TRANSFERT(1,1:NG*NG:NG+1) =
!     >         TRANSFERT(1,1:NG*NG:NG+1) - RDATAX(iadc:iadc+NGP-1)
        ENDIF
      ENDIF
      DO g=1, NGP
        DO ig=1, NGP
         SCAT_MAT(NSCAT) = TRANSFERT(1,g+(ig-1)*NGP)
         NSCAT=NSCAT+1
        ENDDO
      ENDDO

      ! RECOVER ADF IN SAPHYB (IF AVAILABLE) (adapted from
      ! saphyb_browser of UPM)

      IF(LADF) THEN
        IF((ADF_T.EQ.'SEL').OR.(ADF_T.EQ.'GET')) THEN
         CALL LCMSIX (IPSAP,' ',0)
         CALL LCMSIX (IPSAP,'geom        ',1)
         CALL LCMSIX (IPSAP,'outgeom     ',1)
         CALL LCMLEN(IPSAP,'SURF',NSURF,ITYLCM)
         IF(NSF.NE.NSURF) THEN
           WRITE(6,*) "@D2P: ERROR IN NUMBER OF ASSEMBLY SURFACES"
           WRITE(6,*) "THE NUMBER OF SURFACES IN SAP (",
     1     NSURF,") IF DIFFERENT FROM DRAG2PARCS INPUT (",NSF,")"
           CALL XABORT('')
         ENDIF

         CALL LCMGET(IPSAP,'IPAR',IPAR)
         CALL LCMGET(IPSAP,'RPAR',RPAR)

         CALL LCMSIX(IPSAP,' ',0)
         CALL LCMSIX(IPSAP,CALDIR,1)
         CALL LCMSIX(IPSAP,'outflx      ',1)

         CALL LCMGET(IPSAP,'CURRM',CURRN(:,:,2))
         CALL LCMGET(IPSAP,'CURRP',CURRN(:,:,1))
         CALL LCMGET(IPSAP,'SURFLX',SRFLX(:,:))
         CALL LCMGET(IPSAP,'REGFLX',ZAFLX(:,:))
         ADF = 0.
         DIFC(:)=DIFC(:)/B2

         ! CALL to GET_SFI_XS to recover ADF
         CALL D2PADF(IPDAT,IPRINT,NGP,NMIL, ADF, NSF, DIFC,CURRN,SRFLX,
     1   ZAFLX,RPAR,IPAR,ADF_T,STAIDX,NVAR)
        ENDIF
      ENDIF

      ! STORE RESULTS IN INFO DATA BLOCK
      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)
      IF(LABS(2)) CALL LCMPUT(KPTH,'ABSORPTION',NGP,2,ABSORPTION)
      IF(SCAT) CALL LCMPUT(KPTH,'SCAT',NGP*NGP,2,SCAT_MAT)
      IF(LABS(2)) WRITE(6,*) "ABSORPTION EXCESS :", ABSORPTION
      IF(SCAT) WRITE(6,*) "SCATTERING MATRIX  :", SCAT_MAT
      DEALLOCATE (RDATAX,IDATAP)
      END
