*DECK GPTDFL
      SUBROUTINE GPTDFL (IPTRK,IPSYS0,IPFLUP,LL4,ITY,NUN,NGRP,ICL1,ICL2,
     1 IMPX,IMPH,TITR,EPS2,MAXINR,EPSINR,NADI,MAXX0,FKEFF,EVECT,ADECT,
     2 FKEFF2,EASS,SOUR)
*
*-----------------------------------------------------------------------
*
*Purpose:
* solution of a multigroup fixed source eigenvalue problem for the
* calculation of a direct GPT solution in Trivac. Use the precondi-
* tioned power method with a two group SVAT acceleration technique.
*
*Copyright:
* Copyright (C) 1987 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
* IPSYS0  L_SYSTEM pointer to unperturbed system matrices
* IPFLUP  L_FLUX pointer to the gpt solution
* 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. =0: no print ; =1: minimum printing ;
*         =2: iteration history is printed. =3: solution is printed
* IMPH    =0: no action is taken
*         =1: the flux is compared to a reference flux stored on lcm
*         =2: the convergence histogram is printed
*         =3: the convergence histogram is printed with axis and
*            titles. the plotting file is completed
*         =4: the convergence histogram is printed with axis, acce-
*            leration factors and titles. the plotting file is
*            completed
* TITR    character*72 title
* EPS2    convergence criteria for the flux
* MAXINR  maximum number of thermal iterations.
* EPSINR  thermal iteration epsilon.
* NADI    number of inner adi iterations per outer iteration
* MAXX0   maximum number of outer iterations
* FKEFF   effective multiplication factor
* EVECT   unknown vector for the non perturbed direct flux
* ADECT   unknown vector for the non perturbed adjoint flux
* SOUR    fixed source
*
*Parameters: output
* FKEFF2  perturbed effective multiplication factor
* EASS    converged solution
*
*References:
* A. H\'ebert, 'Preconditioning the power method for reactor
* calculations', Nucl. Sci. Eng., 94, 1 (1986).
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPTRK,IPSYS0,IPFLUP
      CHARACTER TITR*72
      INTEGER LL4,ITY,NUN,NGRP,ICL1,ICL2,IMPX,IMPH,MAXINR,NADI,MAXX0
      REAL EPS2,EPSINR,FKEFF,EVECT(NUN,NGRP),ADECT(NUN,NGRP),FKEFF2,
     1 EASS(NUN,NGRP),SOUR(NUN,NGRP)
*----
*  LOCAL VARIABLES
*----
      CHARACTER*12 TEXT12
      LOGICAL LOGTES,LMPH
      DOUBLE PRECISION AIL,BIL,EVAL,D2F(2,3),ALP,BET,DDELN1,DDELD1,
     1 ZNORM,GAZ
      REAL ERR(250),ALPH(250),BETA(250),TKT,TKB
      INTEGER  ITITR(18)
      REAL, DIMENSION(:), ALLOCATABLE :: WORK1,WORK2,WORK3
      REAL, DIMENSION(:,:), ALLOCATABLE :: GRAD1,GRAD2,GAR1,GAR2,GAR3
      REAL, DIMENSION(:), POINTER :: AGAR
      TYPE(C_PTR) AGAR_PTR
      DATA EPS1,MMAXX/1.0E-4,250/
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(GRAD1(NUN,NGRP),GRAD2(NUN,NGRP),GAR1(NUN,NGRP),
     1 GAR2(NUN,NGRP),GAR3(NUN,NGRP),WORK1(NUN),WORK2(NUN))
*
      CALL MTOPEN(IMPX,IPTRK,LL4)
      IF(LL4.GT.NUN) CALL XABORT('GPTDFL: INVALID NUMBER OF UNKNOWNS.')
*----
*  UNPERTURBED EIGENVALUE CALCULATION.
*----
      AIL=0.0D0
      BIL=0.0D0
      TEST=0.0
      DO 80 IGR=1,NGRP
      WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR
      CALL MTLDLM(TEXT12,IPTRK,IPSYS0,LL4,ITY,EVECT(1,IGR),GRAD1(1,IGR))
      CALL XDRSET(WORK1,LL4,0.0)
      DO 70 JGR=1,NGRP
      IF(JGR.EQ.IGR) GO TO 40
      WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR
      CALL LCMLEN(IPSYS0,TEXT12,ILONG,ITYLCM)
      IF(ILONG.EQ.0) GO TO 40
      IF(ITY.EQ.13) THEN
         ALLOCATE(WORK3(LL4))
         CALL MTLDLM(TEXT12,IPTRK,IPSYS0,LL4,ITY,EVECT(1,JGR),WORK3)
         DO 20 I=1,LL4
   20    GRAD1(I,IGR)=GRAD1(I,IGR)-WORK3(I)
         DEALLOCATE(WORK3)
      ELSE
         CALL LCMGPD(IPSYS0,TEXT12,AGAR_PTR)
         CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /))
         DO 30 I=1,ILONG
   30    GRAD1(I,IGR)=GRAD1(I,IGR)-AGAR(I)*EVECT(I,JGR)
      ENDIF
   40 WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR
      CALL LCMLEN(IPSYS0,TEXT12,ILONG,ITYLCM)
      IF(ILONG.EQ.0) GO TO 70
      CALL LCMGPD(IPSYS0,TEXT12,AGAR_PTR)
      CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /))
      DO 60 I=1,ILONG
   60 WORK1(I)=WORK1(I)+AGAR(I)*EVECT(I,JGR)
   70 CONTINUE
      DO 80 I=1,LL4
      AIL=AIL+ADECT(I,IGR)*GRAD1(I,IGR)
   80 BIL=BIL+ADECT(I,IGR)*WORK1(I)
      EVAL=AIL/BIL
      FKEFF2=REAL(1.0D0/EVAL)
      IF(ABS(FKEFF-1.0/EVAL).GT.EPS1) CALL XABORT('GPTDFL: THE COMPUTE'
     1 //'D AND PROVIDED K-EFFECTIVES ARE INCONSISTENTS.')
*----
*  VALIDATION OF THE FIXED SOURCE TERM.
*----
      AIL=0.0D0
      BIL=0.0D0
      DO 90 IGR=1,NGRP
      DO 90 I=1,LL4
      GAZ=ADECT(I,IGR)*SOUR(I,IGR)
      AIL=AIL+GAZ
   90 BIL=BIL+GAZ**2
      GAZ=ABS(AIL)/SQRT(REAL(LL4)*BIL)
      IF(GAZ.GT.EPS2) CALL XABORT('GPTDFL: THE SOURCE TERM IS NOT ORT'
     1 //'HOGONAL TO THE ADJOINT REFERENCE FLUX.')
*----
*  PRECONDITIONED POWER METHOD.
*----
      ISTART=1
      NNADI=NADI
      IF(IMPX.GE.1) WRITE (6,600) NADI
      IF(IMPX.GE.2) WRITE (6,610)
      M=0
  100 M=M+1
*
      IF(MOD(M-ISTART+1,ICL1+ICL2).EQ.1) THEN
         DO 135 IGR=1,NGRP
         WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR
         CALL MTLDLM(TEXT12,IPTRK,IPSYS0,LL4,ITY,EASS(1,IGR),
     +               GAR1(1,IGR))
         DO 135 JGR=1,NGRP
         IF(JGR.EQ.IGR) GO TO 120
         WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR
         CALL LCMLEN(IPSYS0,TEXT12,ILONG,ITYLCM)
         IF(ILONG.EQ.0) GO TO 120
         IF(ITY.EQ.13) THEN
            ALLOCATE(WORK3(LL4))
            CALL MTLDLM(TEXT12,IPTRK,IPSYS0,LL4,ITY,EASS(1,JGR),WORK3)
            DO 105 I=1,LL4
  105       GAR1(I,IGR)=GAR1(I,IGR)-WORK3(I)
            DEALLOCATE(WORK3)
         ELSE
            CALL LCMGPD(IPSYS0,TEXT12,AGAR_PTR)
            CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /))
            DO 110 I=1,ILONG
  110       GAR1(I,IGR)=GAR1(I,IGR)-AGAR(I)*EASS(I,JGR)
         ENDIF
  120    WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR
         CALL LCMLEN(IPSYS0,TEXT12,ILONG,ITYLCM)
         IF(ILONG.EQ.0) GO TO 135
         CALL LCMGPD(IPSYS0,TEXT12,AGAR_PTR)
         CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /))
         DO 125 I=1,ILONG
  125    GAR1(I,IGR)=GAR1(I,IGR)-REAL(EVAL)*AGAR(I)*EASS(I,JGR)
  135    CONTINUE
      ENDIF
*----
*  DIRECTION EVALUATION.
*----
      DO 180 IGR=1,NGRP
      DO 140 I=1,LL4
  140 GRAD1(I,IGR)=-SOUR(I,IGR)-GAR1(I,IGR)
      DO 170 JGR=1,IGR-1
      WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR
      CALL LCMLEN(IPSYS0,TEXT12,ILONG,ITYLCM)
      IF(ILONG.EQ.0) GO TO 170
      IF(ITY.EQ.13) THEN
         CALL MTLDLM(TEXT12,IPTRK,IPSYS0,LL4,ITY,GRAD1(1,JGR),WORK1)
         DO 145 I=1,LL4
  145    GRAD1(I,IGR)=GRAD1(I,IGR)+WORK1(I)
      ELSE
         CALL LCMGPD(IPSYS0,TEXT12,AGAR_PTR)
         CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /))
         DO 150 I=1,ILONG
  150    GRAD1(I,IGR)=GRAD1(I,IGR)+AGAR(I)*GRAD1(I,JGR)
      ENDIF
  170 CONTINUE
*
      WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR
      CALL FLDADI(TEXT12,IPTRK,IPSYS0,LL4,ITY,GRAD1(1,IGR),NNADI)
  180 CONTINUE
*----
*  PERFORM THERMAL (UP-SCATTERING) ITERATIONS
*----
      IF(MAXINR.GT.1) THEN
         CALL FLDTHR(IPTRK,IPSYS0,.FALSE.,LL4,ITY,NUN,NGRP,ICL1,ICL2,
     1   IMPX,NNADI,MAXINR,EPSINR,TKT,TKB,GRAD1)
      ENDIF
*----
*  HOTELLING DEFLATION.
*----
      DDELN1=0.0D0
      DDELD1=0.0D0
      DO 220 IGR=1,NGRP
      CALL XDRSET(WORK1,LL4,0.0)
      DO 210 JGR=1,NGRP
      WRITE(TEXT12,'(1HB,2I3.3)') JGR,IGR
      CALL LCMLEN(IPSYS0,TEXT12,ILONG,ITYLCM)
      IF(ILONG.EQ.0) GO TO 210
      CALL LCMGPD(IPSYS0,TEXT12,AGAR_PTR)
      CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /))
      DO 200 I=1,ILONG
  200 WORK1(I)=WORK1(I)+AGAR(I)*ADECT(I,JGR)
  210 CONTINUE
      DO 220 I=1,LL4
      DDELN1=DDELN1+WORK1(I)*EASS(I,IGR)
  220 DDELD1=DDELD1+WORK1(I)*EVECT(I,IGR)
      ZNORM=DDELN1/DDELD1
      DO 230 IGR=1,NGRP
      DO 230 I=1,LL4
  230 GRAD1(I,IGR)=GRAD1(I,IGR)-REAL(ZNORM)*EVECT(I,IGR)
*----
*  EVALUATION OF THE DISPLACEMENT AND OF THE TWO ACCELERATION PARAMETERS
*  ALP AND BET.
*----
      ALP=1.0D0
      BET=0.0D0
      DO 240 I=1,2
      DO 240 J=1,3
  240 D2F(I,J)=0.0D0
      DO 280 IGR=1,NGRP
      WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR
      CALL MTLDLM(TEXT12,IPTRK,IPSYS0,LL4,ITY,GRAD1(1,IGR),GAR2(1,IGR))
      DO 280 JGR=1,NGRP
      IF(JGR.EQ.IGR) GO TO 260
      WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR
      CALL LCMLEN(IPSYS0,TEXT12,ILONG,ITYLCM)
      IF(ILONG.EQ.0) GO TO 260
      IF(ITY.EQ.13) THEN
         CALL MTLDLM(TEXT12,IPTRK,IPSYS0,LL4,ITY,GRAD1(1,JGR),WORK1)
         DO 245 I=1,LL4
  245    GAR2(I,IGR)=GAR2(I,IGR)-WORK1(I)
      ELSE
         CALL LCMGPD(IPSYS0,TEXT12,AGAR_PTR)
         CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /))
         DO 250 I=1,ILONG
  250    GAR2(I,IGR)=GAR2(I,IGR)-AGAR(I)*GRAD1(I,JGR)
      ENDIF
  260 WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR
      CALL LCMLEN(IPSYS0,TEXT12,ILONG,ITYLCM)
      IF(ILONG.EQ.0) GO TO 280
      CALL LCMGPD(IPSYS0,TEXT12,AGAR_PTR)
      CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /))
      DO 270 I=1,ILONG
  270 GAR2(I,IGR)=GAR2(I,IGR)-REAL(EVAL)*AGAR(I)*GRAD1(I,JGR)
  280 CONTINUE
      IF(1+MOD(M-ISTART,ICL1+ICL2).GT.ICL1) THEN
         DO 290 IGR=1,NGRP
         DO 290 I=1,LL4
         D2F(1,1)=D2F(1,1)+GAR2(I,IGR)**2
         D2F(1,2)=D2F(1,2)+GAR2(I,IGR)*GAR3(I,IGR)
         D2F(2,2)=D2F(2,2)+GAR3(I,IGR)**2
         D2F(1,3)=D2F(1,3)-(GAR1(I,IGR)+SOUR(I,IGR))*GAR2(I,IGR)
  290    D2F(2,3)=D2F(2,3)-(GAR1(I,IGR)+SOUR(I,IGR))*GAR3(I,IGR)
         D2F(2,1)=D2F(1,2)
*        SOLUTION OF A LINEAR SYSTEM.
         CALL ALSBD(2,1,D2F,IER,2)
         IF(IER.NE.0) CALL XABORT('GPTDFL: SINGULAR MATRIX.')
         ALP=D2F(1,3)
         BET=D2F(2,3)/ALP
         IF((ALP.LT.1.0D0).AND.(ALP.GT.0.0D0)) THEN
            ALP=1.0D0
            BET=0.0D0
         ELSE IF(ALP.LE.0.0D0) THEN
            ISTART=M+1
            ALP=1.0D0
            BET=0.0D0
         ENDIF
         DO 300 IGR=1,NGRP
         DO 300 I=1,LL4
         GRAD1(I,IGR)=REAL(ALP)*(GRAD1(I,IGR)+REAL(BET)*GRAD2(I,IGR))
  300    GAR2(I,IGR)=REAL(ALP)*(GAR2(I,IGR)+REAL(BET)*GAR3(I,IGR))
      ENDIF
*
      LOGTES=(M.LT.ICL1).OR.(MOD(M,ICL1+ICL2).EQ.ICL1)
      IF(LOGTES) THEN
         DELT=0.0
         DO 350 IGR=1,NGRP
         CALL XDRSET(WORK1,LL4,0.0)
         CALL XDRSET(WORK2,LL4,0.0)
         DO 320 JGR=1,NGRP
         WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR
         CALL LCMLEN(IPSYS0,TEXT12,ILONG,ITYLCM)
         IF(ILONG.EQ.0) GO TO 320
         CALL LCMGPD(IPSYS0,TEXT12,AGAR_PTR)
         CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /))
         DO 310 I=1,ILONG
         WORK1(I)=WORK1(I)+AGAR(I)*EASS(I,JGR)
  310    WORK2(I)=WORK2(I)+AGAR(I)*GRAD1(I,JGR)
  320    CONTINUE
         DELN=0.0
         DELD=0.0
         DO 340 I=1,LL4
         EASS(I,IGR)=EASS(I,IGR)+GRAD1(I,IGR)
         GAR1(I,IGR)=GAR1(I,IGR)+GAR2(I,IGR)
         GRAD2(I,IGR)=GRAD1(I,IGR)
         GAR3(I,IGR)=GAR2(I,IGR)
         DELN=MAX(DELN,ABS(WORK2(I)))
  340    DELD=MAX(DELD,ABS(WORK1(I)))
         IF(DELD.NE.0.0) DELT=MAX(DELT,DELN/DELD)
  350    CONTINUE
         IF(IMPX.GE.2) WRITE (6,620) M,ALP,BET,ZNORM,DELT
*        COMPUTE THE CONVERGENCE HISTOGRAM.
         IF(IMPH.GE.1) THEN
            LMPH=IMPH.GE.1
            CALL FLDXCO(IPFLUP,LL4,NUN,EASS(1,NGRP),LMPH,ERR(M))
            ALPH(M)=REAL(ALP)
            BETA(M)=REAL(BET)
         ENDIF
         IF(DELT.LT.EPS2) GO TO 370
      ELSE
         DO 360 IGR=1,NGRP
         DO 360 I=1,LL4
         EASS(I,IGR)=EASS(I,IGR)+GRAD1(I,IGR)
         GAR1(I,IGR)=GAR1(I,IGR)+GAR2(I,IGR)
         GRAD2(I,IGR)=GRAD1(I,IGR)
  360    GAR3(I,IGR)=GAR2(I,IGR)
         IF(IMPX.GE.2) WRITE (6,620) M,ALP,BET,ZNORM
*        COMPUTE THE CONVERGENCE HISTOGRAM.
         IF(IMPH.GE.1) THEN
            LMPH=IMPH.GE.1
            CALL FLDXCO(IPFLUP,LL4,NUN,EASS(1,NGRP),LMPH,ERR(M))
            ALPH(M)=REAL(ALP)
            BETA(M)=REAL(BET)
         ENDIF
      ENDIF
      IF(M.EQ.1) TEST=DELT
      IF((M.GT.20).AND.(DELT.GT.TEST)) CALL XABORT('GPTDFL: CONVERGENC'
     1 //'E FAILURE.')
      IF(M.GE.MIN(MAXX0,MMAXX)) THEN
         WRITE (6,710)
         GO TO 370
      ENDIF
      IF(MOD(M,36).EQ.0) THEN
         ISTART=M+1
         NNADI=NNADI+1
         IF (IMPX.NE.0) WRITE (6,720) NNADI
      ENDIF
      GO TO 100
*----
*  SOLUTION EDITION.
*----
  370 IF(IMPX.EQ.1) WRITE (6,640) M
      IF(IMPX.GE.3) THEN
         DO 380 IGR=1,NGRP
         WRITE (6,690) IGR,(EASS(I,IGR),I=1,LL4)
  380    CONTINUE
      ENDIF
      IF(IMPH.GE.2) THEN
         IGRAPH=0
  390    IGRAPH=IGRAPH+1
         WRITE (TEXT12,'(5HHISTO,I3)') IGRAPH
         CALL LCMLEN (IPFLUP,TEXT12,ILENG,ITYLCM)
         IF(ILENG.EQ.0) THEN
            READ (TITR,'(18A4)') ITITR
            CALL LCMSIX (IPFLUP,TEXT12,1)
            CALL LCMPUT (IPFLUP,'HTITLE',18,3,ITITR)
            CALL LCMPUT (IPFLUP,'ALPHA',M,2,ALPH)
            CALL LCMPUT (IPFLUP,'BETA',M,2,BETA)
            CALL LCMPUT (IPFLUP,'ERROR',M,2,ERR)
            CALL LCMPUT (IPFLUP,'IMPH',1,1,IMPH)
            CALL LCMSIX (IPFLUP,' ',2)
         ELSE
            GO TO 390
         ENDIF
      ENDIF
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(GRAD1,GRAD2,GAR1,GAR2,GAR3,WORK1,WORK2)
      RETURN
*
  600 FORMAT(1H1/50H GPTDFL: ITERATIVE PROCEDURE BASED ON PRECONDITION,
     1 17HED POWER METHOD (,I2,37H ADI ITERATIONS PER OUTER ITERATION)./
     2 9X,39HDIRECT FIXED SOURCE EIGENVALUE PROBLEM.)
  610 FORMAT (/29X,15HORTHONORMALIZA-/11X,5HALPHA,3X,4HBETA,6X,
     1 11HTION FACTOR,6X,8HACCURACY,12(1H.))
  620 FORMAT (1X,I3,4X,2F8.3,1PE14.2,6X,2E10.2)
  640 FORMAT(/23H GPTDFL: CONVERGENCE IN,I4,12H ITERATIONS.)
  690 FORMAT(//52H GPTDFL: DIRECT FIXED SOURCE PROBLEM SOLUTION CORRES,
     1 20HPONDING TO THE GROUP,I4//(5X,1P,8E14.5))
  710 FORMAT(/53H GPTDFL: ***WARNING*** THE MAXIMUM NUMBER OF OUTER IT,
     1 20HERATIONS IS REACHED.)
  720 FORMAT(/53H GPTDFL: INCREASING THE NUMBER OF INNER ITERATIONS TO,
     1 I3,36H ADI ITERATIONS PER OUTER ITERATION./)
      END
