*DECK BIVSPS
      SUBROUTINE BIVSPS(IPTRK,IPMACR,IPSYS,IMPX,NGRP,NEL,NLF,NANI,NBFIS,
     1 LDIFF,MAT,VOL,NBMIX)
*
*-----------------------------------------------------------------------
*
*Purpose:
* recover the cross-section data in LCM object with pointer IPMACR,
* compute and store the corresponding system matrices for a simplified
* PN approximation.
*
*Copyright:
* Copyright (C) 2004 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
* IPTRK   L_TRACK pointer to the bivac tracking information.
* IPMACR  L_MACROLIB pointer to the cross sections.
* IPSYS   L_SYSTEM pointer to system matrices.
* IMPX    print parameter (equal to zero for no print).
* NGRP    number of energy groups.
* NEL     total number of finite elements.
* NLF     number of Legendre orders for the flux (even number).
* NANI    number of Legendre orders for the scattering cross sections.
* NBFIS   number of fissionable isotopes.
* LDIFF   flag set to .true. to use 1/3D as 'NTOT1' cross sections.
* MAT     index-number of the mixture type assigned to each volume.
* VOL     volumes.
* NBMIX   total number of material mixtures in the macrolib.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPTRK,IPMACR,IPSYS
      INTEGER IMPX,NGRP,NEL,NLF,NANI,NBFIS,MAT(NEL),NBMIX
      REAL VOL(NEL)
      LOGICAL LDIFF
*----
*  LOCAL VARIABLES
*----
      CHARACTER TEXT12*12,CM*2,HSMG*131
      LOGICAL LFIS
      TYPE(C_PTR) JPMACR,KPMACR
      INTEGER, DIMENSION(:), ALLOCATABLE :: IJJ,NJJ,IPOS,IND
      REAL, DIMENSION(:), ALLOCATABLE :: WORK
      REAL, DIMENSION(:,:), ALLOCATABLE :: SGD,ZUFIS
      REAL, DIMENSION(:,:,:), ALLOCATABLE :: CHI,RCAT,RCATI
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(IJJ(NBMIX),NJJ(NBMIX),IPOS(NBMIX),IND(NGRP))
      ALLOCATE(SGD(NBMIX,2*NLF),WORK(NBMIX*NGRP),
     1 CHI(NBMIX,NBFIS,NGRP),ZUFIS(NBMIX,NBFIS),RCAT(NGRP,NGRP,NBMIX),
     2 RCATI(NGRP,NGRP,NBMIX))
*----
*  PROCESS MACROLIB INFORMATION FOR VARIOUS LEGENDRE ORDERS.
*----
      IF(NLF.EQ.0) CALL XABORT('BIVSPS: SPN APPROXIMATION REQUESTED.')
      JPMACR=LCMGID(IPMACR,'GROUP')
      DO 110 IL=1,NLF
      WRITE(CM,'(I2.2)') IL-1
      CALL XDRSET(RCAT,NGRP*NGRP*NBMIX,0.0)
      DO 50 IGR=1,NGRP
*     PROCESS SECONDARY GROUP IGR.
      KPMACR=LCMGIL(JPMACR,IGR)
      CALL XDRSET(SGD(1,1),NBMIX,0.0)
      CALL LCMLEN(KPMACR,'SIGW'//CM,LENGT,ITYLCM)
      IF((LENGT.GT.0).AND.(IL.LE.NANI)) THEN
         IF(LENGT.GT.NBMIX) CALL XABORT('BIVSPS: INVALID LENGTH FOR'
     1   //' SIGW'//CM//' CROSS SECTIONS.')
         CALL LCMGET(KPMACR,'SIGW'//CM,SGD(1,1))
      ENDIF
      IF(MOD(IL-1,2).EQ.0) THEN
*        macroscopic total cross section in even-parity equations.
         CALL LCMLEN(KPMACR,'NTOT0',LENGT,ITYLCM)
         IF(LENGT.EQ.0) THEN
            CALL XABORT('BIVSPS: NO TOTAL CROSS SECTIONS.')
         ELSE IF(LENGT.GT.NBMIX) THEN
            CALL XABORT('BIVSPS: INVALID LENGTH FOR TOTAL CROSS SECTIO'
     1      //'NS.')
         ENDIF
         CALL LCMGET(KPMACR,'NTOT0',SGD(1,2))
      ELSE
*        macroscopic total cross section in odd-parity equations.
         IF(LDIFF) THEN
            CALL LCMLEN(KPMACR,'DIFF',LENGT,ITYLCM)
            IF(LENGT.EQ.0) CALL XABORT('BIVSPS: DIFFUSION COEFFICIENTS'
     1      //' EXPECTED IN THE MACROLIB.')
            IF(LENGT.GT.NBMIX) CALL XABORT('BIVSPS: INVALID LENGTH FOR'
     1      //' DIFFUSION COEFFICIENTS.')
            CALL LCMGET(KPMACR,'DIFF',SGD(1,2))
            DO 5 IBM=1,NBMIX
    5       SGD(IBM,2)=1.0/(3.0*SGD(IBM,2))
         ELSE
            CALL LCMLEN(KPMACR,'NTOT1',LENGT,ITYLCM)
            IF(LENGT.GT.0) THEN
               IF(LENGT.GT.NBMIX) CALL XABORT('BIVSPS: INVALID LENGTH '
     1         //'FOR NTOT1 CROSS SECTIONS.')
               CALL LCMGET(KPMACR,'NTOT1',SGD(1,2))
            ELSE
               CALL LCMGET(KPMACR,'NTOT0',SGD(1,2))
            ENDIF
         ENDIF
      ENDIF
      DO 10 IBM=1,NBMIX
      IF(SGD(IBM,1).GT.SGD(IBM,2)) THEN
        WRITE(HSMG,'(28HBIVSPS: NEGATIVE XS IN GROUP,I5)') IGR
        CALL XABORT(HSMG)
      ENDIF
   10 RCAT(IGR,IGR,IBM)=SGD(IBM,2)-SGD(IBM,1)
      CALL LCMLEN(KPMACR,'NJJS'//CM,LENGT,ITYLCM)
      IF(LENGT.GT.NBMIX) CALL XABORT('BIVSPS: INVALID LENGTH FOR NJJS'
     1 //CM//' INFORMATION.')
      IF((LENGT.GT.0).AND.(IL.LE.NANI)) THEN
         CALL LCMGET(KPMACR,'NJJS'//CM,NJJ)
         CALL LCMGET(KPMACR,'IJJS'//CM,IJJ)
         IGMIN=IGR
         IGMAX=IGR
         DO 20 IBM=1,NBMIX
         IGMIN=MIN(IGMIN,IJJ(IBM)-NJJ(IBM)+1)
   20    IGMAX=MAX(IGMAX,IJJ(IBM))
         CALL LCMGET(KPMACR,'IPOS'//CM,IPOS)
         CALL LCMGET(KPMACR,'SCAT'//CM,WORK)
         DO 40 JGR=IGMAX,IGMIN,-1
         IF(JGR.EQ.IGR) GO TO 40
         DO 30 IBM=1,NBMIX
         IF((JGR.GT.IJJ(IBM)-NJJ(IBM)).AND.(JGR.LE.IJJ(IBM))) THEN
            RCAT(IGR,JGR,IBM)=-WORK(IPOS(IBM)+IJJ(IBM)-JGR)
         ENDIF
   30    CONTINUE
   40    CONTINUE
      ENDIF
   50 CONTINUE
*----
*  INVERSION OF THE REMOVAL MATRIX FOR CASES WITH IELEM > 1.
*----
      DO 70 IBM=1,NBMIX
      DO 60 JGR=1,NGRP
      DO 60 IGR=1,NGRP
   60 RCATI(IGR,JGR,IBM)=RCAT(IGR,JGR,IBM)
      CALL ALINV(NGRP,RCATI(1,1,IBM),NGRP,IER,IND)
      IF(IER.NE.0) CALL XABORT('BIVSPS: SINGULAR MATRIX.')
   70 CONTINUE
*
      DO 110 IGR=1,NGRP
      IGMIN=IGR
      IGMAX=IGR
      DO 80 IBM=1,NBMIX
      DO 80 JGR=1,NGRP
      IF((RCAT(IGR,JGR,IBM).NE.0.0).OR.(RCATI(IGR,JGR,IBM).NE.0.0)) THEN
         IGMIN=MIN(IGMIN,JGR)
         IGMAX=MAX(IGMAX,JGR)
      ENDIF
   80 CONTINUE
      DO 110 JGR=IGMIN,IGMAX
      DO 90 IBM=1,NBMIX
   90 WORK(IBM)=RCAT(IGR,JGR,IBM)
      WRITE(TEXT12,'(4HSCAR,A2,2I3.3)') CM,IGR,JGR
      CALL LCMPUT(IPSYS,TEXT12,NBMIX,2,WORK)
      DO 100 IBM=1,NBMIX
  100 WORK(IBM)=RCATI(IGR,JGR,IBM)
      WRITE(TEXT12,'(4HSCAI,A2,2I3.3)') CM,IGR,JGR
      CALL LCMPUT(IPSYS,TEXT12,NBMIX,2,WORK)
  110 CONTINUE
*----
*  COMPUTE AND FACTORIZE THE DIAGONAL SYSTEM MATRICES.
*----
      DO 160 IGR=1,NGRP
      DO 140 IL=1,NLF
      WRITE(TEXT12,'(4HSCAR,I2.2,2I3.3)') IL-1,IGR,IGR
      CALL LCMGET(IPSYS,TEXT12,SGD(1,IL))
      WRITE(TEXT12,'(4HSCAI,I2.2,2I3.3)') IL-1,IGR,IGR
      CALL LCMGET(IPSYS,TEXT12,SGD(1,NLF+IL))
  140 CONTINUE
      WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR
      CALL BIVASM(TEXT12,0,IPTRK,IPSYS,IMPX,NBMIX,NEL,NLF,2*NLF,MAT,
     1 VOL,SGD)
*----
*  PUT A FLAG IN IPSYS TO IDENTIFY NON-ZERO SCATTERING TERMS.
*----
      DO 160 IL=1,NLF
      DO 160 JGR=1,NGRP
      WRITE(TEXT12,'(4HSCAR,I2.2,2I3.3)') IL-1,IGR,JGR
      CALL LCMLEN(IPSYS,TEXT12,LENGT,ITYLCM)
      IF(LENGT.EQ.NBMIX) THEN
         WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR
         CALL LCMPUT(IPSYS,TEXT12,1,2,0.0)
      ENDIF
  160 CONTINUE
*----
*  PROCESS FISSION SPECTRUM TERMS.
*----
      KPMACR=LCMGIL(JPMACR,1)
      CALL LCMLEN(KPMACR,'CHI',LENGT,ITYLCM)
      IF(LENGT.GT.0) THEN
         IF(LENGT.NE.NBMIX*NBFIS) CALL XABORT('BIVSPS: INVALID LENGTH '
     1   //'FOR CHI INFORMATION.')
         DO 170 IGR=1,NGRP
         KPMACR=LCMGIL(JPMACR,IGR)
         CALL LCMGET(KPMACR,'CHI',CHI(1,1,IGR))
  170    CONTINUE
      ELSE
         DO 180 IBM=1,NBMIX
         DO 180 IFISS=1,NBFIS
         CHI(IBM,IFISS,1)=1.0
         DO 180 IGR=2,NGRP
  180    CHI(IBM,IFISS,IGR)=0.0
      ENDIF
*----
*  PROCESS FISSION NUSIGF TERMS.
*----
      DO 220 IGR=1,NGRP
*     PROCESS SECONDARY GROUP IGR.
      LFIS=.FALSE.
      DO 190 IBM=1,NBMIX
      DO 190 IFISS=1,NBFIS
  190 LFIS=LFIS.OR.(CHI(IBM,IFISS,IGR).NE.0.0)
      IF(LFIS) THEN
         DO 210 JGR=1,NGRP
         KPMACR=LCMGIL(JPMACR,JGR)
         CALL LCMLEN(KPMACR,'NUSIGF',LENGT,ITYLCM)
         IF(LENGT.NE.NBMIX*NBFIS) CALL XABORT('BIVSPS: INVALID LENGTH '
     1   //'FOR NUSIGF INFORMATION.')
         IF(LENGT.GT.0) THEN
            CALL LCMGET(KPMACR,'NUSIGF',ZUFIS)
            CALL XDRSET(SGD(1,1),4*NBMIX,0.0)
            DO 200 IBM=1,NBMIX
            DO 200 IFISS=1,NBFIS
  200       SGD(IBM,1)=SGD(IBM,1)+CHI(IBM,IFISS,IGR)*ZUFIS(IBM,IFISS)
            WRITE(TEXT12,'(4HFISS,2I3.3)') IGR,JGR
            CALL LCMPUT(IPSYS,TEXT12,NBMIX,2,SGD(1,1))
            WRITE (TEXT12,'(1HB,2I3.3)') IGR,JGR
            CALL BIVASM(TEXT12,1,IPTRK,IPSYS,IMPX,NBMIX,NEL,2,4,MAT,
     1      VOL,SGD)
         ENDIF
  210    CONTINUE
      ENDIF
  220 CONTINUE
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(IJJ,NJJ,IPOS,IND)
      DEALLOCATE(SGD,WORK,CHI,ZUFIS,RCAT,RCATI)
      RETURN
      END
