!	Find means and covariance matrices corresponding to a predictor list for the normal case.

!	beta is the parameter vector.
!	predlist is the predictor list.
!	tolsing is the tolerance for modified Cholesky decomposition.
!	covs are the covariance matrices.
!	means are the means.

subroutine getmeancov(beta,predlist,tolsing,covs,means)
implicit none
interface
!
!  Find statistics of mean and covariance matrix of underlying latent vector.
!
!   beta is the estimated parameter vector.

!   thpr is a predictor vector.
!   tolsing is a tolerance for modified Cholesky decomposition.
!   covmatrix is the estimated covariance matrix of the underlying latent vector corresponding to beta.
!   meanvec is the estimated mean of the underlying latent vector.
!   Note that this routine is for the case of an underlying normal latent vector.
	subroutine meancovstat(beta,thpr,tolsing,covmatrix,meanvec)
		implicit none
		real(kind=8),intent(in)::beta(:),thpr(:),tolsing
		real(kind=8),intent(out)::covmatrix(:,:),meanvec(:)
	end subroutine meancovstat
end interface

real(kind=8),intent(in)::beta(:),predlist(:,:),tolsing
real(kind=8),intent(out)::covs(:,:,:),means(:,:)
!	row counts entries in predlist.
integer::row
do row=1,size(predlist,2)
	call meancovstat(beta,predlist(:,row),tolsing,covs(:,:,row),means(:,row))
end do
return
end subroutine getmeancov


!> @ingroup interchange_sort_asc
!>
!> @brief
!> Run an interchange sort on a vector of integer values.
!>
!> @details
!> Run an ascending on a vector of integer values to sort them in the specified order.
!>
!> @param vec
!> The vector integer values to be sorted.
!>
!> @author Arin R. Bratt
!> @date 11/07/2014
pure subroutine interchange_sort_asc_int(vec)
  ! Arguments
  integer, intent(inout) :: vec(:)

  ! Variables
  integer :: i
  integer :: j
  integer :: swap_value

  ! The interchange sort
  do i = 1,size(vec,1) - 1
     do j = i + 1,size(vec,1)
        if (vec(i) > vec(j)) then
           ! Swap integer values vec(i) and vec(j).
           swap_value = vec(i)
           vec(i) = vec(j)
           vec(j) = swap_value
        end if
     end do
  end do
end subroutine interchange_sort_asc_int


!*******************************************************************************
!*    LICENSED MATERIALS - PROPERTY OF IBM                                     *
!*    "RESTRICTED MATERIALS OF IBM"                                            *
!*                                                                             *
!*    5765-C41                                                                 *
!*    (C) COPYRIGHT IBM CORP. 1997. ALL RIGHTS RESERVED.                       *
!*                                                                             *
!*    U.S. GOVERNMENT USERS RESTRICTED RIGHTS - USE, DUPLICATION               *
!*    OR DISCLOSURE RESTRICTED BY GSA ADP SCHEDULE CONTRACT WITH               *
!*    IBM CORP.                                                                *
!*******************************************************************************
!*******************************************************************************
!* THIS SAMPLE PROGRAM SHOWS HOW TO BUILD AND SOLVE A SPARSE LINEAR            *
!* SYSTEM USING THE SUBROUTINES IN THE SPARSE SECTION OF PARALLEL              *
!* ESSL.  THE MATRIX AND RHS ARE GENERATED                                     *
!* IN PARALLEL, SO THAT THERE IS NO SERIAL BOTTLENECK.                         *
!*                                                                             *
!* THE PROGRAM SOLVES A LINEAR SYSTEM BASED ON THE PARTIAL DIFFERENTIAL        *
!* EQUATION                                                                    *
!*                                                                             *
!*   b1 dd(u)  b2 dd(u)    b3 dd(u)    a1 d(u)   a2 d(u)  a3 d(u)              *
!* -   ------ -  ------ -  ------ -  -----  -  ------  -  ------ + a4 u        *
!*      dxdx     dydy       dzdz        dx       dy         dz                 *
!*                                                                             *
!*  = 0                                                                        *
!*                                                                             *
!* WITH  DIRICHLET BOUNDARY CONDITIONS ON THE UNIT CUBE                        *
!*                                                                             *
!*    0<=x,y,z<=1                                                              *
!*                                                                             *
!* THE EQUATION IS DISCRETIZED WITH FINITE DIFFERENCES AND UNIFORM STEPSIZE;   *
!* THE RESULTING  DISCRETE  EQUATION IS                                        *
!*                                                                             *
!* ( u(x,y,z)(2b1+2b2+2b3+a1+a2+a3)+u(x-1,y,z)(-b1-a1)+u(x,y-1,z)(-b2-a2)+     *
!*  + u(x,y,z-1)(-b3-a3)-u(x+1,y,z)b1-u(x,y+1,z)b2-u(x,y,z+1)b3)*(1/h**2)      *
!*                                                                             *
!*                                                                             *
!* IN THIS SAMPLE PROGRAM THE INDEX SPACE OF THE DISCRETIZED                   *
!* COMPUTATIONAL DOMAIN IS FIRST NUMBERED SEQUENTIALLY IN A STANDARD WAY,      *
!* THEN THE CORRESPONDING VECTOR IS DISTRIBUTED ACCORDING TO AN HPF BLOCK      *
!* DISTRIBUTION DIRECTIVE.                                                     *
!*                                                                             *
!* BOUNDARY CONDITIONS ARE SET IN A VERY SIMPLE WAY, BY ADDING                 *
!* EQUATIONS OF THE FORM                                                       *
!*                                                                             *
!*   u(x,y,z) = rhs(x,y,z)                                                     *
!*******************************************************************************

      PROGRAM PDE77

          USE F90SPARSE
          IMPLICIT NONE

          EXTERNAL PART_BLOCK

          ! .... INPUT PARAMETERS .... !

          CHARACTER*10 :: CMETHD, PREC
          INTEGER      :: IDIM

          ! .... MISCELLANEOUS .... !

          INTEGER,   PARAMETER        :: IZERO=0, IONE=1
          CHARACTER, PARAMETER        :: ORDER='R'
          LOGICAL,   PARAMETER        :: UPDATE=.TRUE., NOUPDATE=.FALSE.

          REAL(KIND(1.D0)), POINTER   :: B_COL(:), X_COL(:)
          REAL(KIND(1.D0)), POINTER   :: DWORK(:)
          REAL(KIND(1.D0)), PARAMETER :: DZERO = 0.D0, ONE = 1.D0
          REAL(KIND(1.D0))            :: TIMEF, T1, T2, TPREC, TSOLVE
          REAL(KIND(1.D0))            :: T3, T4

          INTEGER                     :: NR, NNZ,IRCODE, NNZ1,  NRHS
          EXTERNAL                       TIMEF

          ! .... SPARSE MATRICES .... !

          REAL(8), POINTER  :: AS(:), PRCS(:)
          INTEGER, POINTER  :: DESC_A(:), IA1(:), IA2(:)
          INTEGER           :: INFOA(30)

          ! .... DENSE MATRICES .... !

          REAL(KIND(1.D0)), POINTER :: B(:), X(:)
          INTEGER                   :: LB, LX, LDV, LDV1, IRET

          INTERFACE
              SUBROUTINE CREATE_MTRX_ELL1_BLOCK(PARTS,IDIM,
     &                 AS,IA1,IA2,INFOA,B,T,DESC_A,ICONTXT)
                  IMPLICIT NONE
                  EXTERNAL PARTS
                  INTEGER                  :: IDIM
                  REAL(KIND(1.D0)),POINTER :: B(:), T(:), AS(:)
                  INTEGER                  :: INFOA(30)
                  INTEGER, POINTER         :: DESC_A(:), IA1(:),IA2(:)
                  INTEGER                  :: ICONTXT
              END SUBROUTINE CREATE_MTRX_ELL1_BLOCK
          END INTERFACE

          ! .... COMMUNICATIONS DATA STRUCTURE .... !

          ! .... BLACS PARAMETERS .... !

          INTEGER            :: NPROW, NPCOL, ICONTXT, IAM, NP, MYPROW,
     &                          MYPCOL

          ! .... SOLVER PARAMETERS .... !

          INTEGER            :: ITER, ITMAX, IERR, ITRACE, METHD, IPREC,
     &                          ISTOPC, IPARM(20)
          REAL(KIND(1.D0))   :: ERR, EPS, RPARM(20)

          ! .... OTHER VARIABLES .... !

          INTEGER            :: I, INFO
          INTEGER            :: INTERNAL, M, II, NNZERO

          ! .... INITIALIZE BLACS .... !

          CALL BLACS_PINFO(IAM, NP)
          CALL BLACS_GET(IZERO, IZERO, ICONTXT)

          ! .... RECTANGULAR GRID,  NP X 1 .... !

          CALL BLACS_GRIDINIT(ICONTXT, ORDER, NP, IONE)
          CALL BLACS_GRIDINFO(ICONTXT, NPROW, NPCOL, MYPROW, MYPCOL)

          ! .... GET PARAMETERS .... !

          CALL GET_PARMS(ICONTXT,CMETHD,PREC,IDIM,ISTOPC,ITMAX,ITRACE)

          ! .... ALLOCATE AND FILL IN THE COEFFICIENT MATRIX AND THE RHS .... !

          CALL BLACS_BARRIER(ICONTXT,'All')

          T1 = TIMEF()

          CALL CREATE_MTRX_ELL1_BLOCK(PART_BLOCK,IDIM,AS,IA1,IA2,INFOA,
     &                                B,X,DESC_A,ICONTXT)

          T2 = TIMEF() - T1

          CALL DGAMX2D(ICONTXT,'A',' ',IONE, IONE,T2,IONE,T1,T1,
     &                 -1,-1,-1)

          IF (IAM.EQ.0) WRITE(6,*) 'Matrix creation Time : ',T2/1.D3

          LB   = SIZE(B)
          LX   = SIZE(X)
          LDV  = DESC_A(5)
          LDV1 = DESC_A(6)
          NNZ  = SIZE(AS)
          NNZ1 = SIZE(IA1)

          ALLOCATE(PRCS(10+2*NNZ+LDV+LDV1+40),STAT=IRCODE)

          IF (IRCODE /= 0) THEN
             WRITE(0,*) 'Allocation error'
             CALL BLACS_ABORT(ICONTXT,-1)
             STOP
          ENDIF

          ! .... PREPARE THE PRECONDITIONING DATA STRUCTURE .... !

          SELECT CASE (PREC)
          CASE ('ILU')
              IPREC = 2
          CASE ('DIAGSC')
              IPREC = 1
          CASE ('NONE')
              IPREC = 0
          CASE DEFAULT
              WRITE(0,*) 'Unknown preconditioner'
              CALL BLACS_ABORT(ICONTXT,-1)
          END SELECT

          CALL BLACS_BARRIER(ICONTXT,'All')

          T1 = TIMEF()

          CALL PDSPGPR(IPREC,AS,IA1,IA2,INFOA,PRCS,SIZE(PRCS),
     &                 DESC_A,IRET)

          TPREC = TIMEF()-T1

          CALL DGAMX2D(ICONTXT,'A',' ',IONE, IONE,TPREC,IONE,T1,T1,
     &                 -1,-1,-1)

          IF (IAM.EQ.0) WRITE(6,*) 'Preconditioner Time : ',TPREC/1.D3

          IF (IRET.NE.0) THEN
              WRITE(0,*) 'Error on preconditioner',IRET
              CALL BLACS_ABORT(ICONTXT,-1)
              STOP
          ENDIF

          ! .... ITERATION PARAMETERS .... !

          IF (CMETHD(1:6).EQ.'CGSTAB') THEN
              METHD = 1
          ELSEIF (CMETHD(1:3).EQ.'CGS') THEN
              METHD = 2
          ELSEIF (CMETHD(1:5).EQ.'TFQMR') THEN
              METHD = 3
          ELSE
              WRITE(0,*) 'Unknown method '
              CALL BLACS_ABORT(ICONTXT,-1)
              METHD = 0
          ENDIF

          EPS      = 1.D-9
          IPARM    = 0
          RPARM    = 0.D0

          IPARM(1) = METHD
          IPARM(2) = ISTOPC
          IPARM(3) = ITMAX
          IPARM(4) = ITRACE
          RPARM(1) = EPS

          NRHS = 1

          CALL BLACS_BARRIER(ICONTXT,'All')
          T1 = TIMEF()

          CALL PDSPGIS(AS,IA1,IA2,INFOA,NRHS,B,LB,X,LX,PRCS,
     &                 DESC_A,IPARM,RPARM,INFO)

          CALL BLACS_BARRIER(ICONTXT,'All')

          TSOLVE = TIMEF() - T1
          ERR    = RPARM(2)
          ITER   = IPARM(5)

          IF (IAM.EQ.0) THEN

              WRITE(6,*) 'Time to Solve Matrix : ',TSOLVE/1.D3
              WRITE(6,*) 'Time per iteration : ',TSOLVE/(1.D3*ITER)
              WRITE(6,*) 'Number of iterations : ',ITER
              WRITE(6,*) 'Error on exit : ',ERR
              WRITE(6,*) 'INFO on exit:',INFO

          ENDIF

          CALL BLACS_GRIDEXIT(ICONTXT)
          CALL BLACS_EXIT(0)

          STOP

      END

!*******************************************************************************
!*    PRINT AN ERROR MESSAGE                                                   *
!*******************************************************************************

      SUBROUTINE PR_USAGE(IOUT)
          IMPLICIT NONE
          INTEGER :: IOUT
          WRITE(IOUT,*)'Incorrect parameter(s) found'
          WRITE(IOUT,*)
     &       ' Usage: pde77 methd prec dim [istopc itmax itrace]'
          WRITE(IOUT,*)' Where:'
          WRITE(IOUT,*)'     methd:  CGSTAB TFQMR CGS'
          WRITE(IOUT,*)'     prec :  ILU DIAGSC NONE'
          WRITE(IOUT,*)'     dim     number of points along each axis'
          WRITE(IOUT,*)'             the size of the resulting linear '
          WRITE(IOUT,*)'             system is dim**3'
          WRITE(IOUT,*)'     istopc  Stopping criterion 1 2 or 3  [1]  '
          WRITE(IOUT,*)'     itmax   Maximum number of iterations [500]'
          WRITE(IOUT,*)'     itrace       0  (no tracing, default) or '
          WRITE(IOUT,*)'                  >= 0 do tracing every ITRACE'
          WRITE(IOUT,*)'                  iterations '
          RETURN
      END

!*******************************************************************************
!*     FUNCTIONS PARAMETERIZING THE DIFFERENTIAL EQUATION                      *
!*******************************************************************************

      FUNCTION A1(X,Y,Z)
          REAL(KIND(1.D0)) :: A1
          REAL(KIND(1.D0)) :: X,Y,Z
          A1 = 1.D0
      END

      FUNCTION A2(X,Y,Z)
          REAL(KIND(1.D0)) :: A2
          REAL(KIND(1.D0)) :: X,Y,Z
          A2 = 2.D1*Y
      END

      FUNCTION A3(X,Y,Z)
          REAL(KIND(1.D0)) :: A3
          REAL(KIND(1.D0)) :: X,Y,Z
          A3 = 1.D0
      END

      FUNCTION A4(X,Y,Z)
          REAL(KIND(1.D0)) :: A4
          REAL(KIND(1.D0)) :: X,Y,Z
          A4 = 1.D0
      END

      FUNCTION B1(X,Y,Z)
          REAL(KIND(1.D0)) :: B1
          REAL(KIND(1.D0)) :: X,Y,Z
          B1 = 1.D0
      END

      FUNCTION B2(X,Y,Z)
          REAL(KIND(1.D0)) :: B2
          REAL(KIND(1.D0)) :: X,Y,Z
          B2 = 1.D0
      END

      FUNCTION B3(X,Y,Z)
          REAL(KIND(1.D0)) :: B3
          REAL(KIND(1.D0)) :: X,Y,Z
          B3 = 1.D0
      END

!*******************************************************************************
!* SUBROUTINE TO ALLOCATE AND FILL IN THE COEFFICIENT                          *
!* MATRIX AND THE RHS.                                                         *
!* THE EQUATION GENERATED IS:                                                  *
!*  b1  d d (u)  b2 d d (u)   b3 d d (u)  a1 d (u)) a2 d (u)))  a3d (u)) a4 u  *
!* -   -----   -    ------  -    ------ -    ----- -  ------  - ------ +       *
!*     dx dx        dy dy        dz dz        dx        dy        dz           *
!*                                                                             *
!* =g(x,y,z)                                                                   *
!*                                                                             *
!* WHERE G IS THE RHS EXTRACTED FROM EXACT SOLUTION:                           *
!*                                                                             *
!*  f(x,y,z)=10.d0*X*Y*Z*(1-X)*(1-Y)*(1-Z)*EXP(X**4.5)                         *
!*                                                                             *
!* BOUNDARY CONDITION: DIRICHLET                                               *
!*                                                                             *
!*    0< x,y,z<1                                                               *
!*                                                                             *
!* DISCRETIZED WITH FINITE DIFFERENCES; THE DISCRETE EQUATION IS               *
!*                                                                             *
!*  u(x,y,z)(2b1+2b2+2b3+a1+a2+a3)+u(x-1,y,z)(-b1-a1)+u(x,y-1,z)(-b2-a2)+      *
!*  + u(x,y,z-1)(-b3-a3)-u(x+1,y,z)b1-u(x,y+1,z)b2-u(x,y,z+1)b3                *
!*                                                                             *
!* THIS MATRIX IS NON SYMMETRIC                                                *
!*******************************************************************************

      SUBROUTINE CREATE_MTRX_ELL1_BLOCK(PARTS,IDIM,AS,IA1,IA2,INFOA,
     &                                  B,T,DESC_A,ICONTXT)

          USE F90SPARSE
          EXTERNAL PARTS

          IMPLICIT NONE

          REAL(KIND(1.D0)),POINTER   :: B(:), T(:), AS(:)
          REAL(KIND(1.D0)),POINTER   :: SOL(:)
          REAL(KIND(1.D0)),EXTERNAL  :: A1, A2, A3, B1, B2, B3
          REAL(KIND(1.D0))           :: ZT(10), RAS(20)
          REAL(KIND(1.D0))           :: GLOB_X, GLOB_Y, GLOB_Z, DELTAH

          INTEGER,         POINTER   :: DESC_A(:), IA1(:),IA2(:)
          INTEGER                    :: INFOA(20), PRV(64)
          INTEGER                    :: RIA1(20), RIA2(20), RINFOA(30)
          INTEGER                    :: INDX_OWNER, NV, INV
          INTEGER                    :: IDIM, ICONTXT
          INTEGER                    :: M, N, NNZ, GLOB_ROW, NR, J
          INTEGER                    :: X, Y, Z, COUNTER, IA, I, NPROW
          INTEGER                    :: NPCOL, GAP, INFO
          INTEGER                    :: MYPROW, MYPCOL, DOMAIN_INDEX
          INTEGER                    :: BOUND_COND_0YZ, BOUND_COND_1YZ
          INTEGER                    :: BOUND_COND_X0Z, BOUND_COND_X1Z
          INTEGER                    :: BOUND_COND_XY0, BOUND_COND_XY1
          INTEGER                    :: MP, ELEMENT, LDSCA, IRCODE, NNZ1

          ! .... DELTAH DIMENSION OF EACH GRID CELL .... !
          ! .... DELTAT DISCRETIZATION TIME         .... !

          REAL(KIND(1.D0)),PARAMETER :: RHS=0.D0, ONE=1.D0, ZERO=0.D0
          REAL(KIND(1.D0))           :: TIMEF, T1, T2,T3, TINS
          EXTERNAL                      TIMEF

          ! .... COMMON AREA .... !

          INTEGER                       DIM_BLOCK, NPROC,NNZ2

          CALL BLACS_GRIDINFO(ICONTXT, NPROW, NPCOL, MYPROW, MYPCOL)

          NPROC  = NPROW*NPCOL
          DELTAH = 1.D0/MAX((IDIM-1),1)

          M   = IDIM*IDIM*IDIM
          N   = M

          LDSCA = 3*N+31+3*NPROC

          ALLOCATE(DESC_A(LDSCA),STAT=IRCODE)
          IF (IRCODE /= 0) THEN
             WRITE(0,*) 'Allocation error in CREATE'
             CALL BLACS_ABORT(ICONTXT,-1)
             STOP
          ENDIF

          DESC_A(11) = LDSCA

          CALL PADINIT(N,PARTS,DESC_A,ICONTXT)

          DIM_BLOCK = (N+NPROC-1)/NPROC
          NNZ       = MAX(2,DIM_BLOCK*7)
          NNZ1      = MAX(3,NNZ+DIM_BLOCK)
          NNZ2      = MAX(3,NNZ+min(N,NNZ))

          ALLOCATE(AS(NNZ),IA1(NNZ1),IA2(NNZ2),STAT=IRCODE)
          IF (IRCODE /= 0) THEN
             WRITE(0,*) 'Allocation error in CREATE'
             CALL BLACS_ABORT(ICONTXT,-1)
             STOP
          ENDIF

          INFOA(1) = NNZ
          INFOA(2) = NNZ1
          INFOA(3) = NNZ2

          NR = MAX(DESC_A(5),1)

          ALLOCATE(B(NR),T(NR),STAT=IRCODE)
          IF (IRCODE /= 0) THEN
             WRITE(0,*) 'Allocation error in CREATE'
             CALL BLACS_ABORT(ICONTXT,-1)
             STOP
          ENDIF

          CALL PDSPINIT(AS,IA1,IA2,INFOA,DESC_A)

          ! .... WE BUILD AN AUXILIARY MATRIX CONSISTING OF ONE ROW AT A .... !
          ! .... TIME IN CSR MODE                                        .... !

          RINFOA(4) = 1
          RINFOA(5) = 1
          RINFOA(6) = 1
          RINFOA(7) = N

          GAP       = 1
          RIA2(1)   = 1
          TINS      = 0.D0

          CALL BLACS_BARRIER(ICONTXT,'ALL')
          T1 = TIMEF()

          ! .... LOOP OVER ALL ROWS WHICH BELONGS TO ME; .... !
          ! .... WE HAVE A BLOCK DISTRIBUTION            .... !

          DO GLOB_ROW = 1, N

              CALL PARTS(GLOB_ROW,N,NPROW,PRV,NV)

              DO INV = 1, NV

                  INDX_OWNER = PRV(INV)

                  IF (INDX_OWNER == MYPROW) THEN

                      ELEMENT=1

                      ! .... GLOB_X, GLOB_Y, GLOB_X COORDINATES IN .... !
                      ! .... CURRENT MEASURE UNIT COMPUTE          .... !
                      ! .... POINT COORDINATES                     .... !

                      IF(MOD(GLOB_ROW,(IDIM*IDIM)).EQ.0) THEN
                          X = GLOB_ROW/(IDIM*IDIM)
                      ELSE
                          X = GLOB_ROW/(IDIM*IDIM)+1
                      ENDIF

                      IF(MOD((GLOB_ROW-(X-1)*IDIM*IDIM),IDIM).EQ.0) THEN
                          Y = (GLOB_ROW-(X-1)*IDIM*IDIM)/IDIM
                      ELSE
                          Y = (GLOB_ROW-(X-1)*IDIM*IDIM)/IDIM+1
                      ENDIF

                      Z = GLOB_ROW-(X-1)*IDIM*IDIM-(Y-1)*IDIM

                      GLOB_X=X*DELTAH
                      GLOB_Y=Y*DELTAH
                      GLOB_Z=Z*DELTAH

                      IF(X.EQ.1) THEN
                          RAS(ELEMENT)=ONE
                          RIA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z)
                          ELEMENT=ELEMENT+1
                      ELSEIF (Y.EQ.1) THEN
                          RAS(ELEMENT)=ONE
                          RIA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z)
                          ELEMENT=ELEMENT+1
                      ELSEIF (Z.EQ.1) THEN
                          RAS(ELEMENT)=ONE
                          RIA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z)
                          ELEMENT=ELEMENT+1
                      ELSEIF (X.EQ.IDIM) THEN
                          RAS(ELEMENT)=ONE
                          RIA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z)
                          ELEMENT=ELEMENT+1
                      ELSEIF (Y.EQ.IDIM) THEN
                          RAS(ELEMENT)=ONE
                          RIA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z)
                          ELEMENT=ELEMENT+1
                      ELSEIF (Z.EQ.IDIM) THEN
                          RAS(ELEMENT)=ONE
                          RIA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z)
                          ELEMENT=ELEMENT+1
                      ELSE
                          ! .... INTERNAL POINT .... !

                          ! .... (x-1,y,z) .... !

                          RAS(ELEMENT)=-B1(GLOB_X,GLOB_Y,GLOB_Z)
     &                      -A1(GLOB_X,GLOB_Y,GLOB_Z)
                          RAS(ELEMENT) = RAS(ELEMENT)/(DELTAH*DELTAH)
                          RIA1(ELEMENT)=(X-2)*IDIM*IDIM+(Y-1)*IDIM+(Z)
                          ELEMENT=ELEMENT+1

                          ! .... (x,y-1,z) .... !

                          RAS(ELEMENT)=-B2(GLOB_X,GLOB_Y,GLOB_Z)
     &                      -A2(GLOB_X,GLOB_Y,GLOB_Z)
                          RAS(ELEMENT) = RAS(ELEMENT)/(DELTAH*DELTAH)
                          RIA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-2)*IDIM+(Z)
                          ELEMENT=ELEMENT+1

                          ! .... (x,y,z-1) .... !

                          RAS(ELEMENT)=-B3(GLOB_X,GLOB_Y,GLOB_Z)
     &                       -A3(GLOB_X,GLOB_Y,GLOB_Z)
                          RAS(ELEMENT) = RAS(ELEMENT)/(DELTAH*DELTAH)
                          RIA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z-1)
                          ELEMENT=ELEMENT+1

                          ! .... (x,y,z) .... !

                          RAS(ELEMENT)=2*B1(GLOB_X,GLOB_Y,GLOB_Z)
     &                      +2*B2(GLOB_X,GLOB_Y,GLOB_Z)
     &                      +2*B3(GLOB_X,GLOB_Y,GLOB_Z)
     &                      +A1(GLOB_X,GLOB_Y,GLOB_Z)
     &                      +A2(GLOB_X,GLOB_Y,GLOB_Z)
     &                      +A3(GLOB_X,GLOB_Y,GLOB_Z)
                          RAS(ELEMENT) = RAS(ELEMENT)/(DELTAH*DELTAH)
                          RIA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z)
                          ELEMENT=ELEMENT+1

                          ! .... (x,y,z+1) .... !

                          RAS(ELEMENT)=-B1(GLOB_X,GLOB_Y,GLOB_Z)
                          RAS(ELEMENT) = RAS(ELEMENT)/(DELTAH*DELTAH)
                          RIA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z+1)
                          ELEMENT=ELEMENT+1

                          ! .... (x,y+1,z) .... !

                          RAS(ELEMENT)=-B2(GLOB_X,GLOB_Y,GLOB_Z)
                          RAS(ELEMENT) = RAS(ELEMENT)/(DELTAH*DELTAH)
                          RIA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y)*IDIM+(Z)
                          ELEMENT=ELEMENT+1

                          ! .... (x+1,y,z) .... !

                          RAS(ELEMENT)=-B3(GLOB_X,GLOB_Y,GLOB_Z)
                          RAS(ELEMENT) = RAS(ELEMENT)/(DELTAH*DELTAH)
                          RIA1(ELEMENT)=(X)*IDIM*IDIM+(Y-1)*IDIM+(Z)
                          ELEMENT=ELEMENT+1

                      ENDIF

                      RIA2(2)   = ELEMENT
                      RINFOA(1) = 20
                      RINFOA(2) = 20
                      RINFOA(3) = 20
                      RINFOA(4) = 1
                      RINFOA(5) = 1
                      RINFOA(6) = 1

                      ! .... IA== GLOBAL ROW INDEX .... !

                      IA=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z)
                      T3 = TIMEF()

                      CALL PDSPINS(AS,IA1,IA2,INFOA,DESC_A,IA,1,RAS,
     &                                             RIA1,RIA2,RINFOA)

                      TINS = TINS + (TIMEF()-T3)

                      ! .... BUILD RHS .... !

                      IF (X==1) THEN
                          GLOB_Y=(Y-IDIM/2)*DELTAH
                          GLOB_Z=(Z-IDIM/2)*DELTAH
                          ZT(1) = EXP(-GLOB_Y**2-GLOB_Z**2)
                      ELSEIF ((Y==1).OR.(Y==IDIM).OR.(Z==1)
     &                                           .OR.(Z==IDIM)) THEN
                          GLOB_X=3*(X-1)*DELTAH
                          GLOB_Y=(Y-IDIM/2)*DELTAH
                          GLOB_Z=(Z-IDIM/2)*DELTAH
                          ZT(1) = EXP(-GLOB_Y**2-GLOB_Z**2)*EXP(-GLOB_X)
                      ELSE
                          ZT(1) = 0.D0
                      ENDIF

                      CALL PDGEINS(1,B,NR,IA,1,1,1,ZT,1,DESC_A)

                      ZT(1) = 0.D0

                      CALL PDGEINS(1,T,NR,IA,1,1,1,ZT,1,DESC_A)

                  ENDIF
              ENDDO
          ENDDO

          CALL BLACS_BARRIER(ICONTXT,'ALL')

          T2 = TIMEF()

          IF (MYPROW.EQ.0) THEN
              WRITE(0,*) '     pspins  time',TINS/1.D3
              WRITE(0,*) '   Insert time',(T2-T1)/1.D3
          ENDIF

          CALL BLACS_BARRIER(ICONTXT,'ALL')

          T1 = TIMEF()

          CALL PDSPASB(AS,IA1,IA2,INFOA,DESC_A,'GEN  ','DEF  ',0,INFO)

          CALL BLACS_BARRIER(ICONTXT,'ALL')

          T2 = TIMEF()

          IF (MYPROW.EQ.0) THEN
              WRITE(0,*) '   Assembly  time',(T2-T1)/1.D3
          ENDIF

          CALL PDGEASB(1,B,NR,DESC_A)
          CALL PDGEASB(1,T,NR,DESC_A)

          RETURN
      END

!*******************************************************************************
!*    GET ITERATION PARAMETERS FROM THE COMMAND LINE                           *
!*******************************************************************************

      SUBROUTINE GET_PARMS(ICONTXT,CMETHD,PREC,IDIM,ISTOPC,ITMAX,ITRACE)
          IMPLICIT NONE
          INTEGER      :: ICONTXT, IDIM, ISTOPC, ITMAX, ITRACE
          CHARACTER*10 :: CMETHD, PREC

          INTEGER      :: INTBUF(10)
          INTEGER      :: IRET, NPROW, NPCOL, MYPROW, MYPCOL, IP, I, NP
          INTEGER      :: IARGC
          EXTERNAL        IARGC

          CHARACTER*40 :: CHARBUF

          CALL BLACS_GRIDINFO(ICONTXT, NPROW, NPCOL, MYPROW, MYPCOL)
          NP = NPROW * NPCOL

          IF (MYPROW==0) THEN

              ! .... READ COMMAND LINE PARAMETERS .... !

              IP = IARGC()

              IF (IARGC().GE.3) THEN

                  CALL GETARG(1,CHARBUF)
                  READ(CHARBUF,*) CMETHD

                  CALL GETARG(2,CHARBUF)
                  READ(CHARBUF,*) PREC

                  ! .... CONVERT STRINGS IN ARRAY .... !

                  DO I = 1, LEN(CMETHD)
                      INTBUF(I) = IACHAR(CMETHD(I:I))
                  ENDDO

                  ! .... BROADCAST PARAMETERS TO ALL PROCESSORS .... !

                  CALL IGEBS2D(ICONTXT,'ALL',' ',10,1,INTBUF,10)

                  DO I = 1, LEN(PREC)
                      INTBUF(I) = IACHAR(PREC(I:I))
                  ENDDO

                  ! .... BROADCAST PARAMETERS TO ALL PROCESSORS .... !

                  CALL IGEBS2D(ICONTXT,'ALL',' ',10,1,INTBUF,10)

                  CALL GETARG(3,CHARBUF)
                  READ(CHARBUF,*) IDIM

                  IF (IARGC().GE.4) THEN
                      CALL GETARG(4,CHARBUF)
                      READ(CHARBUF,*) ISTOPC
                  ELSE
                      ISTOPC=1
                  ENDIF

                  IF (IARGC().GE.5) THEN
                      CALL GETARG(5,CHARBUF)
                      READ(CHARBUF,*) ITMAX
                  ELSE
                      ITMAX=500
                  ENDIF

                  IF (IARGC().GE.6) THEN
                      CALL GETARG(6,CHARBUF)
                      READ(CHARBUF,*) ITRACE
                  ELSE
                      ITRACE=0
                  ENDIF

                  ! .... BROADCAST PARAMETERS TO ALL PROCESSORS .... !

                  CALL IGEBS2D(ICONTXT,'ALL',' ',1,1,IDIM,  1)
                  CALL IGEBS2D(ICONTXT,'ALL',' ',1,1,ISTOPC,1)
                  CALL IGEBS2D(ICONTXT,'ALL',' ',1,1,ITMAX, 1)
                  CALL IGEBS2D(ICONTXT,'ALL',' ',1,1,ITRACE,1)

                  WRITE(6,*)'Solving matrix: ELL1'
                  WRITE(6,*)'on  grid',IDIM,'x',IDIM,'x',IDIM
                  WRITE(6,*)' with BLOCK data distribution, NP=',NP,
     &                     ' Preconditioner=',PREC,
     &                     ' Iterative methd=',CMETHD
              ELSE

                  ! .... WRONG NUMBER OF PARAMETER, PRINT AN .... !
                  ! .... ERROR MESSAGE AND EXIT              .... !

                  CALL PR_USAGE(0)
                  CALL BLACS_ABORT(ICONTXT,-1)

                  STOP 1

              ENDIF

          ELSE

              ! .... RECEIVE PARAMETERS .... !

              CALL IGEBR2D(ICONTXT,'ALL',' ',10,1,INTBUF,10,0,0)

              DO I = 1, 10
                  CMETHD(I:I) = ACHAR(INTBUF(I))
              ENDDO

              CALL IGEBR2D(ICONTXT,'ALL',' ',10,1,INTBUF,10,0,0)

              DO I = 1, 10
                  PREC(I:I) = ACHAR(INTBUF(I))
              ENDDO

              CALL IGEBR2D(ICONTXT,'ALL',' ',1,1,IDIM,  1,0,0)
              CALL IGEBR2D(ICONTXT,'ALL',' ',1,1,ISTOPC,1,0,0)
              CALL IGEBR2D(ICONTXT,'ALL',' ',1,1,ITMAX, 1,0,0)
              CALL IGEBR2D(ICONTXT,'ALL',' ',1,1,ITRACE,1,0,0)

          ENDIF

          RETURN

      END


module CMFD

  use sdata, only: dp
  implicit none
  save

contains

  !****************************************************************************!

  subroutine coup_coef()

    !Purpose: to calculate FDM nodal coupling coefficients

    use sdata, only: ng, nnod, ix, iy, iz, xyz, D, xdel, ydel, zdel, &
    ystag, xstag, nod, nzz, xeast, xwest, ysouth, ynorth, zbott, ztop

    implicit none

    real(dp) :: alb = 1.e30_dp
    real(dp) :: d1, d2
    integer  :: n, g, i, j, k
    logical  :: first = .true.

    if (first) then
      allocate(nod(nnod,ng))
      do g = 1, ng
          do n = 1, nnod
              nod(n,g)%dn = 0._dp    ! initial nodal coupling coefficients
          end do
      end do
      first = .false.
    end if

    ! Calculate FDM coupling coefficients
    do g = 1, ng
      do n = 1, nnod

        ! Set i, j, k
        i = ix(n); j = iy(n); k = iz(n)

        ! Set FDM coupling coefficients in x direction
        if (i == ystag(j)%smax) then
          if (xeast == 0) then
            nod(n,g)%df(1) = 2._dp * alb * D(n,g) / &
                         (2._dp * D(n,g) + alb * xdel(i))
          else if (xeast == 1) then
            nod(n,g)%df(1) =  D(n,g) / (2._dp * D(n,g) + 0.5_dp * xdel(i))
          else
            nod(n,g)%df(1) = 0._dp
          end if
        else
          d2 = D(xyz(i+1, j, k), g)
          nod(n,g)%df(1) = 2._dp * D(n,g) * d2 / &
                       (D(n,g) * xdel(i+1) +  d2 * xdel(i))
        end if

        if (i == ystag(j)%smin) then
          if (xwest == 0) then
            nod(n,g)%df(2) = 2._dp * alb * D(n,g) / &
                         (2._dp * D(n,g) + alb * xdel(i))
          else if (xwest == 1) then
            nod(n,g)%df(2) =  D(n,g) / (2._dp * D(n,g) + 0.5_dp * xdel(i))
          else
            nod(n,g)%df(2) = 0._dp
          end if
        else
          d1 = D(xyz(i-1, j, k), g)
          nod(n,g)%df(2) = 2._dp * D(n,g) * d1 / &
                       (D(n,g) * xdel(i-1) +  d1 * xdel(i))
        end if

        ! Set nodal coupling coefficients in y direction
        if (j == xstag(i)%smax) then
          if (ynorth == 0) then
            nod(n,g)%df(3) = 2._dp * alb * D(n,g) / &
                         (2._dp * D(n,g) + alb * ydel(j))
          else if (ynorth == 1) then
            nod(n,g)%df(3) =  D(n,g) / (2._dp * D(n,g) + 0.5_dp * ydel(j))
          else
            nod(n,g)%df(3) = 0._dp
          end if
        else
          d2 = D(xyz(i, j+1, k), g)
          nod(n,g)%df(3) = 2._dp * D(n,g) * d2 / &
                       (D(n,g) * ydel(j+1) +  d2 * ydel(j))
        end if

        if (j == xstag(i)%smin) then
          if (ysouth == 0) then
            nod(n,g)%df(4) = 2._dp * alb * D(n,g) / &
                         (2._dp * D(n,g) + alb * ydel(j))
          else if (ysouth == 1) then
            nod(n,g)%df(4) =  D(n,g) / (2._dp * D(n,g) + 0.5_dp * ydel(j))
          else
            nod(n,g)%df(4) = 0._dp
          end if
        else
          d1 = D(xyz(i, j-1, k), g)
          nod(n,g)%df(4) = 2._dp * D(n,g) * d1 / &
                       (D(n,g) * ydel(j-1) +  d1 * ydel(j))
        end if

        ! Set nodal coupling coefficients in z direction
        if (k == nzz) then
          if (ztop == 0) then
            nod(n,g)%df(5) = 2._dp * alb * D(n,g) / &
                         (2._dp * D(n,g) + alb * zdel(k))
          else if (ztop == 1) then
            nod(n,g)%df(5) =  D(n,g) / (2._dp * D(n,g) + 0.5_dp * zdel(k))
          else
            nod(n,g)%df(5) = 0._dp
          end if
        else
          d2 = D(xyz(i, j, k+1), g)
          nod(n,g)%df(5) = 2._dp * D(n,g) * d2 / &
                       (D(n,g) * zdel(k+1) +  d2 * zdel(k))
        end if

        if (k == 1) then
          if (zbott == 0) then
            nod(n,g)%df(6) = 2._dp * alb * D(n,g) / &
                         (2._dp * D(n,g) + alb * zdel(k))
          else if (zbott == 1) then
            nod(n,g)%df(6) =  D(n,g) / (2._dp * D(n,g) + 0.5_dp * zdel(k))
          else
            nod(n,g)%df(6) = 0._dp
          end if
        else
          d1 = D(xyz(i, j, k-1), g)
          nod(n,g)%df(6) = 2._dp * D(n,g) * d1 / &
                       (D(n,g) * zdel(k-1) +  d1 * zdel(k))
        end if
      end do
    end do

  end subroutine coup_coef

  !****************************************************************************!

  subroutine set_ind()

    !Purpose: to set indexes for CMFD matrix

    use sdata, only: ix, iy, iz, ystag, xstag, nnod, nxx, nyy, nzz, ind

    implicit none

    integer, dimension(nxx,nyy) :: nodp  !radial node position
    integer :: n, np, rec, i, j, k

    ! setup radial node position nodp
    nodp = 0
    rec = 0
    do j = 1, nyy
      do i = ystag(j)%smin, ystag(j)%smax
        rec = rec + 1
        nodp(i,j) = rec
      end do
    end do

    ! Calculate number of nodes for one planar
    np = rec

    do n = 1, nnod

      ! Set i, j, k
      i = ix(n); j = iy(n); k = iz(n)
      rec = 0

      ! Lower diagonal matrix element for z-direction
      if (k /= 1) then
        rec = rec + 1
        ind(n)%col(rec) = n - np
      end if

      ! Lower diagonal matrix element for y-direction
      if (j /= xstag(i)%smin) then
        rec = rec + 1
        ind(n)%col(rec) = n - (nodp(i,j) - nodp(i,j-1))
      end if

      ! Lower diagonal matrix element for x-direction
      if (i /= ystag(j)%smin) then
        rec = rec + 1
        ind(n)%col(rec) = n - 1
      end if

      ! Diagonal matrix elementss
      rec = rec + 1
      ind(n)%col(rec) = n

       ! Upper diagonal matrix element for x-direction
      if (i /= ystag(j)%smax) then
        rec = rec + 1
        ind(n)%col(rec) = n + 1
      end if

      ! Upper diagonal matrix element for y-direction
      if (j /= xstag(i)%smax) then
        rec = rec + 1
        ind(n)%col(rec) = n + (nodp(i,j+1) - nodp(i,j))
      end if

      ! Upper diagonal matrix element for z-direction
      if (k /= nzz) then
        rec = rec + 1
        ind(n)%col(rec) = n + np
      end if

    end do

  end subroutine set_ind

  !****************************************************************************!

  subroutine matrix_setup(opt)

    !Purpose: to setup sparse penta-diagonal matrix. Elements are indexed in
    ! two-dimensional vector ind and non-zero elements strored in A

    use sdata, only: nod, ix, iy, iz, xdel, ydel, zdel, &
    ystag, xstag, nnod, sigr, nzz, ng, A, ind

    implicit none

    integer, intent(in)         :: opt
    integer :: n, g, rec, i, j, k
    logical :: first = .true.

    ! Allocate FDM matrix for first time
    if (first) then
      allocate(A(nnod,ng))
      do n = 1, nnod
        do g = 1, ng
          allocate(A(n,g)%elmn(ind(n)%ncol))
        end do
      end do
      call set_ind()
      first = .false.
    end if

    ! If need to recalculate FDM coupling coefficients
    if (opt > 0) call coup_coef()

    ! Setup CMFD linear system
    do g = 1, ng
      do n = 1, nnod

        ! Set i, j, k
        i = ix(n); j = iy(n); k = iz(n)
        rec = 0

        ! Lower diagonal matrix element for z-direction
        if (k /= 1) then
          rec = rec + 1
          A(n,g)%elmn(rec) = -(nod(n,g)%df(6) - nod(n,g)%dn(6)) / zdel(k)
        end if

        ! Lower diagonal matrix element for y-direction
        if (j /= xstag(i)%smin) then
          rec = rec + 1
          A(n,g)%elmn(rec) = -(nod(n,g)%df(4) - nod(n,g)%dn(4)) / ydel(j)
        end if

        ! Lower diagonal matrix element for x-direction
        if (i /= ystag(j)%smin) then
          rec = rec + 1
          A(n,g)%elmn(rec) = -(nod(n,g)%df(2) - nod(n,g)%dn(2)) / xdel(i)
        end if

        ! Diagonal matrix elementss
        rec = rec + 1
        A(n,g)%elmn(rec) = (nod(n,g)%df(1) + nod(n,g)%df(2) - &
                           nod(n,g)%dn(1) + nod(n,g)%dn(2)) / xdel(i) + &
                           (nod(n,g)%df(3) + nod(n,g)%df(4) - &
                           nod(n,g)%dn(3) + nod(n,g)%dn(4)) / ydel(j) + &
                           (nod(n,g)%df(5) + nod(n,g)%df(6) - &
                           nod(n,g)%dn(5) + nod(n,g)%dn(6)) / zdel(k) + &
                           sigr(n,g)

         ! Upper diagonal matrix element for x-direction
        if (i /= ystag(j)%smax) then
          rec = rec + 1
          A(n,g)%elmn(rec) = -(nod(n,g)%df(1) + nod(n,g)%dn(1)) / xdel(i)
        end if

        ! Upper diagonal matrix element for y-direction
        if (j /= xstag(i)%smax) then
          rec = rec + 1
          A(n,g)%elmn(rec) = -(nod(n,g)%df(3) + nod(n,g)%dn(3)) / ydel(j)
        end if

        ! Upper diagonal matrix element for z-direction
        if (k /= nzz) then
          rec = rec + 1
          A(n,g)%elmn(rec) = -(nod(n,g)%df(5) + nod(n,g)%dn(5)) / zdel(k)
        end if

      end do
    end do

  end subroutine matrix_setup

  !****************************************************************************!

  subroutine fiss_extrp(popt,e1,e2,erro,errn,fs)

  !
  ! Purpose:
  !    To perform fission source extrapolation

  USE io,    ONLY: ounit, scr

  implicit none

  integer, intent(in)                   :: popt
  real(dp), intent(in)                  :: e1, e2
  real(dp), dimension(:), intent(in)    :: erro, errn
  real(dp), dimension(:), intent(inout) :: fs

  real(dp) :: domiR, mval

  domiR = e2 / e1
  mval = MAXVAL(ABS(erro))
  if (mval * mval < 0.0) domiR = -domiR
  fs = fs + domiR / (1._DP - domiR) * errn
  if (popt > 0) then
    write(ounit,*) '    ...FISSION SOURCE EXTRAPOLATED...'
    if (scr) write(*,*) '    ...FISSION SOURCE EXTRAPOLATED...'
  end if

  end subroutine fiss_extrp

  !****************************************************************************!

  subroutine nodal_upd(popt, nmode)

  !
  ! Purpose:
  !    To update nodal coupling coefficients

  USE sdata, ONLY: ndmax, im, jm ,km, kern, get_time, nod_time
  USE nodal, ONLY: nodal_update, nodal_update_pnm
  USE io,    ONLY: ounit, scr

  implicit none

  integer, intent(in) :: popt
  integer, intent(in) :: nmode      ! Nodal update mode
  real(dp) :: st, fn

  st = get_time()

  ndmax = 0._dp
  !Update nodal coupling coefficients
  if (kern == 'SANM') then
    call nodal_update(nmode)
  else
    call nodal_update_pnm(nmode)
  end if
  !Update CMFD matrix
  call matrix_setup(0)
  if (popt > 0) then
    write(ounit,*) '    .....NODAL COUPLING UPDATED..... '
    write(ounit,1145) ndmax, im, jm, km
    if (scr) then
      write(*,*) '    .....NODAL COUPLING UPDATED..... '
      write(*,1145) ndmax, im, jm, km
    end if
  end if

  fn = get_time()

  nod_time = nod_time + (fn-st)

  1145 FORMAT ('MAX. CHANGE IN NODAL COUPLING COEF.= ', ES12.5, &
               ' AT NODE I = ', I2, ', J = ', I2, ', K = ', I2)

end subroutine nodal_upd

!****************************************************************************!

subroutine print_keff(popt)

!
! Purpose:
!    To update nodal coupling coefficients

USE sdata, ONLY: Ke
USE io,    ONLY: ounit, scr

implicit none

integer, intent(in) :: popt

if (popt > 0) then
  write(ounit,*)
  write(ounit,1146) Ke
  if (scr) then
    write(*,*)
    write(*,1146) Ke
  end if
end if

1146 format(2X,'MULTIPLICATION EFFECTIVE (K-EFF) = ', F9.6)

end subroutine print_keff

  !****************************************************************************!

  subroutine outer(popt)

  !
  ! Purpose:
  !    To perform forward outer iteration

  USE sdata, ONLY: ng, nnod, nout, nin, serc, ferc, fer, ser, f0, nupd, &
                   Ke, nac, fs0, s0, ndmax, kern, get_time, fdm_time
  USE io,    ONLY: ounit, scr, bther
  USE nodal, ONLY: nodal_update

  implicit none

  integer, optional, intent(in) :: popt

  real(dp)                     :: Keo                !Old Multiplication factor (Keff)
  real(dp), dimension(nnod)    :: fs0c               !old fission source
  real(dp), dimension(nnod)    :: bs                 !total source
  real(dp), dimension(nnod,ng) :: f0c                !Old flux
  real(dp) :: f, fc                                  ! new and old integrated fission sources
  integer  :: p, g
  real(dp) :: e1, e2
  real(dp), dimension(nnod) :: errn, erro            ! current and past error vectors
  logical  :: first = .true.
  real(dp) :: st, fn

  st = get_time()

  !Setup CMFD matrix
  CALL matrix_setup(1)

  !Allocate flux and fission source for first time
  if (first .and. bther == 0) then
    allocate (f0(nnod,ng), fs0(nnod), s0(nnod,ng))
    Ke = 1._dp
    f0 = 1._dp
    call FSrc(fs0)
    first = .false.
  end if

  ! Initialize keff and fission source
  f = Integrate(fs0)
  errn = 1._DP
  e1 = Integrate(errn)

  fn = get_time()
  fdm_time = fdm_time + (fn-st) ! Get FDM time

  !Start outer iteration
  do p=1, nout
    st = get_time()
    fc   = f         ! Save old integrated fission source
    fs0c = fs0       ! Save old fission source
    f0c  = f0        ! Save old flux
    Keo  = Ke        ! Save old multiplication factor
    erro = errn      ! Save old fission source error/difference
    do g = 1, ng
      !!!Calculate total source
      call TSrc(g, Ke, bs)

      !!!Inner Iteration
      call bicg(nin, g, bs, f0(:,g))
    end do
    CALL FSrc (fs0)               !Update fission source
    errn = fs0 - fs0c
    e2 = l2norm(errn)
    if (MOD(p,nac) == 0) call fiss_extrp(popt,e1,e2,erro,errn,fs0)     ! Fission source extrapolation
    e1 = e2                       ! Save l2 norm of the fission source error
    f = Integrate(fs0)            ! Integrate fission source
    Ke = Keo * f / fc             ! Update Keff
    CALL RelE(fs0, fs0c, ser)     ! Search maximum point wise fission source Relative Error
    CALL RelEg(f0, f0c, fer)      ! Search maximum point wise flux error
    fn = get_time()
    fdm_time = fdm_time + (fn-st) ! Get FDM time
    if (MOD(p,nupd) == 0 .and. kern /= ' FDM') call nodal_upd(popt, 1)  ! Nodal coefficients update
    if (popt > 0) then
      write(ounit,'(I5,F13.6,2ES15.5)') p, Ke, ser, fer                 ! Write outer iteration evolution
      if (scr) write(*,'(I5,F13.6,2ES15.5)') p, Ke, ser, fer            ! Write outer iteration evolution
    end if
    if ((ser < serc) .AND. (fer < ferc) .AND. (ndmax < 1.e-2)) exit
  end do

  if (p-1 == nout) THEN
    write(*,*)
    write(*,*) '  MAXIMUM NUMBER OF OUTER ITERATION IS REACHED IN FORWARD CALCULATION.'
    write(*,*) '  CHECK PROBLEM SPECIFICATION OR CHANGE ITERATION CONTROL (%ITER).'
    write(*,*) '  PERHAPS BY MAKING FISSION SOURCE INTERPOLATION MORE FREQUENT'
    write(*,*) '  ADPRES IS STOPING...'
    STOP
  end if

  call print_keff(popt)

  end subroutine outer

  !****************************************************************************!

  subroutine outer_fs(popt)

  !
  ! Purpose:
  !    To perform fixed-source outer iteration

  USE sdata, ONLY: ng, nnod, nout, nin, serc, ferc, fer, ser, f0, nupd, &
                   Ke, nac, fs0, s0, ndmax, kern, get_time, fdm_time
  USE io,    ONLY: ounit, scr
  USE nodal, ONLY: nodal_update

  implicit none

  integer, optional, intent(in) :: popt

  real(dp), dimension(nnod)    :: fs0c               !old fission source
  real(dp), dimension(nnod,ng) :: f0c                !Old flux
  real(dp), dimension(nnod)    :: bs                 !total source
  integer  :: p, g
  real(dp) :: e1, e2
  real(dp), dimension(nnod) :: errn, erro            ! current and past error vectors
  logical  :: first = .true.
  real(dp) :: st, fn

  st = get_time()

  !Setup CMFD matrix
  CALL matrix_setup(1)

  !Allocate flux and fission source for first time
  if (first) then
    allocate (f0(nnod,ng), fs0(nnod), s0(nnod,ng))
    Ke = 1._dp
    f0 = 1._dp
    call FSrc(fs0)
    first = .false.
  end if

  ! Initialize keff and fission source
  errn = 1._DP
  e1 = Integrate(errn)

  fn = get_time()
  fdm_time = fdm_time + (fn-st) ! Get FDM time

  !Start outer iteration
  do p=1, nout
    st = get_time()
    fs0c = fs0       ! Save old fission source
    f0c  = f0        ! Save old flux
    erro = errn       ! Save old fission source error/difference
    do g = 1, ng
      !!!Calculate total source
      call TSrc(g, Ke, bs)

      !!!Inner Iteration
      call bicg(nin, g, bs, f0(:,g))
    end do
    CALL FSrc (fs0)               !Update fission source
    errn = fs0 - fs0c
    e2 = l2norm(errn)
    if (MOD(p,nac) == 0) call fiss_extrp(popt,e1,e2,erro,errn,fs0)     ! Fission source extrapolation
    e1 = e2                       ! Save l2 norm of the fission source error
    CALL RelE(fs0, fs0c, ser)     ! Search maximum point wise fission source Relative Error
    CALL RelEg(f0, f0c, fer)      ! Search maximum point wise flux error
    fn = get_time()
    fdm_time = fdm_time + (fn-st) ! Get FDM time
    if (MOD(p,nupd) == 0 .and. kern /= ' FDM') call nodal_upd(popt, 1)  ! Nodal coefficients update
    if (popt > 0) then
      write(ounit,'(I5,2ES15.5)') p, ser, fer            ! Write outer iteration evolution
      if (scr) write(*,'(I5,2ES15.5)') p, ser, fer      ! Write outer iteration evolution
    end if
    if ((ser < serc) .AND. (fer < ferc) .AND. (ndmax < 1.e-2)) exit
  end do

  if (p-1 == nout) THEN
    write(*,*)
    write(*,*) '  MAXIMUM NUMBER OF OUTER ITERATION IS REACHED IN FIXED-SOURCE CALCULATION.'
    write(*,*) '  CHECK PROBLEM SPECIFICATION OR CHANGE ITERATION CONTROL (%ITER).'
    write(*,*) '  PERHAPS BY MAKING FISSION SOURCE INTERPOLATION MORE FREQUENT'
    write(*,*) '  ADPRES IS STOPING...'
    STOP
  end if

  end subroutine outer_fs

  !****************************************************************************!

  subroutine outer_ad(popt)

  !
  ! Purpose:
  !    To perform adjoint outer iteration

  USE sdata, ONLY: ng, nnod, nout, nin, serc, ferc, fer, ser, f0, nupd, &
                   Ke, nac, fs0, s0, ndmax, kern, get_time, fdm_time
  USE io,    ONLY: ounit, scr
  USE nodal, ONLY: nodal_update

  implicit none

  integer, optional, intent(in) :: popt

  real(dp)                     :: Keo                !Old Multiplication factor (Keff)
  real(dp), dimension(nnod)    :: fs0c               !old fission source
  real(dp), dimension(nnod,ng) :: f0c                !Old flux
  real(dp), dimension(nnod)    :: bs                 !total source
  real(dp) :: f, fc                                  ! new and old integrated fission sources
  integer  :: p, g
  real(dp) :: e1, e2
  real(dp), dimension(nnod) :: errn, erro            ! current and past error vectors
  logical  :: first = .true.
  real(dp) :: st, fn

  st = get_time()

  !Setup CMFD matrix
  CALL matrix_setup(1)

  !Allocate flux and fission source for first time
  if (first .and. popt > 0) then
    allocate (f0(nnod,ng), fs0(nnod), s0(nnod,ng))
    Ke = 1._dp
    f0 = 1._dp
    call FSrcAd(fs0)
    first = .false.
  end if

  ! Initialize keff and fission source
  f = Integrate(fs0)
  errn = 1._DP
  e1 = Integrate(errn)

  fn = get_time()
  fdm_time = fdm_time + (fn-st) ! Get FDM time

  !Start outer iteration
  do p=1, nout
    st = get_time()
    fc   = f         ! Save old integrated fission source
    fs0c = fs0       ! Save old fission source
    f0c  = f0        ! Save old flux
    Keo  = Ke        ! Save old multiplication factor
    erro = errn       ! Save old fission source error/difference
    do g = ng,1,-1
      !!!Calculate total source
      call TSrcAd(g, Ke, bs)

      !!!Inner Iteration
      call bicg(nin, g, bs, f0(:,g))
    end do
    CALL FSrcAd (fs0)               !Update fission source
    errn = fs0 - fs0c
    e2 = l2norm(errn)
    if (MOD(p,nac) == 0) call fiss_extrp(popt,e1,e2,erro,errn,fs0)     ! Fission source extrapolation
    e1 = e2                       ! Save l2 norm of the fission source error
    f = Integrate(fs0)            ! Integrate fission source
    Ke = Keo * f / fc             ! Update Keff
    CALL RelE(fs0, fs0c, ser)     ! Search maximum point wise fission source Relative Error
    CALL RelEg(f0, f0c, fer)      ! Search maximum point wise flux error
    fn = get_time()
    fdm_time = fdm_time + (fn-st) ! Get FDM time
    ! For RODEJECT mode, adjoint calculation is approximated using
    ! nodal coefficients from forward calculation.
    if (MOD(p,nupd) == 0 .and. kern /= ' FDM' &
    .and. popt > 0) call nodal_upd(popt, 0)                       ! Nodal coefficients update
    if (popt > 0) then
      write(ounit,'(I5,F13.6,2ES15.5)') p, Ke, ser, fer           ! Write outer iteration evolution
      if (scr) write(*,'(I5,F13.6,2ES15.5)') p, Ke, ser, fer      ! Write outer iteration evolution
    end if
    if ((ser < serc) .AND. (fer < ferc) .AND. (ndmax < 1.e-2)) exit
  end do

  if (p-1 == nout) THEN
    write(*,*)
    write(*,*) '  MAXIMUM NUMBER OF OUTER ITERATION IS REACHED IN ADJOINT CALCULATION.'
    write(*,*) '  CHECK PROBLEM SPECIFICATION OR CHANGE ITERATION CONTROL (%ITER).'
    write(*,*) '  PERHAPS BY MAKING FISSION SOURCE INTERPOLATION MORE FREQUENT'
    write(*,*) '  ADPRES IS STOPING...'
    STOP
  end if

  call print_keff(popt)

  end subroutine outer_ad

  !****************************************************************************!

  subroutine outer_th(maxn)

  !
  ! Purpose:
  !    To perform TH outer iteration

  USE sdata, ONLY: ng, nnod, nin, serc, ferc, fer, ser, f0, nupd, &
                   Ke, nac, s0, fs0, ndmax, nth, kern, get_time, fdm_time
  USE io,    ONLY: ounit, biter
  USE nodal, ONLY: nodal_update

  implicit none

  integer, intent(in) :: maxn                        ! Max. number of outer iteration

  real(dp)                     :: Keo                !Old Multiplication factor (Keff)
  real(dp), dimension(nnod)    :: fs0c               !old fission source
  real(dp), dimension(nnod,ng) :: f0c                !Old flux
  real(dp), dimension(nnod)    :: bs                 !total source
  real(dp) :: f, fc                                  ! new and old integrated fission sources
  integer  :: p, g
  real(dp) :: e1, e2
  real(dp), dimension(nnod) :: errn, erro            ! current and past error vectors
  logical  :: first = .true.
  real(dp) :: st, fn
  logical  :: lnupd

  st = get_time()

  !Setup CMFD matrix
  CALL matrix_setup(1)

  !Allocate flux and fission source for first time
  if (first) then
    allocate (f0(nnod,ng), fs0(nnod), s0(nnod,ng))
    Ke = 1._dp
    f0 = 1._dp
    call FSrc(fs0)
    first = .false.
  end if

  ! Initialize keff and fission source
  f = Integrate(fs0)
  errn = 1._DP
  e1 = Integrate(errn)

  fn = get_time()
  fdm_time = fdm_time + (fn-st) ! Get FDM time

  if (biter == 0) nupd = int(nth/2)

  !Start outer iteration
  do p=1, maxn
    st = get_time()
    fc   = f         ! Save old integrated fission source
    fs0c = fs0       ! Save old fission source
    f0c  = f0        ! Save old flux
    Keo  = Ke        ! Save old multiplication factor
    erro = errn       ! Save old fission source error/difference
    do g = 1, ng
      !!!Calculate total source
      call TSrc(g, Ke, bs)

      !!!Inner Iteration
      call bicg(nin, g, bs, f0(:,g))
    end do
    CALL FSrc (fs0)               !Update fission source
    errn = fs0 - fs0c
    e2 = l2norm(errn)
    if (MOD(p,nac) == 0) call fiss_extrp(0,e1,e2,erro,errn,fs0)     ! Fission source extrapolation
    e1 = e2                       ! Save l2 norm of the fission source error
    f = Integrate(fs0)            ! Integrate fission source
    Ke = Keo * f / fc             ! Update Keff
    CALL RelE(fs0, fs0c, ser)     ! Search maximum point wise fission source Relative Error
    CALL RelEg(f0, f0c, fer)      ! Search maximum point wise flux error
    fn = get_time()
    fdm_time = fdm_time + (fn-st) ! Get FDM time
    if (MOD(p,nupd) == 0 .and. kern /= ' FDM') then
      lnupd = .false.
      call nodal_upd(0, 1)        ! Nodal coefficients update
    end if
    if ((ser < serc) .AND. (fer < ferc) .AND. (ndmax < 1.e-2)) exit
  end do

  if (lnupd .and. kern /= ' FDM') then
    write(*,*) 'ERROR: OUTER ITERATION WITHIN T-H ITERATION FINISHED WITHOUT NODAL UPDATE'
    write(*,*) 'CHANGE ITERATION CONTROL USING %ITER CARD'
    write(ounit,*) 'ERROR: OUTER ITERATION WITHIN T-H ITERATION FINISHED WITHOUT NODAL UPDATE'
    write(ounit,*) 'CHANGE ITERATION CONTROL USING %ITER CARD'
    stop
  end if

  end subroutine outer_th

  !****************************************************************************!

  subroutine outer_tr(ht,maxi)

  !
  ! Purpose:
  !    To perform transient fixed source outer iteration

  USE sdata, ONLY: ng, nnod, nout, nin, serc, ferc, fer, ser, f0, nupd, &
                   nac, fs0, ndmax, exsrc, kern, get_time, fdm_time
  USE nodal, ONLY: nodal_update

  implicit none

  real(dp), intent(in)        :: ht                ! Time step
  logical, intent(out)         :: maxi              ! Does it reach max number of iteration?

  real(dp), dimension(nnod)    :: fs0c               !old fission source
  real(dp), dimension(nnod,ng) :: f0c                !Old flux
  real(dp), dimension(nnod)    :: bs                 !total source
  integer  :: p, g
  real(dp) :: e1, e2
  real(dp), dimension(nnod) :: errn, erro            ! current and past error vectors
  real(dp) :: st, fn

  st = get_time()

  !Setup CMFD matrix
  CALL matrix_setup(1)

  ! Get terms that do not appear in static calculation
  call get_exsrc(ht, exsrc)

  fn = get_time()
  fdm_time = fdm_time + (fn-st) ! Get FDM time

  !Start outer iteration
  do p=1, nout
    st = get_time()
    fs0c = fs0       ! Save old fission source
    f0c  = f0        ! Save old flux
    erro = errn      ! Save old fission source error/difference
    do g = 1, ng
      !!!Calculate total source
      call TSrcTr(g, bs)

      !!!Inner Iteration
      call bicg(nin, g, bs, f0(:,g))
    end do
    CALL FSrc (fs0)               !Update fission source
    errn = fs0 - fs0c
    e2 = l2norm(errn)
    if (MOD(p,nac) == 0) call fiss_extrp(0,e1,e2,erro,errn,fs0)     ! Fission source extrapolation
    e1 = e2                       ! Save l2 norm of the fission source error
    CALL RelE(fs0, fs0c, ser)     ! Search maximum point wise fission source Relative Error
    CALL RelEg(f0, f0c, fer)      ! Search maximum point wise flux error
    fn = get_time()
    fdm_time = fdm_time + (fn-st) ! Get FDM time
    if (MOD(p,nupd) == 0 .and. kern /= ' FDM') call nodal_upd(0, 2)  ! Nodal coefficients update
    if ((ser < serc) .AND. (fer < ferc) .AND. (ndmax < 1.e-2)) exit
  end do

  if (p==nout+1) THEN
      maxi = .TRUE.
  ELSE
      maxi = .FALSE.
  end if

  end subroutine outer_tr

  !****************************************************************************!

   subroutine get_exsrc(ht, exsrc)

  !
  ! Purpose:
  !    To calculate paramaters from previous time step
  !

  USE sdata, ONLY: lamb, c0, iBeta, chi, mat, velo, &
  fst, ft, nf, m, omeg, ng, nnod, dfis, nuf, &
  bth, sth, s0, tbeta, sigrp, L
  USE io, ONLY: bxtab

  ! Purpose:
     ! To update get external source for transient fixed source problem
     ! This external source is the terms that do not appear in ..
     ! static calculation

  implicit none

  real(dp), intent(in)                      :: ht
  real(dp), dimension(:,:), intent(out)     :: exsrc

  real(dp) :: dt, dtp
  integer  :: n, i, g
  real(dp) :: a1, a2, pxe, pthet

  if (bxtab == 1) then
    dfis = 0._dp
    do n = 1, nnod
      dt = 0._dp; dtp = 0._dp
      do i = 1, nf
        pxe  = exp(-m(mat(n))%lamb(i)*ht)
        if (nuf(n,ng) > 0.) then
          a1   = (1._dp - pxe) / (m(mat(n))%lamb(i)*ht)
        else
          a1 = 0._dp
        end if
        a2   = 1._dp - a1
        a1   = a1 - pxe
        dfis(n) = dfis(n) + m(mat(n))%iBeta(i) * a2
        dt   = dt   + m(mat(n))%lamb(i) * c0(n,i) * pxe &
             + m(mat(n))%iBeta(i) * a1 * fst(n)
        dtp  = dtp + m(mat(n))%lamb(i) * c0(n,i)
      end do

      do g = 1, ng
        pthet = -L(n,g) - sigrp(n,g) * ft(n,g) + s0(n,g) &
              + (1._dp - tbeta(mat(n))) * chi(mat(n),g) * fst(n) &
              +  chi(mat(n),g) * dtp
        exsrc(n,g) = chi(mat(n),g) * dt &
                   + exp(omeg(n,g) * ht) * ft(n,g) &
                   / (sth * m(mat(n))%velo(g) * ht) + bth * pthet
      end do
    end do
  else
    dfis = 0._dp
    do n = 1, nnod
      dt = 0._dp; dtp = 0._dp
      do i = 1, nf
        pxe  = exp(-lamb(i)*ht)
        a1   = (1._dp - pxe) / (lamb(i)*ht)
        a2   = 1._dp - a1
        a1   = a1 - pxe
        dfis(n) = dfis(n) + iBeta(i) * a2
        dt   = dt   + lamb(i) * c0(n,i) * pxe &
             + iBeta(i) * a1 * fst(n)
        dtp  = dtp + lamb(i) * c0(n,i)
      end do

      do g = 1, ng
        pthet = -L(n,g) - sigrp(n,g) * ft(n,g) + s0(n,g) &
              + (1._dp - tbeta(mat(n))) * chi(mat(n),g) * fst(n) &
              +  chi(mat(n),g) * dtp
        exsrc(n,g) = chi(mat(n),g) * dt &
                   + exp(omeg(n,g) * ht) * ft(n,g) / (sth * velo(g) * ht) &
                   + bth * pthet
      end do
    end do
  end if

  end subroutine get_exsrc

 !****************************************************************************!

  subroutine FSrc(fs)
  !
  ! Purpose:
  !   To calculate fission source and fission source moments
  !

  USE sdata, ONLY: nnod, nuf, ng, f0

  implicit none

  real(dp), dimension(:), intent(out) :: fs

  integer :: n, g

  fs = 0._dp
  do g = 1, ng
      do n = 1, nnod
         fs(n)   = fs(n)   + f0 (n,g) * nuf(n,g)
      end do
  end do

  END subroutine FSrc

  !******************************************************************************!

  subroutine FSrcAd(fs)
    !
    ! Purpose:
    !   To calculate fission source (adjoint)
    !

    USE sdata, ONLY: nnod, chi, mat, ng, f0

    implicit none

    real(dp), dimension(:), intent(out) :: fs

    integer :: n, g

    fs = 0._dp
    do g = 1, ng
        do n = 1, nnod
           fs(n)   = fs(n)   + f0 (n,g) * chi(mat(n),g)
        end do
    end do

  end subroutine FSrcAd

  !****************************************************************************!

  subroutine TSrc(g, Keff, bs)
  !
  ! Purpose:
  !   To update total source
  !

  USE sdata, ONLY: chi, mat, nnod, fs0, f0, ng, sigs, chi, s0, exsrc

  implicit none

  integer, intent(in) :: g
  real(dp), intent(in) :: Keff
  real(dp), dimension(:), intent(out) :: bs

  integer :: n, h

  s0 = 0._dp
  do h = 1, ng
      do n = 1, nnod
          if (g /= h) s0(n,g)   = s0(n,g) + sigs(n,h,g) * f0(n,h)
      end do
  end do

  do n = 1, nnod
    bs(n) = chi(mat(n),g) * fs0(n)/Keff  + s0(n,g) + exsrc(n,g)
  end do

  end subroutine TSrc

  !******************************************************************************!

  subroutine TSrcAd(g, Keff, bs)
    !
    ! Purpose:
    !   To update total source (adjoint)
    !

    USE sdata, ONLY: nnod, fs0, f0, ng, sigs, nuf, s0, exsrc

    implicit none

    integer, intent(in) :: g
    real(dp), intent(in) :: Keff
    real(dp), dimension(:), intent(out) :: bs

    integer :: n, h

    s0 = 0._dp
    do h = 1, ng
        do n = 1, nnod
            if (g /= h) s0(n,g)   = s0(n,g) + sigs(n,g,h) * f0(n,h)
        end do
    end do

    do n = 1, nnod
      bs(n) = nuf(n,g) * fs0(n)/Keff  + s0(n,g) + exsrc(n,g)
    end do

  end subroutine TSrcAd

  !****************************************************************************!

  subroutine TSrcTr(g, bs)
  !
  ! Purpose:
  !   To update total source for transient fixed source problem
  !

  USE sdata, ONLY: chi, mat, nnod, fs0, f0, ng, sigs, chi, exsrc, &
  tbeta, s0, dfis

  implicit none

  integer, intent(in)       :: g
  real(dp), dimension(:), intent(out) :: bs

  integer :: n, h

  s0 = 0._dp
  do h = 1, ng
      do n = 1, nnod
          if (g /= h) s0(n,g)   = s0(n,g) + sigs(n,h,g) * f0(n,h)
      end do
  end do

  do n = 1, nnod
    bs(n) =  (1._dp - tbeta(mat(n)) + dfis(n)) * chi(mat(n),g) * fs0(n) &
                + s0(n,g) + exsrc(n,g)
  end do

  end subroutine TSrcTr

  !****************************************************************************!

  function l2norm(a) result(x)

    !purpose: to perform dot product

    real(dp), dimension(:), intent(in)   :: a
    real(dp)                             :: x   ! resulting vector

    integer   :: n

    x = 0._dp
    do n = 1, size(a)
      x = x + a(n)**2
    end do

    x = sqrt(x)

  end function l2norm

  !****************************************************************************!

  FUNCTION Integrate(s) RESULT(intg)

    !
    ! Purpose:
    !    To perform volume integration

  USE sdata, ONLY: nnod, vdel

  implicit none

  real(dp), dimension (:), intent(in) :: s
  real(dp) :: intg
  integer :: n

  intg = 0.
  do n = 1, nnod
      intg = intg + vdel(n) * s(n)
  end do

  end FUNCTION Integrate

  !******************************************************************************!

  subroutine RelE(newF, oldF, rel)

    !
    ! Purpose:
    !    To calculate Max Relative error

  USE sdata, ONLY: nnod

  implicit none

  real(dp), dimension(:), intent(in) :: newF, oldF
  real(dp), intent(out) :: rel

  real(dp) :: error
  integer :: n

  rel = 0.

  do n= 1, nnod
      if (ABS(newF(n)) > 1.e-10_DP) THEN
          error = ABS(newF(n) - oldF(n)) / ABS(newF(n))
          if (error > rel) rel = error
      end if
  end do

  end subroutine RelE

  !******************************************************************************!

  subroutine RelEg(newF, oldF, rel)

    !
    ! Purpose:
    !    To calculate Max Relative error for flux

  USE sdata, ONLY: nnod, ng

  implicit none

  real(dp), dimension(:,:), intent(in) :: newF, oldF
  real(dp), intent(out) :: rel

  real(dp) :: error
  integer :: n, g

  rel = 0.

  do n= 1, nnod
     do g = 1, ng
        if (ABS(newF(n,g)) > 1.d-10) THEN
           error = ABS(newF(n,g) - oldF(n,g)) / ABS(newF(n,g))
           if (error > rel) rel = error
        end if
    end do
  end do

  end subroutine RelEg

  !****************************************************************************!

  subroutine bicg(imax,g,b,x)

    !Purpose: to solve linear of system equation with BiCGSTAB method
    ! (without preconditioner). Sparse matrix saved in a and indexed in rc.
    ! a dimension is (#non_zero_elements)
    ! rc dimension is (2,#non_zero_elements+1)
    ! adapted from:
    ! https://www.cfd-online.com/Wiki/Sample_code_for_BiCGSTAB_-_Fortran_90

    implicit none

    integer, intent(in)                  :: imax, g  ! Max. number of iteration and group number
    real(dp), dimension(:), intent(in)   :: b   ! source
    real(dp), dimension(:), intent(inout)  :: x

    real(dp), dimension(size(b, dim=1))  :: r, rs, v, p, s, t
    real(dp)                             :: rho      , rho_prev
    real(dp)                             :: alpha    , omega   , beta, theta
    integer                              :: i

    r  = b - sp_matvec(g,x)
    rs = r
    rho   = 1.0_dp; alpha = 1.0_dp; omega = 1.0_dp
    v  = 0.0_dp; p  = 0.0_dp

    do i = 1, imax
      rho_prev = rho
      rho      = dproduct(rs,r)
      beta     = (rho/rho_prev) * (alpha/omega)
      p        = r + beta * (p - omega*v)
      v        = sp_matvec(g,p)
      alpha    = rho/dproduct(rs,v)
      s        = r - alpha*v
      t        = sp_matvec(g,s)
      theta    = dproduct(t,t)
      omega    = dproduct(t,s)/theta
      x        = x + alpha*p + omega*s
      r        = s - omega*t
    end do

  end subroutine bicg

 !****************************************************************************!

 function sp_matvec(g,x) result(v)

   USE sdata, ONLY: A, ind, nnod

   !purpose: to perform matrix vector multiplication Axb. A is a square matrix.
   ! Sparse matrix saved in A and indexed in ind

   integer, intent(in) :: g                    ! group number of FDM matrix
   real(dp), dimension(:), intent(in)   :: x   ! vector
   real(dp), dimension(size(x))         :: v   ! resulting vector

   integer   :: n
   integer   :: i

   v = 0._dp
   do n = 1, nnod
     do i = 1, ind(n)%ncol
       v(n) = v(n) + A(n,g)%elmn(i)*x(ind(n)%col(i))
     end do
   end do

 end function sp_matvec

 !****************************************************************************!

 function dproduct(a,b) result(x)

   !purpose: to perform dot product

   real(dp), dimension(:), intent(in)   :: a, b   ! vector
   real(dp)                             :: x   ! resulting vector

   integer   :: n

   x = 0._dp
   do n = 1, size(a)
     x = x + a(n) * b(n)
   end do

 end function dproduct

  !****************************************************************************!

  subroutine PowDis (p)

  !
  ! Purpose:
  !    To calculate power distribution
  !

  USE sdata, ONLY: ng, nnod, sigf, f0, vdel, mode
  USE io,    ONLY: ounit

  implicit none

  real(dp), dimension(:), intent(out) :: p
  integer :: g, n
  real(dp) :: tpow, pow

  p = 0._DP
  do g= 1, ng
      do n= 1, nnod
        pow = f0(n,g) * sigf(n,g) * vdel(n)
        if (pow < 0.) pow = 0.
        p(n) = p(n) + pow
      end do
  end do

  ! Normalize to 1._DP
  tpow = 0._DP
  do n = 1, nnod
      tpow = tpow + p(n)
  end do

  if (tpow <= 0 .AND. mode /= 'FIXEDSRC') THEN
     write(ounit, *) '   ERROR: TOTAL NODES POWER IS ZERO OR LESS'
     write(ounit, *) '   STOP IN subroutine POWDIS'
     STOP
  end if

  do n = 1, nnod
      p(n) = p(n) / tpow
  end do

  end subroutine PowDis

  !****************************************************************************!

end module


      double complex function trI3(p1,p2,p3,m1,m2,m3,mu2,ep)
c--- this is a switchyard routine: depending on value of
c--- integer variable, this routine either:
c---  TRscalarselect = 1    calls QCDLoop for scalar integral
c---  TRscalarselect = 2    calls OneLOop for scalar integral
c---  TRscalarselect = 3    calls both routines and compares results
c      use avh_olo
      implicit none
      include 'TRscalarselect.f'
      double precision p1,p2,p3,m1,m2,m3,mu2
      double complex qlI3,resQCDLoop,resOneLOop,result(0:2)
      integer ep

      TRscalarselect=1

c--- call to QCDLoop if necessary
      if ((TRscalarselect .eq. 1) .or.(TRscalarselect .eq. 3)) then
        resQCDLoop=qlI3(p1,p2,p3,m1,m2,m3,mu2,ep)
      endif

      if (TRscalarselect .eq. 1) then
        trI3=resQCDLoop
        return
      endif

      call olo_c0(result,p1,p2,p3,m1,m2,m3,dsqrt(mu2))
      resOneLOop=result(abs(ep))
      trI3=resOneLOop

      if (TRscalarselect .eq. 3) then
        if ((cdabs(resOneLOop) .gt. 1d-12) .and.
     &      (abs(resQCDLoop/resOneLOop-1d0) .gt. 1d-12)) then
          write(6,*) 'trI3: ',p1,p2,p3,m1,m2,m3,mu2,ep
          write(6,*) 'QCDLoop:',resQCDLoop
          write(6,*) 'OneLOop:',resOneLOop
          write(6,*) '->ratio:',resQCDLoop/resOneLOop
        endif
      endif

      return
      end


program complex2
complex :: x, y, z
x = (3.0, 4.0)
y = (3.0, 2.0)
z = x**y
print *, z
end program


C FISHPAK7 FROM PORTLIB                                  12/30/83
      SUBROUTINE HSTCRT (A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,
     1                   ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                        F I S H P A K                          *
C     *                                                               *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                  (VERSION 3.1 , OCTOBER 1980)                  *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C     * * * * * * * * *  PURPOSE    * * * * * * * * * * * * * * * * * *
C
C      HSTCRT SOLVES THE STANDARD FIVE-POINT FINITE DIFFERENCE
C      APPROXIMATION ON A STAGGERED GRID TO THE HELMHOLTZ EQUATION IN
C      CARTESIAN COORDINATES
C
C      (D/DX)(DU/DX) + (D/DY)(DU/DY) + LAMBDA*U = F(X,Y)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     * * * * * * * *    PARAMETER DESCRIPTION     * * * * * * * * * *
C
C             * * * * * *   ON INPUT    * * * * * *
C
C    A,B
C      THE RANGE OF X, I.E. A .LE. X .LE. B.  A MUST BE LESS THAN B.
C
C    M
C      THE NUMBER OF GRID POINTS IN THE INTERVAL (A,B).  THE GRID POINTS
C      IN THE X-DIRECTION ARE GIVEN BY X(I) = A + (I-0.5)DX FOR
C      I=1,2,...,M WHERE DX =(B-A)/M.  M MUST BE GREATER THAN 2.
C
C    MBDCND
C      INDICATES THE TYPE OF BOUNDARY CONDITIONS AT X = A AND X = B.
C
C      = 0  IF THE SOLUTION IS PERIODIC IN X,
C           U(M+I,J) = U(I,J).
C
C      = 1  IF THE SOLUTION IS SPECIFIED AT X = A AND X = B.
C
C      = 2  IF THE SOLUTION IS SPECIFIED AT X = A AND THE DERIVATIVE
C           OF THE SOLUTION WITH RESPECT TO X IS SPECIFIED AT X = B.
C
C      = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO X IS
C           SPECIFIED AT X = A  AND X = B.
C
C      = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO X IS
C           SPECIFIED AT X = A  AND THE SOLUTION IS SPECIFIED AT X = B.
C
C    BDA
C      A ONE-DIMENSIONAL ARRAY OF LENGTH N THAT SPECIFIES THE BOUNDARY
C      VALUES (IF ANY) OF THE SOLUTION AT X = A.  WHEN MBDCND = 1 OR 2,
C
C               BDA(J) = U(A,Y(J)) ,          J=1,2,...,N.
C
C      WHEN MBDCND = 3 OR 4,
C
C               BDA(J) = (D/DX)U(A,Y(J)) ,    J=1,2,...,N.
C
C    BDB
C      A ONE-DIMENSIONAL ARRAY OF LENGTH N THAT SPECIFIES THE BOUNDARY
C      VALUES OF THE SOLUTION AT X = B.  WHEN MBDCND = 1 OR 4
C
C               BDB(J) = U(B,Y(J)) ,          J=1,2,...,N.
C
C      WHEN MBDCND = 2 OR 3
C
C               BDB(J) = (D/DX)U(B,Y(J)) ,    J=1,2,...,N.
C
C    C,D
C      THE RANGE OF Y, I.E. C .LE. Y .LE. D.  C MUST BE LESS
C      THAN D.
C
C    N
C      THE NUMBER OF UNKNOWNS IN THE INTERVAL (C,D).  THE UNKNOWNS IN
C      THE Y-DIRECTION ARE GIVEN BY Y(J) = C + (J-0.5)DY,
C      J=1,2,...,N, WHERE DY = (D-C)/N.  N MUST BE GREATER THAN 2.
C
C    NBDCND
C      INDICATES THE TYPE OF BOUNDARY CONDITIONS AT Y = C
C      AND Y = D.
C
C      = 0  IF THE SOLUTION IS PERIODIC IN Y, I.E.
C           U(I,J) = U(I,N+J).
C
C      = 1  IF THE SOLUTION IS SPECIFIED AT Y = C AND Y = D.
C
C      = 2  IF THE SOLUTION IS SPECIFIED AT Y = C AND THE DERIVATIVE
C           OF THE SOLUTION WITH RESPECT TO Y IS SPECIFIED AT Y = D.
C
C      = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO Y IS
C           SPECIFIED AT Y = C AND Y = D.
C
C      = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO Y IS
C           SPECIFIED AT Y = C AND THE SOLUTION IS SPECIFIED AT Y = D.
C
C    BDC
C      A ONE DIMENSIONAL ARRAY OF LENGTH M THAT SPECIFIES THE BOUNDARY
C      VALUES OF THE SOLUTION AT Y = C.   WHEN NBDCND = 1 OR 2,
C
C               BDC(I) = U(X(I),C) ,              I=1,2,...,M.
C
C      WHEN NBDCND = 3 OR 4,
C
C               BDC(I) = (D/DY)U(X(I),C),     I=1,2,...,M.
C
C      WHEN NBDCND = 0, BDC IS A DUMMY VARIABLE.
C
C    BDD
C      A ONE-DIMENSIONAL ARRAY OF LENGTH M THAT SPECIFIES THE BOUNDARY
C      VALUES OF THE SOLUTION AT Y = D.  WHEN NBDCND = 1 OR 4,
C
C               BDD(I) = U(X(I),D) ,              I=1,2,...,M.
C
C      WHEN NBDCND = 2 OR 3,
C
C               BDD(I) = (D/DY)U(X(I),D) ,    I=1,2,...,M.
C
C      WHEN NBDCND = 0, BDD IS A DUMMY VARIABLE.
C
C    ELMBDA
C      THE CONSTANT LAMBDA IN THE HELMHOLTZ EQUATION.  IF LAMBDA IS
C      GREATER THAN 0, A SOLUTION MAY NOT EXIST.  HOWEVER, HSTCRT WILL
C      ATTEMPT TO FIND A SOLUTION.
C
C    F
C      A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE RIGHT
C      SIDE OF THE HELMHOLTZ EQUATION.  FOR I=1,2,...,M AND J=1,2,...,N
C
C               F(I,J) = F(X(I),Y(J)) .
C
C      F MUST BE DIMENSIONED AT LEAST M X N.
C
C    IDIMF
C      THE ROW (OR FIRST) DIMENSION OF THE ARRAY F AS IT APPEARS IN THE
C      PROGRAM CALLING HSTCRT.  THIS PARAMETER IS USED TO SPECIFY THE
C      VARIABLE DIMENSION OF F.  IDIMF MUST BE AT LEAST M.
C
C    W
C      A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED BY THE USER FOR
C      WORK SPACE.  W MAY REQUIRE UP TO 13M + 4N + M*INT(LOG2(N))
C      LOCATIONS.  THE ACTUAL NUMBER OF LOCATIONS USED IS COMPUTED BY
C      HSTCRT AND IS RETURNED IN THE LOCATION W(1).
C
C
C             * * * * * *   ON OUTPUT   * * * * * *
C
C    F
C      CONTAINS THE SOLUTION U(I,J) OF THE FINITE DIFFERENCE
C      APPROXIMATION FOR THE GRID POINT (X(I),Y(J)) FOR
C      I=1,2,...,M, J=1,2,...,N.
C
C    PERTRB
C      IF A COMBINATION OF PERIODIC OR DERIVATIVE BOUNDARY CONDITIONS IS
C      SPECIFIED FOR A POISSON EQUATION (LAMBDA = 0), A SOLUTION MAY NOT
C      EXIST.  PERTRB IS A CONSTANT, CALCULATED AND SUBTRACTED FROM F,
C      WHICH ENSURES THAT A SOLUTION EXISTS.  HSTCRT THEN COMPUTES THIS
C      SOLUTION, WHICH IS A LEAST SQUARES SOLUTION TO THE ORIGINAL
C      APPROXIMATION.  THIS SOLUTION PLUS ANY CONSTANT IS ALSO A
C      SOLUTION; HENCE, THE SOLUTION IS NOT UNIQUE.  THE VALUE OF PERTRB
C      SHOULD BE SMALL COMPARED TO THE RIGHT SIDE F.  OTHERWISE, A
C      SOLUTION IS OBTAINED TO AN ESSENTIALLY DIFFERENT PROBLEM.  THIS
C      COMPARISON SHOULD ALWAYS BE MADE TO INSURE THAT A MEANINGFUL
C      SOLUTION HAS BEEN OBTAINED.
C
C    IERROR
C      AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS.
C      EXCEPT TO NUMBERS 0 AND  6, A SOLUTION IS NOT ATTEMPTED.
C
C      =  0  NO ERROR
C
C      =  1  A .GE. B
C
C      =  2  MBDCND .LT. 0 OR MBDCND .GT. 4
C
C      =  3  C .GE. D
C
C      =  4  N .LE. 2
C
C      =  5  NBDCND .LT. 0 OR NBDCND .GT. 4
C
C      =  6  LAMBDA .GT. 0
C
C      =  7  IDIMF .LT. M
C
C      =  8  M .LE. 2
C
C      SINCE THIS IS THE ONLY MEANS OF INDICATING A POSSIBLY
C      INCORRECT CALL TO HSTCRT, THE USER SHOULD TEST IERROR AFTER
C      THE CALL.
C
C    W
C      W(1) CONTAINS THE REQUIRED LENGTH OF W.
C
C
C     * * * * * * *   PROGRAM SPECIFICATIONS    * * * * * * * * * * * *
C
C     DIMENSION OF   BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N),
C     ARGUMENTS      W(SEE ARGUMENT LIST)
C
C     LATEST         JUNE 1, 1977
C     REVISION
C
C     SUBPROGRAMS    HSTCRT,POISTG,POSTG2,GENBUN,POISD2,POISN2,POISP2,
C     REQUIRED       COSGEN,MERGE,TRIX,TRI3,PIMACH
C
C     SPECIAL        NONE
C     CONDITIONS
C
C     COMMON         NONE
C     BLOCKS
C
C     I/O            NONE
C
C     PRECISION      SINGLE
C
C     SPECIALIST     ROLAND SWEET
C
C     LANGUAGE       FORTRAN
C
C     HISTORY        WRITTEN BY ROLAND SWEET AT NCAR IN JANUARY , 1977
C
C     ALGORITHM      THIS SUBROUTINE DEFINES THE FINITE-DIFFERENCE
C                    EQUATIONS, INCORPORATES BOUNDARY DATA, ADJUSTS THE
C                    RIGHT SIDE WHEN THE SYSTEM IS SINGULAR AND CALLS
C                    EITHER POISTG OR GENBUN WHICH SOLVES THE LINEAR
C                    SYSTEM OF EQUATIONS.
C
C     SPACE          8131(DECIMAL) = 17703(OCTAL) LOCATIONS ON THE
C     REQUIRED       NCAR CONTROL DATA 7600
C
C     TIMING AND        THE EXECUTION TIME T ON THE NCAR CONTROL DATA
C     ACCURACY       7600 FOR SUBROUTINE HSTCRT IS ROUGHLY PROPORTIONAL
C                    TO M*N*LOG2(N).  SOME TYPICAL VALUES ARE LISTED IN
C                    THE TABLE BELOW.
C                       THE SOLUTION PROCESS EMPLOYED RESULTS IN A LOSS
C                    OF NO MORE THAN FOUR SIGNIFICANT DIGITS FOR N AND M
C                    AS LARGE AS 64.  MORE DETAILED INFORMATION ABOUT
C                    ACCURACY CAN BE FOUND IN THE DOCUMENTATION FOR
C                    SUBROUTINE POISTG WHICH IS THE ROUTINE THAT
C                    ACTUALLY SOLVES THE FINITE DIFFERENCE EQUATIONS.
C
C
C                       M(=N)    MBDCND    NBDCND    T(MSECS)
C                       -----    ------    ------    --------
C
C                        32       1-4       1-4         56
C                        64       1-4       1-4        230
C
C     PORTABILITY    AMERICAN NATIONAL STANDARDS INSTITUTE FORTRAN.
C                    ALL MACHINE DEPENDENT CONSTANTS ARE LOCATED IN THE
C                    FUNCTION PIMACH.
C
C     REQUIRED       COS
C     RESIDENT
C     ROUTINES
C
C     REFERENCE      SCHUMANN, U. AND R. SWEET,"A DIRECT METHOD FOR
C                    THE SOLUTION OF POISSON"S EQUATION WITH NEUMANN
C                    BOUNDARY CONDITIONS ON A STAGGERED GRID OF
C                    ARBITRARY SIZE," J. COMP. PHYS. 20(1976),
C                    PP. 171-182.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
      DIMENSION       F(IDIMF,1) ,BDA(1)     ,BDB(1)     ,BDC(1)     ,
     1                BDD(1)     ,W(1)
C
C     CHECK FOR INVALID PARAMETERS.
C
      IERROR = 0
      IF (A .GE. B) IERROR = 1
      IF (MBDCND.LT.0 .OR. MBDCND.GT.4) IERROR = 2
      IF (C .GE. D) IERROR = 3
      IF (N .LE. 2) IERROR = 4
      IF (NBDCND.LT.0 .OR. NBDCND.GT.4) IERROR = 5
      IF (IDIMF .LT. M) IERROR = 7
      IF (M .LE. 2) IERROR = 8
      IF (IERROR .NE. 0) RETURN
      NPEROD = NBDCND
      MPEROD = 0
      IF (MBDCND .GT. 0) MPEROD = 1
      DELTAX = (B-A)/FLOAT(M)
      TWDELX = 1./DELTAX
      DELXSQ = 2./DELTAX**2
      DELTAY = (D-C)/FLOAT(N)
      TWDELY = 1./DELTAY
      DELYSQ = DELTAY**2
      TWDYSQ = 2./DELYSQ
      NP = NBDCND+1
      MP = MBDCND+1
C
C     DEFINE THE A,B,C COEFFICIENTS IN W-ARRAY.
C
      ID2 = M
      ID3 = ID2+M
      ID4 = ID3+M
      S = (DELTAY/DELTAX)**2
      ST2 = 2.*S
      DO 101 I=1,M
         W(I) = S
         J = ID2+I
         W(J) = -ST2+ELMBDA*DELYSQ
         J = ID3+I
         W(J) = S
  101 CONTINUE
C
C     ENTER BOUNDARY DATA FOR X-BOUNDARIES.
C
      GO TO (111,102,102,104,104),MP
  102 DO 103 J=1,N
         F(1,J) = F(1,J)-BDA(J)*DELXSQ
  103 CONTINUE
      W(ID2+1) = W(ID2+1)-W(1)
      GO TO 106
  104 DO 105 J=1,N
         F(1,J) = F(1,J)+BDA(J)*TWDELX
  105 CONTINUE
      W(ID2+1) = W(ID2+1)+W(1)
  106 GO TO (111,107,109,109,107),MP
  107 DO 108 J=1,N
         F(M,J) = F(M,J)-BDB(J)*DELXSQ
  108 CONTINUE
      W(ID3) = W(ID3)-W(1)
      GO TO 111
  109 DO 110 J=1,N
         F(M,J) = F(M,J)-BDB(J)*TWDELX
  110 CONTINUE
      W(ID3) = W(ID3)+W(1)
  111 CONTINUE
C
C     ENTER BOUNDARY DATA FOR Y-BOUNDARIES.
C
      GO TO (121,112,112,114,114),NP
  112 DO 113 I=1,M
         F(I,1) = F(I,1)-BDC(I)*TWDYSQ
  113 CONTINUE
      GO TO 116
  114 DO 115 I=1,M
         F(I,1) = F(I,1)+BDC(I)*TWDELY
  115 CONTINUE
  116 GO TO (121,117,119,119,117),NP
  117 DO 118 I=1,M
         F(I,N) = F(I,N)-BDD(I)*TWDYSQ
  118 CONTINUE
      GO TO 121
  119 DO 120 I=1,M
         F(I,N) = F(I,N)-BDD(I)*TWDELY
  120 CONTINUE
  121 CONTINUE
      DO 123 I=1,M
         DO 122 J=1,N
            F(I,J) = F(I,J)*DELYSQ
  122    CONTINUE
  123 CONTINUE
      IF (MPEROD .EQ. 0) GO TO 124
      W(1) = 0.
      W(ID4) = 0.
  124 CONTINUE
      PERTRB = 0.
      IF (ELMBDA) 133,126,125
  125 IERROR = 6
      GO TO 133
  126 GO TO (127,133,133,127,133),MP
  127 GO TO (128,133,133,128,133),NP
C
C     FOR SINGULAR PROBLEMS MUST ADJUST DATA TO INSURE THAT A SOLUTION
C     WILL EXIST.
C
  128 CONTINUE
      S = 0.
      DO 130 J=1,N
         DO 129 I=1,M
            S = S+F(I,J)
  129    CONTINUE
  130 CONTINUE
      PERTRB = S/FLOAT(M*N)
      DO 132 J=1,N
         DO 131 I=1,M
            F(I,J) = F(I,J)-PERTRB
  131    CONTINUE
  132 CONTINUE
      PERTRB = PERTRB/DELYSQ
C
C     SOLVE THE EQUATION.
C
  133 CONTINUE
      IF (NPEROD .EQ. 0) GO TO 134
      CALL POISTG (NPEROD,N,MPEROD,M,W(1),W(ID2+1),W(ID3+1),IDIMF,F,
     1             IERR1,W(ID4+1))
      GO TO 135
  134 CONTINUE
      CALL GENBUN (NPEROD,N,MPEROD,M,W(1),W(ID2+1),W(ID3+1),IDIMF,F,
     1             IERR1,W(ID4+1))
  135 CONTINUE
      W(1) = W(ID4+1)+3.*FLOAT(M)
      RETURN
      END