*DECK LIBADJ
      SUBROUTINE LIBADJ (IPLIB,NGRO,NBISO,NL,NDEL,NBESP,IPISO,NED,
     1 NAMEAD)
*
*-----------------------------------------------------------------------
*
*Purpose:
* transposition of the usefull interpolated microscopic cross section
* for producing an adjoint problem
*
*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
* IPLIB   pointer to the lattice microscopic cross section library
*         (L_LIBRARY signature)
* NGRO    number of energy groups
* NBISO   number of isotopes present in the calculation domain
* NL      number of Legendre orders required in the calculation
*         NL=1 or higher
* NDEL    number of delayed precursor groups
* NBESP   number of energy-dependent fission spectra
* IPISO   pointer array towards microlib isotopes.
* NED     number of extra vector edits from matxs
* NAMEAD  matxs names of the extra vector edits
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPLIB,IPISO(NBISO)
      INTEGER NGRO,NBISO,NL,NDEL,NBESP,NED,NAMEAD(2,NED)
*----
*  LOCAL VARIABLES
*----
      TYPE(C_PTR) JPLIB
      CHARACTER TEXT8*8,HNUSIG*12,HCHI*12
      INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO
      REAL, ALLOCATABLE, DIMENSION(:,:) :: GA1,GA2,SIGS
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(ITYPRO(NL),GA1(NGRO,2),GA2(NGRO,NGRO),SIGS(NGRO,NL),
     1 SCAT(NGRO,NGRO,NL))
*----
*  ***MATERIAL/ISOTOPE LOOP***
*----
      IF(NBESP.NE.0) CALL XABORT('LIBADJ: MULTIPLE FISSION SPECTRA NOT'
     1 //' IMPLEMENTED.')
      IMPX=0
      DO 200 IMT=1,NBISO
      JPLIB=IPISO(IMT)
      IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 200
      CALL XDRLGS(JPLIB,-1,IMPX,0,NL-1,1,NGRO,SIGS,SCAT,ITYPRO)
      INGRO=NL-1
      DO 10 IL=NL-1,0,-1
      IF(ITYPRO(IL+1).EQ.0) THEN
         INGRO=INGRO-1
      ELSE
         GO TO 20
      ENDIF
   10 CONTINUE
   20 DO 50 IL=0,INGRO
      IF(ITYPRO(IL+1).GT.0) THEN
         DO 30 I=1,NGRO
         GA1(I,1)=SIGS(NGRO-I+1,IL+1)
         DO 30 J=1,NGRO
   30    GA2(I,J)=SCAT(NGRO-J+1,NGRO-I+1,IL+1)
         DO 40 I=1,NGRO
         SIGS(I,IL+1)=GA1(I,1)
         DO 40 J=1,NGRO
   40    SCAT(NGRO-J+1,NGRO-I+1,IL+1)=GA2(J,I)
      ENDIF
   50 CONTINUE
      CALL XDRLGS(JPLIB,1,IMPX,0,INGRO,1,NGRO,SIGS,SCAT,ITYPRO)
*
      CALL LCMLEN(JPLIB,'TRANC',LENGT,ITYLCM)
      IF (LENGT.GT.0) THEN
         CALL LCMGET(JPLIB,'TRANC',GA1(1,1))
         DO 130 I=1,NGRO
  130    GA1(I,2)=GA1(NGRO-I+1,1)
         CALL LCMPUT(JPLIB,'TRANC',NGRO,2,GA1(1,2))
      ENDIF
*
      CALL LCMGET(JPLIB,'NTOT0',GA1(1,1))
      DO 140 I=1,NGRO
  140 GA1(I,2)=GA1(NGRO-I+1,1)
      CALL LCMPUT(JPLIB,'NTOT0',NGRO,2,GA1(1,2))
*
      DO 175 IDEL=0,NDEL
      IF(IDEL.EQ.0) THEN
         HNUSIG='NUSIGF'
         HCHI='CHI'
      ELSE
         WRITE(HNUSIG,'(6HNUSIGF,I2.2)') IDEL
         WRITE(HCHI,'(3HCHI,I2.2)') IDEL
      ENDIF
      CALL LCMLEN(JPLIB,HNUSIG,LENGT,ITYLCM)
      IF (LENGT.GT.0) THEN
         CALL LCMGET(JPLIB,HNUSIG,GA1(1,1))
         SUM=0.0
         DO 150 I=1,NGRO
  150    SUM=SUM+GA1(I,1)
         DO 160 I=1,NGRO
  160    GA1(I,2)=GA1(NGRO-I+1,1)/SUM
         CALL LCMGET(JPLIB,HCHI,GA1(1,1))
         CALL LCMPUT(JPLIB,HCHI,NGRO,2,GA1(1,2))
         DO 170 I=1,NGRO
  170    GA1(I,2)=GA1(NGRO-I+1,1)*SUM
         CALL LCMPUT(JPLIB,HNUSIG,NGRO,2,GA1(1,2))
      ENDIF
  175 CONTINUE
*
      DO 190 IED=1,NED
      WRITE(TEXT8,'(2A4)') (NAMEAD(I0,IED),I0=1,2)
      IF((TEXT8.EQ.'TRANC').OR.(TEXT8.EQ.'NTOT0').OR.
     1 (TEXT8(:6).EQ.'NUSIGF').OR.(TEXT8(:3).EQ.'CHI'))
     2 GO TO 190
      CALL LCMLEN(JPLIB,TEXT8,LENGT,ITYLCM)
      IF (LENGT.GT.0) THEN
         CALL LCMGET(JPLIB,TEXT8,GA1(1,1))
         DO 180 I=1,NGRO
  180    GA1(I,2)=GA1(NGRO-I+1,1)
         CALL LCMPUT(JPLIB,TEXT8,NGRO,2,GA1(1,2))
      ENDIF
  190 CONTINUE
  200 CONTINUE
*
      CALL LCMGET(IPLIB,'DELTAU',GA1(1,1))
      DO 210 I=1,NGRO
  210 GA1(I,2)=GA1(NGRO-I+1,1)
      CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,GA1(1,2))
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(SCAT,SIGS,GA2,GA1,ITYPRO)
      RETURN
      END
