*DECK SPHCMI
      SUBROUTINE SPHCMI(IPMICR,IPRINT,NMERGE,NISOT,NGCOND,NWGTH,NL,NED,
     1 NDEL,SPH)
*
*-----------------------------------------------------------------------
*
*Purpose:
* SPH-correction of a Microlib.
*
*Copyright:
* Copyright (C) 2011 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
* IPMICR  pointer to the condensed microlib (L_LIBRARY signature).
* IPRINT  print flag (equal to 0 for no print).
* NMERGE  number of merged regions.
* NISOT   number of isotopes in microlib.
* NGCOND  number of condensed groups.
* NWGTH   order of SPH factors used in equivalence:
*         = 0 only P0; = 1 P0 and P1.
* NL      number of Legendre orders in scattering info.
* NED     number of additional phi-weighted edits in microlib.
* NDEL    number of delayed precursor groups.
* SPH     SPH homogenization factors.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPMICR
      INTEGER IPRINT,NMERGE,NISOT,NGCOND,NWGTH,NL,NED,NDEL,
     1 IHUSED(3,NISOT),IMIX(NISOT)
      REAL SPH(NMERGE,NGCOND,NWGTH+1)
*----
*  LOCAL VARIABLES
*----
      PARAMETER(NSTATE=40)
      INTEGER ISTATE(NSTATE)
      CHARACTER HSIGN*12,TEXT12*12,CM*2,TEXT8*8,HMAKE(100)*12
      INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPR
      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IHEDIT
      REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: WSCAT
*----
*  SCRATCH STORAGE ALLOCATION
*   IHEDIT  character*8 names of phi-weighted edits in microlib.
*----
      ALLOCATE(IHEDIT(2,NED),ITYPR(NL))
      ALLOCATE(GAR(NGCOND,10+NL+NED+2*NDEL),WSCAT(NGCOND,NGCOND,NL))
*----
*  RECOVER MICROLIB INFORMATION
*----
      CALL LCMGTC(IPMICR,'SIGNATURE',12,1,HSIGN)
      IF(HSIGN.NE.'L_LIBRARY') CALL XABORT('SPHCMI: MICROLIB EXPECTED')
      CALL LCMGET(IPMICR,'STATE-VECTOR',ISTATE)
      IF(ISTATE(1).NE.NMERGE) CALL XABORT('SPHCMI: INVALID NMERGE')
      IF(ISTATE(2).NE.NISOT) CALL XABORT('SPHCMI: INVALID NISOT')
      IF(ISTATE(3).NE.NGCOND) CALL XABORT('SPHCMI: INVALID NGCOND')
      IF(ISTATE(4).NE.NL) CALL XABORT('SPHCMI: INVALID NL')
      IF(ISTATE(13).NE.NED) CALL XABORT('SPHCMI: INVALID NED')
      IF(ISTATE(19).NE.NDEL) CALL XABORT('SPHCMI: INVALID NDEL')
      ITRANC=ISTATE(5)
      IF(NED.GT.0) CALL LCMGET(IPMICR,'ADDXSNAME-P0',IHEDIT)
*----
*  LOOP OVER ISOTOPES
*----
      CALL LCMGET(IPMICR,'ISOTOPESUSED',IHUSED)
      CALL LCMGET(IPMICR,'ISOTOPESMIX',IMIX)
      DO 200 ISOT=1,NISOT
      WRITE(TEXT12,'(3A4)') (IHUSED(I0,ISOT),I0=1,3)
      IF(IPRINT.GT.4) THEN
         WRITE(6,'(29H SPHCMI: PROCESSING ISOTOPE '',A12,2H''.)') TEXT12
      ENDIF
      IBM=IMIX(ISOT)
      CALL LCMSIX(IPMICR,TEXT12,1)
      MAXH=10+NL+NED+2*NDEL
      IF(MAXH+NL.GT.100) CALL XABORT('SPHCMI: STATIC STORAGE EXCEEDED')
      DO 10 J=1,MAXH+NL
   10 HMAKE(J)=' '
      CALL XDRSET(GAR,NGCOND*(10+NL+NED+2*NDEL),0.0)
      CALL XDRSET(WSCAT,NGCOND*NGCOND*NL,0.0)
*----
*  RECOVER CALCULATION-SPECIFIC ISOTOPIC DATA FROM THE COMPO
*----
      CALL LCMGET(IPMICR,'NWT0',GAR(1,1))
      HMAKE(1)='NWT0'
      CALL LCMLEN(IPMICR,'NWT1',LENGTH,ITYLCM)
      IF(LENGTH.EQ.NGCOND) THEN
         CALL LCMGET(IPMICR,'NWT1',GAR(1,2))
         HMAKE(2)='NWT1'
      ENDIF
      CALL XDRLGS(IPMICR,-1,IPRINT,0,NL-1,1,NGCOND,GAR(1,3),WSCAT,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(IPMICR,'NTOT0',GAR(1,3+NL))
      HMAKE(3+NL)='NTOT0'
      CALL LCMLEN(IPMICR,'NTOT1',LENGTH,ITYLCM)
      IF(LENGTH.EQ.NGCOND) THEN
         CALL LCMGET(IPMICR,'NTOT1',GAR(1,4+NL))
         HMAKE(4+NL)='NTOT1'
      ENDIF
      CALL LCMLEN(IPMICR,'NUSIGF',LENGTH,ITYLCM)
      IF(LENGTH.EQ.NGCOND) THEN
         CALL LCMGET(IPMICR,'NUSIGF',GAR(1,5+NL))
         HMAKE(5+NL)='NUSIGF'
      ENDIF
      IF(NDEL.GT.0) THEN
         WRITE(TEXT12,'(6HNUSIGF,I2.2)') NDEL
         CALL LCMLEN(IPMICR,TEXT12,LENGTH,ITYLCM)
         IF(LENGTH.EQ.NGCOND) THEN
            DO 40 IDEL=1,NDEL
            WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL
            CALL LCMGET(IPMICR,TEXT12,GAR(1,MAXH-2*NDEL-2+IDEL))
   40       HMAKE(MAXH-2*NDEL-2+IDEL)=TEXT12
         ENDIF
      ENDIF
      CALL LCMLEN(IPMICR,'H-FACTOR',LENGTH,ITYLCM)
      IF(LENGTH.EQ.NGCOND) THEN
         CALL LCMGET(IPMICR,'H-FACTOR',GAR(1,MAXH-2*NDEL-4))
         HMAKE(MAXH-2*NDEL-4)='H-FACTOR'
      ENDIF
      CALL LCMLEN(IPMICR,'OVERV',LENGTH,ITYLCM)
      IF(LENGTH.EQ.NGCOND) THEN
         CALL LCMGET(IPMICR,'OVERV',GAR(1,MAXH-2*NDEL-3))
         HMAKE(MAXH-2*NDEL-3)='OVERV'
      ENDIF
      CALL LCMLEN(IPMICR,'TRANC',LENGTH,ITYLCM)
      IF(LENGTH.EQ.NGCOND) THEN
         CALL LCMGET(IPMICR,'TRANC',GAR(1,MAXH-2*NDEL-2))
         HMAKE(MAXH-2*NDEL-2)='TRANC'
      ENDIF
      DO 60 IED=1,NED
      WRITE(TEXT8,'(2A4)') (IHEDIT(I0,IED),I0=1,2)
      CALL LCMLEN(IPMICR,TEXT8,LENGTH,ITYLCM)
      IF((LENGTH.GT.0).AND.(TEXT8.NE.'TRANC')) THEN
         CALL LCMGET(IPMICR,TEXT8,GAR(1,5+NL+IED))
         HMAKE(5+NL+IED)=TEXT8
      ENDIF
   60 CONTINUE
      CALL LCMLEN(IPMICR,'STRD',LENGTH,ITYLCM)
      IF(LENGTH.EQ.NGCOND) THEN
         CALL LCMGET(IPMICR,'STRD',GAR(1,MAXH))
         HMAKE(MAXH)='STRD'
      ENDIF
*----
*  APPLY SPH CORRECTION
*----
      DO 80 J=1,MAXH
      IF((HMAKE(J).NE.' ').AND.(HMAKE(J)(:4).NE.'SIGS')) THEN
         IF((HMAKE(J).EQ.'NWT1').OR.(HMAKE(J).EQ.'NTOT1').OR.
     1   (HMAKE(J)(:4).EQ.'STRD')) THEN
            IIL=MIN(2,NWGTH+1)
         ELSE
            IIL=1
         ENDIF
         DO 70 IG=1,NGCOND
         IF((HMAKE(J)(:2).EQ.'NW').OR.(HMAKE(J).EQ.'STRD')) THEN
            GAR(IG,J)=GAR(IG,J)/SPH(IBM,IG,IIL)
         ELSE
            GAR(IG,J)=GAR(IG,J)*SPH(IBM,IG,IIL)
         ENDIF
   70    CONTINUE
      ENDIF
   80 CONTINUE
      DO 90 IL=1,NL
      IIL=MIN(IL,NWGTH+1)
      ITYPR(IL)=0
      IF(HMAKE(MAXH+IL+1).NE.' ') ITYPR(IL)=1
      DO 90 IG2=1,NGCOND
      GAR(IG2,2+IL)=GAR(IG2,2+IL)*SPH(IBM,IG2,IIL)
      DO 90 IG1=1,NGCOND
   90 WSCAT(IG1,IG2,IL)=WSCAT(IG1,IG2,IL)*SPH(IBM,IG2,IIL)
*----
*  SAVE CORRECTED INFORMATION ON LCM
*----
      DO 110 J=1,MAXH
      IF((HMAKE(J).NE.' ').AND.(HMAKE(J)(:4).NE.'SIGS')) THEN
         CALL LCMPUT(IPMICR,HMAKE(J),NGCOND,2,GAR(1,J))
      ENDIF
  110 CONTINUE
      CALL XDRLGS(IPMICR,1,IPRINT,0,NL-1,1,NGCOND,GAR(1,3),WSCAT,ITYPR)
      CALL LCMSIX(IPMICR,' ',2)
  200 CONTINUE
*----
*  CORRECT MACROLIB INFORMATION
*----
      CALL LCMLEN(IPMICR,'MACROLIB',ILONG,ITYLCM)
      IF(ILONG.NE.0) THEN
        CALL LCMSIX(IPMICR,'MACROLIB',1)
        CALL LCMGET(IPMICR,'STATE-VECTOR',ISTATE)
        NIFISS=ISTATE(4)
        CALL SPHCMA(IPMICR,IPRINT,NMERGE,NGCOND,NWGTH,NIFISS,NED,SPH)
        CALL LCMSIX(IPMICR,' ',2)
      ENDIF
      IF(IPRINT.GT.5) WRITE(6,'(/28H SPHCMI: MICROLIB CORRECTED.)')
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(WSCAT,GAR)
      DEALLOCATE(ITYPR,IHEDIT)
      RETURN
      END
