*DECK MACPXS
      SUBROUTINE MACPXS(IPLIST,MAXFIS,NGROUP,NBMIX,NIFISS,NANISO,NDELG,
     >                  ITRANC,LNEWXS,XSTOTL,XSTOT1,XSFISS,XSSPEC,
     >                  XSFIXE,XSTRAN,XSDIFF,XSNFTO,XSH,XSSCAT,NEDMAC,
     >                  ISCATA,XSNUDL,XSCHDL,XSDIFX,XSDIFY,XSDIFZ,
     >                  XSOVRV,XSINT0,XSINT1)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Transfer cross section information on the macrolib.
*
*Copyright:
* Copyright (C) 2006 Ecole Polytechnique de Montreal
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version
*
*Author(s): G. Marleau
*
*Parameters: input
* IPLIST  LCM pointer to the macrolib.
* MAXFIS  set to max(1,NIFISS).
* NGROUP  number of energy groups.
* NBMIX   maximum number of mixtures.
* NIFISS  number of fissile isotopes.
* NANISO  maximum Legendre order (=1: isotropic collision;
*         =2: linearly anisotropic collision).
* NDELG   number of precursor groups for delayed neutrons.
* ITRANC  transport correction option (=0: no correction; =1: Apollo-
*         type; =2: recover TRANC record; =4: leakage correction alone).
* LNEWXS  check change in cross sections.
* XSTOTL  P0 total cross section of mixture.
* XSTOT1  P1 total cross section of mixture.
* XSFISS  nu*fission cross section of mixture.
* XSSPEC  fission spectrum.
* XSFIXE  fixe sources.
* XSTRAN  transport correction.
* XSDIFF  isotropic diffusion coefficient.
* XSNFTO  fission cross section of mixture.
* XSH     power factor.
* XSSCAT  scattering cross section of mixture/group.
* NEDMAC  number of macro edit cross sections.
* XSNUDL  delayed nu*fission cross section of mixture.
* XSCHDL  delayed-neutron fission spectrum.
* XSDIFX  x-directed diffusion coefficients.
* XSDIFY  y-directed diffusion coefficients.
* XSDIFZ  z-directed diffusion coefficients.
* XSOVRV  reciprocal neutron velocities.
* XSINT0  P0 volume-integrated flux of mixture
* XSINT1  P1 volume-integrated flux of mixture
* ISCATA  check for scattering anisotropy.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPLIST
      INTEGER   MAXFIS,NGROUP,NBMIX,NIFISS,NANISO,NDELG,ITRANC,NEDMAC,
     >          ISCATA(NANISO)
      REAL      XSTOTL(NBMIX,NGROUP),XSTOT1(NBMIX,NGROUP),
     >          XSFISS(NBMIX,MAXFIS,NGROUP),XSSPEC(NBMIX,MAXFIS,NGROUP),
     >          XSFIXE(NBMIX,NGROUP),XSTRAN(NBMIX,NGROUP),
     >          XSDIFF(NBMIX,NGROUP),XSNFTO(NBMIX,NGROUP),
     >          XSH(NBMIX,NGROUP),XSSCAT(NGROUP,NBMIX,NANISO,NGROUP),
     >          XSNUDL(NBMIX,MAXFIS,NDELG,NGROUP),
     >          XSCHDL(NBMIX,MAXFIS,NDELG,NGROUP),
     >          XSDIFX(NBMIX,NGROUP),XSDIFY(NBMIX,NGROUP),
     >          XSDIFZ(NBMIX,NGROUP),XSOVRV(NBMIX,NGROUP),
     >          XSINT0(NBMIX,NGROUP),XSINT1(NBMIX,NGROUP)
      LOGICAL   LNEWXS(18)
*----
*  LOCAL VARIABLES
*----
      PARAMETER(MAXNED=50)
      TYPE(C_PTR) JPLIST,KPLIST
      CHARACTER CANISO*2,CHID*12,NUSIGD*12,HVECT(MAXNED)*8
*----
* ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: INGSCT,IFGSCT,IPOSCT
      REAL, ALLOCATABLE, DIMENSION(:) :: XSWORK
*----
*  SCRATCH STORAGE ALLOCATION
*   INGSCT  number of scattering group for cross sections.
*   IFGSCT  first scattering group for cross sections.
*   IPOSCT  material position in scattering.
*----
      ALLOCATE(INGSCT(NBMIX),IFGSCT(NBMIX),IPOSCT(NBMIX))
      ALLOCATE(XSWORK(NBMIX*(2+NGROUP)))
*----
*  GET NUMBER OF MACRO EDIT X-SECTIONS
*----
      CALL LCMLEN(IPLIST,'ADDXSNAME-P0',ILCMLN,ILCMTY)
      NEDMAC=ILCMLN/2
      IF(NEDMAC.GT.MAXNED) CALL XABORT('MACPXS: MAXNED OVERFLOW(1).')
      IF(NEDMAC.GT.0) CALL LCMGTC(IPLIST,'ADDXSNAME-P0',8,NEDMAC,HVECT)
      IF(LNEWXS(8)) THEN
        DO IED=1,NEDMAC
          IF(HVECT(IED).EQ.'H-FACTOR') GO TO 5
        ENDDO
        NEDMAC=NEDMAC+1
        IF(NEDMAC.GT.MAXNED) CALL XABORT('MACPXS: MAXNED OVERFLOW(2).')
        HVECT(NEDMAC)='H-FACTOR'
      ENDIF
    5 IF(LNEWXS(15)) THEN
        DO IED=1,NEDMAC
          IF(HVECT(IED).EQ.'OVERV') GO TO 10
        ENDDO
        NEDMAC=NEDMAC+1
        IF(NEDMAC.GT.MAXNED) CALL XABORT('MACPXS: MAXNED OVERFLOW(3).')
        HVECT(NEDMAC)='OVERV'
      ENDIF
   10 IF(LNEWXS(16)) THEN
        DO IED=1,NEDMAC
          IF(HVECT(IED).EQ.'NFTOT') GO TO 15
        ENDDO
        NEDMAC=NEDMAC+1
        IF(NEDMAC.GT.MAXNED) CALL XABORT('MACPXS: MAXNED OVERFLOW(4).')
        HVECT(NEDMAC)='NFTOT'
      ENDIF
   15 IF(NEDMAC.GT.0) CALL LCMPTC(IPLIST,'ADDXSNAME-P0',8,NEDMAC,HVECT)
*
      JPLIST=LCMLID(IPLIST,'GROUP',NGROUP)
      DO 100 IGR=1,NGROUP
        KPLIST=LCMDIL(JPLIST,IGR)
*----
*  PUT TOTAL, FIXE AND TRANC ON THE MACROLIB IF MODIFIED
*----
        IF(LNEWXS(1)) CALL LCMPUT(KPLIST,'NTOT0',NBMIX,2,XSTOTL(1,IGR))
        IF(LNEWXS(3)) CALL LCMPUT(KPLIST,'FIXE' ,NBMIX,2,XSFIXE(1,IGR))
        IF(LNEWXS(6)) CALL LCMPUT(KPLIST,'TRANC',NBMIX,2,XSTRAN(1,IGR))
        IF(LNEWXS(7)) CALL LCMPUT(KPLIST,'DIFF',NBMIX,2,XSDIFF(1,IGR))
        IF(LNEWXS(8)) CALL LCMPUT(KPLIST,'H-FACTOR',NBMIX,2,XSH(1,IGR))
        IF(LNEWXS(9)) CALL LCMPUT(KPLIST,'NTOT1',NBMIX,2,XSTOT1(1,IGR))
*----
*  PUT CHI AND NUSIGF ON THE MACROLIB IF MODIFIED
*----
        IF(LNEWXS(2))
     >   CALL LCMPUT(KPLIST,'NUSIGF',NBMIX*NIFISS,2,XSFISS(1,1,IGR))
        IF(LNEWXS(4))
     >   CALL LCMPUT(KPLIST,'CHI',NBMIX*NIFISS,2,XSSPEC(1,1,IGR))
*----
*  PUT DIFFX, DIFFY AND DIFFZ ON THE MACROLIB IF MODIFIED
*----
        IF(LNEWXS(10))CALL LCMPUT(KPLIST,'DIFFX',NBMIX,2,XSDIFX(1,IGR))
        IF(LNEWXS(11))CALL LCMPUT(KPLIST,'DIFFY',NBMIX,2,XSDIFY(1,IGR))
        IF(LNEWXS(12))CALL LCMPUT(KPLIST,'DIFFZ',NBMIX,2,XSDIFZ(1,IGR))
*----
*  PUT CHID, NUSIGD AND OVERV ON THE MACROLIB IF MODIFIED
*----
        IF(LNEWXS(13)) THEN
          DO I=1,NDELG
            WRITE(NUSIGD,'(A6,I2.2)') 'NUSIGF',I
            CALL LCMPUT(KPLIST,NUSIGD,NBMIX*NIFISS,2,XSNUDL(1,1,I,IGR))
          ENDDO
        ENDIF
        IF(LNEWXS(14)) THEN
          DO I=1,NDELG
            WRITE(CHID,'(A3,I2.2)') 'CHI',I
            CALL LCMPUT(KPLIST,CHID,NBMIX*NIFISS,2,XSCHDL(1,1,I,IGR))
          ENDDO
        ENDIF
        IF(LNEWXS(15))CALL LCMPUT(KPLIST,'OVERV',NBMIX,2,XSOVRV(1,IGR))
        IF(LNEWXS(16))CALL LCMPUT(KPLIST,'NFTOT',NBMIX,2,XSNFTO(1,IGR))
        IF(LNEWXS(17))CALL LCMPUT(KPLIST,'FLUX-INTG',NBMIX,2,
     >                XSINT0(1,IGR))
        IF(LNEWXS(18))CALL LCMPUT(KPLIST,'FLUX-INTG-P1',NBMIX,2,
     >                XSINT1(1,IGR))
*----
*  COMPRESS AND PUT ON SCATT ON THE MACROLIB IF MODIFIED
*----
        DO 60 IANIS=1,NANISO
          WRITE(CANISO,'(I2.2)') IANIS-1
          IF(LNEWXS(5).AND.ISCATA(IANIS).EQ.2) THEN
            NELEM=0
            DO 50 INM=1,NBMIX
              J2=IGR
              J1=IGR
              DO 20 JGR=1,NGROUP
              IF(XSSCAT(JGR,INM,IANIS,IGR).NE.0.0) THEN
                J2=MAX(J2,JGR)
                J1=MIN(J1,JGR)
              ENDIF
  20          CONTINUE
              INGSCT(INM)=J2-J1+1
              IFGSCT(INM)=J2
              IPOSCT(INM)=NELEM+1
              DO 30 JGR=J2,J1,-1
                NELEM=NELEM+1
                XSWORK(2*NBMIX+NELEM)=XSSCAT(JGR,INM,IANIS,IGR)
  30          CONTINUE
*----
*  STORE DIAGONAL ELEMENTS OF SCATTERING MATRIX
*  AND TOTAL SCATTERING OUT OF GROUP
*----
              XSWORK(INM)=XSSCAT(IGR,INM,IANIS,IGR)
              XSTOT=0.0
              DO 40 JGR=1,NGROUP
              XSTOT=XSTOT+XSSCAT(IGR,INM,IANIS,JGR)
  40          CONTINUE
              XSWORK(NBMIX+INM)=XSTOT
  50        CONTINUE
            CALL LCMPUT(KPLIST,'NJJS'//CANISO,NBMIX,1,INGSCT)
            CALL LCMPUT(KPLIST,'IJJS'//CANISO,NBMIX,1,IFGSCT)
            CALL LCMPUT(KPLIST,'IPOS'//CANISO,NBMIX,1,IPOSCT)
            CALL LCMPUT(KPLIST,'SIGW'//CANISO,NBMIX,2,XSWORK)
            CALL LCMPUT(KPLIST,'SIGS'//CANISO,NBMIX,2,XSWORK(NBMIX+1))
            CALL LCMPUT(KPLIST,'SCAT'//CANISO,NELEM,2,
     >      XSWORK(2*NBMIX+1))
          ENDIF
  60    CONTINUE
*----
*  COMPUTE/RECOVER TRANSPORT CORRECTION
*----
        IF(ITRANC.EQ.2) THEN
*         RECOVER TRANSPORT CORRECTION FROM RECORD 'TRANC'.
          CALL LCMLEN(KPLIST,'TRANC',ILCMLN,ITYLCM)
          IF(ILCMLN.NE.NBMIX) CALL XABORT('MACPXS: NO TRANC RECORD '
     >    //'AVAILABLE')
        ELSE IF(ITRANC.NE.0) THEN
          CALL XDRSET(XSWORK,NBMIX,0.0)
          CALL LCMLEN(KPLIST,'NTOT1',ILCMLN,ITYLCM)
          IF(ILCMLN.EQ.NBMIX) THEN
*           LEAKAGE CORRECTION.
            CALL LCMGET(KPLIST,'NTOT0',XSWORK(NBMIX+1))
            CALL LCMGET(KPLIST,'NTOT1',XSWORK(2*NBMIX+1))
            DO 70 INM=1,NBMIX
            XSWORK(INM)=XSWORK(NBMIX+INM)-XSWORK(2*NBMIX+INM)
  70        CONTINUE
          ENDIF
          IF(ITRANC.EQ.1) THEN
*           APOLLO-TYPE TRANSPORT CORRECTION.
            CALL LCMLEN(KPLIST,'SIGS01',ILCMLN,ITYLCM)
            IF(ILCMLN.EQ.NBMIX) THEN
              CALL LCMGET(KPLIST,'SIGS01',XSWORK(NBMIX+1))
              DO 80 INM=1,NBMIX
              XSWORK(INM)=XSWORK(INM)+XSWORK(NBMIX+INM)
  80          CONTINUE
            ENDIF
          ELSE IF(ITRANC.NE.4) THEN
            CALL XABORT('MACPXS: UNKNOWN TYPE OF CORRECTION.')
          ENDIF
*         ***CAUTION*** 'TRANC' CONTAINS BOTH TRANSPORT AND LEAKAGE
*         CORRECTIONS.
          CALL LCMPUT(KPLIST,'TRANC',NBMIX,2,XSWORK)
        ENDIF
 100  CONTINUE
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(XSWORK)
      DEALLOCATE(IPOSCT,IFGSCT,INGSCT)
      RETURN
      END
