*DECK USSIN1
      SUBROUTINE USSIN1(IPLI0,IPLIB,NGRP,NBMIX,NBISO,NIRES,NBNRS,NL,
     1 NED,NDEL,IREX,IMPX,ISONAM,ISOBIS,MIX,IAPT,MASKI,SPH,PHGAR,
     2 STGAR,SFGAR,SSGAR,S0GAR,SAGAR,SDGAR)
*
*-----------------------------------------------------------------------
*
*Purpose:
* write the self-shielded and SPH-corrected cross sections on the
* internal library.
*
*Copyright:
* Copyright (C) 2003 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
* IPLI0   pointer to the internal microscopic cross section library
*         builded by the self-shielding module (L_LIBRARY signature).
* IPLIB   pointer to the internal microscopic cross section library
*         with subgroups (L_LIBRARY signature).
* NGRP    number of energy groups.
* NBMIX   number of mixtures in the internal library.
* NBISO   number of isotopes.
* NIRES   number of resonant isotopes in fuel regions.
* NBNRS   number of totally correlated fuel regions.
* NL      number of Legendre orders required in the calculation
*         (NL=1 or higher).
* NED     number of extra vector edits.
* NDEL    number of delayed neutron precursor groups.
* IREX    fuel region index assigned to each mixture (equal to zero
*         in non-resonant mixtures or in mixtures not used).
* IMPX    print flag. equal to zero for no print.
* ISONAM  alias name of isotopes in IPLIB.
* ISOBIS  alias name of isotopes in IPLI0.
* MIX     mix number of each isotope (can be zero).
* IAPT    resonant isotope index associated with isotope I. Mixed
*         moderator if IAPT(I)=NIRES+1. Out-of-fuel isotope if
*         IAPT(I)=0.
* MASKI   isotopic flag (MASKI(ISO)=.true. to process isotope ISO).
* SPH     SPH factors.
* PHGAR   averaged fluxes.
* STGAR   microscopic self-shielded total x-s.
* SFGAR   microscopic self-shielded fission x-s.
* SSGAR   microscopic self-shielded scattering x-s.
* S0GAR   microscopic transfer scattering xs (isotope,secondary,
*         primary).
* SAGAR   microscopic self-shielded additional xs.
* SDGAR   microscopic self-shielded delayed nu-sigf xs.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPLI0,IPLIB
      INTEGER NGRP,NBMIX,NBISO,NIRES,NBNRS,NL,NED,NDEL,IREX(NBMIX),
     1 IMPX,ISONAM(3,NBISO),ISOBIS(3,NBISO),MIX(NBISO),IAPT(NBISO)
      REAL SPH(NBNRS,NIRES,NGRP),PHGAR(NBNRS,NIRES,NGRP),
     1 STGAR(NBNRS,NIRES,NGRP),SFGAR(NBNRS,NIRES,NGRP),
     2 SSGAR(NBNRS,NIRES,NL,NGRP),S0GAR(NBNRS,NIRES,NL,NGRP,NGRP),
     3 SAGAR(NBNRS,NIRES,NED,NGRP),SDGAR(NBNRS,NIRES,NDEL,NGRP)
      LOGICAL MASKI(NBISO)
*----
*  LOCAL VARIABLES
*----
      PARAMETER(MAXED=50,MAXSAV=100)
      INTEGER IPAR(40),KCHAR(3),ISAV(MAXSAV)
      CHARACTER TEXT12*12,HNAMIS*12,HSIGN*12,CM*2,HVECT(MAXED)*6
      LOGICAL LOGNF,LTEST
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: ISONR,ITITLE
      REAL, ALLOCATABLE, DIMENSION(:) :: GAR1,ENERGY,LAMB
      REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR2
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(GAR1(NGRP),GAR2(NGRP,NGRP),ENERGY(NGRP+1))
*
      CALL LCMGET(IPLIB,'SIGNATURE',KCHAR)
      WRITE(HSIGN,'(3A4)') (KCHAR(I1),I1=1,3)
      IF(HSIGN.NE.'L_LIBRARY') THEN
         CALL XABORT('USSIN1: SIGNATURE IS '//HSIGN//'. L_LIBRARY EXPEC'
     1   //'TED.')
      ENDIF
      CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR)
      IF(NGRP.NE.IPAR(3)) CALL XABORT('USSIN1: INVALID NB OF GROUPS.')
      IF(NL.NE.IPAR(4)) CALL XABORT('USSIN1: INVALID VALUE OF NL.')
      IF(NED.NE.IPAR(13)) CALL XABORT('USSIN1: INVALID VALUE OF NED.')
      IF(NED.GT.0) THEN
         IF(NED.GT.MAXED) CALL XABORT('USSIN1: INVALID VALUE OF MAXED.')
         CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED,HVECT)
      ENDIF
      CALL LCMLEN(IPLIB,'ENERGY',LENGT,ITYLCM)
      IF(LENGT-1.NE.NGRP) CALL XABORT('LIBIN2: INVALID GROUP STRUCTU'
     1 //'RE.')
      CALL LCMGET(IPLIB,'ENERGY',ENERGY)
      CALL LCMPUT(IPLI0,'ENERGY',NGRP+1,2,ENERGY)
      CALL LCMGET(IPLIB,'DELTAU',ENERGY)
      CALL LCMPUT(IPLI0,'DELTAU',NGRP,2,ENERGY)
      ALLOCATE(ISONR(3*NBISO))
      CALL LCMGET(IPLIB,'ISOTOPERNAME',ISONR)
      CALL LCMPUT(IPLI0,'ISOTOPERNAME',3*NBISO,3,ISONR)
      DEALLOCATE(ISONR)
      DO 370 ISOT=1,NBISO
      IRES=IAPT(ISOT)
      IF(MASKI(ISOT).AND.(IRES.GT.0).AND.(IRES.LE.NIRES)) THEN
         WRITE(HNAMIS,'(3A4)') (ISONAM(J,ISOT),J=1,3)
         CALL LCMLEN(IPLIB,HNAMIS,LENGT,ITYLCM)
         IF(LENGT.EQ.0) CALL XABORT('USSIN1: UNABLE TO FIND ISOTOPE '''
     1   //HNAMIS//'''.')
         CALL LCMSIX(IPLIB,HNAMIS,1)
         WRITE(TEXT12,'(3A4)') (ISOBIS(J,ISOT),J=1,3)
         IF(IMPX.GT.0) WRITE (6,'(/29H USSIN1: PROCESSING ISOTOPE '',
     1   A12,2H''.)') TEXT12
         CALL LCMSIX(IPLI0,TEXT12,1)
         CALL LCMGET(IPLIB,'AWR',AWR)
         CALL LCMPUT(IPLI0,'AWR',1,2,AWR)
         CALL LCMLEN(IPLIB,'README',LENTIT,ITYLCM)
         IF(LENTIT.GT.0) THEN
            ALLOCATE(ITITLE(LENTIT))
            CALL LCMGET(IPLIB,'README',ITITLE)
            CALL LCMPUT(IPLI0,'README',LENTIT,3,ITITLE)
            DEALLOCATE(ITITLE)
         ENDIF
         CALL LCMLEN(IPLIB,'NUSIGF',NFIS,ITYLCM)
         LOGNF=(NFIS.GT.0)
         IF(LOGNF) THEN
            CALL LCMGET(IPLIB,'CHI',GAR1)
            CALL LCMPUT(IPLI0,'CHI',NGRP,2,GAR1)
         ENDIF
         IND=IREX(MIX(ISOT))
         IF(IND.EQ.0) CALL XABORT('USSIN1: IREX FAILURE.')
         DO 20 IG1=1,NGRP
   20    GAR1(IG1)=PHGAR(IND,IRES,IG1)
         CALL LCMPUT(IPLI0,'NWT0',NGRP,2,GAR1)
         DO 30 IG1=1,NGRP
   30    GAR1(IG1)=SPH(IND,IRES,IG1)
         CALL LCMPUT(IPLI0,'SPH00',NGRP,2,GAR1)
         DO 40 IG1=1,NGRP
   40    GAR1(IG1)=STGAR(IND,IRES,IG1)
         CALL LCMPUT(IPLI0,'NTOT0',NGRP,2,GAR1)
         IF(LOGNF) THEN
            DO 50 IG1=1,NGRP
   50       GAR1(IG1)=SFGAR(IND,IRES,IG1)
            CALL LCMPUT(IPLI0,'NUSIGF',NGRP,2,GAR1)
         ENDIF
         DO 90 IL=1,NL
         WRITE(CM,'(I2.2)') IL-1
         DO 60 IG1=1,NGRP
         GAR1(IG1)=SSGAR(IND,IRES,IL,IG1)
         DO 60 IG2=1,NGRP
   60    GAR2(IG2,IG1)=S0GAR(IND,IRES,IL,IG2,IG1)
         CALL XDRLGS(IPLI0,1,IMPX,IL-1,IL-1,1,NGRP,GAR1,GAR2,ITYPRO)
   90    CONTINUE
         CALL LCMLEN(IPLIB,'XS-SAVED',ILENG,ITYLCM)
         IF(ILENG.GT.MAXSAV) CALL XABORT('USSIN1: XS-SAVED OVERFLOW.')
         IF(ILENG.GT.0) CALL LCMGET(IPLIB,'XS-SAVED',ISAV)
         IF(ILENG.GT.0) CALL LCMPUT(IPLI0,'XS-SAVED',ILENG,1,ISAV)
         CALL LCMLEN(IPLIB,'SCAT-SAVED',ILENG,ITYLCM)
         IF(ILENG.GT.MAXSAV) CALL XABORT('USSIN1: SCAT-SAVED OVERFLOW.')
         IF(ILENG.GT.0) CALL LCMGET(IPLIB,'SCAT-SAVED',ISAV)
         IF(ILENG.GT.0) CALL LCMPUT(IPLI0,'SCAT-SAVED',ILENG,1,ISAV)
         DO 110 IED=1,NED
         CALL LCMLEN(IPLIB,HVECT(IED),NEDI,ITYLCM)
         IF((NEDI.GT.0).AND.(HVECT(IED)(:3).NE.'CHI').AND.
     1   (HVECT(IED)(:2).NE.'NU').AND.(HVECT(IED).NE.'NGOLD').AND.
     2   (HVECT(IED)(:3).NE.'NWT').AND.(HVECT(IED).NE.'NTOT0')) THEN
            DO 100 IG1=1,NGRP
  100       GAR1(IG1)=SAGAR(IND,IRES,IED,IG1)
            CALL LCMPUT(IPLI0,HVECT(IED),NGRP,2,GAR1)
         ENDIF
  110    CONTINUE
         CALL LCMLEN(IPLIB,'NUSIGF01',ILONG,ITYLCM)
         IF(ILONG.EQ.NGRP) THEN
            CALL LCMLEN(IPLIB,'LAMBDA-D',ILONG,ITYLCM)
            IF(ILONG.EQ.0) CALL XABORT('USSIN1: MISSING LAMBDA-D INFO '
     1      //'FOR '//HNAMIS//'.')
            ALLOCATE(LAMB(ILONG))
            CALL LCMGET(IPLIB,'LAMBDA-D',LAMB)
            CALL LCMPUT(IPLI0,'LAMBDA-D',ILONG,2,LAMB)
            DEALLOCATE(LAMB)
            DO 130 IDEL=1,NDEL
            WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL
            LTEST=.FALSE.
            DO 120 IG1=1,NGRP
            GAR1(IG1)=SDGAR(IND,IRES,IDEL,IG1)
  120       LTEST=LTEST.OR.(GAR1(IG1).NE.0.0)
            IF(LTEST) THEN
               CALL LCMPUT(IPLI0,TEXT12,NGRP,2,GAR1)
               WRITE(TEXT12,'(3HCHI,I2.2)') IDEL
               CALL LCMGET(IPLIB,TEXT12,GAR1)
               CALL LCMPUT(IPLI0,TEXT12,NGRP,2,GAR1)
            ENDIF
  130       CONTINUE
         ENDIF
*
         IF(IMPX.GT.2) THEN
            WRITE (6,'(/13H SPH FACTORS:/(1X,1P,10E12.4))')
     1      (SPH(IND,IRES,I),I=1,NGRP)
            CALL LCMGET(IPLI0,'NTOT0',GAR1)
            WRITE (6,'(/36H SELF-SHIELDED MICROSCOPIC TOTAL XS:/
     1      (1X,1P,10E12.4))') (GAR1(I),I=1,NGRP)
            DO 350 IL=1,NL
            WRITE(CM,'(I2.2)') IL-1
            CALL LCMLEN(IPLI0,'SCAT'//CM,ILSCAT,ITYLCM)
            IF(ILSCAT.GT.NGRP**2) CALL XABORT('USSIN1: OVERWRITING ME'
     1      //'MORY(2).')
            IF((IL.EQ.1).OR.(ILSCAT.GT.0)) THEN
               CALL LCMGET(IPLI0,'SIGS'//CM,GAR1)
               WRITE (6,'(/16H SELF-SHIELDED P,A2,18H MICROSCOPIC SCATT,
     1         9HERING XS:/(1X,1P,10E12.4))') CM,(GAR1(I),I=1,NGRP)
            ENDIF
  350       CONTINUE
            IF(LOGNF) THEN
               CALL LCMGET(IPLI0,'NUSIGF',GAR1)
               WRITE (6,'(/38H SELF-SHIELDED MICROSCOPIC FISSION XS:/
     1         (1X,1P,10E12.4))') (GAR1(I),I=1,NGRP)
               CALL LCMGET(IPLI0,'CHI',GAR1)
               WRITE (6,'(/18H FISSION SPECTRUM:/
     1         (1X,1P,10E12.4))') (GAR1(I),I=1,NGRP)
            ENDIF
            DO 360 IED=1,NED
            CALL LCMLEN(IPLI0,HVECT(IED),NEDI,ITYLCM)
            IF((NEDI.GT.0).AND.(HVECT(IED)(:3).NE.'CHI').AND.
     1      (HVECT(IED)(:2).NE.'NU').AND.(HVECT(IED).NE.'NGOLD').AND.
     2      (HVECT(IED)(:3).NE.'NWT').AND.(HVECT(IED).NE.'NTOT0')) THEN
               CALL LCMGET(IPLI0,HVECT(IED),GAR1)
               WRITE (6,'(/15H SELF-SHIELDED ,A6,1H:/(1X,1P,10E12.4))')
     1         HVECT(IED),(GAR1(I),I=1,NGRP)
            ENDIF
  360       CONTINUE
         ENDIF
         CALL LCMSIX(IPLI0,' ',2)
         CALL LCMSIX(IPLIB,' ',2)
      ENDIF
  370 CONTINUE
      IF(IMPX.GT.2) CALL LCMLIB(IPLI0)
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(ENERGY,GAR2,GAR1)
      RETURN
      END
