*DECK PNF
      SUBROUTINE PNF(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 spherical
* harmonics (PN) method in BIVAC.
*
*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
*----
      TYPE(C_PTR) KPSYS,IPTRK
      CHARACTER   TITR*72
      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,MAXIT=20,EPSINR=1.0E-5,ICL1=3,
     1            ICL2=3)
      INTEGER     IPAR(NSTATE)
      DOUBLE PRECISION F1,F2,R1,R2,DMU
      CHARACTER   NAMP*12
      LOGICAL     LBIHET
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: MU,KN,IPERT
      REAL, ALLOCATABLE, DIMENSION(:) :: SUNKN,QFR,SGDI,RR,VV,SYS,OLD1,
     1 OLD2,XX,YY,FGAR
*----
*  RECOVER PN SPECIFIC PARAMETERS.
*----
      IF(IDIR.NE.0) CALL XABORT('PNF: EXPECTING IDIR=0')
      IF(IFTRAK.NE.0) CALL XABORT('PNF: EXPECTING IFTRAK=0')
      CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR)
      IF(NREG.NE.IPAR(1)) CALL XABORT('PNF: INVALID VALUE OF NREG.')
      IF(NUN.NE.IPAR(2)) CALL XABORT('PNF: INVALID VALUE OF NUN.')
      ITYPE=IPAR(6)
      IELEM=IPAR(8)
      ICOL=IPAR(9)
      ISPLH=IPAR(10)
      L4=IPAR(11)
      LX=IPAR(12)
      NLF=IPAR(14)
      ISPN=IPAR(15)
      ISCAT=IPAR(16)
      NVD=IPAR(17)
      LBIHET=IPAR(40).NE.0
      IF(IMPX.GT.3) 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,'(//6H PNF: ,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 5 I=1,NUN
    5    SUNKN(I)=SUNKNO(I)
         NREGAR=NREG
         NBMIXG=NBMIX
         CALL DOORFB2(KPSYS,IPTRK,IMPX,NBMIX,NREG,NUN,KEYFLX,NBMIX2,
     1   NREG2,SUNKNO)
         NREG=NREG2
         NBMIX=NBMIX2
         CALL LCMSIX(KPSYS,'BIHET',1)
      ENDIF
*
      ALLOCATE(MU(L4))
      CALL LCMGET(IPTRK,'MU',MU)
      CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM)
      CALL LCMLEN(IPTRK,'QFR',MAXQF,ITYLCM)
      ALLOCATE(KN(MAXKN),QFR(MAXQF))
      CALL LCMGET(IPTRK,'KN',KN)
      CALL LCMGET(IPTRK,'QFR',QFR)
*----
*  RECOVER CROSS SECTIONS.
*----
      CALL LCMGET(KPSYS,'STATE-VECTOR',IPAR)
      NAN=IPAR(8)
      ALLOCATE(SGDI(NBMIX*NAN))
      DO 10 IL=0,NAN-1
      WRITE(NAMP,'(4HSCAI,I2.2,6H001001)') IL
      CALL LCMGET(KPSYS,NAMP,SGDI(IL*NBMIX+1))
   10 CONTINUE
*----
*  RECOVER THE FINITE ELEMENT UNIT STIFFNESS MATRIX.
*----
      CALL LCMSIX(IPTRK,'BIVCOL',1)
      CALL LCMLEN(IPTRK,'T',LC,ITYLCM)
      ALLOCATE(RR(LC*LC),VV(LC*(LC-1)))
      CALL LCMGET(IPTRK,'R',RR)
      CALL LCMGET(IPTRK,'V',VV)
      CALL LCMSIX(IPTRK,' ',2)
*----
*  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
*----
*  INNER ITERATION LOOP FOR ONE-GROUP TRANSPORT EQUATION.
*----
      IIMAX=MU(L4)*(NLF/2)
      ALLOCATE(SYS(IIMAX))
      CALL LCMGET(KPSYS,'IA001001',SYS)
      ALLOCATE(OLD1(NUN),OLD2(NUN))
      CALL XDRSET(OLD2,NUN,0.0)
      TEST=0.0
      ITER=0
   30 ITER=ITER+1
      IF(ITER.GT.MAXIT) THEN
         WRITE(IUNOUT,'(43H PNF: MAXIMUM NUMBER OF ONE-SPEED ITERATION,
     1   9H REACHED.)')
         GO TO 100
      ENDIF
      DO 40 I=1,NUN
      OLD1(I)=OLD2(I)
   40 OLD2(I)=FUNKNO(I)
      IF((ITYPE.EQ.2).OR.((ITYPE.EQ.5).AND.(ISPN.EQ.1))) THEN
         ALLOCATE(XX(NREG),YY(NREG))
         CALL LCMGET(IPTRK,'XX',XX)
         CALL LCMGET(IPTRK,'YY',YY)
         CALL PNFL2E(NREG,IELEM,ICOL,XX,YY,MAT,VOL,NBMIX,NLF,NVD,
     1   NAN,SGDI,L4,KN,QFR,MU,IIMAX,LC,RR,VV,SYS,SUNKNO,FUNKNO)
         DEALLOCATE(YY,XX)
      ELSE IF((ITYPE.EQ.2).OR.((ITYPE.EQ.8).AND.(ISPN.EQ.1))) THEN
         NBLOS=LX/3
         ALLOCATE(IPERT(NBLOS))
         CALL LCMGET(IPTRK,'SIDE',SIDE)
         CALL LCMGET(IPTRK,'IPERT',IPERT)
         CALL PNFH2E(IELEM,ICOL,NBLOS,SIDE,NLF,NVD,L4,IPERT,KN,QFR,MU,
     1   IIMAX,LC,VV,SYS,SUNKNO,FUNKNO)
         DEALLOCATE(IPERT)
      ELSE
         CALL XABORT('PNF: TYPE OF DISCRETIZATION NOT IMPLEMENTED.')
      ENDIF
      IF(NLF.EQ.2) GO TO 100
*----
*  VARIATIONAL ACCELERATION.
*----
      IF(MOD(ITER-1,ICL1+ICL2).GE.ICL1) THEN
         F1=0.0
         F2=0.0
         DO  70 I=1,NUN
         R1=OLD2(I)-OLD1(I)
         R2=FUNKNO(I)-OLD2(I)
         F1=F1+R1*(R2-R1)
   70    F2=F2+(R2-R1)*(R2-R1)
         DMU=-F1/F2
         IF(DMU.GT.0.0) THEN
            DO  80 I=1,NUN
            FUNKNO(I)=OLD2(I)+REAL(DMU)*(FUNKNO(I)-OLD2(I))
            OLD2(I)=OLD1(I)+REAL(DMU)*(OLD2(I)-OLD1(I))
   80       CONTINUE
         ENDIF
      ENDIF      
      AAA=0.0
      BBB=0.0
      DO 90 I=1,NREG
      IF(KEYFLX(I).EQ.0) GO TO 90
      AAA=MAX(AAA,ABS(FUNKNO(KEYFLX(I))-OLD2(KEYFLX(I))))
      BBB=MAX(BBB,ABS(FUNKNO(KEYFLX(I))))
   90 CONTINUE
      IF(IMPX.GT.1) WRITE(IUNOUT,300) ITER,AAA,BBB,DMU
      IF(AAA.LE.EPSINR*BBB) GO TO 100
      IF(ITER.EQ.1) TEST=AAA
      IF((ITER.GE.10).AND.(AAA.GT.TEST)) THEN
         WRITE(IUNOUT,'(43H PNF: UNABLE TO CONVERGE ONE-SPEED ITERATIO,
     1   3HNS.)')
         GO TO 100
      ENDIF
      GO TO 30
  100 DEALLOCATE(OLD2,OLD1,SYS,VV,RR,SGDI,QFR,KN,MU)
*----
*  DIVISION OF THE EVEN-PARITY SOURCES BY THE VOLUMES.
*----
      DO 130 K=1,NREG
      IF(MAT(K).EQ.0) GO TO 130
      JND1=KEYFLX(K)
      SUNKNO(JND1)=SUNKNO(JND1)/VOL(K)
  130 CONTINUE
*
      IF((IMPX.GT.0).AND.(NLF.GT.2)) WRITE(IUNOUT,'(15H PNF: NUMBER OF,
     1 22H ONE-SPEED ITERATIONS=,I5,1H.)') ITER
*----
*  DOUBLE HETEROGENEITY TREATMENT
*----
      IF(LBIHET) THEN
         CALL LCMSIX(KPSYS,' ',2)
         NREG=NREGAR
         NBMIX=NBMIXG
         DO 140 I=1,NUN
  140    SUNKNO(I)=SUNKN(I)
         DEALLOCATE(SUNKN)
         CALL DOORFB3(KPSYS,IPTRK,IMPX,NBMIX,NREG,NUN,KEYFLX,SUNKNO,
     1   FUNKNO)
      ENDIF
*
      IF(IMPX.GT.3) 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
  300 FORMAT(25H PNF: ONE-SPEED ITERATION,I3,8H  ERROR=,1P,E11.4,
     1 5H OVER,E11.4,22H  ACCELERATION FACTOR=,0P,F7.3)
      END
