*DECK FLDDRV
      SUBROUTINE FLDDRV (CMODUL,IPTRK,IPSYS,REC,NEL,LL4,ITY,NUN,NBMIX,
     1 MAT,VOL,IDL,NGRP,TITR,IPFLUX)
*
*-----------------------------------------------------------------------
*
*Purpose:
* solution of the neutron flux as an eigenvalue problem.
*
*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
* CMODUL  name of the assembly door ('BIVAC' or 'TRIVAC').
* IPTRK   L_TRACK pointer to the tracking information.
* IPSYS   L_SYSTEM pointer to system matrices.
* REC     flux recovery flag:
*         .true.: recover the existing solution as initial estimate;
*         .false.: use a uniform initial estimate.
* NEL     total number of finite elements.
* LL4     order of the system matrices.
* ITY     type of solution (2: classical Trivac; 3: Thomas-Raviart).
* NUN     total number of unknowns per group.
* NBMIX   number of material mixtures.
* MAT     index-number of the mixture type assigned to each volume.
* VOL     volumes.
* IDL     position of the average flux component associated with each
*         volume.
* NGRP    number of energy groups.
* TITR    title.
* IPFLUX  L_FLUX pointer to the solution.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      CHARACTER CMODUL*12,TITR*72
      TYPE(C_PTR) IPTRK,IPSYS,IPFLUX
      INTEGER NEL,LL4,ITY,NUN,NBMIX,MAT(NEL),IDL(NEL),NGRP
      REAL VOL(NEL)
      LOGICAL REC
*----
*  LOCAL VARIABLES
*----
      PARAMETER (NSTATE=40)
      CHARACTER TEXT4*4
      DOUBLE PRECISION DFLOTT
      LOGICAL ADJ,RAND
      INTEGER ISTATE(NSTATE)
      REAL EPSCON(3)
      REAL, DIMENSION(:), ALLOCATABLE :: FKEFFV
      REAL, DIMENSION(:,:), ALLOCATABLE :: EVECT
      REAL, DIMENSION(:,:,:), ALLOCATABLE :: EV,AD
      TYPE(C_PTR) JPFLUX,KPFLUX,MPFLUX,NPFLUX
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(EVECT(NUN,NGRP))
*
*-----------------------------------------------------------------------
* INFORMATION RECOVERED FROM L_SYSTEM AT IPSYS:
*  'A  1  1'  : SYSTEM MATRIX RELATED TO FAST LEAKAGE AND REMOVAL.
*  'A  2  2'  : SYSTEM MATRIX RELATED TO THERMAL LEAKAGE AND REMOVAL.
*  'A  1  2'  : SYSTEM MATRIX RELATED TO UP-SCATTERING.
*  'A  2  1'  : SYSTEM MATRIX RELATED TO DOWN-SCATTERING.
*  'B  1  1'  : SYSTEM MATRIX RELATED TO FAST FISSION.
*  'B  1  2'  : SYSTEM MATRIX RELATED TO THERMAL FISSION.
*-----------------------------------------------------------------------
*
*----
*  READ THE INPUT DATA
*----
      IMPX=1
      IMPH=0
      RAND=.FALSE.
      IF(REC) THEN
*        RECOVER EXISTING OPTIONS.
         CALL LCMGET(IPFLUX,'STATE-VECTOR',ISTATE)
         ADJ=MOD(ISTATE(3)/10,10).EQ.1
         LMOD=ISTATE(4)
         ICL1=ISTATE(8)
         ICL2=ISTATE(9)
         MAXINR=ISTATE(11)
         MAXOUT=ISTATE(12)
         NADI=ISTATE(13)
         CALL LCMGET(IPFLUX,'EPS-CONVERGE',EPSCON)
         EPSINR=EPSCON(1)
         EPSOUT=EPSCON(2)
      ELSE
*        DEFAULT OPTIONS.
         ADJ=.FALSE.
         LMOD=0
         ICL1=3
         ICL2=3
         MAXINR=0
         MAXOUT=200
         CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE)
         NADI=ISTATE(33)
         EPSINR=1.0E-2
         EPSOUT=1.0E-4
      ENDIF
*
   10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
      IF(INDIC.EQ.10) GO TO 170
   20 IF(INDIC.NE.3) CALL XABORT('FLDDRV: CHARACTER DATA EXPECTED.')
*
      IF((TEXT4.NE.'VAR1').AND.(TEXT4.NE.'ACCE')) GO TO 30
      CALL REDGET(INDIC,ICL1,FLOTT,TEXT4,DFLOTT)
      IF(INDIC.NE.1) CALL XABORT('FLDDRV: INTEGER DATA EXPECTED(1).')
      CALL REDGET(INDIC,ICL2,FLOTT,TEXT4,DFLOTT)
      IF(INDIC.NE.1) CALL XABORT('FLDDRV: INTEGER DATA EXPECTED(2).')
      GO TO 10
*
   30 IF(TEXT4.NE.'EDIT') GO TO 40
      CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT)
      IF(INDIC.NE.1) CALL XABORT('FLDDRV: INTEGER DATA EXPECTED(3).')
      GO TO 10
*
   40 IF(TEXT4.NE.'ADI') GO TO 50
      CALL REDGET(INDIC,NADI,FLOTT,TEXT4,DFLOTT)
      IF(INDIC.NE.1) CALL XABORT('FLDDRV: INTEGER DATA EXPECTED(4).')
      GO TO 10
*
   50 IF(TEXT4.NE.'ADJ') GO TO 60
      ADJ=.TRUE.
      GO TO 10
*
   60 IF(TEXT4.NE.'EXTE') GO TO 80
   70 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
      IF(INDIC.EQ.1) THEN
         MAXOUT=NITMA
      ELSE IF(INDIC.EQ.2) THEN
         EPSOUT=FLOTT
      ELSE
         GO TO 20
      ENDIF
      GO TO 70
*
   80 IF(TEXT4.NE.'THER') GO TO 100
   90 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
      IF(INDIC.EQ.1) THEN
         MAXINR=NITMA
      ELSE IF(INDIC.EQ.2) THEN
         EPSINR=FLOTT
      ELSE
         GO TO 20
      ENDIF
      GO TO 90
*
  100 IF(TEXT4.NE.'MONI') GO TO 110
      CALL REDGET(INDIC,LMOD,FLOTT,TEXT4,DFLOTT)
      IF(INDIC.NE.1) CALL XABORT('FLDDRV: INTEGER DATA EXPECTED(5).')
      IF(LMOD.LE.0) CALL XABORT('FLDDRV: INVALID VALUE OF LMOD.')
      GO TO 10
*
  110 IF(TEXT4.NE.'RAND') GO TO 120
      RAND=.TRUE.
      GO TO 10
*
  120 IF(TEXT4.NE.'HIST') GO TO 160
      CALL REDGET(INDIC,IMPH,FLOTT,TEXT4,DFLOTT)
      IF(INDIC.NE.1) CALL XABORT('FLDDRV: INTEGER DATA EXPECTED(6).')
      GO TO 10
*
  160 IF(TEXT4.NE.';') CALL XABORT('FLDDRV: '//TEXT4//' IS AN INVALID '
     1 //'KEY WORD.')
*----
*  FLUXES INITIALIZATION
*----
  170 IF(REC.AND.(IMPH.EQ.0)) THEN
         CALL LCMLEN(IPFLUX,'FLUX',ILONG,ITYLCM)
         IF(ILONG.NE.NGRP) CALL XABORT('FLDDRV: UNABLE TO RECOVER ''FLU'
     1   //'X''.')
         JPFLUX=LCMGID(IPFLUX,'FLUX')
         DO 180 IGR=1,NGRP
         CALL LCMGDL(JPFLUX,IGR,EVECT(1,IGR))
  180    CONTINUE
      ELSE
*        INITIAL ESTIMATE OF THE DIRECT FLUXES.
         CALL XDRSET(EVECT,NGRP*NUN,1.0)
      ENDIF
*
      IF(LMOD.GT.0) THEN
*        BI-ORTHOGONAL HARMONIC CALCULATION.
         IF(CMODUL.NE.'TRIVAC') CALL XABORT('FLDDRV: HARMONIC CALCULAT'
     1   //'ION IS ONLY POSSIBLE WITH TRIVAC.')
         ALLOCATE(FKEFFV(LMOD),EV(NUN,NGRP,LMOD),AD(NUN,NGRP,LMOD))
         CALL FLDMON(IPTRK,IPSYS,IPFLUX,LL4,ITY,NUN,NGRP,LMOD,ICL1,
     1   ICL2,IMPX,IMPH,TITR,EPSOUT,NADI,MAXOUT,MAXINR,EPSINR,RAND,
     2   FKEFFV,EV,AD)
         JPFLUX=LCMLID(IPFLUX,'MODE',LMOD)
         DO 200 IMOD=1,LMOD
*        CREATE A DIRECTORY AT IMOD-TH LIST ELEMENT.
         KPFLUX=LCMDIL(JPFLUX,IMOD)
*        PUT THREE NODES IN DIRECTORY KPFLUX.
         CALL LCMPUT(KPFLUX,'K-EFFECTIVE',1,2,FKEFFV(IMOD))
         CALL LCMPUT(KPFLUX,'K-INFINITY',1,2,FKEFFV(IMOD))
         MPFLUX=LCMLID(KPFLUX,'FLUX',NGRP)
         NPFLUX=LCMLID(KPFLUX,'AFLUX',NGRP)
*        STORE FLUX AND ADJOINT FLUX IN THE IGR-TH COMPONENT OF EACH
*        LIST.
         DO 190 IGR=1,NGRP
         CALL FLDTRI(IPTRK,NEL,NUN,EV(1,IGR,IMOD),MAT,VOL,IDL)
         CALL FLDTRI(IPTRK,NEL,NUN,AD(1,IGR,IMOD),MAT,VOL,IDL)
  190    CONTINUE
         CALL FLDNOR(IPSYS,NUN,NGRP,NEL,NBMIX,MAT,VOL,IDL,'DIRE',
     1   EV(1,IGR,IMOD))
         CALL FLDNOR(IPSYS,NUN,NGRP,NEL,NBMIX,MAT,VOL,IDL,'ADJO',
     1   AD(1,IGR,IMOD))
         CALL LCMPDL(MPFLUX,IGR,NUN,2,EV(1,IGR,IMOD))
         CALL LCMPDL(NPFLUX,IGR,NUN,2,AD(1,IGR,IMOD))
  200    CONTINUE
         DEALLOCATE(AD,EV,FKEFFV)
      ELSE
*        DIRECT NEUTRON FLUX CALCULATION.
         IF(CMODUL.EQ.'BIVAC') THEN
            CALL FLDSMB(IPTRK,IPSYS,IPFLUX,LL4,ITY,NUN,NGRP,ICL1,ICL2,
     1      IMPX,IMPH,TITR,EPSOUT,MAXOUT,MAXINR,EPSINR,EVECT,FKEFF)
            DO 210 IGR=1,NGRP
            CALL FLDBIV(IPTRK,NEL,NUN,EVECT(1,IGR),MAT,VOL,IDL)
  210       CONTINUE
         ELSE IF(CMODUL.EQ.'TRIVAC') THEN
            CALL FLDDIR(IPTRK,IPSYS,IPFLUX,LL4,ITY,NUN,NGRP,ICL1,ICL2,
     1      IMPX,IMPH,TITR,EPSOUT,NADI,MAXOUT,MAXINR,EPSINR,EVECT,FKEFF)
            DO 220 IGR=1,NGRP
            CALL FLDTRI(IPTRK,NEL,NUN,EVECT(1,IGR),MAT,VOL,IDL)
  220       CONTINUE
         ENDIF
         CALL FLDNOR(IPSYS,NUN,NGRP,NEL,NBMIX,MAT,VOL,IDL,'DIRE',EVECT)
         CALL LCMPUT(IPFLUX,'K-EFFECTIVE',1,2,FKEFF)
         CALL LCMPUT(IPFLUX,'K-INFINITY',1,2,FKEFF)
         JPFLUX=LCMLID(IPFLUX,'FLUX',NGRP)
         DO 230 IGR=1,NGRP
         CALL LCMPDL(JPFLUX,IGR,NUN,2,EVECT(1,IGR))
  230    CONTINUE
      ENDIF
*----
*  ADJOINT NEUTRON FLUX CALCULATION
*----
      IF(ADJ) THEN
         IF(CMODUL.NE.'TRIVAC') CALL XABORT('FLDDRV: ADJOINT CALCULATI'
     1   //'ON IS ONLY POSSIBLE WITH TRIVAC.')
*        ADJOINT FLUX INITIALIZATION.
         IF(REC.AND.(IMPH.EQ.0)) THEN
            CALL LCMLEN(IPFLUX,'AFLUX',ILONG,ITYLCM)
            IF(ILONG.NE.NGRP) CALL XABORT('FLDDRV: UNABLE TO RECOVER AF'
     1      //'LUX.')
            JPFLUX=LCMGID(IPFLUX,'AFLUX')
            DO 240 IGR=1,NGRP
            CALL LCMGDL(JPFLUX,IGR,EVECT(1,IGR))
  240       CONTINUE
         ELSE
*           INITIAL ESTIMATE OF THE ADJOINT FLUXES.
            CALL XDRSET(EVECT,NGRP*NUN,1.0)
         ENDIF
*
         CALL FLDADJ(IPTRK,IPSYS,LL4,ITY,NUN,NGRP,ICL1,ICL2,IMPX,EPSOUT,
     1   NADI,MAXOUT,MAXINR,EPSINR,EVECT,FKEFF)
         CALL LCMPUT(IPFLUX,'AK-EFFECTIVE',1,2,FKEFF)
         CALL LCMPUT(IPFLUX,'AK-INFINITY',1,2,FKEFF)
         JPFLUX=LCMLID(IPFLUX,'AFLUX',NGRP)
         DO 260 IGR=1,NGRP
         CALL FLDTRI(IPTRK,NEL,NUN,EVECT(1,IGR),MAT,VOL,IDL)
  260    CONTINUE
         CALL FLDNOR(IPSYS,NUN,NGRP,NEL,NBMIX,MAT,VOL,IDL,'ADJO',EVECT)
         DO 270 IGR=1,NGRP
         CALL LCMPDL(JPFLUX,IGR,NUN,2,EVECT(1,IGR))
  270    CONTINUE
      ENDIF
*----
* SET STATE-VECTOR AND EPS-CONVERGE
*----
      CALL XDISET(ISTATE,NSTATE,0)
      ISTATE(1)=NGRP
      ISTATE(2)=NUN
      ISTATE(3)=1
      IF(ADJ) ISTATE(3)=11
      ISTATE(4)=LMOD
      ISTATE(5)=0
      ISTATE(6)=2
      ISTATE(7)=0
      ISTATE(8)=ICL1
      ISTATE(9)=ICL2
      ISTATE(10)=0
      ISTATE(11)=MAXINR
      ISTATE(12)=MAXOUT
      ISTATE(13)=NADI
      CALL LCMPUT(IPFLUX,'STATE-VECTOR',NSTATE,1,ISTATE)
      EPSCON(1)=EPSINR
      EPSCON(2)=EPSOUT
      EPSCON(3)=EPSOUT
      CALL LCMPUT(IPFLUX,'EPS-CONVERGE',3,2,EPSCON)
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(EVECT)
      RETURN
      END
