*DECK COMACR
      SUBROUTINE COMACR(IPEDIT,IMPX,IPCPO,NG,NMIL,NED,NL,NDEL,IMIL,
     1 FNORM,NSPH,EIGENK,B2,VOLUME,ENER,DELT,HVECT,NF)
*
*-----------------------------------------------------------------------
*
*Purpose:
* transform a macrolib into IPEDIT into a microlib into IPCPO.
*
*Copyright:
* Copyright (C) 2007 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): A. Hebert
*
*Parameters: input
* IPEDIT  pointer to the edition object (L_EDIT signature).
* IMPX    print parameter.
* IPCPO   pointer to the multicompo.
* NG      number of energy groups.
* NMIL    number of homogenized mixtures.
* NED     number of extra edits.
* NL      number of Legendre orders.
* NDEL    number of precursor groups.
* IMIL    homogenized mixture index we want to recover.
* FNORM   flux normalization factor.
* NSPH    flag for SPH content (=0 no SPH, =1 NSPH included in COMPO).
*
*Parameters: output
* EIGENK  effective multiplication factor.
* B2      buckling.
* VOLUME  volume of homogenized mixture IMIL.
* ENER    energy limits.
* DELT    lethargy increments.
* HVECT   additional edit names.
* NF      number of fissile isotopes.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPEDIT,IPCPO
      INTEGER IMPX,NG,NMIL,NL,NED,IMIL,NSPH,HVECT(2,NED+1),NF
      REAL FNORM,EIGENK,B2,VOLUME,ENER(NG+1),DELT(NG)
*----
*  LOCAL VARIABLES
*----
      PARAMETER (NSTATE=40)
      TYPE(C_PTR) JPEDIT,KPEDIT
      INTEGER IPAR(NSTATE)
      CHARACTER TEXT8*8,TEXT12*12,CM*2
      LOGICAL LHF
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS,ITYPR
      REAL, ALLOCATABLE, DIMENSION(:) :: GAR3
      REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR1
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: GAR2
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(IJJ(NMIL),NJJ(NMIL),IPOS(NMIL),ITYPR(NL))
      ALLOCATE(GAR1(NG,11+2*NDEL+NED+NL+1),GAR2(NG,NG,NL),GAR3(NMIL*NG))
*
      CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR)
      IF(NG.NE.IPAR(1)) THEN
         CALL XABORT('COMACR: INVALID NUMBER OF GROUPS IN MACROLIB.')
      ELSE IF(NMIL.NE.IPAR(2)) THEN
         CALL XABORT('COMACR: INVALID NUMBER OF MIXTURES IN MACROLIB.')
      ELSE IF(NL.NE.IPAR(3)) THEN
         CALL XABORT('COMACR: INVALID NUMBER OF MIXTURES IN MACROLIB.')
      ELSE IF(IPAR(4).GT.1) THEN
         CALL XABORT('COMACR: MULTIPLE FISSION SPECTRA NOT SUPPORTED.')
      ELSE IF(NED.NE.IPAR(5)) THEN
         CALL XABORT('COMACR: INVALID NUMBER OF EDITS IN MACROLIB.')
      ELSE IF(NDEL.NE.IPAR(7)) THEN
         CALL XABORT('COMACR: INVALID NUMBER OF PRECURSOR GROUPS IN MA'
     1   //'CROLIB.')
      ENDIF
      NF=IPAR(4)
      NLEAK=IPAR(9)
      NWP1=IPAR(10)
      LHF=.FALSE.
      IF(NF.GT.0) THEN
         CALL LCMGET(IPEDIT,'K-EFFECTIVE',EIGENK)
      ELSE
         EIGENK=0.0
      ENDIF
      CALL LCMLEN(IPEDIT,'B2  B1HOM',ILONG,ITYLCM)
      IF(ILONG.EQ.1) THEN
         CALL LCMGET(IPEDIT,'B2  B1HOM',B2)
      ELSE
         B2=0.0
      ENDIF
      CALL LCMGET(IPEDIT,'ENERGY',ENER)
      CALL LCMGET(IPEDIT,'DELTAU',DELT)
      IF(NED.GT.0) CALL LCMGET(IPEDIT,'ADDXSNAME-P0',HVECT)
      IF(NSPH.EQ.1) THEN
        TEXT8='NSPH    '
        READ(TEXT8,'(2A4)') HVECT(1,NED+1),HVECT(2,NED+1)
      ENDIF
      CALL LCMGET(IPEDIT,'VOLUME',GAR3)
      VOLUME=GAR3(IMIL)
      CALL LCMSIX(IPCPO,'*MAC*RES',1)
      JPEDIT=LCMGID(IPEDIT,'GROUP')
      CALL XDRSET(GAR2,NG*NG*NL,0.0)
      DO 120 IG=1,NG
      KPEDIT=LCMGIL(JPEDIT,IG)
      CALL LCMGET(KPEDIT,'FLUX-INTG',GAR3)
      GAR1(IG,1)=FNORM*GAR3(IMIL)/VOLUME
      CALL LCMGET(KPEDIT,'NTOT0',GAR3)
      GAR1(IG,2)=GAR3(IMIL)
      CALL LCMGET(KPEDIT,'OVERV',GAR3)
      GAR1(IG,3)=GAR3(IMIL)
      IF(NLEAK.EQ.1) THEN
         CALL LCMGET(KPEDIT,'DIFF',GAR3)
         GAR1(IG,4)=1.0/(3.0*GAR3(IMIL))
      ELSE IF(NLEAK.EQ.2) THEN
         CALL LCMGET(KPEDIT,'DIFFX',GAR3)
         GAR1(IG,4)=1.0/(3.0*GAR3(IMIL))
         CALL LCMGET(KPEDIT,'DIFFY',GAR3)
         GAR1(IG,5)=1.0/(3.0*GAR3(IMIL))
         CALL LCMGET(KPEDIT,'DIFFZ',GAR3)
         GAR1(IG,6)=1.0/(3.0*GAR3(IMIL))
      ENDIF
      IF(NWP1.EQ.1) THEN
         CALL LCMLEN(KPEDIT,'FLUX-INTG-P1',LENGTH,ITYLCM)
         IF(LENGTH.GT.0) THEN
           CALL LCMGET(KPEDIT,'FLUX-INTG-P1',GAR3)
           GAR1(IG,7)=GAR3(IMIL)/VOLUME
         ENDIF
         CALL LCMGET(KPEDIT,'NTOT1',GAR3)
         GAR1(IG,8)=GAR3(IMIL)
      ENDIF
      IF(NF.EQ.1) THEN
         CALL LCMGET(KPEDIT,'NUSIGF',GAR3)
         GAR1(IG,9)=GAR3(IMIL)
         CALL LCMGET(KPEDIT,'CHI',GAR3)
         GAR1(IG,10)=GAR3(IMIL)
      ENDIF
      CALL LCMLEN(KPEDIT,'H-FACTOR',LENGTH,ITYLCM)
      IF(LENGTH.EQ.NMIL) THEN
         LHF=.TRUE.
         CALL LCMGET(KPEDIT,'H-FACTOR',GAR3)
         GAR1(IG,11)=GAR3(IMIL)
      ELSE
         GAR1(IG,11)=0.0
      ENDIF
      DO 90 IDEL=1,NDEL
      IF(NF.EQ.1) THEN
         WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL
         CALL LCMGET(KPEDIT,TEXT12,GAR3)
         GAR1(IG,11+2*(IDEL-1)+1)=GAR3(IMIL)
         WRITE(TEXT12,'(3HCHI,I2.2)') IDEL
         CALL LCMGET(KPEDIT,TEXT12,GAR3)
         GAR1(IG,11+2*(IDEL-1)+2)=GAR3(IMIL)
      ENDIF
   90 CONTINUE
      DO 100 IED=1,NED
      WRITE(TEXT8,'(2A4)') HVECT(1,IED),HVECT(2,IED)
      CALL LCMGET(KPEDIT,TEXT8,GAR3)
      GAR1(IG,11+2*NDEL+IED)=GAR3(IMIL)
  100 CONTINUE
      DO 120 IL=1,NL
      WRITE(CM,'(I2.2)') IL-1
      LENGTH=1
      IF(IL.GT.1) CALL LCMLEN(KPEDIT,'SCAT'//CM,LENGTH,ITYLCM)
      IF(LENGTH.GT.0) THEN
         CALL LCMGET(KPEDIT,'SIGS'//CM,GAR3)
         GAR1(IG,11+2*NDEL+NED+IL)=GAR3(IMIL)
         CALL LCMGET(KPEDIT,'SCAT'//CM,GAR3)
         CALL LCMGET(KPEDIT,'NJJS'//CM,NJJ)
         CALL LCMGET(KPEDIT,'IJJS'//CM,IJJ)
         CALL LCMGET(KPEDIT,'IPOS'//CM,IPOS)
         IPOSDE=IPOS(IMIL)
         DO 110 JG=IJJ(IMIL),IJJ(IMIL)-NJJ(IMIL)+1,-1
         GAR2(IG,JG,IL)=GAR3(IPOSDE)
  110    IPOSDE=IPOSDE+1
      ENDIF
      IF(NSPH.EQ.1) THEN
        CALL LCMGET(KPEDIT,'NSPH',GAR3)
        GAR1(IG,11+2*NDEL+NED+NL+1)=GAR3(IMIL)
      ENDIF
  120 CONTINUE
      CALL LCMPUT(IPCPO,'NWT0',NG,2,GAR1(1,1))
      CALL LCMPUT(IPCPO,'NTOT0',NG,2,GAR1(1,2))
      CALL LCMPUT(IPCPO,'OVERV',NG,2,GAR1(1,3))
      IF(NLEAK.EQ.1) THEN
         CALL LCMPUT(IPCPO,'STRD',NG,2,GAR1(1,4))
      ELSE IF(NLEAK.EQ.2) THEN
         CALL LCMPUT(IPCPO,'STRD-X',NG,2,GAR1(1,4))
         CALL LCMPUT(IPCPO,'STRD-Y',NG,2,GAR1(1,5))
         CALL LCMPUT(IPCPO,'STRD-Z',NG,2,GAR1(1,6))
      ENDIF
      IF(NWP1.EQ.1) THEN
         CALL LCMPUT(IPCPO,'NWT1',NG,2,GAR1(1,7))
         CALL LCMPUT(IPCPO,'NTOT1',NG,2,GAR1(1,8))
      ENDIF
      IF(NF.EQ.1) THEN
         CALL LCMPUT(IPCPO,'NUSIGF',NG,2,GAR1(1,9))
         CALL LCMPUT(IPCPO,'CHI',NG,2,GAR1(1,10))
      ENDIF
      IF(LHF) CALL LCMPUT(IPCPO,'H-FACTOR',NG,2,GAR1(1,11))
      DO 130 IDEL=1,NDEL
      IF(NF.EQ.1) THEN
         WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL
         CALL LCMPUT(IPCPO,TEXT12,NG,2,GAR1(1,11+2*(IDEL-1)+1))
         WRITE(TEXT12,'(3HCHI,I2.2)') IDEL
         CALL LCMPUT(IPCPO,TEXT12,NG,2,GAR1(1,11+2*(IDEL-1)+1))
      ENDIF
  130 CONTINUE
      DO 140 IED=1,NED
      WRITE(TEXT8,'(2A4)') HVECT(1,IED),HVECT(2,IED)
      CALL LCMPUT(IPCPO,TEXT8,NG,2,GAR1(1,11+2*NDEL+IED))
  140 CONTINUE
      IF(NSPH.EQ.1) THEN
         CALL LCMPUT(IPCPO,'NSPH',NG,2,GAR1(1,11+2*NDEL+NED+NL+1))
      ENDIF
      CALL XDRLGS(IPCPO,1,IMPX,0,NL-1,1,NG,GAR1(1,12+2*NDEL+NED),GAR2,
     1 ITYPR)
      CALL LCMSIX(IPCPO,' ',2)
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(GAR3,GAR2,GAR1)
      DEALLOCATE(ITYPR,IPOS,NJJ,IJJ)
      RETURN
      END
