*DECK NCRISO
      SUBROUTINE NCRISO(IPLIB,LPCPO,HNAME,IBM,NCAL,NGRP,NL,NED,HVECT,
     1 NDEL,NDFI,IMPX,FACT,TERP)
*
*-----------------------------------------------------------------------
*
*Purpose:
* recover nuclear data from a single isotopic directory.
*
*Copyright:
* Copyright (C) 2006 Ecole Polytechnique de Montreal
*
*Author(s): A. Hebert
*
*Parameters: input
* IPLIB   address of the microlib LCM object.
* LPCPO   address of the 'CALCULATIONS' tree in the multidimensional
*         compo object.
* HNAME   character*12 name of the compo isotope been processed.
* IBM     mixture index.
* NCAL    number of elementary calculations in the compo object.
* NGRP    number of energy groups.
* NL      number of Legendre orders.
* NED     number of extra vector edits.
* HVECT   character names of the extra vector edits.
* NDEL    number of delayed precursor groups.
* NDFI    number of fissile isotopes.
* IMPX    print parameter (equal to zero for no print).
* FACT    number density factors.
* TERP    interpolation weights.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPLIB,LPCPO
      INTEGER IBM,NCAL,NGRP,NL,NED,NDEL,NDFI,IMPX
      REAL FACT(NCAL),TERP(NCAL)
      CHARACTER HNAME*12,HVECT(NED)*(*)
*----
*  LOCAL VARIABLES
*----
      PARAMETER(IOUT=6)
      LOGICAL LAWR,LMEVF,LMEVG,LDECA,LWD,LYIELD,LPIFI
      CHARACTER CM*2,HMAKE(100)*12,TEXT12*12
      TYPE(C_PTR) MPCPO
      INTEGER, ALLOCATABLE, DIMENSION(:) :: JPIF1,ITYPR
      REAL, ALLOCATABLE, DIMENSION(:) :: YIEL1,PYIE1,WDLA
      REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR1,GAR2
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: WSCA1,WSCA2
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(JPIF1(NDFI),ITYPR(NL))
      ALLOCATE(GAR1(NGRP,10+NL+NED+2*NDEL),YIEL1(NGRP+1),
     1 PYIE1(NDFI),WSCA1(NGRP,NGRP,NL),GAR2(NGRP,10+NL+NED+2*NDEL),
     2 WSCA2(NGRP,NGRP,NL),WDLA(NDEL))
*----
*  RECOVER GENERIC ISOTOPIC DATA FROM THE COMPO
*----
      LAWR=.FALSE.
      LMEVF=.FALSE.
      LMEVG=.FALSE.
      LDECA=.FALSE.
      LYIELD=.FALSE.
      LPIFI=.FALSE.
      LWD=.FALSE.
      DO 10 ICAL=NCAL,1,-1
      MPCPO=LCMGIL(LPCPO,ICAL)
      CALL LCMLEN(MPCPO,HNAME,ILENG,ITYLCM)
      IF(ILENG.EQ.0) GO TO 10
      CALL LCMSIX(MPCPO,HNAME,1)
      CALL LCMLEN(MPCPO,'AWR',LENGTH,ITYLCM)
      IF(LENGTH.EQ.1) CALL LCMGET(MPCPO,'AWR',AWR)
      LAWR=(LENGTH.EQ.1)
      CALL LCMLEN(MPCPO,'MEVF',LENGTH,ITYLCM)
      IF(LENGTH.EQ.1) CALL LCMGET(MPCPO,'MEVF',EMEVF)
      LMEVF=(LENGTH.EQ.1)
      CALL LCMLEN(MPCPO,'MEVG',LENGTH,ITYLCM)
      IF(LENGTH.EQ.1) CALL LCMGET(MPCPO,'MEVG',EMEVG)
      LMEVG=(LENGTH.EQ.1)
      CALL LCMLEN(MPCPO,'DECAY',LENGTH,ITYLCM)
      IF(LENGTH.EQ.1) CALL LCMGET(MPCPO,'DECAY',DECAY)
      LDECA=(LENGTH.EQ.1)
      CALL LCMLEN(MPCPO,'YIELD',LENGTH,ITYLCM)
      LYIELD=(LENGTH.EQ.NGRP+1)
      IF(LYIELD) CALL LCMGET(MPCPO,'YIELD',YIEL1)
      CALL LCMLEN(MPCPO,'PYIELD',LENGTH,ITYLCM)
      LPIFI=(LENGTH.GT.0).AND.(LENGTH.EQ.NDFI)
      IF(LPIFI) THEN
         CALL LCMGET(MPCPO,'PIFI',JPIF1)
         CALL LCMGET(MPCPO,'PYIELD',PYIE1)
      ENDIF
      CALL LCMLEN(MPCPO,'LAMBDA-D',LENGTH,ITYLCM)
      LWD=(LENGTH.EQ.NDEL).AND.(NDEL.GT.0)
      IF(LWD) CALL LCMGET(MPCPO,'LAMBDA-D',WDLA)
      CALL LCMSIX(MPCPO,' ',2)
      GO TO 15
   10 CONTINUE
      WRITE(6,120) IBM,HNAME
      CALL XABORT('NCRISO: UNABLE TO FIND AN ISOTOPE DIRECTORY.')
*----
*  LOOP OVER ELEMENTARY CALCULATIONS
*----
   15 MAXH=10+NL+NED+2*NDEL
      IF(MAXH+NL.GT.100) CALL XABORT('NCRISO: STATIC STORAGE EXCEEDED')
      DO 20 J=1,MAXH+NL
   20 HMAKE(J)=' '
      CALL XDRSET(GAR2,NGRP*(10+NL+NED+2*NDEL),0.0)
      CALL XDRSET(WSCA2,NGRP*NGRP*NL,0.0)
      DO 100 ICAL=1,NCAL
      WEIGHT=TERP(ICAL)
      IF(WEIGHT.EQ.0.0) GO TO 100
      FACT0=FACT(ICAL)
      MPCPO=LCMGIL(LPCPO,ICAL)
      IF(IMPX.GT.4) THEN
         WRITE(IOUT,'(34H NCRISO: COMPO ACCESS FOR ISOTOPE ,A,6H AND C,
     1   10HALCULATION,I5,1H.)') HNAME,ICAL
         IF(IMPX.GT.50) CALL LCMLIB(MPCPO)
      ENDIF
      CALL LCMLEN(MPCPO,HNAME,ILENG,ITYLCM)
      IF(ILENG.EQ.0) GO TO 100
      CALL LCMSIX(MPCPO,HNAME,1)
*----
*  RECOVER CALCULATION-SPECIFIC ISOTOPIC DATA FROM THE COMPO
*----
      CALL LCMLEN(MPCPO,'NWT0',LENGTH,ITYLCM)
      IF(LENGTH.EQ.NGRP) THEN
         CALL LCMGET(MPCPO,'NWT0',GAR1(1,1))
         HMAKE(1)='NWT0'
      ENDIF
      CALL LCMLEN(MPCPO,'NWT1',LENGTH,ITYLCM)
      IF(LENGTH.EQ.NGRP) THEN
         CALL LCMGET(MPCPO,'NWT1',GAR1(1,2))
         HMAKE(2)='NWT1'
      ENDIF
      CALL XDRLGS(MPCPO,-1,IMPX,0,NL-1,1,NGRP,GAR1(1,3),WSCA1,ITYPR)
      DO 30 IL=0,NL-1
      IF(ITYPR(IL+1).NE.0) THEN
         WRITE (CM,'(I2.2)') IL
         HMAKE(3+IL)='SIGS'//CM
      ENDIF
   30 CONTINUE
      CALL LCMGET(MPCPO,'NTOT0',GAR1(1,3+NL))
      HMAKE(3+NL)='NTOT0'
      CALL LCMLEN(MPCPO,'NTOT1',LENGTH,ITYLCM)
      IF(LENGTH.EQ.NGRP) THEN
         CALL LCMGET(MPCPO,'NTOT1',GAR1(1,4+NL))
         HMAKE(4+NL)='NTOT1'
      ENDIF
      CALL LCMLEN(MPCPO,'NUSIGF',LENGTH,ITYLCM)
      IF(LENGTH.EQ.NGRP) THEN
         CALL LCMGET(MPCPO,'NUSIGF',GAR1(1,5+NL))
         HMAKE(5+NL)='NUSIGF'
         CALL LCMGET(MPCPO,'CHI',GAR1(1,MAXH-NDEL-1))
         HMAKE(MAXH-NDEL-1)='CHI'
      ENDIF
      IF(NDEL.GT.0) THEN
         WRITE(TEXT12,'(6HNUSIGF,I2.2)') NDEL
         CALL LCMLEN(MPCPO,TEXT12,LENGTH,ITYLCM)
         IF(LENGTH.EQ.NGRP) THEN
            DO 40 IDEL=1,NDEL
            WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL
            CALL LCMGET(MPCPO,TEXT12,GAR1(1,MAXH-2*NDEL-2+IDEL))
   40       HMAKE(MAXH-2*NDEL-2+IDEL)=TEXT12
         ENDIF
         WRITE(TEXT12,'(3HCHI,I2.2)') NDEL
         CALL LCMLEN(MPCPO,TEXT12,LENGTH,ITYLCM)
         IF(LENGTH.EQ.NGRP) THEN
            DO 50 IDEL=1,NDEL
            WRITE(TEXT12,'(3HCHI,I2.2)') IDEL
            CALL LCMGET(MPCPO,TEXT12,GAR1(1,MAXH-NDEL-1+IDEL))
   50       HMAKE(MAXH-NDEL-1+IDEL)=TEXT12
         ENDIF
      ENDIF
      CALL LCMLEN(MPCPO,'H-FACTOR',LENGTH,ITYLCM)
      IF(LENGTH.EQ.NGRP) THEN
         CALL LCMGET(MPCPO,'H-FACTOR',GAR1(1,MAXH-2*NDEL-4))
         HMAKE(MAXH-2*NDEL-4)='H-FACTOR'
      ENDIF
      CALL LCMLEN(MPCPO,'OVERV',LENGTH,ITYLCM)
      IF(LENGTH.EQ.NGRP) THEN
         CALL LCMGET(MPCPO,'OVERV',GAR1(1,MAXH-2*NDEL-3))
         HMAKE(MAXH-2*NDEL-3)='OVERV'
      ENDIF
      CALL LCMLEN(MPCPO,'TRANC',LENGTH,ITYLCM)
      IF(LENGTH.EQ.NGRP) THEN
         CALL LCMGET(MPCPO,'TRANC',GAR1(1,MAXH-2*NDEL-2))
         HMAKE(MAXH-2*NDEL-2)='TRANC'
      ENDIF
      DO 60 IED=1,NED
      CALL LCMLEN(MPCPO,HVECT(IED),LENGTH,ITYLCM)
      IF((LENGTH.GT.0).AND.(HVECT(IED).NE.'TRANC')) THEN
         CALL LCMGET(MPCPO,HVECT(IED),GAR1(1,5+NL+IED))
         HMAKE(5+NL+IED)=HVECT(IED)
      ENDIF
   60 CONTINUE
      CALL LCMLEN(MPCPO,'STRD',LENGTH,ITYLCM)
      IF(LENGTH.EQ.NGRP) THEN
         CALL LCMGET(MPCPO,'STRD',GAR1(1,MAXH))
         HMAKE(MAXH)='STRD'
      ENDIF
*----
*  ADD CONTRIBUTIONS FROM A SINGLE ELEMENTARY CALCULATION
*----
      DO 80 J=1,MAXH
      IF((HMAKE(J).NE.' ').AND.(HMAKE(J)(:4).NE.'SIGS')) THEN
         DO 70 IG=1,NGRP
         IF((HMAKE(J)(:2).EQ.'NW').OR.(HMAKE(J)(:3).EQ.'CHI').OR.
     1   (HMAKE(J).EQ.'OVERV')) THEN
            GAR2(IG,J)=GAR2(IG,J)+WEIGHT*GAR1(IG,J)
         ELSE
            GAR2(IG,J)=GAR2(IG,J)+FACT0*WEIGHT*GAR1(IG,J)
         ENDIF
   70    CONTINUE
      ENDIF
   80 CONTINUE
      DO 90 IL=1,NL
      ITYPR(IL)=0
      IF(HMAKE(MAXH+IL+1).NE.' ') ITYPR(IL)=1
      DO 90 IG2=1,NGRP
      GAR2(IG2,2+IL)=GAR2(IG2,2+IL)+FACT0*WEIGHT*GAR1(IG2,2+IL)
      DO 90 IG1=1,NGRP
   90 WSCA2(IG1,IG2,IL)=WSCA2(IG1,IG2,IL)+FACT0*WEIGHT*WSCA1(IG1,IG2,IL)
      CALL LCMSIX(MPCPO,' ',2)
  100 CONTINUE
*----
*  SAVE ISOTOPIC DATA IN THE MICROLIB
*----
      IF(LAWR) CALL LCMPUT(IPLIB,'AWR',1,2,AWR)
      IF(LMEVF) CALL LCMPUT(IPLIB,'MEVF',1,2,EMEVF)
      IF(LMEVG) CALL LCMPUT(IPLIB,'MEVG',1,2,EMEVG)
      IF(LDECA) CALL LCMPUT(IPLIB,'DECAY',1,2,DECAY)
      IF(LYIELD) CALL LCMPUT(IPLIB,'YIELD',NGRP+1,2,YIEL1)
      IF(LPIFI) THEN
         CALL LCMPUT(IPLIB,'PYIELD',NDFI,2,PYIE1)
         CALL LCMPUT(IPLIB,'PIFI',NDFI,1,JPIF1)
      ENDIF
      IF(LWD) CALL LCMPUT(IPLIB,'LAMBDA-D',NDEL,2,WDLA)
      DO 110 J=1,MAXH
      IF((HMAKE(J).NE.' ').AND.(HMAKE(J)(:4).NE.'SIGS')) THEN
         CALL LCMPUT(IPLIB,HMAKE(J),NGRP,2,GAR2(1,J))
      ENDIF
  110 CONTINUE
      CALL XDRLGS(IPLIB,1,IMPX,0,NL-1,1,NGRP,GAR2(1,3),WSCA2,ITYPR)
      IF(IMPX.GT.50) CALL LCMLIB(IPLIB)
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(WDLA,WSCA2,GAR2,WSCA1,PYIE1,YIEL1,GAR1)
      DEALLOCATE(ITYPR,JPIF1)
      RETURN
*
  120 FORMAT(17H NCRISO: MIXTURE=,I5,10H ISOTOPE=',A12,2H'.)
      END
