*DECK SYBILF
      SUBROUTINE SYBILF (IPSYS,IPTRK,IFTRAK,IMPX,IDIR,NREG,NBMIX,NUNKNO,
     1 MAT,VOL,KEYFLX,FUNKNO,SUNKNO,TITR)
*
*-----------------------------------------------------------------------
*
*Purpose:
* solve one-group transport equation for fluxes using the SYBIL current
* iteration method.
*
*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
* IPSYS   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 (=0 only for SYBIL).
* NREG    total number of regions for which specific values of the
*         neutron flux and reactions rates are required.
* NBMIX   number of mixtures.
* NUNKNO  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
*----
      TYPE(C_PTR) IPSYS,IPTRK
      CHARACTER   TITR*72
      INTEGER     IFTRAK,IMPX,IDIR,NREG,NBMIX,NUNKNO,MAT(NREG),
     1            KEYFLX(NREG)
      REAL        VOL(NREG),FUNKNO(NUNKNO),SUNKNO(NUNKNO)
*----
*  LOCAL VARIABLES
*----
      PARAMETER  (IUNOUT=6,NSTATE=40)
      CHARACTER   NAMLCM*12,NAMMY*12
      INTEGER     ISTATE(NSTATE),IPAR(16)
      LOGICAL     EMPTY,LCM,LBIHET
*----
*  ALLOCATABLE ARRAYS
*----
      TYPE(C_PTR) NMC3_PTR,PROCE_PTR,PIJW_PTR,PISW_PTR,PSJW_PTR,
     1 PSSW_PTR,XX4_PTR,YY4_PTR,NMC4_PTR,IFR_PTR,ALB_PTR,INUM_PTR,
     2 MIX_PTR,DVX_PTR,IGEN_PTR
      REAL, ALLOCATABLE, DIMENSION(:) :: SUNKN
      INTEGER, POINTER, DIMENSION(:) :: NMC3,NMC4,IFR,INUM,MIX,IGEN
      REAL, POINTER, DIMENSION(:) :: PROCE,PIJW,PISW,PSJW,PSSW,XX4,YY4,
     1 ALB,DVX,FGAR
*
      IF(IDIR.NE.0) CALL XABORT('SYBILF: EXPECTING IDIR=0')
      IF(IFTRAK.NE.0) CALL XABORT('SYBILF: EXPECTING IFTRAK=0')
      IF(MAT(1).LT.0) CALL XABORT('SYBILF: EXPECTING MAT(1)>=0')
      IF(VOL(1).LT.0.0) CALL XABORT('SYBILF: EXPECTING VOL(1)>=0')
      CALL LCMINF(IPSYS,NAMLCM,NAMMY,EMPTY,ILONG,LCM)
      IF(IDIR.NE.0) CALL XABORT('SYBILF: PIJK FORBIDDEN HERE')
*----
*  RECOVER SYBIL SPECIFIC PARAMETERS
*----
      CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE)
      ITG=ISTATE(6)
      LBIHET=ISTATE(40).NE.0
*
      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,'(//9H SYBILF: ,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(NUNKNO))
         DO 10 I=1,NUNKNO
   10    SUNKN(I)=SUNKNO(I)
         NREGAR=NREG
         NBMIXG=NBMIX
         CALL DOORFB2(IPSYS,IPTRK,IMPX,NBMIX,NREG,NUNKNO,KEYFLX,NBMIX2,
     1   NREG2,SUNKNO)
         NREG=NREG2
         NBMIX=NBMIX2
         CALL LCMSIX(IPSYS,'BIHET',1)
      ENDIF
*
      IF(ITG.EQ.1) THEN
         CALL XABORT('SYBILF: THIS GEOMETRY CANNOT BE PROCESSED WITH A'
     1   //' CURRENT ITERATION METHOD. USE KEYWORD PIJ IN ASM: (1).')
      ELSE IF(ITG.EQ.2) THEN
         CALL XABORT('SYBILF: THIS GEOMETRY CANNOT BE PROCESSED WITH A'
     1   //' CURRENT ITERATION METHOD. USE KEYWORD PIJ IN ASM: (2).')
      ELSE IF(ITG.EQ.3) THEN
         CALL LCMSIX(IPTRK,'DOITYOURSELF',1)
         CALL LCMGET(IPTRK,'PARAM',IPAR)
         NSUPCE=IPAR(1)
         ISTAT=IPAR(3)
         CALL LCMGPD(IPTRK,'NMC',NMC3_PTR)
         CALL LCMGPD(IPTRK,'PROCEL',PROCE_PTR)
         CALL LCMSIX(IPTRK,' ',2)
*
         CALL C_F_POINTER(NMC3_PTR,NMC3,(/ NSUPCE+1 /))
         CALL C_F_POINTER(PROCE_PTR,PROCE,(/ NSUPCE*NSUPCE /))
         NPIJ=0
         DO 30 IKG=1,NSUPCE
         J2=NMC3(IKG+1)-NMC3(IKG)
   30    NPIJ=NPIJ+J2*J2
         IF(NMC3(NSUPCE+1).NE.NREG) CALL XABORT('SYBILF: ABORT.')
*
         IF(LCM) THEN
            CALL LCMGPD(IPSYS,'PIJW$SYBIL',PIJW_PTR)
            CALL LCMGPD(IPSYS,'PISW$SYBIL',PISW_PTR)
            CALL LCMGPD(IPSYS,'PSJW$SYBIL',PSJW_PTR)
            CALL LCMGPD(IPSYS,'PSSW$SYBIL',PSSW_PTR)
*
            CALL C_F_POINTER(PIJW_PTR,PIJW,(/ NPIJ /))
            CALL C_F_POINTER(PISW_PTR,PISW,(/ NREG /))
            CALL C_F_POINTER(PSJW_PTR,PSJW,(/ NREG /))
            CALL C_F_POINTER(PSSW_PTR,PSSW,(/ NSUPCE /))
         ELSE
            ALLOCATE(PIJW(NPIJ),PISW(NREG),PSJW(NREG),PSSW(NSUPCE))
            CALL LCMGET(IPSYS,'PIJW$SYBIL',PIJW)
            CALL LCMGET(IPSYS,'PISW$SYBIL',PISW)
            CALL LCMGET(IPSYS,'PSJW$SYBIL',PSJW)
            CALL LCMGET(IPSYS,'PSSW$SYBIL',PSSW)
         ENDIF
*
         CALL SYBJJ0 (NREG,NSUPCE,NPIJ,NUNKNO,FUNKNO,SUNKNO,IMPX,ISTAT,
     1   NMC3,PROCE,PIJW,PISW,PSJW,PSSW)
         IF(.NOT.LCM) DEALLOCATE(PSSW,PSJW,PISW,PIJW)
      ELSE IF(ITG.EQ.4) THEN
         CALL LCMSIX(IPTRK,'EURYDICE',1)
         CALL LCMGET(IPTRK,'PARAM',IPAR)
         IHEX=IPAR(1)
         MULTC=IPAR(2)
         NMCEL=IPAR(4)
         NMERGE=IPAR(5)
         NGEN=IPAR(6)
         IJAT=IPAR(7)
         CALL LCMGPD(IPTRK,'XX',XX4_PTR)
         CALL LCMGPD(IPTRK,'YY',YY4_PTR)
         CALL LCMGPD(IPTRK,'NMC',NMC4_PTR)
         CALL LCMGPD(IPTRK,'IFR',IFR_PTR)
         CALL LCMGPD(IPTRK,'ALB',ALB_PTR)
         CALL LCMGPD(IPTRK,'INUM',INUM_PTR)
         CALL LCMGPD(IPTRK,'MIX',MIX_PTR)
         CALL LCMGPD(IPTRK,'DVX',DVX_PTR)
         CALL LCMGPD(IPTRK,'IGEN',IGEN_PTR)
         CALL LCMSIX(IPTRK,' ',2)
*
         CALL C_F_POINTER(XX4_PTR,XX4,(/ NGEN /))
         CALL C_F_POINTER(YY4_PTR,YY4,(/ NGEN /))
         CALL C_F_POINTER(NMC4_PTR,NMC4,(/ NGEN+1 /))
         CALL C_F_POINTER(IFR_PTR,IFR,(/ NCOUR*NMCEL /))
         CALL C_F_POINTER(ALB_PTR,ALB,(/ NCOUR*NMCEL /))
         CALL C_F_POINTER(INUM_PTR,INUM,(/ NMCEL /))
         CALL C_F_POINTER(MIX_PTR,MIX,(/ NCOUR*NMERGE /))
         CALL C_F_POINTER(DVX_PTR,DVX,(/ NCOUR*NMERGE /))
         CALL C_F_POINTER(IGEN_PTR,IGEN,(/ NMERGE /))
*
         NCOUR=4
         IF(IHEX.NE.0) NCOUR=6
         NPIJ=0
         DO 40 IKG=1,NGEN
         J2=NMC4(IKG+1)-NMC4(IKG)
   40    NPIJ=NPIJ+J2*J2
         NPIS=NMC4(NGEN+1)
*
         IF(MULTC.EQ.1) THEN
            IF(LCM) THEN
               CALL LCMGPD(IPSYS,'PIJW$SYBIL',PIJW_PTR)
               CALL LCMGPD(IPSYS,'PISW$SYBIL',PISW_PTR)
               CALL LCMGPD(IPSYS,'PSJW$SYBIL',PSJW_PTR)
               CALL LCMGPD(IPSYS,'PSSW$SYBIL',PSSW_PTR)
*
               CALL C_F_POINTER(PIJW_PTR,PIJW,(/ NPIJ /))
               CALL C_F_POINTER(PISW_PTR,PISW,(/ NPIS /))
               CALL C_F_POINTER(PSJW_PTR,PSJW,(/ NPIS /))
               CALL C_F_POINTER(PSSW_PTR,PSSW,(/ NGEN /))
            ELSE
               ALLOCATE(PIJW(NPIJ),PISW(NPIS),PSJW(NPIS),PSSW(NGEN))
               CALL LCMGET(IPSYS,'PIJW$SYBIL',PIJW)
               CALL LCMGET(IPSYS,'PISW$SYBIL',PISW)
               CALL LCMGET(IPSYS,'PSJW$SYBIL',PSJW)
               CALL LCMGET(IPSYS,'PSSW$SYBIL',PSSW)
            ENDIF
*
            CALL SYBJJ1 (NREG,NMCEL,NMERGE,NGEN,NPIJ,NPIS,NUNKNO,FUNKNO,
     1      SUNKNO,IMPX,NCOUR,XX4,YY4,NMC4,IFR,ALB,INUM,IGEN,PIJW,PISW,
     2      PSJW,PSSW)
         ELSE
            IF(MULTC.EQ.4) NCOUR=3*NCOUR
            IF(LCM) THEN
               CALL LCMGPD(IPSYS,'PIJW$SYBIL',PIJW_PTR)
               CALL LCMGPD(IPSYS,'PISW$SYBIL',PISW_PTR)
               CALL LCMGPD(IPSYS,'PSJW$SYBIL',PSJW_PTR)
               CALL LCMGPD(IPSYS,'PSSW$SYBIL',PSSW_PTR)
*
               CALL C_F_POINTER(PIJW_PTR,PIJW,(/ NPIJ /))
               CALL C_F_POINTER(PISW_PTR,PISW,(/ NCOUR*NPIS /))
               CALL C_F_POINTER(PSJW_PTR,PSJW,(/ NCOUR*NPIS /))
               CALL C_F_POINTER(PSSW_PTR,PSSW,(/ NCOUR*NCOUR*NGEN /))
            ELSE
               ALLOCATE(PIJW(NPIJ),PISW(NCOUR*NPIS),PSJW(NCOUR*NPIS),
     1         PSSW(NCOUR*NCOUR*NGEN))
               CALL LCMGET(IPSYS,'PIJW$SYBIL',PIJW)
               CALL LCMGET(IPSYS,'PISW$SYBIL',PISW)
               CALL LCMGET(IPSYS,'PSJW$SYBIL',PSJW)
               CALL LCMGET(IPSYS,'PSSW$SYBIL',PSSW)
            ENDIF
*
            CALL SYBJJ2 (NREG,NMCEL,NMERGE,NGEN,IJAT,NPIJ,NPIS,NUNKNO,
     1      FUNKNO,SUNKNO,IMPX,NCOUR,NMC4,IFR,ALB,INUM,MIX,DVX,IGEN,
     2      PIJW,PISW,PSJW,PSSW)
         ENDIF
         IF(.NOT.LCM) DEALLOCATE(PSSW,PSJW,PISW,PIJW)
      ELSE
         CALL XABORT('SYBILF: UNKNOWN CP MODULE(2).')
      ENDIF
*----
*  DOUBLE HETEROGENEITY TREATMENT
*----
      IF(LBIHET) THEN
         CALL LCMSIX(IPSYS,' ',2)
         NREG=NREGAR
         NBMIX=NBMIXG
         DO 60 I=1,NUNKNO
   60    SUNKNO(I)=SUNKN(I)
         DEALLOCATE(SUNKN)
         CALL DOORFB3(IPSYS,IPTRK,IMPX,NBMIX,NREG,NUNKNO,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
