*DECK NAPPPR
      SUBROUTINE NAPPPR(IPMAP,IPTRK,IPFLU,IPMTX,IPMPP,IPMAC,NSTATE)
*
*-----------------------------------------------------------------------
*
*Purpose:
* - Perform the Pin Power Reconstruction
*
*Copyright:
* Copyright (C) 2014 Ecole Polytechnique de Montreal.
*
*Author(s): R. Chambon
*
*Parameters: input/output
*    for core with heteroGEneous mixture
* IPMAP   LCM object address of Map.
* IPTRK   LCM object address of Tracking.
* IPFLU   LCM object address of Flux.
* IPMTX   LCM object address of Matex.
*    for core with pin-by-pin mixture.
* IPMPP   LCM object address of Map.
* IPFLU   LCM object address of Flux.
*
* NSTATE  length of the state vector
*
*-----------------------------------------------------------------------
*
      USE GANLIB
      IMPLICIT NONE
*----
*  SUBROUTINE ARGUMENTS
*----
      INTEGER      NSTATE
      TYPE(C_PTR)  IPMAP,IPTRK,IPFLU,IPMTX,IPMPP,IPMAC
*----
*  LOCAL VARIABLES
*----
      INTEGER IOUT,NGPT
      REAL REPS
      PARAMETER (REPS=1.0E-4,IOUT=6,NGPT=2)
      TYPE(C_PTR) JPFLU,JPMAC,KPMAC,JPMAP,KPMAP
      INTEGER INDIC,NITMA,LENGTH
      CHARACTER TEXT*12
      REAL FLOT
      DOUBLE PRECISION DFLOT
      INTEGER ISTATE(NSTATE),IMPX,IMETH
      INTEGER NXP,NYP,NXD,NYD,NZD,NAX,NAY,
     1  NASS,NCOMB,NG,NASS2,NREG,NXM,NYM,NZM,
     2  NXT,NYT,NZT,NXDA,NYDA,NZDA,NCH,NZASS,NPIN,IFX,NCHP,NXMP,NYMP,
     3  NZMP,NXS,NASSP,NUN,IEL
      CHARACTER LABEL*8
      CHARACTER TFDINF*12
      INTEGER I,J,K,IP,JP,I1,I2,J1,J2,K1,K2,IASS,ICH,IG,
     1  IM,JM,ID,JD,KM,IASSP,IXPIN,IYPIN,IZPIN,iax,jax,IGP,JGP,KGP
      REAL SPIN,SGAP,POW,FACT,POWTOT,POWASS,DX,DY,DZ,FPD
      REAL ZGKSIX(NGPT),ZGKSIY(NGPT),ZGKSIZ(NGPT),WGKSIX(NGPT),
     1  WGKSIY(NGPT),WGKSIZ(NGPT),X(NGPT),Y(NGPT),Z(NGPT),
     2  FLUGP(NGPT,NGPT,NGPT)
      LOGICAL LSPX,LSPY,LSPZ,LCH,LPOW,LNOINT
      CHARACTER*4, ALLOCATABLE, DIMENSION(:) :: NAMX,NAMY
      INTEGER, ALLOCATABLE, DIMENSION(:) :: NBAX,IBAX,AZONE,
     1  ACOMB,AZONEP
      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: CODEA
      INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: KEYFLX,BMIX,
     1  BMIXP,MAT
      REAL, ALLOCATABLE, DIMENSION(:) :: MXP,MYP,MXD,MYD,MZD,MXM,
     1  MYM,MZM,MXDA,MYDA,MZDA,FLXD,SFM,HFM,FDINFM,FTINFM,VOLM
      REAL, ALLOCATABLE, DIMENSION(:,:) :: FXTD,FYTD
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: HFA,SFA
      REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: FLXDA,VOL
      REAL, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: FLXP,SF,HF,FDINF,FTINF
*
      IMPX=0
      LSPX=.FALSE.
      LSPY=.FALSE.
      LSPZ=.FALSE.
      LPOW=.FALSE.
      LNOINT=.FALSE.
      NZASS=0
      NPIN=0
      IFX=1
      POW=1.0
* Read mandatory keywords
* [EDIT] PPR
      CALL REDGET(INDIC,NITMA,FLOT,TEXT,DFLOT)
      IF(INDIC.NE.3) CALL XABORT('NAPPPR: character data expected.')
      IF(TEXT.EQ.'EDIT') THEN
        CALL REDGET(INDIC,IMPX,FLOT,TEXT,DFLOT)
        IF(INDIC.NE.1) CALL XABORT('NAPPPR: inteGEr data expected.')
        CALL REDGET(INDIC,NITMA,FLOT,TEXT,DFLOT)
        IF(INDIC.NE.3) CALL XABORT('NAPPPR: character data expected.')
      ENDIF
      IF(TEXT.NE.'PPR') CALL XABORT('NAPPPR: ''PPR'' keyword '//
     1  'expected.')
* NPIN
      CALL REDGET(INDIC,NITMA,FLOT,TEXT,DFLOT)
      IF(INDIC.NE.3) CALL XABORT('NAPPPR: character data expected.')
      IF(TEXT.NE.'NPIN') CALL XABORT('NAPPPR: ''NPIN'' keyword '//
     1  'expected.')
      CALL REDGET(INDIC,NPIN,FLOT,TEXT,DFLOT)
      IF(INDIC.NE.1) CALL XABORT('NAPPPR: NPIN inteGEr expected.')
      NXP=NPIN
      NYP=NPIN
* NZASS
      CALL REDGET(INDIC,NITMA,FLOT,TEXT,DFLOT)
      IF(INDIC.NE.3) CALL XABORT('NAPPPR: character data expected.')
      IF(TEXT.NE.'NZASS') CALL XABORT('NAPPPR: ''NZASS'' keyword '//
     1  'expected.')
      CALL REDGET(INDIC,NZASS,FLOT,TEXT,DFLOT)
      IF(INDIC.NE.1) CALL XABORT('NAPPPR: NZASS inteGEr expected.')
* SPIN + SGAP
      CALL REDGET(INDIC,NITMA,FLOT,TEXT,DFLOT)
      IF(INDIC.NE.3) CALL XABORT('NAPPPR: character data expected.')
      IF(TEXT.NE.'DIM') CALL XABORT('NAPPPR: ''NZASS'' keyword '//
     1  'expected.')
      CALL REDGET(INDIC,NITMA,SPIN,TEXT,DFLOT)
      IF(INDIC.NE.2) CALL XABORT('NAPPPR: SPIN real expected.')
      CALL REDGET(INDIC,NITMA,SGAP,TEXT,DFLOT)
      IF(INDIC.NE.2) CALL XABORT('NAPPPR: SGAP real expected.')
      
* GEt core GEometry description in matex
      IF(IMPX.GE.100)WRITE(6,*) 'debug:GEt matex info'
      CALL LCMGET(IPMTX,'STATE-VECTOR',ISTATE)
      NG=ISTATE(1)
      NXD=ISTATE(8)
      NYD=ISTATE(9)
      NZD=ISTATE(10)
      ALLOCATE(MXD(NXD+1),MYD(NYD+1),MZD(NZD+1))
      CALL LCMGET(IPMTX,'MESHX',MXD)
      CALL LCMGET(IPMTX,'MESHY',MYD)
      CALL LCMGET(IPMTX,'MESHZ',MZD)
* GEt KEYFLX
      IF(IMPX.GE.100)WRITE(6,*) 'debug:GEt track info'
      CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE)
      NREG=ISTATE(1)
      NUN=ISTATE(2)
      NXT=ISTATE(14)
      NYT=ISTATE(15)
      NZT=ISTATE(16)
      IEL=ISTATE(9)
      IF((NXD.NE.NXT).OR.(NYD.NE.NYT).OR.(NZD.NE.NZT)) CALL XABORT
     1  ('NAPPPR: dimension do not match between MATEX and TRACKING')
      ALLOCATE(KEYFLX(NXT,NYT,NZT),MAT(NXT,NYT,NZT))
      CALL LCMGET(IPTRK,'KEYFLX',KEYFLX)
      CALL LCMGET(IPTRK,'MATCOD',MAT)
      ALLOCATE(FLXD(NUN))
* GEt assembly GEometry in map
      IF(IMPX.GE.100)WRITE(6,*) 'debug:GEt map info'
      CALL LCMGET(IPMAP,'STATE-VECTOR',ISTATE)
      NCH=ISTATE(2)
      NASS=ISTATE(14)
      NAX=ISTATE(15)
      NAY=ISTATE(16)
      ALLOCATE(AZONE(NCH))
      ALLOCATE(NAMX(NAX),NAMY(NAY))
      CALL LCMGET(IPMAP,'A-ZONE',AZONE)
      CALL LCMGET(IPMAP,'AXNAME',NAMX)
      CALL LCMGET(IPMAP,'AYNAME',NAMY)
      CALL LCMSIX(IPMAP,'GEOMAP',1)
      CALL LCMGET(IPMAP,'STATE-VECTOR',ISTATE)
      NXM=ISTATE(3)
      NYM=ISTATE(4)
      NZM=ISTATE(5)
      ALLOCATE(MXM(NXM+1),MYM(NYM+1),MZM(NZM+1))
      ALLOCATE(NBAX(NAY),IBAX(NAY))
      ALLOCATE(BMIX(NXM,NYM,NZM))
      CALL LCMGET(IPMAP,'MESHX',MXM)
      CALL LCMGET(IPMAP,'MESHY',MYM)
      CALL LCMGET(IPMAP,'MESHZ',MZM)
      CALL LCMLEN(IPMAP,'A-NX',LENGTH,INDIC)
      IF(LENGTH.NE.NAY) CALL XABORT('NAPPPR: Number of assembly along'
     1  //'Y direction do not match between MAP and embedded GEometry')
      CALL LCMGET(IPMAP,'A-NX',NBAX)
      CALL LCMGET(IPMAP,'A-IBX',IBAX)
      CALL LCMSIX(IPMAP,'GEOMAP',2)
      CALL LCMGET(IPMAP,'BMIX',BMIX)
* GEt data in pin by pin assembly GEometry 
      IF(IMPX.GE.100)WRITE(6,*) 'debug:GEt map pinBypin info'
      CALL LCMGET(IPMPP,'STATE-VECTOR',ISTATE)
      NCHP=ISTATE(2)
      NASSP=ISTATE(14)
*     total number of fuel bundles = tot. nb. of .XS 
      NXS=ISTATE(9)
      IF(NASS.NE.NASSP)CALL XABORT('NAPPPR: number of assembly do not '
     1  //'match between unfolded GEometries')
      ALLOCATE(AZONEP(NCHP))
      CALL LCMGET(IPMPP,'A-ZONE',AZONEP)
      CALL LCMSIX(IPMPP,'GEOMAP',1)
      CALL LCMGET(IPMPP,'STATE-VECTOR',ISTATE)
      NXMP=ISTATE(3)
      NYMP=ISTATE(4)
      NZMP=ISTATE(5)
      CALL LCMSIX(IPMPP,'GEOMAP',2)
      ALLOCATE(BMIXP(NXMP,NYMP,NZMP))
      CALL LCMGET(IPMPP,'BMIX',BMIXP)
      IF(IMPX.GE.5) THEN
        WRITE(6,*) 'MATEX dimension   (het):',NXD,NYD,NZD
        WRITE(6,*) 'TRACKING dimension(het):',NXT,NYT,NZT
        WRITE(6,*) 'MAP dimension     (het):',NXM,NYM,NZM
        WRITE(6,*) 'MAP dimension     (pin):',NXMP,NYMP,NZMP
      ENDIF
* Read remaining input file
      NCOMB=0
      ALLOCATE(ACOMB(NASS))
      IF(IMPX.GE.100)WRITE(6,*) 'debug: beg read input'
      IMETH=0
    5 CALL REDGET(INDIC,NITMA,FLOT,TEXT,DFLOT)
        IF(TEXT.EQ.'METH') THEN
        CALL REDGET(INDIC,NITMA,FLOT,TEXT,DFLOT)
        IF(INDIC.NE.3) CALL XABORT('NAPPPR: character data expected.')
        IF(TEXT.EQ.'GPPR') THEN
          IMETH=1
          CALL REDGET(INDIC,IFX,FLOT,TEXT,DFLOT)
          IF(INDIC.NE.1) CALL XABORT('NAPPPR: inteGEr data expected.')
          WRITE(TFDINF,500) IFX
        ELSE
          CALL XABORT('NAPPPR: '//TEXT//' is a wrong method keyword.')
        ENDIF
        GOTO 5
      ELSEIF(TEXT.EQ.'POWER') THEN
        LPOW=.TRUE.
        CALL REDGET(INDIC,NITMA,POW,TEXT,DFLOT)
        IF(INDIC.NE.2) CALL XABORT('NAPPPR: POWER real expected.')
        GOTO 5
      ELSEIF(TEXT.EQ.';') THEN
        GOTO 50
      ELSE
        CALL XABORT('NAPPPR: '//TEXT//' is a wrong keyword.')
      ENDIF
*-----------------------------
   50 CONTINUE
      IF(IMPX.GE.100)WRITE(6,*) 'debug: computation begin'
* Compute mesh X and Y for a pin-by-pin assembly
      ALLOCATE(MXP(NXP+1),MYP(NYP+1))
      MXP(1)=0.0
      DO I=1,NXP
        MXP(I+1)=SGAP+SPIN*I
      ENDDO
      MXP(NPIN+1)=SGAP+MXP(NPIN+1)
      MYP(1)=0.0
      DO I=1,NYP
        MYP(I+1)=SGAP+SPIN*I
      ENDDO
      MYP(NPIN+1)=SGAP+MYP(NPIN+1)
* Compute IX-,IX+,IY-,IY+,IZ-,IZ+ for each assembly in core GEometry
      IF(IMPX.GE.100) WRITE(6,*) 'debug PPR:IX-,IX+,IY-,IY+,IZ-,IZ+'
      ALLOCATE(CODEA(NASS,6))
      CALL XDISET(CODEA,NASS*6,0)
      ICH=0
      I1=0
      I2=0
      NASS2=0
      DO IASS=1,NASS
        CODEA(IASS,1)=NXD+1
        CODEA(IASS,2)=0
        CODEA(IASS,3)=NYD+1
        CODEA(IASS,4)=0
        CODEA(IASS,5)=NZD+1
        CODEA(IASS,6)=0
      ENDDO
      DO 150 JM=1,NYM
      DO 130 IM=1,NXM
      LCH=.TRUE.
      IASS=0
      DO 100 KM=1,NZM
      IF(BMIX(IM,JM,KM).NE.0) THEN
        IF(LCH) THEN
          ICH=ICH+1
          LCH=.FALSE.
          IASS=AZONE(ICH)
          NASS2=MAX(NASS2,IASS)
          DO I=1,NXD+1
            IF(MXD(I).EQ.MXM(IM)) I1=I
            IF(MXD(I).EQ.MXM(IM+1)) I2=I
          ENDDO
          CODEA(IASS,1)=MIN(I1,CODEA(IASS,1))
          CODEA(IASS,2)=MAX(I2,CODEA(IASS,2))
          DO I=1,NYD+1
            IF(MYD(I).EQ.MYM(JM)) I1=I
            IF(MYD(I).EQ.MYM(JM+1)) I2=I
          ENDDO
          CODEA(IASS,3)=MIN(I1,CODEA(IASS,3))
          CODEA(IASS,4)=MAX(I2,CODEA(IASS,4))
          DO I=1,NZD+1
            IF(MZD(I).EQ.MZM(KM)) I1=I
            IF(MZD(I).EQ.MZM(KM+1)) I2=I
          ENDDO
          CODEA(IASS,5)=MIN(I1,CODEA(IASS,5))
          CODEA(IASS,6)=MAX(I2,CODEA(IASS,6))
        ELSE
          DO I=2,NZD+1
            IF(MZD(I).EQ.MZM(KM+1)) I2=I
          ENDDO
          CODEA(IASS,6)=MAX(I2,CODEA(IASS,6))
        ENDIF
      ENDIF
  100 CONTINUE
  130 CONTINUE
  150 CONTINUE
      IF(IMPX.GE.10) THEN
        WRITE(6,*) 'Position of the assemblies in the core'
        WRITE(6,*) 'IX-,IX+,IY-,IY+,IZ-,IZ+'
        do iass=1,nass
          WRITE(6,*) 'Assembly #',iass,':',(CODEA(iass,i),i=1,6)
        ENDDO
      ENDIF
      IF(NASS2.NE.NASS)CALL XABORT('NAPPPR: number of assembly do not'
     1 //' match: NASS2.NE.NASS')
* For all assembly perform PPR 
      ALLOCATE(FLXP(NXP,NYP,NZASS,NG,NASS))
      DO IASS=1,NASS
*   GEt flux at core GEometry level for assembly only
      I1=CODEA(IASS,1)
      I2=CODEA(IASS,2)
      J1=CODEA(IASS,3)
      J2=CODEA(IASS,4)
      K1=CODEA(IASS,5)
      K2=CODEA(IASS,6)
      NXDA=I2-I1
      NYDA=J2-J1
      NZDA=K2-K1
      ALLOCATE(FLXDA(NXDA,NYDA,NZDA,NG))
      CALL XDRSET(FLXDA,NXDA*NYDA*NZDA*NG,0.0)
      IF(NZDA.NE.NZASS) CALL XABORT('NAPPPR: incoherent number of mesh' 
     1 //' in Z direction for an assembly: NZDA.NE.NZASS')
      JPFLU=LCMGID(IPFLU,'FLUX')
      IF((LNOINT).OR.(IMPX.GE.5)) THEN
        
        DO IG=1,NG
          CALL LCMGDL(JPFLU,IG,FLXD)
        DO I=I1,I2-1
        DO J=J1,J2-1
        DO K=K1,K2-1
          FLXDA(I-I1+1,J-J1+1,K-K1+1,IG)=FLXD(KEYFLX(I,J,K))
        ENDDO
C       end K
        ENDDO
C       end J
        ENDDO
C       end I
        ENDDO
C       end IG
      ENDIF
      ALLOCATE(MXDA(NXDA+1),MYDA(NYDA+1),MZDA(NZDA+1))
      DO I=I1,I2
        MXDA(I-I1+1)=MXD(I)-MXD(I1)+MXP(1)
      ENDDO
      DO J=J1,J2
        MYDA(J-J1+1)=MYD(J)-MYD(J1)+MYP(1)
      ENDDO
      DO K=K1,K2
        MZDA(K-K1+1)=MZD(K)
      ENDDO
      IF(IMPX.GE.5) THEN
        WRITE(6,*) 'Flux and mesh at heteroGEneous assembly level'
        WRITE(6,*) 'Mesh X:',(MXDA(I),I=1,NXDA+1)
        WRITE(6,*) 'Mesh Y:',(MYDA(I),I=1,NYDA+1)
        WRITE(6,*) 'Mesh Z:',(MZDA(I),I=1,NZDA+1)
        WRITE(6,*) 'Flux:'
        DO IG=1,NG
        WRITE(6,*) 'Group #',IG
        DO K=1,NZDA
        WRITE(6,*) 'Plan #',K
        DO J=1,NYDA
        WRITE(6,*) (FLXDA(I,J,K,IG),I=1,NXDA)
        ENDDO
        ENDDO
        ENDDO
      ENDIF
*   project flux at assembly level
      ALLOCATE(FXTD(NXP,NXDA),FYTD(NYP,NYDA))
      CALL XDRSET(FXTD,NXP*NXDA,0.0)
      CALL XDRSET(FYTD,NYP*NYDA,0.0)
*   compute fraction of the transport volumes occupied by diffusion volumes  
      CALL NAPFTD(NXP,MXP,NXDA,MXDA,FXTD)
      CALL NAPFTD(NYP,MYP,NYDA,MYDA,FYTD)
!      DO IP=1,NXP
!      DXP=MXP(IP+1)-MXP(IP)
!      DO ID=1,NXDA
!        IF((MXDA(ID).LE.MXP(IP)).AND.(MXDA(ID+1).GE.MXP(IP+1))) THEN
!          FXTD(IP,ID)=1.0
!        ELSEIF ((MXDA(ID).LE.MXP(IP)).AND.(MXDA(ID+1).GT.MXP(IP))) THEN
!          FXTD(IP,ID)=(MXDA(ID+1)-MXP(IP))/DXP
!        ELSEIF ((MXDA(ID).GE.MXP(IP)).AND.
!     1          (MXDA(ID+1).LE.MXP(IP+1))) THEN
!          FXTD(IP,ID)=(MXDA(ID+1)-MXDA(ID))/DXP
!        ELSEIF ((MXDA(ID).LT.MXP(IP+1)).AND.
!     1          (MXDA(ID+1).GE.MXP(IP+1))) THEN
!          FXTD(IP,ID)=(MXP(IP+1)-MXDA(ID))/DXP
!        ENDIF
!      ENDDO
!      ENDDO
*
!      DO IP=1,NYP
!      DYP=MYP(IP+1)-MYP(IP)
!      DO ID=1,NYDA
!        IF((MYDA(ID).LE.MYP(IP)).AND.(MYDA(ID+1).GE.MYP(IP+1))) THEN
!          FYTD(IP,ID)=1.0
!        ELSEIF ((MYDA(ID).LE.MYP(IP)).AND.(MYDA(ID+1).GT.MYP(IP))) THEN
!          FYTD(IP,ID)=(MYDA(ID+1)-MYP(IP))/DYP
!        ELSEIF ((MYDA(ID).GE.MYP(IP)).AND.
!     1          (MYDA(ID+1).LE.MYP(IP+1))) THEN
!          FYTD(IP,ID)=(MYDA(ID+1)-MYDA(ID))/DYP
!        ELSEIF ((MYDA(ID).LT.MYP(IP+1)).AND.
!     1          (MYDA(ID+1).GE.MYP(IP+1))) THEN
!          FYTD(IP,ID)=(MYP(IP+1)-MYDA(ID))/DYP
!        ENDIF
!      ENDDO
!      ENDDO
!     adds up all fluxes
      DO IG=1,NG
      IF(.NOT.LNOINT) CALL LCMGDL(JPFLU,IG,FLXD)
      DO K=1,NZASS
      DO IP=1,NXP
      DO JP=1,NYP
        FLXP(IP,JP,K,IG,IASS)=0.0
        DO ID=1,NXDA
        DO JD=1,NYDA
          IF(LNOINT) THEN
* No interpolation: use averaGE flux
            FLXP(IP,JP,K,IG,IASS)=FLXP(IP,JP,K,IG,IASS)
     1       +FLXDA(ID,JD,K,IG)*FXTD(IP,ID)*FYTD(JP,JD)
* Interpolate flux with polynomial representation
*   (only if pin and macro region have a non-nul intersection)
          ELSEIF(FXTD(IP,ID)*FYTD(JP,JD).NE.0.0) THEN
*     indent removed
*     compute gauss points and weights
      CALL ALGPT(NGPT,MAX(MXP(IP),MXDA(ID)),MIN(MXP(IP+1),MXDA(ID+1)),
     1   ZGKSIX,WGKSIX)
      DX=MIN(MXP(IP+1),MXDA(ID+1))-MAX(MXP(IP),MXDA(ID))
      CALL ALGPT(NGPT,MAX(MYP(JP),MYDA(JD)),MIN(MYP(JP+1),MYDA(JD+1)),
     1   ZGKSIY,WGKSIY)
      DY=MIN(MYP(JP+1),MYDA(JD+1))-MAX(MYP(JP),MYDA(JD))
      CALL ALGPT(NGPT,MZDA(K),MZDA(K+1),ZGKSIZ,WGKSIZ)
      DZ=MZDA(K+1)-MZDA(K)
      IF(IMPX.GE.5) then
        WRITE(6,*) 'IP,JP:',IP,JP,FXTD(IP,ID),'ID,JD:',ID,JD,FYTD(JP,JD)
        WRITE(6,*) 'Gauss point ZGWG:',(ZGKSIX(I),I=1,NGPT),
     1   (WGKSIX(I),I=1,NGPT),'DX',DX
        WRITE(6,*) 'Gauss point ZGWG:',(ZGKSIY(I),I=1,NGPT),
     1   (WGKSIY(I),I=1,NGPT),'DY',DY
        WRITE(6,*) 'Gauss point ZGWG:',(ZGKSIZ(I),I=1,NGPT),
     1   (WGKSIZ(I),I=1,NGPT),'DZ',DZ
      ENDIF
      
      FPD=0.0
      DO IGP=1,NGPT
        X(IGP)=MXD(I1)-MXP(1)+ZGKSIX(IGP)
      ENDDO
      DO JGP=1,NGPT
        Y(JGP)=MYD(J1)-MYP(1)+ZGKSIY(JGP)
      ENDDO
      DO KGP=1,NGPT
        Z(KGP)=ZGKSIZ(KGP)
      ENDDO
      IF(IMPX.GE.5) then
        WRITE(6,*) 'Gauss point X:',(X(I),I=1,NGPT)
        WRITE(6,*) 'Gauss point Y:',(Y(I),I=1,NGPT)
        WRITE(6,*) 'Gauss point Z:',(Z(I),I=1,NGPT)
      ENDIF
      IF(IEL.GT.0) THEN
*     interpolate flux
      CALL VALUE4(IEL,NUN,NXD,NYD,NZD,X,Y,Z,MXD,MYD,MZD,FLXD,MAT,
     1  KEYFLX,NGPT,NGPT,NGPT,FLUGP)
      IF(IMPX.GE.5) then
        WRITE(6,*) 'Gauss flux values:'
      DO KGP=1,NGPT
        WRITE(6,*) 'KGP=:',KGP
      DO JGP=1,NGPT
        WRITE(6,*) (FLUGP(IGP,JGP,KGP),IGP=1,NGPT)
      ENDDO
      ENDDO
      ENDIF
*     integrate flux (gauss method)
      DO IGP=1,NGPT
      DO JGP=1,NGPT
      DO KGP=1,NGPT
        FPD=FPD+FLUGP(IGP,JGP,KGP)*WGKSIX(IGP)*WGKSIY(JGP)*WGKSIZ(KGP)
      ENDDO
      ENDDO
      ENDDO
*        GEt averaGE flux
      FPD=FPD/DX/DY/DZ
      ELSE
        CALL XABORT('NAPPPR: Only Trivac / dual implemented yet')
      ENDIF
      FLXP(IP,JP,K,IG,IASS)=FLXP(IP,JP,K,IG,IASS)
     1                     +FPD*FXTD(IP,ID)*FYTD(JP,JD)
*     indent back
          ENDIF
        ENDDO
        ENDDO
      ENDDO
      ENDDO
      ENDDO
      ENDDO

      DEALLOCATE(FXTD,FYTD)
      DEALLOCATE(MXDA,MYDA,MZDA)
      DEALLOCATE(FLXDA)
      IF(IMPX.GE.100)WRITE(6,*) 'debug PPR:projection flux for one '
     1  //'assem end'
!     end of DO IASS=1,NASS
      ENDDO
      IF(IMPX.GE.100)WRITE(6,*) 'debug PPR:projection flux for all '
     1  //'assem end'
* GPPR
      IF(IMETH.EQ.1) THEN
      IF(IMPX.GE.100)WRITE(6,*) 'debug PPR:',TFDINF
*   GEt Volume, Sigma^t_p, phi^t,inf_p and phi^d,inf_m,p from macrolib of fuel
*      Note: if homoGEneous (normal PPR), m=1
        ALLOCATE(VOLM(NXS),SFM(NXS),HFM(NXS),FTINFM(NXS),FDINFM(NXS))
        ALLOCATE(VOL(NPIN,NPIN,NZASS,NASS),SF(NPIN,NPIN,NZASS,NG,NASS))
        ALLOCATE(HF(NPIN,NPIN,NZASS,NG,NASS))
        ALLOCATE(FTINF(NPIN,NPIN,NZASS,NG,NASS))
        ALLOCATE(FDINF(NPIN,NPIN,NZASS,NG,NASS))
        CALL XDRSET(VOL,NPIN*NPIN*NZASS*NASS,0.0)
        CALL XDRSET(SF,NPIN*NPIN*NZASS*NG*NASS,0.0)
        CALL XDRSET(HF,NPIN*NPIN*NZASS*NG*NASS,0.0)
        CALL XDRSET(FTINF,NPIN*NPIN*NZASS*NG*NASS,0.0)
        CALL XDRSET(FDINF,NPIN*NPIN*NZASS*NG*NASS,0.0)
        CALL LCMGET(IPMAC,'VOLUME',VOLM)
        JPMAC=LCMGID(IPMAC,'GROUP')
        DO IG=1,NG
        KPMAC=LCMGIL(JPMAC,IG)
        CALL LCMGET(KPMAC,'NFTOT',SFM)
        CALL LCMGET(KPMAC,'H-FACTOR',HFM)
        CALL LCMGET(KPMAC,'FLUX-INTG',FTINFM)
        CALL LCMGET(KPMAC,TFDINF,FDINFM)
        
        DO IASS=1,NASS
        IZPIN=1
          DO K=1,NZMP
          IYPIN=1
          IASSP=0
          DO J=1,NYMP
          IXPIN=0
          DO I=1,NXMP
          IF(BMIXP(I,J,K).NE.0) THEN
            IASSP=IASSP+1
            IF(AZONEP(IASSP).EQ.IASS) THEN
              IXPIN=IXPIN+1
              SF(IXPIN,IYPIN,IZPIN,IG,IASS)=SFM(BMIXP(I,J,K))
              HF(IXPIN,IYPIN,IZPIN,IG,IASS)=HFM(BMIXP(I,J,K))
              FTINF(IXPIN,IYPIN,IZPIN,IG,IASS)=FTINFM(BMIXP(I,J,K))
     1            /VOLM(BMIXP(I,J,K))
              FDINF(IXPIN,IYPIN,IZPIN,IG,IASS)=FDINFM(BMIXP(I,J,K))
              VOL(IXPIN,IYPIN,IZPIN,IASS)=VOLM(BMIXP(I,J,K))
            ENDIF
          ENDIF
          ENDDO
          IF(IXPIN.GT.0) THEN
            IYPIN=IYPIN+1
            IF(IXPIN.NE.NPIN) CALL XABORT('NAPPPR: NPIN ne IXPIN')
          ENDIF
          ENDDO
          IF(IYPIN.GT.1) THEN
            IZPIN=IZPIN+1
            IF((IYPIN-1).NE.NPIN) CALL XABORT('NAPPPR: NPIN ne IYPIN')
          ENDIF
          ENDDO
!       end of DO IASS=1,NASS
        ENDDO
!       end of DO IG=1,NG
        ENDDO
        IF(IMPX.GE.10) then
        DO iass=1,nass
          WRITE(6,*) 'XS for assembly #',IASS
          DO k=1,nzass
          WRITE(6,*) 'Plane #',K
          DO ig=1,ng
          WRITE(6,*) 'group #',ig
          WRITE(6,*) 'SF #'
          DO j=1,npin
           WRITE(6,*) (SF(I,J,K,ig,iass),I=1,NPIN)
          ENDDO
          WRITE(6,*) 'HF #'
          DO j=1,npin
           WRITE(6,*) (HF(I,J,K,ig,iass),I=1,NPIN)
          ENDDO
          WRITE(6,*) 'FTINF #'
          DO j=1,npin
           WRITE(6,*) (FTINF(I,J,K,ig,iass),I=1,NPIN)
          ENDDO
          WRITE(6,*) 'FLXP #'
          DO j=1,npin
           WRITE(6,*) (FLXP(I,J,K,ig,iass),I=1,NPIN)
          ENDDO
          WRITE(6,*) 'FDINF #'
          DO j=1,npin
           WRITE(6,*) (FDINF(I,J,K,ig,iass),I=1,NPIN)
          ENDDO
!           end of do ig=1,ng
          ENDDO
          WRITE(6,*) 'VOL #'
          DO j=1,npin
           WRITE(6,*) (VOL(I,J,K,iass),I=1,NPIN)
          ENDDO
          ENDDO
        ENDDO
        ENDIF
* Print and save reaction rates
        IF(IMPX.GE.100)WRITE(6,*) 'debug: Print and save reaction rates'
        IF(LPOW) THEN
          POWTOT=0.0
          DO IASS=1,NASS
          K1=CODEA(IASS,5)
          DO K=1,NZASS
          DO J=1,NPIN
          DO I=1,NPIN
          DO IG=1,NG
            POWTOT=POWTOT+HF(I,J,K,IG,IASS)*FTINF(I,J,K,IG,IASS)
     1        *FLXP(I,J,K,IG,IASS)/FDINF(I,J,K,IG,IASS)
     2        *(MXP(I+1)-MXP(I))*(MYP(J+1)-MYP(J))
     3        *(MZM(K1+K)-MZM(K1+K-1))
          ENDDO
          ENDDO
          ENDDO
          ENDDO
          ENDDO
          FACT=POW/POWTOT
        ELSE
          FACT=1.0
        ENDIF
        ALLOCATE(SFA(NPIN,NPIN,NZASS),HFA(NPIN,NPIN,NZASS))
        JPMAP=LCMLID(IPMAP,'ASSEMBLY',NASS)
        IAX=0
        JAX=1
!        WRITE(6,*) (NBAX(I),I=1,NAY)
!        WRITE(6,*) (IBAX(I),I=1,NAY)
        DO IASS=1,NASS
        K1=CODEA(IASS,5)
        IAX=IAX+1
        IF(IAX.GT.NBAX(JAX)) THEN
          IAX=1
          JAX=JAX+1
        ENDIF
        WRITE(LABEL,'(A4,A4)') NAMY(JAX),NAMX(IBAX(JAX)+IAX-1)
        IF(IMPX.GE.3) then
          WRITE(6,*) 'Reaction rates for assembly #',IASS,' Label:',
     1     label
        ENDIF
        DO K=1,NZASS
          IF(IMPX.GE.2) WRITE(6,*) 'Plane #',K
        DO J=1,NPIN
        DO I=1,NPIN
        SFA(I,J,K)=0.0
        HFA(I,J,K)=0.0
        DO IG=1,NG
          SFA(I,J,K)=SFA(I,J,K)+SF(I,J,K,IG,IASS)*FTINF(I,J,K,IG,IASS)
     1        *FLXP(I,J,K,IG,IASS)/FDINF(I,J,K,IG,IASS)
     2        *FACT
     2        *(MXP(I+1)-MXP(I))*(MYP(J+1)-MYP(J))
     3        *(MZM(K1+K)-MZM(K1+K-1))
          HFA(I,J,K)=HFA(I,J,K)+HF(I,J,K,IG,IASS)*FTINF(I,J,K,IG,IASS)
     1        *FLXP(I,J,K,IG,IASS)/FDINF(I,J,K,IG,IASS)
     2        *FACT
     2        *(MXP(I+1)-MXP(I))*(MYP(J+1)-MYP(J))
     3        *(MZM(K1+K)-MZM(K1+K-1))
!       end of DO IG=1,NG
        ENDDO
!       end of I=1,NPIN
        ENDDO
          IF(IMPX.GE.3) WRITE(6,*) (HFA(I,J,K),I=1,NPIN)
!       end of J=1,NPIN
        ENDDO
!       end of DO K=1,NZASS
        ENDDO
*
        KPMAP=LCMDIL(JPMAP,IASS)
        CALL LCMPUT(KPMAP,'LABEL',2,3,LABEL)
        CALL LCMPUT(KPMAP,'PIN-POWER',NPIN*NPIN*NZASS,2,HFA)
        CALL LCMPUT(KPMAP,'SIG_F*PHI',NPIN*NPIN*NZASS,2,SFA)
        CALL LCMPUT(KPMAP,'FLUX',NPIN*NPIN*NZASS*NG,2,
     1              FLXP(1,1,1,1,IASS))
        POWASS=0.0
        DO K=1,NZASS
        DO J=1,NPIN
        DO I=1,NPIN
          POWASS=POWASS+HFA(I,J,K)
        ENDDO
        ENDDO
        ENDDO
        IF(IMPX.GE.2) THEN
          WRITE(6,*) 'Power of assembly #',IASS,":",POWASS
        ENDIF
        CALL LCMPUT(KPMAP,'ASS-POWER',1,2,POWASS)
!       end of DO IASS=1,NASS
        ENDDO
!     end of IF(IMETH.EQ.1) THEN
      ENDIF
      CALL LCMGET(IPMAP,'STATE-VECTOR',ISTATE)
      ISTATE(17)=NZASS
      CALL LCMPUT(IPMAP,'STATE-VECTOR',NSTATE,1,ISTATE)
      
!
      IF(IMPX.GE.100)WRITE(6,*) 'debug: beging deallacate'

      DEALLOCATE(FLXP,FLXD)
      DEALLOCATE(MXP,MYP)

      DEALLOCATE(CODEA)
      IF(IMETH.EQ.1) THEN 
        DEALLOCATE(VOLM,SFM,HFM,FTINFM,FDINFM)
        DEALLOCATE(VOL,SF,HF,FTINF,FDINF)
        DEALLOCATE(SFA,HFA)
      ENDIF
      DEALLOCATE(ACOMB)
      DEALLOCATE(AZONE,AZONEP)
      DEALLOCATE(NAMX,NAMY)
      DEALLOCATE(BMIX,BMIXP)
      DEALLOCATE(MXM,MYM,MZM)
      DEALLOCATE(NBAX,IBAX)
      DEALLOCATE(KEYFLX,MAT)
      DEALLOCATE(MXD,MYD,MZD)

      RETURN
  500 FORMAT(5HFINF_,I3.3,4H    )
      END
