*DECK BIVAF
      SUBROUTINE BIVAF(KPSYS,IPTRK,IFTRAK,IMPX,IDIR,NREG,NBMIX,NUN,MAT,
     1 VOL,KEYFLX,FUNKNO,SUNKNO,TITR)
*
*-----------------------------------------------------------------------
*
*Purpose:
* solve one-group transport equation for fluxes using the diffusion
* 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
* KPSYS   pointer to the assembly matrices.
* IPTRK   pointer to the tracking (L_TRACK signature).
* IFTRAK  not used.
* IMPX    print flag (equal to zero for no print).
* IDIR    not used.
* NREG    total number of regions for which specific values of the
*         neutron flux and reactions rates are required.
* NBMIX   number of mixtures.
* NUN     total number of unknowns in vectors SUNKNO and FUNKNO.
* MAT     index-number of the mixture type assigned to each volume.
* VOL     volumes.
* KEYFLX  position of averaged flux elements in FUNKNO vector.
* SUNKNO  input source vector.
* TITR    title.
*
*Parameters: input/output
* FUNKNO  unknown vector.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      CHARACTER   TITR*72
      TYPE(C_PTR) KPSYS,IPTRK
      INTEGER     IFTRAK,IMPX,IDIR,NREG,NBMIX,NUN,MAT(NREG),KEYFLX(NREG)
      REAL        VOL(NREG),FUNKNO(NUN),SUNKNO(NUN)
*----
*  LOCAL VARIABLES
*----
      PARAMETER  (IUNOUT=6,NSTATE=40)
      INTEGER     IPAR(NSTATE)
      LOGICAL     CYLIND,LBIHET
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: MU,KN
      REAL, ALLOCATABLE, DIMENSION(:) :: SUNKN,XX,YY,DD,QFR,BFR,SYS,T,
     1 TS,RH,RT,ZGLOB,FGAR
*----
*  RECOVER BIVAC SPECIFIC PARAMETERS.
*----
      IF(IDIR.NE.0) CALL XABORT('BIVAF: EXPECTING IDIR=0')
      IF(IFTRAK.NE.0) CALL XABORT('BIVAF: EXPECTING IFTRAK=0')
      CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR)
      IF(NREG.NE.IPAR(1)) CALL XABORT('BIVAF: INVALID VALUE OF NREG.')
      IF(NUN.NE.IPAR(2)) CALL XABORT('BIVAF: INVALID VALUE OF NUN.')
      ITYPE=IPAR(6)
      CYLIND=(ITYPE.EQ.3).OR.(ITYPE.EQ.6)
      IELEM=IPAR(8)
      ICOL=IPAR(9)
      ISPLH=IPAR(10)
      LL4=IPAR(11)
      LX=IPAR(12)
      LY=IPAR(13)
      NLF=IPAR(14)
      ISPN=IPAR(15)
      ISCAT=IPAR(16)
      LBIHET=IPAR(40).NE.0
      IF(NLF.GT.0) CALL XABORT('BIVAF: LIMITED TO DIFFUSION THEORY.')
      IF(IMPX.GT.2) THEN
         ALLOCATE(FGAR(NREG))
         CALL XDRSET(FGAR,NREG,0.0)
         DO I=1,NREG
            IF(KEYFLX(I).NE.0) FGAR(I)=SUNKNO(KEYFLX(I))
         ENDDO
         WRITE(IUNOUT,'(//8H BIVAF: ,A72)') TITR
         WRITE(IUNOUT,'(/33H N E U T R O N    S O U R C E S :)')
         WRITE(IUNOUT,'(1P,6(5X,E15.7))') (FGAR(I),I=1,NREG)
         DEALLOCATE(FGAR)
      ENDIF
*----
*  DOUBLE HETEROGENEITY TREATMENT
*----
      NREGAR=0
      NBMIXG=0
      IF(LBIHET) THEN
         ALLOCATE(SUNKN(NUN))
         DO 10 I=1,NUN
   10    SUNKN(I)=SUNKNO(I)
         NREGAR=NREG
         NBMIXG=NBMIX
         CALL DOORFB2(KPSYS,IPTRK,IMPX,NBMIX,NREG,NUN,KEYFLX,SUNKNO)
         CALL LCMSIX(KPSYS,'BIHET',1)
      ENDIF
*
      ALLOCATE(XX(LX*LY),YY(LX*LY),DD(LX*LY))
      IF(ITYPE.EQ.8) THEN
         CALL LCMGET(IPTRK,'SIDE',SIDE)
      ELSE
         CALL LCMGET(IPTRK,'XX',XX)
         CALL LCMGET(IPTRK,'YY',YY)
         CALL LCMGET(IPTRK,'DD',DD)
      ENDIF
      ALLOCATE(MU(LL4))
      CALL LCMGET(IPTRK,'MU',MU)
      CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM)
      CALL LCMLEN(IPTRK,'QFR',MAXQF,ITYLCM)
      ALLOCATE(KN(MAXKN),QFR(MAXQF),BFR(MAXQF))
      CALL LCMGET(IPTRK,'KN',KN)
      CALL LCMGET(IPTRK,'QFR',QFR)
      CALL LCMGET(IPTRK,'BFR',BFR)
*----
*  MULTIPLICATION OF THE EVEN-PARITY SOURCES BY THE VOLUMES.
*----
      DO 20 K=1,NREG
      IF(MAT(K).EQ.0) GO TO 20
      JND1=KEYFLX(K)
      SUNKNO(JND1)=SUNKNO(JND1)*VOL(K)
   20 CONTINUE
*----
*  COMPUTE THE NEUTRON FLUX
*----
      IIMAX=MU(LL4)
      ALLOCATE(SYS(IIMAX))
      CALL LCMGET(KPSYS,'IA001001',SYS)
      IF((IELEM.LT.0).AND.(ITYPE.NE.8)) THEN
         CALL LCMSIX(IPTRK,'BIVCOL',1)
         CALL LCMLEN(IPTRK,'T',LC,ITYLCM)
         ALLOCATE(T(LC),TS(LC))
         CALL LCMGET(IPTRK,'T',T)
         CALL LCMGET(IPTRK,'TS',TS)
         CALL LCMSIX(IPTRK,' ',2)
         CALL BIVS01(MAXKN,CYLIND,NREG,NUN,LL4,IIMAX,XX,DD,MAT,KN,BFR,
     1   VOL,KEYFLX,MU,SUNKNO,LC,T,TS,SYS,FUNKNO)
         DEALLOCATE(TS,T)
      ELSE IF((IELEM.GT.0).AND.(ITYPE.NE.8)) THEN
         CALL BIVS02(CYLIND,IELEM,ICOL,NREG,NUN,LL4,IIMAX,MAT,KN,BFR,
     1   VOL,MU,SUNKNO,SYS,FUNKNO)
      ELSE IF((IELEM.LT.0).AND.(ITYPE.EQ.8)) THEN
         CALL LCMSIX(IPTRK,'BIVCOL',1)
         ALLOCATE(RH(36),RT(9))
         CALL LCMGET(IPTRK,'RH',RH)
         CALL LCMGET(IPTRK,'RT',RT)
         CALL LCMSIX(IPTRK,' ',2)
         IF(ISPLH.EQ.1) THEN
            NELEM=MAXKN/7
         ELSE
            NELEM=MAXKN/4
         ENDIF
         CALL BIVS03(MAXKN,MAXQF,NREG,NUN,LL4,ISPLH,NELEM,IIMAX,SIDE,
     1   KN,QFR,BFR,VOL,KEYFLX,MU,SUNKNO,RH,RT,SYS,FUNKNO)
         DEALLOCATE(RT,RH)
      ELSE IF((IELEM.GT.0).AND.(ITYPE.EQ.8).AND.(ICOL.EQ.4)) THEN
         CALL BIVS04(MAXKN,MAXQF,NREG,NUN,LL4,ISPLH,IIMAX,SIDE,KN,QFR,
     1   BFR,VOL,KEYFLX,MU,SUNKNO,SYS,FUNKNO)
      ELSE IF((IELEM.GT.0).AND.(ITYPE.EQ.8)) THEN
         ALLOCATE(ZGLOB(LX*ISPLH**2))
         CALL LCMGET(IPTRK,'ZGLOB',ZGLOB)
         CALL BIVS05(IELEM,ISPLH,LX,NUN,LL4,IIMAX,ZGLOB,KN,BFR,KEYFLX,
     1   MU,SUNKNO,SYS,FUNKNO)
         DEALLOCATE(ZGLOB)
      ELSE
         CALL XABORT('BIVAF: UNKNOWN TYPE OF GEOMETRY.')
      ENDIF
      DEALLOCATE(SYS,BFR,QFR,KN,MU,DD,YY,XX)
*----
*  DIVISION OF THE EVEN-PARITY SOURCES BY THE VOLUMES.
*----
      DO 30 K=1,NREG
      IF(MAT(K).EQ.0) GO TO 30
      JND1=KEYFLX(K)
      SUNKNO(JND1)=SUNKNO(JND1)/VOL(K)
   30 CONTINUE
*----
*  DOUBLE HETEROGENEITY TREATMENT
*----
      IF(LBIHET) THEN
         CALL LCMSIX(KPSYS,' ',2)
         NREG=NREGAR
         NBMIX=NBMIXG
         DO 40 I=1,NUN
   40    SUNKNO(I)=SUNKN(I)
         DEALLOCATE(SUNKN)
         CALL DOORFB3(KPSYS,IPTRK,IMPX,NBMIX,NREG,NUN,KEYFLX,SUNKNO,
     1   FUNKNO)
      ENDIF
*
      IF(IMPX.GT.2) THEN
         ALLOCATE(FGAR(NREG))
         CALL XDRSET(FGAR,NREG,0.0)
         DO I=1,NREG
            IF(KEYFLX(I).NE.0) FGAR(I)=FUNKNO(KEYFLX(I))
         ENDDO
         WRITE(IUNOUT,'(//33H N E U T R O N    F L U X E S   :)')
         WRITE(IUNOUT,'(1P,6(5X,E15.7))') (FGAR(I),I=1,NREG)
         DEALLOCATE(FGAR)
      ENDIF
      RETURN
      END
