*DECK SPHTRA
      SUBROUTINE SPHTRA(JPSYS,NPSYS,KSPH,NREG,NGCOND,NBMIX,MAT,VOL,
     1 COURIN,SUNKNO,FUNKNO)
*
*-----------------------------------------------------------------------
*
*Purpose:
* transport calculation over the macro-geometry using the collision
* probability technique. Use the Bell factor acceleration strategy.
*
*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
* JPSYS   pointer to the 'GROUP' directory in the system LCM object.
* NPSYS   group masks.
* KSPH    type of SPH factor normalization:
*         <0 asymptotic normalization;
*         =1 average flux normalization;
*         >1 Selengut normalization.
* NREG    number of macro-regions (in the macro calculation).
* NGCOND  number of condensed groups.
* NBMIX   number of material mixtures.
* MAT     mixture index per macro-region.
* VOL     volume of macro-regions.
* COURIN  averaged flux if KSPH=1. Equal to 4 times the incoming current
*         per unit surface if KSPH=>1.
* SUNKNO  fission and out-of-group diffusion sources.
*
*Parameters: output
* FUNKNO  neutron flux.
*
*Reference(s):
* P. Blanc-Tranchant, A. Santamarina, G. Willermoz and A. Hebert,
* "Definition and Validation of a 2-D Transport Scheme for PWR Control
* Rod Clusters", paper presented at the Int. Conf. on Mathematics and
* Computation, Reactor Physics and Environmental Analysis in Nuclear
* Applications, Madrid, Spain, September 27-30, 1999.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) JPSYS
      INTEGER NPSYS(NGCOND),KSPH,NREG,NGCOND,NBMIX,MAT(NREG)
      REAL VOL(NREG),COURIN(NGCOND),SUNKNO(NREG,NGCOND),
     1 FUNKNO(NREG,NGCOND)
*----
*  LOCAL VARIABLES
*----
      TYPE(C_PTR) KPSYS
      REAL, ALLOCATABLE, DIMENSION(:) :: SIGMA
      REAL, ALLOCATABLE, DIMENSION(:,:) :: PIJ
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: WORK2,WORK3
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(PIJ(NREG,NREG),SIGMA(0:NBMIX))
      ALLOCATE(WORK2(NREG+1,NREG+1),WORK3(NREG,NREG+2))
*----
*  COMPUTE THE WORK2 MATRIX.
*----
      DO 100 IGR=1,NGCOND
      CALL XDRSET(FUNKNO(1,IGR),NREG,0.0)
      IF(NPSYS(IGR).EQ.0) GO TO 100
      KPSYS=LCMGIL(JPSYS,IGR)
      CALL LCMGET(KPSYS,'DRAGON-TXSC',SIGMA)
      CALL LCMGET(KPSYS,'DRAGON-PCSCT',PIJ)
      DO 10 I=1,NREG
      WORK2(I,NREG+1)=0.0D0
      DO 10 J=1,NREG
      WORK2(I,NREG+1)=WORK2(I,NREG+1)+PIJ(I,J)*VOL(I)*SUNKNO(J,IGR)
   10 WORK2(I,J)=PIJ(I,J)*VOL(I)
*----
*  COMPUTE THE NEUTRON FLUXES.
*----
      IF(KSPH.LT.0) THEN
*        ASYMPTOTIC NORMALIZATION.
         VOLTOT=0.0
         DO 30 I=1,NREG
         IF(MAT(I).EQ.-KSPH) THEN
            VOLTOT=VOLTOT+VOL(I)
            WORK2(NREG+1,I)=VOL(I)
         ELSE
            WORK2(NREG+1,I)=0.0D0
         ENDIF
         DO 20 J=1,NREG
         JBM=MAT(J)
   20    WORK2(I,J)=-SIGMA(JBM)*WORK2(I,J)
   30    WORK2(I,I)=WORK2(I,I)+VOL(I)
         WORK2(NREG+1,NREG+1)=COURIN(IGR)*VOLTOT
      ELSE
*        INTEGRATED FLUX OR SELENGUT NORMALIZATION.
         VOLTOT=0.0
         DO 50 I=1,NREG
         VOLTOT=VOLTOT+VOL(I)
         WORK2(NREG+1,I)=VOL(I)
         DO 40 J=1,NREG
         JBM=MAT(J)
   40    WORK2(I,J)=-SIGMA(JBM)*WORK2(I,J)
   50    WORK2(I,I)=WORK2(I,I)+VOL(I)
         WORK2(NREG+1,NREG+1)=COURIN(IGR)*VOLTOT
      ENDIF
      CALL ALSVDF(WORK2,NREG+1,NREG,NREG+1,NREG,WORK3(1,NREG+1),
     1 WORK3,WORK3(1,NREG+2))
      CALL ALSVDS(WORK2,WORK3(1,NREG+1),WORK3,NREG+1,NREG,NREG+1,
     1 NREG,WORK2(1,NREG+1),WORK2(1,NREG+1),WORK3(1,NREG+2))
      DO 90 I=1,NREG
   90 FUNKNO(I,IGR)=REAL(WORK2(I,NREG+1))
  100 CONTINUE
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(WORK3,WORK2,SIGMA,PIJ)
      RETURN
      END
