*DECK COMMIC
      SUBROUTINE COMMIC(IMPX,IPCPO,IPEDIT,LMACRO,ICAL,MAXCAL,NMIL,
     1 NISOTS,NG,NED,FNORM,LISO)
*
*-----------------------------------------------------------------------
*
*Purpose:
* recover a microlib corresponding to a set of homogenized mixtures.
*
*Copyright:
* Copyright (C) 2002 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
* IMPX    print parameter.
* IPCPO   pointer to the multicompo.
* IPEDIT  pointer to the edition object (L_EDIT signature).
* LMACRO  flag set to .TRUE. to recover cross sections from the
*         macrolib.
* ICAL    index of the elementary calculation.
* MAXCAL  maximum number of elementary calculations in the multicompo.
* NMIL    number of homogenized mixtures.
* NISOTS  number of isotopes in the microlib pointed by IPEDIT.
* NG      number of energy groups.
* NED     number of additional edits.
* FNORM   flux normalization factor.
* LISO    =.true. if we want to register the region number of the
*         isotopes.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPCPO,IPEDIT
      INTEGER IMPX,ICAL,MAXCAL,NMIL,NISOTS,NG,NED
      REAL FNORM
      LOGICAL LMACRO,LISO
*----
*  LOCAL VARIABLES
*----
      PARAMETER (NSTATE=40)
      TYPE(C_PTR) JPCPO,KPCPO,LPCPO,MPCPO
      CHARACTER TEXT4*4,TEXT12*12
      INTEGER IPAR(NSTATE)
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IMIX1,ITYP1,ITOD1,ITYP2,
     1 ITOD2,IPIFI,ISW
      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: HUSE1,HNAM1,HUSE2,HNAM2,
     1 HVECT
      REAL, ALLOCATABLE, DIMENSION(:) :: DENS1,TEMP1,VOL1,DENS2,TEMP2,
     1 VOL2,WORK,ENER,DELT,VOLMIX
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(HUSE1(3,NISOTS),HNAM1(3,NISOTS),IMIX1(NISOTS),
     1 ITYP1(NISOTS),ITOD1(NISOTS),HUSE2(3,NISOTS),HNAM2(3,NISOTS),
     2 ITYP2(NISOTS),ITOD2(NISOTS),IPIFI(NISOTS),ISW(NISOTS),
     3 HVECT(2,NED+1))
      ALLOCATE(DENS1(NISOTS),TEMP1(NISOTS),VOL1(NISOTS),DENS2(NISOTS),
     1 TEMP2(NISOTS),VOL2(NISOTS),WORK(NG),ENER(NG+1),DELT(NG),
     2 VOLMIX(NMIL))
*----
*  RECOVER THE TOC RECORDS
*----
      IDF=0
      IF(.NOT.LMACRO) THEN
         CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR)
         CALL LCMGET(IPEDIT,'ISOTOPESUSED',HUSE1)
         CALL LCMGET(IPEDIT,'ISOTOPERNAME',HNAM1)
         CALL LCMGET(IPEDIT,'ISOTOPESDENS',DENS1)
         CALL LCMGET(IPEDIT,'ISOTOPESMIX',IMIX1)
         CALL LCMGET(IPEDIT,'ISOTOPESTYPE',ITYP1)
         CALL LCMGET(IPEDIT,'ISOTOPESTODO',ITOD1)
         CALL LCMGET(IPEDIT,'ISOTOPESVOL',VOL1)
         CALL LCMGET(IPEDIT,'ISOTOPESTEMP',TEMP1)
         CALL LCMGET(IPEDIT,'MIXTURESVOL',VOLMIX)
         CALL LCMGET(IPEDIT,'K-EFFECTIVE',EIGENK)
         CALL LCMLEN(IPEDIT,'B2  B1HOM',ILONG,ITYLCM)
         IF(ILONG.EQ.1) THEN
            CALL LCMGET(IPEDIT,'B2  B1HOM',B2)
         ELSE
            B2=0.0
         ENDIF
         IF(NED.GT.0) CALL LCMGET(IPEDIT,'ADDXSNAME-P0',HVECT)
         CALL LCMGET(IPEDIT,'ENERGY',ENER)
         CALL LCMGET(IPEDIT,'DELTAU',DELT)
         IDF=IPAR(24)
      ENDIF
*----
*  LOOP OVER HOMOGENIZED MIXTURES
*----
      TEXT4='    '
      NSPH=0
      READ(TEXT4,'(A4)') ITEXT
      JPCPO=LCMLID(IPCPO,'MIXTURES',NMIL)
      DO 130 IMIL=1,NMIL
      KPCPO=LCMDIL(JPCPO,IMIL)
      LPCPO=LCMLID(KPCPO,'CALCULATIONS',MAXCAL)
      MPCPO=LCMDIL(LPCPO,ICAL)
      IF(LMACRO) THEN
*        RECOVER CROSS SECTIONS FROM THE MACROLIB.
         CALL LCMSIX(IPEDIT,'MACROLIB',1)
         CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR)
         NL=IPAR(3)
         NDEL=IPAR(7)
         IDF=IPAR(12)
         NSPH=IPAR(14)
         CALL COMACR(IPEDIT,IMPX,MPCPO,NG,NMIL,NED,NL,NDEL,IMIL,FNORM,
     1   NSPH,EIGENK,B2,VOLUME,ENER,DELT,HVECT,NF)
         CALL LCMSIX(IPEDIT,' ',2)
         ISO2=1
         DENS2(ISO2)=1.0
         ITYP2(ISO2)=1
         IF(NF.GT.0) ITYP2(ISO2)=2
         ITOD2(ISO2)=1
         VOL2(ISO2)=VOLUME
         VOLMIX(IMIL)=VOLUME
         TEMP2(ISO2)=0.0
         TEXT12='*MAC*RES'
         READ(TEXT12,'(3A4)') (HUSE2(I0,ISO2),I0=1,3)
         TEXT12='    *MAC*RES'
         READ(TEXT12,'(3A4)') (HNAM2(I0,ISO2),I0=1,3)
         CALL XDISET(IPAR,NSTATE,0)
         IPAR(3)=NG
         IPAR(4)=NL
         IPAR(13)=NED+NSPH
         IPAR(24)=IDF
      ELSE
*        RECOVER CROSS SECTIONS FROM THE MICROLIB.
         ISO2=0
         CALL XDISET(ISW,NISOTS,0)
         DO 100 ISO1=1,NISOTS
         IF(IMIX1(ISO1).EQ.IMIL) THEN
            ISO2=ISO2+1
            ISW(ISO1)=ISO2
            DO 10 I0=1,2
   10       HUSE2(I0,ISO2)=HUSE1(I0,ISO1)
            HUSE2(3,ISO2)=ITEXT
            IF(LISO) HUSE2(3,ISO2)=HUSE1(3,ISO1)
            DO 15 I0=1,3
   15       HNAM2(I0,ISO2)=HNAM1(I0,ISO1)
            DENS2(ISO2)=DENS1(ISO1)
            ITYP2(ISO2)=ITYP1(ISO1)
            ITOD2(ISO2)=ITOD1(ISO1)
            VOL2(ISO2)=VOL1(ISO1)
            TEMP2(ISO2)=TEMP1(ISO1)
            WRITE(TEXT12,'(3A4)') (HUSE1(I0,ISO1),I0=1,3)
            CALL LCMSIX(IPEDIT,TEXT12,1)
            WRITE(TEXT12,'(3A4)') (HUSE2(I0,ISO2),I0=1,3)
            CALL LCMSIX(MPCPO,TEXT12,1)
            CALL LCMEQU(IPEDIT,MPCPO)
*
*           FLUX NORMALIZATION:
            CALL LCMGET(MPCPO,'NWT0',WORK)
            DO 20 IG=1,NG
   20       WORK(IG)=WORK(IG)*FNORM
            CALL LCMPUT(MPCPO,'NWT0',NG,2,WORK)
            CALL LCMLEN(MPCPO,'NWT1',ILONG,ITYLCM)
            IF(ILONG.GT.0) THEN
               CALL LCMGET(MPCPO,'NWT1',WORK)
               DO 30 IG=1,NG
   30          WORK(IG)=WORK(IG)*FNORM
               CALL LCMPUT(MPCPO,'NWT1',NG,2,WORK)
            ENDIF
            CALL LCMSIX(MPCPO,' ',2)
            CALL LCMSIX(IPEDIT,' ',2)
         ENDIF
  100    CONTINUE
      ENDIF
*----
*  COPY DISCONTINUITY FACTOR INFORMATION
*----
      IF(IDF.NE.0) THEN
         CALL LCMSIX(IPEDIT,'MACROLIB',1)
         CALL LCMLEN(IPEDIT,'ADF',ILONG,ITYLCM)
         IF(ILONG.EQ.0) CALL XABORT('COMMIC: MISSING ADF DIRECTORY IN '
     1   //'EDITION OBJECT.')
         CALL LCMSIX(IPEDIT,'ADF',1)
            CALL LCMSIX(MPCPO,'MACROLIB',1)
            CALL LCMSIX(MPCPO,'ADF',1)
            CALL LCMEQU(IPEDIT,MPCPO)
            CALL LCMSIX(MPCPO,' ',2)
            CALL LCMSIX(MPCPO,' ',2)
         CALL LCMSIX(IPEDIT,' ',2)
         CALL LCMSIX(IPEDIT,' ',2)
      ENDIF
*----
*  RESET THE FISSILE ISOTOPES INDICES IN PIFI
*----
      DO 120 ISO=1,ISO2
      IF(ITYP2(ISO).EQ.3) THEN
         WRITE(TEXT12,'(3A4)') (HUSE2(I0,ISO),I0=1,3)
         CALL LCMSIX(MPCPO,TEXT12,1)
         CALL LCMLEN(MPCPO,'PIFI',ILONG,ITYLCM)
         IF(ILONG.GT.NISOTS) CALL XABORT('COMMIC: PIFI FAILURE.')
         IF(ILONG.GT.0) THEN
            CALL LCMGET(MPCPO,'PIFI',IPIFI)
            DO 110 I=1,ILONG
            IF(IPIFI(I).EQ.0) GO TO 110
            IF(IPIFI(I).GT.NISOTS) CALL XABORT('COMMIC: ISW OVERFLOW.')
            IF(ISW(IPIFI(I)).EQ.0) CALL XABORT('COMMIC: ISW FAILURE.')
            IPIFI(I)=ISW(IPIFI(I))
  110       CONTINUE
            CALL LCMPUT(MPCPO,'PIFI',ILONG,1,IPIFI)
         ENDIF
         CALL LCMSIX(MPCPO,' ',2)
      ENDIF
  120 CONTINUE
*
      IPAR(1)=1
      IPAR(2)=ISO2
      IPAR(11)=0
      IPAR(14)=1
      TEXT12='L_LIBRARY'
      CALL LCMPTC(MPCPO,'SIGNATURE',12,1,TEXT12)
      CALL LCMPUT(MPCPO,'STATE-VECTOR',NSTATE,1,IPAR)
      CALL XDISET(ISW,ISO2,1)
      CALL LCMPUT(MPCPO,'ISOTOPESMIX',ISO2,1,ISW)
      CALL LCMPUT(MPCPO,'ISOTOPESUSED',3*ISO2,3,HUSE2)
      CALL LCMPUT(MPCPO,'ISOTOPERNAME',3*ISO2,3,HNAM2)
      CALL LCMPUT(MPCPO,'ISOTOPESDENS',ISO2,2,DENS2)
      CALL LCMPUT(MPCPO,'ISOTOPESTYPE',ISO2,1,ITYP2)
      CALL LCMPUT(MPCPO,'ISOTOPESTODO',ISO2,1,ITOD2)
      CALL LCMPUT(MPCPO,'ISOTOPESVOL',ISO2,2,VOL2)
      CALL LCMPUT(MPCPO,'ISOTOPESTEMP',ISO2,2,TEMP2)
      CALL LCMPUT(MPCPO,'MIXTURESVOL',1,2,VOLMIX(IMIL))
      CALL LCMPUT(MPCPO,'K-EFFECTIVE',1,2,EIGENK)
      IF(B2.NE.0.0) CALL LCMPUT(MPCPO,'B2  B1HOM',1,2,B2)
      IF((NED+NSPH).GT.0) CALL LCMPUT(MPCPO,'ADDXSNAME-P0',2*(NED+NSPH),
     1  3,HVECT)
      CALL LCMPUT(MPCPO,'ENERGY',NG+1,2,ENER)
      CALL LCMPUT(MPCPO,'DELTAU',NG,2,DELT)
      IF(IMPX.GT.2) WRITE(6,140) IMIL,ISO2
  130 CONTINUE
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(VOLMIX,DELT,ENER,WORK,VOL2,TEMP2,DENS2,VOL1,TEMP1,
     1 DENS1)
      DEALLOCATE(HVECT,ISW,IPIFI,ITOD2,ITYP2,HNAM2,HUSE2,ITOD1,ITYP1,
     1 IMIX1,HNAM1,HUSE1)
      RETURN
*
  140 FORMAT(39H COMMIC: PROCESSING HOMOGENIZED MIXTURE,I4,9H CONTAINI,
     1 2HNG,I5,10H ISOTOPES.)
      END
