*DECK KINST1
      SUBROUTINE KINST1(NEN,KEN,CMOD,NGR,NBM,NBFIS,NDG,NEL,NUN,LL4,NUP,
     1 IDLPC,INORM,POWER,FNORM,DNF,DNS,PDC,LNUD,LCHD,IMPX)
*
*-----------------------------------------------------------------------
*
*Purpose:
* recover the initial steady-state solution.
*
*Copyright:
* Copyright (C) 2008 Ecole Polytechnique de Montreal.
*
*Author(s): D. Sekki
*
*Parameters: input/output
* NEN    number of LCM objects used in the module.
* KEN    addresses of LCM objects: (1) L_KINET; (2) L_MACROLIB;
*        (3) L_TRACK; (4) L_SYSTEM; (5) L_FLUX.
* CMOD   name of the assembly door (BIVAC or TRIVAC).
* NGR    number of energy groups.
* NBM    number of material mixtures.
* NBFIS  number of fissile isotopes.
* NDG    number of delayed-neutron groups.
* NEL    total number of finite elements.
* NUN    total number of unknowns per energy group.
* LL4    order of system matrices.
* NUP    total number of precursor unknowns per precursor group.
* IDLPC  position of averaged precursor values in unknown vector.
* INORM  type of flux normalization (=0: no normalization; =1: imposed
*        factor; =2: maximum flux; =3 initial power).
* POWER  initial power.
* FNORM  normalization factor for the flux.
* DNF    delayed neutron fractions.
* DNS    delayed neutron spectrum (from input).
* PDC    precursor decay constants.
* LNUD   flag: =.true. if DNF provided from module input.
* LCHD   flag: =.true. if DNS provided from module input.
* IMPX   printing parameter (=0 for no print).
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) KEN(NEN)
      INTEGER NEN,NGR,NBM,NBFIS,NDG,NEL,NUN,LL4,NUP,IDLPC(NEL),INORM
      CHARACTER CMOD*12
      REAL POWER,FNORM,DNS(NDG,NGR),PDC(NDG),DNF(NDG)
      LOGICAL LNUD,LCHD
*----
*  LOCAL VARIABLES
*----
      PARAMETER(NSTATE=40,IOS=6,ITR=0)
      INTEGER ISTATE(NSTATE),MAT(NEL),IDL(NEL)
      REAL VOL(NEL),PMAX(NDG,NBFIS)
      TYPE(C_PTR) JPFLX
      REAL, DIMENSION(:), ALLOCATABLE :: GAR,RM
      REAL, DIMENSION(:,:), ALLOCATABLE :: EVECT,OVR
      REAL, DIMENSION(:,:,:), ALLOCATABLE :: PC,CHI,SGF
      REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: SGD,CHD
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(EVECT(NUN,NGR),PC(NUP,NDG,NBFIS),SGD(NBM,NBFIS,NGR,NDG))
*----
*  RECOVER THE TYPE OF ASSEMBLY
*----
      CALL XDISET(ISTATE,NSTATE,0)
      CALL LCMGET(KEN(4),'STATE-VECTOR',ISTATE)
      ITY=ISTATE(4)
*----
*  RECOVER THE INITIAL FLUX UNKNOWN VECTOR
*----
      CALL LCMGET(KEN(3),'MATCOD',MAT)
      CALL LCMGET(KEN(3),'VOLUME',VOL)
      CALL LCMGET(KEN(3),'KEYFLX',IDL)
      CALL XDISET(ISTATE,NSTATE,0)
      CALL LCMGET(KEN(3),'STATE-VECTOR',ISTATE)
      IGM=ISTATE(6)
      IF(IMPX.GT.1) WRITE(IOS,1001) NUN
      CALL XDRSET(EVECT,NUN*NGR,0.)
      CALL LCMGET(KEN(5),'K-EFFECTIVE',FKEFF)
      JPFLX=LCMGID(KEN(5),'FLUX')      
      DO 10 IGR=1,NGR
      CALL LCMGDL(JPFLX,IGR,EVECT(1,IGR))
   10 CONTINUE
*----
*  FIND THE MAXIMUM FLUX VALUE
*----
      FMAX=0.0
      IDMX=0
      DO 20 IGR=1,NGR
      DO 20 IEL=1,NEL
      IND=IDL(IEL)
      IF(IND.EQ.0) GO TO 20
      IF(ABS(EVECT(IND,IGR)).GT.FMAX) THEN
        FMAX=EVECT(IND,IGR)
        IDMX=IEL
        IGMX=IGR
      ENDIF
   20 CONTINUE
      IF(IDMX.EQ.0) CALL XABORT('KINST1: UNABLE TO SET FMAX.')
*----
*  NORMALIZE THE FLUX
*----
      IF(INORM.EQ.2) THEN
        FNORM=1.0/FMAX
      ELSE IF(INORM.EQ.3) THEN
        CALL KINPOW(KEN(2),NGR,NBM,NUN,NEL,MAT,VOL,IDL,EVECT,POWTOT)
        FNORM=POWER/POWTOT
        CALL LCMPUT(KEN(1),'POWER-INI',1,2,POWER)
        CALL LCMPUT(KEN(1),'E-POW',1,2,POWER)
        IF(IMPX.GT.0) WRITE(6,*) 'INITIAL REACTOR POWER (W) =',POWER
      ENDIF
      DO 30 IGR=1,NGR
      DO 30 IND=1,NUN
   30 EVECT(IND,IGR)=EVECT(IND,IGR)*FNORM
      FMAX=FMAX*FNORM
      IF(IMPX.GE.5)THEN
        DO 40 IGR=1,NGR
   40   WRITE(IOS,1003) IGR,(EVECT(I,IGR),I=1,NUN)
      ENDIF
*----
*  RECOVER CROSS SECTIONS
*----
      ALLOCATE(OVR(NBM,NGR),CHI(NBM,NBFIS,NGR),CHD(NBM,NBFIS,NGR,NDG),
     1 SGF(NBM,NBFIS,NGR))
      DT=1.0
      CALL KINXSD(KEN(2),NGR,NBM,NBFIS,NDG,FKEFF,DT,DNF,DNS,LNUD,LCHD,
     1 OVR,CHI,CHD,SGF,SGD)
      DEALLOCATE(SGF,CHD,CHI,OVR)
*----
*  INITIAL PRECURSOR UNKNOWN VECTOR
*----
      CALL XDRSET(PC,NUP*NDG*NBFIS,0.)
      IF(IMPX.GT.1)WRITE(IOS,1005)
      ALLOCATE(GAR(NUN))
      DO 90 IFIS=1,NBFIS
      DO 90 IDG=1,NDG
      IF(CMOD.EQ.'BIVAC')THEN
        DO 50 IGR=1,NGR
        CALL KINBLM(KEN(3),NBM,NUP,SGD(1,IFIS,IGR,IDG),EVECT(1,IGR),
     1  GAR)
        DO 50 IND=1,NUP
   50   PC(IND,IDG,IFIS)=PC(IND,IDG,IFIS)+GAR(IND)
        CALL MTLDLS('RM',KEN(3),KEN(4),LL4,1,PC(1,IDG,IFIS))
      ELSEIF(CMOD.EQ.'TRIVAC')THEN
        DO 60 IGR=1,NGR
        CALL KINTLM(KEN(3),NBM,NUP,SGD(1,IFIS,IGR,IDG),EVECT(1,IGR),
     1  GAR)
        DO 60 IND=1,NUP
   60   PC(IND,IDG,IFIS)=PC(IND,IDG,IFIS)+GAR(IND)
        CALL LCMLEN(KEN(4),'RM',ILONG,ITYLCM)
        CALL LCMLIB(KEN(4))
        ALLOCATE(RM(ILONG))
        CALL LCMGET(KEN(4),'RM',RM)
        DO 70 IND=1,ILONG
        FACT=RM(IND)
        IF(FACT.EQ.0.0) CALL XABORT('KINST1: SINGULAR RM.')
   70   PC(IND,IDG,IFIS)=PC(IND,IDG,IFIS)/FACT
        DEALLOCATE(RM)
      ENDIF
      DO 80 IND=1,NUP
   80 PC(IND,IDG,IFIS)=PC(IND,IDG,IFIS)/PDC(IDG)
      IF(CMOD.EQ.'BIVAC')THEN
        CALL FLDBIV(KEN(3),NEL,NUP,PC(1,IDG,IFIS),MAT,VOL,IDLPC)
      ELSEIF(CMOD.EQ.'TRIVAC')THEN
        CALL FLDTRI(KEN(3),NEL,NUP,PC(1,IDG,IFIS),MAT,VOL,IDLPC)
      ENDIF
   90 CONTINUE
      DEALLOCATE(GAR)
      IF(IMPX.GT.5) THEN
        WRITE(IOS,1006)
        DO 100 IFIS=1,NBFIS
        DO 100 IDG=1,NDG
        WRITE(IOS,1007) IDG,IFIS,(PC(IND,IDG,IFIS),IND=1,LL4)
  100   CONTINUE
      ENDIF
*----
*  FIND THE PRECURSOR CORRESPONDING TO MAXIMUM FLUX
*----
      IND=IDLPC(IDMX)
      IF(IND.EQ.0) CALL XABORT('KINST1: UNABLE TO SET PMAX.')
      DO 110 IFIS=1,NBFIS
      DO 110 IDG=1,NDG
  110 PMAX(IDG,IFIS)=PC(IND,IDG,IFIS)
      IF(IMPX.GT.0) WRITE(IOS,1002) FMAX,IDMX,IGMX
*----
*  PRINT AVERAGED PRECURSOR VALUES
*----
      IF(IMPX.GT.1) THEN
        DO 130 IFIS=1,NBFIS
        WRITE(IOS,1008) IFIS,(IDG,IDG=1,NDG)
        DO 120 IEL=1,NEL
        IND=IDLPC(IEL)
        WRITE(IOS,1009) IEL,(PC(IND,IDG,IFIS),IDG=1,NDG)
  120   CONTINUE
        WRITE(IOS,'(/)')
  130   CONTINUE
      ENDIF
*----
*  L_KINET STATE-VECTOR
*----
      CALL XDISET(ISTATE,NSTATE,0)
      ISTATE(1)=ITR
      ISTATE(2)=NDG
      ISTATE(3)=NGR
      ISTATE(4)=IGM
      ISTATE(5)=NEL
      ISTATE(6)=NUN
      ISTATE(7)=LL4
      ISTATE(8)=NUP
      ISTATE(9)=NBFIS
      ISTATE(10)=ITY
      ISTATE(13)=INORM
      CALL LCMPUT(KEN(1),'STATE-VECTOR',NSTATE,1,ISTATE)
      CALL LCMPUT(KEN(1),'E-IDLPC',NEL,1,IDLPC)
      CALL LCMPUT(KEN(1),'E-VECTOR',NUN*NGR,2,EVECT)
      CALL LCMPUT(KEN(1),'E-PREC',NUP*NDG*NBFIS,2,PC)
      CALL LCMPUT(KEN(1),'E-KEFF',1,2,FKEFF)
      CALL LCMPUT(KEN(1),'LAMBDA-D',NDG,2,PDC)
      IF(LNUD) CALL LCMPUT(KEN(1),'BETA-D',NDG,2,DNF)
      IF(LCHD) CALL LCMPUT(KEN(1),'CHI-D',NDG*NGR,2,DNS)
      CALL LCMPUT(KEN(1),'CTRL-FLUX',1,2,FMAX)
      CALL LCMPUT(KEN(1),'CTRL-PREC',NDG*NBFIS,2,PMAX)
      CALL LCMPUT(KEN(1),'CTRL-IDL',1,1,IDMX)
      CALL LCMPUT(KEN(1),'CTRL-IGR',1,1,IGMX)
      IF(IMPX.GT.2) CALL LCMLIB(KEN(1))
      IF(IMPX.GE.1) WRITE (IOS,1010) IMPX,(ISTATE(I),I=1,10),ISTATE(13)
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(SGD,PC,EVECT)
      RETURN
*
 1001 FORMAT(1X,'RECOVERING THE INITIAL UNKNOWN VECTOR',
     1 1X,'FOR FLUXES'/1X,'TOTAL NUMBER OF UNKNOWNS PE',
     2 'R',1X,'ENERGY GROUP',1X,I6/)
 1002 FORMAT(/1X,'CONTROLLING PARAMETERS:',2X,'MAX-VA',
     1 'L',1X,1PE12.5,3X,'IDL #',I5.5,3X,'IGR #',I2.2/)
 1003 FORMAT(/1X,'=> INITIAL UNKNOWN FLUX VECTOR CORR',
     1 'ESPONDING TO THE GROUP #',I2.2//(1P,8E14.5,5X))
 1005 FORMAT(/1X,'COMPUTING THE INITIAL UNKNOWN VECTOR',
     1 1X,'FOR PRECURSORS'/)
 1006 FORMAT(/1X,'=> INITIAL PRECURSOR UNKNOWN VECTOR')
 1007 FORMAT(/17H PRECURSOR GROUP=,I5,18H  FISSILE ISOTOPE=,I5/
     1 (1P,8E14.5))
 1008 FORMAT(/52H KINST1: AVERAGED PRECURSOR VALUES (FISSILE ISOTOPE=,
     1 I5,1H)/(9X,6I13,:))
 1009 FORMAT(1X,I6,2X,1P,6E13.5,:/(9X,6E13.5,:))
 1010 FORMAT(/8H OPTIONS/8H -------/
     1 7H IMPX  ,I6,30H   (0=NO PRINT/1=SHORT/2=MORE)/
     2 7H ITR   ,I6,28H   (CURRENT TIME SPEP INDEX)/
     3 7H NDG   ,I6,39H   (NUMBER OF PRECURSOR DELAYED GROUPS)/
     4 7H NGR   ,I6,28H   (NUMBER OF ENERGY GROUPS)/
     5 7H IGM   ,I6,21H   (TYPE OF GEOMETRY)/
     6 7H NEL   ,I6,30H   (NUMBER OF FINITE ELEMENTS)/
     7 7H NUN   ,I6,46H   (TOTAL NUMBER OF UNKNOWNS PER ENERGY GROUP)/
     8 7H LL4   ,I6,45H   (NUMBER OF FLUX UNKNOWNS PER ENERGY GROUP)/
     9 7H NUP   ,I6,47H   (NUMBER OF PRECURSORS UNKNOWNS PER DELAYED G,
     1 5HROUP)/
     2 7H NBFIS ,I6,31H   (NUMBER OF FISSILE ISOTOPES)/
     3 7H ITY   ,I6,28H   (TYPE OF SYSTEM MATRICES)/
     4 7H INORM ,I6,47H   (0=NO FLUX NORMALIZATION/1=FIXED/2=MAXIMUM/3,
     5 7H=POWER))
      END
