*DECK FLDTHR
      SUBROUTINE FLDTHR(IPTRK,IPSYS,LADJ,LL4,ITY,NUN,NGRP,ICL1,ICL2,
     1 IMPX,NNADI,MAXINR,EPSINR,ITER,TKT,TKB,GRAD1)
*
*-----------------------------------------------------------------------
*
*Purpose:
* perform thermal (up-scattering) iterations in Trivac.
*
*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.
* ITY     type of solution (2: classical Trivac; 3: Thomas-Raviart).
* 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).
* NNADI   number of inner ADI iterations per outer iteration.
* MAXINR  maximum number of thermal iterations.
* EPSINR  thermal iteration epsilon.
*
*Parameters: input/output
* ITER    actual number of thermal iterations.
* 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,ITY,NUN,NGRP,ICL1,ICL2,IMPX,NNADI,MAXINR,ITER
      REAL EPSINR,TKT,TKB,GRAD1(NUN,NGRP)
      LOGICAL LADJ
*----
*  LOCAL VARIABLES
*----
      CHARACTER TEXT12*12,TEXT3*3
      REAL, DIMENSION(:), ALLOCATABLE :: W
      REAL, DIMENSION(:,:), ALLOCATABLE :: GAR2
      REAL, DIMENSION(:,:,:), ALLOCATABLE :: WORK
      REAL, DIMENSION(:), POINTER :: AGAR
      TYPE(C_PTR) AGAR_PTR
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(GAR2(NUN,NGRP),WORK(LL4,NGRP,3))
*
      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 '
      ITER=2
      DO
         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,ITY,WORK(1,IGR,3),
     1      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
            IF(ITY.EQ.13) THEN
               ALLOCATE(W(LL4))
               CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,WORK(1,JGR,3),W)
               DO 15 I=1,LL4
   15          GAR2(I,IGR)=GAR2(I,IGR)-W(I)
               DEALLOCATE(W)
            ELSE
               CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR)
               CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /))
               DO 20 I=1,ILONG
   20          GAR2(I,IGR)=GAR2(I,IGR)-AGAR(I)*WORK(I,JGR,3)
            ENDIF
   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
            IF(ITY.EQ.13) THEN
               ALLOCATE(W(LL4))
               CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GAR2(1,JGR),W)
               DO 35 I=1,LL4
   35          GAR2(I,IGR)=GAR2(I,IGR)+W(I)
               DEALLOCATE(W)
            ELSE
               CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR)
               CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /))
               DO 40 I=1,ILONG
   40          GAR2(I,IGR)=GAR2(I,IGR)+AGAR(I)*GAR2(I,JGR)
            ENDIF
   50       CONTINUE
            CALL KDRCPU(TK2)
            TKB=TKB+(TK2-TK1)
*
            CALL KDRCPU(TK1)
            WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR
            CALL FLDADI(TEXT12,IPTRK,IPSYS,LL4,ITY,GAR2(1,IGR),NNADI)
            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,ITY,WORK(1,IGR,3),
     1      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
            IF(ITY.EQ.13) THEN
               ALLOCATE(W(LL4))
               CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,WORK(1,JGR,3),W)
               DO 65 I=1,LL4
   65          GAR2(I,IGR)=GAR2(I,IGR)-W(I)
               DEALLOCATE(W)
            ELSE
               CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR)
               CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /))
               DO 70 I=1,ILONG
   70          GAR2(I,IGR)=GAR2(I,IGR)-AGAR(I)*WORK(I,JGR,3)
            ENDIF
   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
            IF(ITY.EQ.13) THEN
               ALLOCATE(W(LL4))
               CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GAR2(1,JGR),W)
               DO 85 I=1,LL4
   85          GAR2(I,IGR)=GAR2(I,IGR)+W(I)
               DEALLOCATE(W)
            ELSE
               CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR)
               CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /))
               DO 90 I=1,ILONG
   90          GAR2(I,IGR)=GAR2(I,IGR)+AGAR(I)*GAR2(I,JGR)
            ENDIF
  100       CONTINUE
            CALL KDRCPU(TK2)
            TKB=TKB+(TK2-TK1)
*
            CALL KDRCPU(TK1)
            WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR
            CALL FLDADI(TEXT12,IPTRK,IPSYS,LL4,ITY,GAR2(1,IGR),NNADI)
            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-1,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.2) WRITE(6,1000) ITER,GINN,EPSINR,IGDEB,ZMU,TEXT3
         IF((GINN.LT.EPSINR).OR.(ITER.EQ.MAXINR)) EXIT
         ITER=ITER+1
      ENDDO
*----
*  END OF THERMAL ITERATIONS
*----
      DO 170 I=1,LL4
      DO 170 IGR=1,NGRP
  170 GRAD1(I,IGR)=WORK(I,IGR,3)
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(GAR2,WORK)
      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
