*DECK FLDBHR
      SUBROUTINE FLDBHR(IPTRK,IPSYS,LADJ,LL4,NUN,NGRP,ICL1,ICL2,IMPX,
     1 MAXINR,EPSINR,TKT,TKB,GRAD1)
*
*-----------------------------------------------------------------------
*
*Purpose:
* perform thermal (up-scattering) iterations in Bivac.
*
*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
* IPTRK   L_TRACK pointer to the tracking information.
* IPSYS   L_SYSTEM pointer to system matrices.
* LADJ    flag set to .TRUE. for adjoint solution acceleration.
* LL4     order of the system matrices.
* NUN     number of unknowns in each energy group.
* NGRP    number of energy groups.
* ICL1    number of free iretations in one cycle of the inverse power
*         method.
* ICL2    number of accelerated iterations in one cycle.
* IMPX    print parameter (set to 0 for no printing).
* MAXINR  maximum number of thermal iterations.
* EPSINR  thermal iteration epsilon.
*
*Parameters: input/output
* TKT     CPU time spent to compute the solution of linear systems.
* TKB     CPU time spent to compute the bilinear products.
* GRAD1   delta flux for this outer iteration.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPTRK,IPSYS
      INTEGER LL4,NUN,NGRP,ICL1,ICL2,IMPX,MAXINR
      REAL EPSINR,TKT,TKB,GRAD1(NUN,NGRP)
      LOGICAL LADJ
*----
*  LOCAL VARIABLES
*----
      CHARACTER TEXT12*12,TEXT3*3
      REAL, DIMENSION(:), ALLOCATABLE :: WORK2
      REAL, DIMENSION(:,:), ALLOCATABLE :: GAR2
      REAL, DIMENSION(:,:,:), ALLOCATABLE :: WORK
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(GAR2(NUN,NGRP),WORK(LL4,NGRP,3),WORK2(LL4))
*
      NCTOT=ICL1+ICL2
      IF(ICL2.EQ.0) THEN
         NCPTM=NCTOT+1
      ELSE
         NCPTM=ICL1
      ENDIF
      DO 10 IGR=1,NGRP
      DO 10 I=1,LL4
      WORK(I,IGR,1)=0.0
      WORK(I,IGR,2)=0.0
   10 WORK(I,IGR,3)=GRAD1(I,IGR)
      IGDEB=1
*----
*  PERFORM THERMAL (UP-SCATTERING) ITERATIONS
*----
      TEXT3='NO '
      DO 150 ITER=2,MAXINR
      CALL KDRCPU(TK1)
      IF(LADJ) THEN
*        ADJOINT SOLUTION
         DO 30 IGR=IGDEB,NGRP
         WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR
         CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,1,WORK(1,IGR,3),GAR2(1,IGR))
         DO 30 JGR=1,NGRP
         IF(JGR.EQ.IGR) GO TO 30
         WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR
         CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM)
         IF(ILONG.EQ.0) GO TO 30
         CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,1,WORK(1,JGR,3),WORK2)
         DO 20 I=1,LL4
   20    GAR2(I,IGR)=GAR2(I,IGR)-WORK2(I)
   30    CONTINUE
         DO 60 IGR=NGRP,IGDEB,-1
         DO 50 JGR=NGRP,IGR+1,-1
         WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR
         CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM)
         IF(ILONG.EQ.0) GO TO 50
         CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,1,GAR2(1,JGR),WORK2)
         DO 40 I=1,LL4
   40    GAR2(I,IGR)=GAR2(I,IGR)+WORK2(I)
   50    CONTINUE
         CALL KDRCPU(TK2)
         TKB=TKB+(TK2-TK1)
*
         CALL KDRCPU(TK1)
         WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR
         CALL MTLDLS(TEXT12,IPTRK,IPSYS,LL4,1,GAR2(1,IGR))
         DO 60 I=1,LL4
         WORK(I,IGR,1)=WORK(I,IGR,2)
         WORK(I,IGR,2)=WORK(I,IGR,3)
   60    WORK(I,IGR,3)=GRAD1(I,IGR)+(WORK(I,IGR,2)-GAR2(I,IGR))
      ELSE
*        DIRECT SOLUTION
         DO 80 IGR=IGDEB,NGRP
         WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR
         CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,1,WORK(1,IGR,3),GAR2(1,IGR))
         DO 80 JGR=1,NGRP
         IF(JGR.EQ.IGR) GO TO 80
         WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR
         CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM)
         IF(ILONG.EQ.0) GO TO 80
         CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,1,WORK(1,JGR,3),WORK2)
         DO 70 I=1,LL4
   70    GAR2(I,IGR)=GAR2(I,IGR)-WORK2(I)
   80    CONTINUE
         DO 110 IGR=IGDEB,NGRP
         DO 100 JGR=1,IGR-1
         WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR
         CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM)
         IF(ILONG.EQ.0) GO TO 100
         CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,1,GAR2(1,JGR),WORK2)
         DO 90 I=1,LL4
   90    GAR2(I,IGR)=GAR2(I,IGR)+WORK2(I)
  100    CONTINUE
         CALL KDRCPU(TK2)
         TKB=TKB+(TK2-TK1)
*
         CALL KDRCPU(TK1)
         WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR
         CALL MTLDLS(TEXT12,IPTRK,IPSYS,LL4,1,GAR2(1,IGR))
         DO 110 I=1,LL4
         WORK(I,IGR,1)=WORK(I,IGR,2)
         WORK(I,IGR,2)=WORK(I,IGR,3)
  110    WORK(I,IGR,3)=GRAD1(I,IGR)+(WORK(I,IGR,2)-GAR2(I,IGR))
      ENDIF
      IF(MOD(ITER-2,NCTOT).GE.NCPTM) THEN
         CALL FLD2AC(NGRP,LL4,IGDEB,WORK,ZMU)
      ELSE
         ZMU=1.0
      ENDIF
      IGDEBO=IGDEB
      DO 130 IGR=IGDEBO,NGRP
      GINN=0.0
      FINN=0.0
      DO 120 I=1,LL4
      GINN=MAX(GINN,ABS(WORK(I,IGR,2)-WORK(I,IGR,3)))
  120 FINN=MAX(FINN,ABS(WORK(I,IGR,3)))
      GINN=GINN/FINN
      IF((GINN.LT.EPSINR).AND.(IGDEB.EQ.IGR)) IGDEB=IGDEB+1
  130 CONTINUE
      CALL KDRCPU(TK2)
      TKT=TKT+(TK2-TK1)
      IF(GINN.LT.EPSINR) TEXT3='YES'
      IF(IMPX.GT.1) WRITE(6,1000) ITER,GINN,EPSINR,IGDEB,ZMU,TEXT3
      IF(GINN.LT.EPSINR) GO TO 160
  150 CONTINUE
*----
*  END OF THERMAL ITERATIONS
*----
  160 DO 170 I=1,LL4
      DO 170 IGR=1,NGRP
  170 GRAD1(I,IGR)=WORK(I,IGR,3)
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(GAR2,WORK,WORK2)
      RETURN
*
 1000 FORMAT (10X,3HIN(,I3,6H) FLX:,5H PRC=,1P,E9.2,5H TAR=,E9.2,
     1 7H IGDEB=, I13,6H ACCE=,0P,F12.5,12H  CONVERGED=,A3)
      END
