!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine umat_ideal_gas(amat,iel,iint,kode,elconloc,emec,emec0,
     &        beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime,
     &        icmd,ielas,mi,
     &        nstate_,xstateini,xstate,stre,stiff,iorien,pgauss,orab)
!
!     calculates stiffness and stresses for an ideal gas
!     For this material there is just one material constant equal to
!     initial density x specific gas constant
!     The user should list this constant (which does not depend on
!     the temperature)
!     underneath the *USER MATERIAL,CONSTANTS=1 card. The name of the
!     material has to start with IDEAL_GAS, e.g. IDEAL_GAS_AIR or
!     IDEAL_GAS_NITROGEN etc.
!
!     This routine should only be used with nlgeom=yes
!
!     icmd=3: calculates stress at mechanical strain
!     else: calculates stress at mechanical strain and the stiffness
!           matrix
!
!     INPUT:
!
!     amat               material name
!     iel                element number
!     iint               integration point number
!
!     kode               material type (-100-#of constants entered
!                        under *USER MATERIAL): can be used for materials
!                        with varying number of constants
!
!     elconloc(21)       user defined constants defined by the keyword
!                        card *USER MATERIAL (max. 21, actual # =
!                        -kode-100), interpolated for the
!                        actual temperature t1l
!
!     emec(6)            Lagrange mechanical strain tensor (component order:
!                        11,22,33,12,13,23) at the end of the increment
!                        (thermal strains are subtracted)
!     emec0(6)           Lagrange mechanical strain tensor at the start of the
!                        increment (thermal strains are subtracted)
!     beta(6)            residual stress tensor (the stress entered under
!                        the keyword *INITIAL CONDITIONS,TYPE=STRESS)
!
!     xokl(3,3)          deformation gradient at the start of the increment
!     voj                Jacobian at the start of the increment
!     xkl(3,3)           deformation gradient at the end of the increment
!     vj                 Jacobian at the end of the increment
!
!     ithermal           0: no thermal effects are taken into account
!                        >0: thermal effects are taken into account (triggered
!                        by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE)
!     t1l                temperature at the end of the increment
!     dtime              time length of the increment
!     time               step time at the end of the current increment
!     ttime              total time at the start of the current step
!
!     icmd               not equal to 3: calculate stress and stiffness
!                        3: calculate only stress
!     ielas              0: no elastic iteration: irreversible effects
!                        are allowed
!                        1: elastic iteration, i.e. no irreversible
!                           deformation allowed
!
!     mi(1)              max. # of integration points per element in the
!                        model
!     nstate_            max. # of state variables in the model
!
!     xstateini(nstate_,mi(1),# of elements)
!                        state variables at the start of the increment
!     xstate(nstate_,mi(1),# of elements)
!                        state variables at the end of the increment
!
!     stre(6)            Piola-Kirchhoff stress of the second kind
!                        at the start of the increment
!
!     iorien             number of the local coordinate axis system
!                        in the integration point at stake (takes the value
!                        0 if no local system applies)
!     pgauss(3)          global coordinates of the integration point
!     orab(7,*)          description of all local coordinate systems.
!                        If a local coordinate system applies the global
!                        tensors can be obtained by premultiplying the local
!                        tensors with skl(3,3). skl is  determined by calling
!                        the subroutine transformatrix:
!                        call transformatrix(orab(1,iorien),pgauss,skl)
!
!
!     OUTPUT:
!
!     xstate(nstate_,mi(1),# of elements)
!                        updated state variables at the end of the increment
!     stre(6)            Piola-Kirchhoff stress of the second kind at the
!                        end of the increment
!     stiff(21):         consistent tangent stiffness matrix in the material
!                        frame of reference at the end of the increment. In
!                        other words: the derivative of the PK2 stress with
!                        respect to the Lagrangian strain tensor. The matrix
!                        is supposed to be symmetric, only the upper half is
!                        to be given in the same order as for a fully
!                        anisotropic elastic material (*ELASTIC,TYPE=ANISO).
!                        Notice that the matrix is an integral part of the
!                        fourth order material tensor, i.e. the Voigt notation
!                        is not used.
!
      implicit none
!
      character*80 amat
!
      integer ithermal(*),icmd,kode,ielas,iel,iint,nstate_,mi(*),iorien,
     &  i,
     &  kk(84),k,l,m,n,nt
!
      real*8 elconloc(*),stiff(21),emec(6),emec0(6),beta(6),stre(6),
     &  vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*),
     &  time,ttime,xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*),
     &  rho0r,c(3,3),cinv(3,3),v3,didc(3,3)
!
      kk=(/1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3,
     &  1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3,3,3,1,3,
     &  1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3,1,2,2,3,1,3,2,3,
     &  2,3,2,3/)
!
      rho0r=elconloc(1)
!
!     calculation of the Green deformation tensor for the total
!     strain and the thermal strain
!
      do i=1,3
         c(i,i)=emec(i)*2.d0+1.d0
      enddo
      c(1,2)=2.d0*emec(4)
      c(1,3)=2.d0*emec(5)
      c(2,3)=2.d0*emec(6)
!
!     calculation of the third invariant of C
!
      v3=c(1,1)*(c(2,2)*c(3,3)-c(2,3)*c(2,3))
     &     -c(1,2)*(c(1,2)*c(3,3)-c(1,3)*c(2,3))
     &     +c(1,3)*(c(1,2)*c(2,3)-c(1,3)*c(2,2))
!
!     inversion of c
!
      cinv(1,1)=(c(2,2)*c(3,3)-c(2,3)*c(2,3))/v3
      cinv(2,2)=(c(1,1)*c(3,3)-c(1,3)*c(1,3))/v3
      cinv(3,3)=(c(1,1)*c(2,2)-c(1,2)*c(1,2))/v3
      cinv(1,2)=(c(1,3)*c(2,3)-c(1,2)*c(3,3))/v3
      cinv(1,3)=(c(1,2)*c(2,3)-c(2,2)*c(1,3))/v3
      cinv(2,3)=(c(1,2)*c(1,3)-c(1,1)*c(2,3))/v3
      cinv(2,1)=cinv(1,2)
      cinv(3,1)=cinv(1,3)
      cinv(3,2)=cinv(2,3)
!
!     changing the meaning of v3
!
      v3=v3*rho0r
!
!     stress at mechanical strain
!
      stre(1)=v3*cinv(1,1)
      stre(2)=v3*cinv(2,2)
      stre(3)=v3*cinv(3,3)
      stre(4)=v3*cinv(1,2)
      stre(5)=v3*cinv(1,3)
      stre(6)=v3*cinv(2,3)
!
!     tangent
!
      if(icmd.ne.3) then
!
!
!        second derivative of the c-invariants w.r.t. c(k,l)
!        and c(m,n)
!
         if(icmd.ne.3) then
            nt=0
            do i=1,21
               k=kk(nt+1)
               l=kk(nt+2)
               m=kk(nt+3)
               n=kk(nt+4)
               nt=nt+4
               stiff(i)=v3*(cinv(m,n)*cinv(k,l)-
     &            (cinv(k,m)*cinv(n,l)+cinv(k,n)*cinv(m,l))/2.d0)
            enddo
         endif
      endif
!
      return
      end


module SD_volume_operator
#include <messenger.h>
    use mod_kinds,              only: rk,ik
    use mod_constants,          only: ZERO,ONE,TWO,HALF

    use type_operator,          only: operator_t
    use type_chidg_worker,      only: chidg_worker_t
    use type_properties,        only: properties_t
    use DNAD_D
    use ieee_arithmetic
    implicit none
    private

    !>
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   9/14/2016
    !!
    !!
    !!
    !-------------------------------------------------------------------------
    type, extends(operator_t), public :: SD_volume_operator_t

    contains

        procedure   :: init
        procedure   :: compute

    end type SD_volume_operator_t
    !*************************************************************************

contains

    !>
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   8/29/2016
    !!
    !--------------------------------------------------------------------------------
    subroutine init(self)
        class(SD_volume_operator_t),   intent(inout)      :: self

        ! Set operator name
        call self%set_name('Scalar Diffusion Volume Operator')

        ! Set operator type
        call self%set_operator_type('Volume Diffusive Operator')

        ! Set operator equations
        call self%add_primary_field('u')

    end subroutine init
    !********************************************************************************

    !>
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   9/14/2016
    !!
    !!
    !!
    !------------------------------------------------------------------------------------
    subroutine compute(self,worker,prop)
        class(SD_volume_operator_t),    intent(inout)   :: self
        type(chidg_worker_t),           intent(inout)   :: worker
        class(properties_t),            intent(inout)   :: prop

        type(AD_D), allocatable, dimension(:)   ::  &
            grad1_u, grad2_u, grad3_u, mu,          &
            flux_1, flux_2, flux_3

        !
        ! Interpolate solution to quadrature nodes
        !
        grad1_u = worker%get_field('u', 'grad1', 'element')
        grad2_u = worker%get_field('u', 'grad2', 'element')
        grad3_u = worker%get_field('u', 'grad3', 'element')

        !
        ! Compute scalar coefficient
        !
        mu = worker%get_field('Scalar Diffusion Coefficient', 'value', 'element')

        !
        ! Compute volume flux at quadrature nodes
        !
        flux_1 = -mu*grad1_u
        flux_2 = -mu*grad2_u
        flux_3 = -mu*grad3_u

        !
        ! Integrate volume flux
        !
        call worker%integrate_volume_flux('u','Diffusion',flux_1,flux_2,flux_3)

    end subroutine compute
    !****************************************************************************************************

end module SD_volume_operator


!
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
       module B_and_J_Library
       use BJdata

       contains

       subroutine b_eval(theta,zeta,bfield)
       implicit none
       real(rprec), parameter :: zero = 0._dp
       real(rprec) :: theta, zeta, bfield
       real(rprec), dimension(max_bmns) :: temp
       temp(:) = blocal_rdcd(:)*cos(theta*xm_rdcd(:)
     >   - zeta*xn_rdcd(:))
       bfield = sum(temp)

       end subroutine b_eval

       function b_along_fld_line(arg)  result(bb)
       implicit none
       real(rprec) :: zeta, theta, bb, arg
       real(rprec), dimension(max_bmns) :: temp
       select case (device)
        case ("qos")
         zeta = arg
         theta = theta0 + iota_local*zeta
        case ("qas")
         theta = arg
         zeta = theta/iota_local + phi0
        case default
         write(*,'("Need to select either qo or qa device")')
         stop 23
        end select
        temp(:) = blocal_rdcd(:)*cos(theta*xm_rdcd(:)
     >   - zeta*xn_rdcd(:))
        bb = sum(temp)
c        call b_eval(theta,zeta,bb)
       end function b_along_fld_line
c
       function invb_along_fld_line(arg)  result(bi)
       implicit none
       real(rprec) :: zeta, theta, bb, bi, arg
       real(rprec), dimension(max_bmns) :: temp
       select case (device)
        case ("qos")
         zeta = arg
         theta = theta0 + iota_local*zeta
        case ("qas")
         theta = arg
         zeta = theta/iota_local + phi0
        case default
         write(*,'("Need to select either qo or qa device")')
         stop 23
        end select
        temp(:) = blocal_rdcd(:)*cos(theta*xm_rdcd(:)
     >   - zeta*xn_rdcd(:))
        bb = sum(temp)
c        call b_eval(theta,zeta,bb)
        bi = 1./bb
       end function invb_along_fld_line
c

       function b_along_const_theta(zeta)  result(bb)
       implicit none
       real(rprec) :: zeta, theta, bb
         theta = theta0
        call b_eval(theta,zeta,bb)
       end function b_along_const_theta
c

       function invb_along_const_theta(zeta)  result(bi)
       implicit none
       real(rprec) :: zeta, theta, bb, bi
        theta = theta0
        call b_eval(theta,zeta,bb)
        bi = 1./bb
       end function invb_along_const_theta
c
       end module B_and_J_Library


      SUBROUTINE CALCULATE_XY(IRAYPROC,NUMCOEFF,AZ,VE,XLLS,YLLS,
     $NDATA,WEIGHT)

C  This subroutine calculates the independent variables used in the
C  regression for all good data on a ring and stores them in arrays.

      IMPLICIT NONE
      INCLUDE 'vad_analysis_memory.for'
      INCLUDE 'vad_analysis_constants.for'
      INTEGER IRAYPROC,NUMCOEFF,NDATA,I,J,N
      REAL AZ(IRAYPROC),VE(IRAYPROC),XLLS(MAXCOEFFS,IRAYPROC),
     $YLLS(IRAYPROC),A,WEIGHT(IRAYPROC)
cc -- Changed 1-24-98 by wcl, NDATA is not initialized the first time
cc      DO I=1,NDATA
      do i=1,irayproc
      WEIGHT(I)=1.
      ENDDO
      NDATA=0
      N=NUMCOEFF/2
      DO 100 I=1,IRAYPROC
         IF(VE(I).LE.60..AND.VE(I).GE.-70.)THEN
            NDATA=NDATA+1
c            A=AZ(I)*RAD_CONVERSION
            A=AZ(I)
            XLLS(1,NDATA)=1.
            DO 50 J=1,N
               XLLS(2*J,NDATA)=SIN(FLOAT(J)*A)
               XLLS(2*J+1,NDATA)=COS(FLOAT(J)*A)
50          CONTINUE
            YLLS(NDATA)=VE(I)
         ENDIF
100   CONTINUE
      RETURN
      END
C==============================================================================

      SUBROUTINE LLS(NUMCOEFF,NDATA,EFFECTIVE_NDATA,X,Y,WEIGHT,S,
     $STAND_ERR,C,FLAG)

C  This subroutine performs a weighted linear least squares regression.

C  Input:
C  NDATA is the number of data points to fit.
C  EFFECTIVE_NDATA is the effective number of data points to use when
C  estimating the standard deviation about the regression.
C  It should equal NDATA except when groups of data have been weighted
C  to appear to be single data points.
C  Then it should be the number of groups of data.
C  NUMCOEFF is the number of independent variables (including the constant
C  term if used) in the fit.
C  Each independent variable has a coefficient to be determined.
C  X(I,J) is the value of the Ith independent variable for the Jth data point.
C  Y(J) is the value of the dependent variable for the Jth data point.
C  WEIGHT(J) is the weight assigned to the Jth data point.

C  Output:
C  C(I) is the coefficient for the Ith independent variable.
C  STAND_ERR(I) is the standard error of Ith coefficient.
C  S is the estimated standard deviation about the regression.
C  FLAG is returned .TRUE. if and only if there was sufficient data for
C  the regression to be performed.

      IMPLICIT NONE
      INCLUDE 'vad_analysis_memory.for'
      LOGICAL FLAG
      INTEGER NDATA,NUMCOEFF,IPOINT,ICOEFF,IROW,ICOL,EFFECTIVE_NDATA
      REAL S,SSRES,YREG
CC Change the array size from numcoeff to MAXCOEFFS 12/14/2000 by WCL
      REAL C(MAXCOEFFS),STAND_ERR(MAXCOEFFS)
      REAL Y(NDATA),WEIGHT(NDATA)
      REAL B(MAXCOEFFS)
      REAL X(MAXCOEFFS,NDATA)
      REAL A(MAXCOEFFS,MAXCOEFFS),
     $AINV(MAXCOEFFS,MAXCOEFFS)

C  Check whether there are enough data.
C  Since the standard error of the coefficients is being estimated, need
C  at least one more data than coefficients.
      IF(NDATA.LE.NUMCOEFF.OR.EFFECTIVE_NDATA.LE.NUMCOEFF)THEN
         FLAG=.FALSE.
         RETURN
      ELSE
         FLAG=.TRUE.
      ENDIF

C  Initialize the regression matrices.
      DO 10 ICOL=1,MAXCOEFFS
         DO 11 IROW=1,MAXCOEFFS
            A(IROW,ICOL)=0.
11       CONTINUE
10    CONTINUE
      DO 12 IROW=1,MAXCOEFFS
         B(IROW)=0.
         C(IROW)=0.  !reset C to 0.
12    CONTINUE

C  Loop through the data and accumulate the covariances in the regression
C  matrices.
      DO 20 IPOINT=1,NDATA
         DO 21 ICOL=1,NUMCOEFF
            DO 22 IROW=1,NUMCOEFF
               A(IROW,ICOL)=A(IROW,ICOL)+
     $         X(IROW,IPOINT)*X(ICOL,IPOINT)*WEIGHT(IPOINT)
22          CONTINUE
21       CONTINUE
         DO 23 IROW=1,NUMCOEFF
            B(IROW)=B(IROW)+X(IROW,IPOINT)*Y(IPOINT)*WEIGHT(IPOINT)
23       CONTINUE
20    CONTINUE

C  Find the inverse of A.
      CALL MINV(A,MAXCOEFFS,MAXCOEFFS,AINV,MAXCOEFFS,MAXCOEFFS,
     $NUMCOEFF)

C  Multiply AINV and B to get the coefficients C.
      CALL MAT_MULT(AINV,MAXCOEFFS,MAXCOEFFS,NUMCOEFF,NUMCOEFF,
     $B,MAXCOEFFS,1,NUMCOEFF,1,C,NUMCOEFF,1)

C  Calculate the sum of squares about the regression.
      SSRES=0.
      DO 200 IPOINT=1,NDATA
         YREG=0.
         DO 180 ICOEFF=1,NUMCOEFF
            YREG=YREG+C(ICOEFF)*X(ICOEFF,IPOINT)
180      CONTINUE
         SSRES=SSRES+WEIGHT(IPOINT)*(Y(IPOINT)-YREG)**2
200   CONTINUE

C  Calculate the estimated standard deviation about the regression.
      S=SQRT(SSRES/FLOAT(EFFECTIVE_NDATA-NUMCOEFF))

C  Calculate the standard error of the coefficients.
      DO 300 ICOEFF=1,NUMCOEFF
         STAND_ERR(ICOEFF)=S*SQRT(AINV(ICOEFF,ICOEFF))
300   CONTINUE

      RETURN
      END
C==============================================================================
C==============================================================================
C==============================================================================
      SUBROUTINE MINV(A,ISIZE1,ISIZE2,B,ISIZE3,ISIZE4,M)

C  This subroutine calculates the inverse of a matrix.

C  Input:
C  A is the square matrix whose inverse is to be found.
C  M is the number of rows, as well as the number of columns, of A.
C  It must be less than or equal to MAXCOEFFS.
C  ISIZE1 is the first dimension of A in the calling program.
C  It must be greater than or equal to M.
C  ISIZE2 is the second dimension of A in the calling program.
C  It must be greater than or equal to M.
C  ISIZE3 is the first dimension of B in the calling program.
C  It must be greater than or equal to M.
C  ISIZE4 is the second dimension of B in the calling program.
C  It must be greater than or equal to M.

C  Output:
C  B is the inverse matrix of A.
C  It also has M rows and M columns.

      IMPLICIT NONE
      INCLUDE 'vad_analysis_memory.for'
      INCLUDE 'vad_analysis_constants.for'
      INTEGER ISIZE1,ISIZE2,ISIZE3,ISIZE4,M,I,J
      REAL A(ISIZE1,ISIZE2)
      REAL B(ISIZE3,ISIZE4)
      DOUBLEPRECISION DUMDP(MAXCOEFFS,2*MAXCOEFFS)

      DO 200 I=1,MAXCOEFFS
         DO 201 J=1,2*MAXCOEFFS
            DUMDP(I,J)=0.D0
201      CONTINUE
200   CONTINUE

      DO 101 I=1,M
         DO 102 J=1,M
            DUMDP(I,J)=DBLE(A(I,J))
102      CONTINUE
101   CONTINUE

      DO 103 I=1,M
         DO 104 J=M+1,2*M
            IF(I.EQ.J-M)THEN
               DUMDP(I,J)=1.D0
            ELSE
               DUMDP(I,J)=0.D0
            ENDIF
104      CONTINUE
103   CONTINUE

      CALL ROWRED_PP(DUMDP,MAXCOEFFS,2*MAXCOEFFS,M,2*M,0,
     $LOG_OUTPUT_UNIT)

      DO 105 I=1,M
         DO 106 J=1,M
            B(I,J)=SNGL(DUMDP(I,J+M))
106      CONTINUE
105   CONTINUE

      RETURN
      END
C==============================================================================
C==============================================================================
C==============================================================================
      SUBROUTINE ROWRED_PP(A,ISIZE1,ISIZE2,M,N,IWRITE,LU)

C  This subroutine row reduces a matrix using partial pivoting.

C  Input and output:
C  A is the double precision matrix to be row reduced.
C  The row reduced form replaces the original matrix.

C  Input:
C  M is the number of rows in A.
C  N is the number of columns in A.
C  ISIZE1 is the first dimension of A in the calling program.
C  It must be greater than or equal to M.
C  ISIZE2 is the second dimension of A in the calling program.
C  It must be greater than or equal to N.
C  LU is the logical unit number to which written output is sent.
C  IWRITE controls what is written to LU as follows.
C     If IWRITE=0, nothing is written.
C     If IWRITE=1, the initial and row reduced matrices are written.
C     If IWRITE=2, the initial, final, and all intermediate matrices during
C     the row reduction are written.

      IMPLICIT NONE
      INTEGER IWRITE,LU,M,N,ISIZE1,ISIZE2,I,J,II,JJ,IP
      DOUBLEPRECISION A(ISIZE1,ISIZE2),W,X,Y,Z,STORE

      IF(IWRITE.GE.1)THEN
         CALL ROWRED_PP_WRITE(LU,A,ISIZE1,ISIZE2,M,N,1)
      ENDIF

C  Initialize the pivot row and the pivot column.
      I=1
      J=1

C  Check whether the pivot column is all zero.
104   DO 101 II=I,M
         IF(A(II,J).NE.0.D0)THEN
            GOTO 102
         ENDIF
101   CONTINUE

C  The pivot column is all zero.
C  Advance the pivot column.
      IF(J.LT.N)THEN
         J=J+1
         GOTO 104
      ELSE
         GOTO 103
      ENDIF

C  The pivot column is not all zero.
C  Interchange rows so that the term in the pivot column and pivot row
C  divided by the largest term in the row is maximum.
102   X=0.D0
      DO 105 II=I,M
         W=0.D0
         DO 1002 JJ=J,N
            IF(DABS(A(II,JJ)).GT.W)THEN
               W=DABS(A(II,JJ))
            ENDIF
1002     CONTINUE
         IF(W.NE.0.D0)THEN
            IF(DABS(A(II,J))/W.GT.X)THEN
               X=DABS(A(II,J)/W)
               IP=II
            ENDIF
         ENDIF
105   CONTINUE
110   IF(IP.NE.I)THEN
         DO 107 JJ=1,N
            STORE=A(I,JJ)
            A(I,JJ)=A(IP,JJ)
            A(IP,JJ)=STORE
107      CONTINUE
         IF(IWRITE.GE.2)THEN
            CALL ROWRED_PP_WRITE(LU,A,ISIZE1,ISIZE2,M,N,2)
         ENDIF
      ENDIF

C  Divide the terms in the pivot row by the term in the pivot row and
C  column.
106   Y=A(I,J)
      A(I,J)=1.D0
      IF(J+1.LE.N)THEN
         DO 108 JJ=J+1,N
            A(I,JJ)=A(I,JJ)/Y
108      CONTINUE
      ENDIF
      IF(IWRITE.GE.2)THEN
         CALL ROWRED_PP_WRITE(LU,A,ISIZE1,ISIZE2,M,N,2)
      ENDIF

C  Eliminate the terms in the pivot column in rows other than the pivot
C  row.
      DO 109 II=1,M
         IF(II.NE.I)THEN
            Z=A(II,J)
            A(II,J)=0.D0
            IF(J+1.LE.N)THEN
               DO 111 JJ=J+1,N
                  A(II,JJ)=A(II,JJ)-A(I,JJ)*Z
111            CONTINUE
            ENDIF
         ENDIF
109   CONTINUE
      IF(IWRITE.GE.2)THEN
         CALL ROWRED_PP_WRITE(LU,A,ISIZE1,ISIZE2,M,N,2)
      ENDIF

C  Row reduction for the current pivot row and pivot column is complete.
C  Advance the pivot row and pivot column.
      IF(I.LT.M.AND.J.LT.N)THEN
         I=I+1
         J=J+1
         GOTO 104
      ENDIF

C  The matrix is row reduced.
103   IF(IWRITE.EQ.1)THEN
         CALL ROWRED_PP_WRITE(LU,A,ISIZE1,ISIZE2,M,N,3)
      ENDIF

      RETURN
      END
C==============================================================================
C==============================================================================
C==============================================================================
      SUBROUTINE ROWRED_PP_WRITE(LU,A,ISIZE1,ISIZE2,M,N,KODE)

C  This subroutine performs the writing of matrices for subroutine
C  ROWRED_PP.

      IMPLICIT NONE
      INTEGER LU,ISIZE1,ISIZE2,M,N,KODE,I,J
      DOUBLEPRECISION A(ISIZE1,ISIZE2)

      IF(KODE.EQ.1)THEN
         WRITE(LU,64)
64       FORMAT(' ORIGINAL MATRIX')
      ELSEIF(KODE.EQ.2)THEN
         WRITE(LU,65)
65       FORMAT(' MATRIX AFTER ROW REDUCTION OPERATION')
      ELSEIF(KODE.EQ.3)THEN
         WRITE(LU,66)
66       FORMAT(' ROW REDUCED MATRIX')
      ENDIF

      WRITE(LU,63)
63    FORMAT(' ')

      DO 101 I=1,M
         WRITE(LU,61)(A(I,J),J=1,N)
61       FORMAT(' ',8E16.8)
         WRITE(LU,63)
101   CONTINUE

      WRITE(LU,62)
62    FORMAT(//)

      RETURN
      END
C==============================================================================
C==============================================================================
C==============================================================================
      SUBROUTINE MAT_MULT(A,ISIZE1,ISIZE2,MA,NA,B,ISIZE3,ISIZE4,MB,NB,
     $C,ISIZE5,ISIZE6)

C  This subroutine multiples two matrices.

C  Input:
C  A is the first matrix to be multiplied.
C  B is the second matrix to be multiplied.
C  MA is the number of rows in A.
C  NA is the number of columns in A.
C  MB is the number of rows in B.
C  MB must be equal to NA for matrix multiplication to be defined.
C  NB is the number of columns in B.
C  ISIZE1 is the first dimension of A in the calling program.
C  It must be greater than or equal to MA.
C  ISIZE2 is the second dimension of A in the calling program.
C  It must be greater than or equal to NA.
C  ISIZE3 is the first dimension of B in the calling program.
C  It must be greater than or equal to MB.
C  ISIZE4 is the second dimension of B in the calling program.
C  It must be greater than or equal to NB.
C  ISIZE5 is the first dimension of C in the calling program.
C  It must be greater than or equal to MA.
C  ISIZE6 is the second dimension of C in the calling program.
C  It must be greater than or equal to NB.

C  Output:
C  C is the resultant matrix.
C  It has MA rows and NB columns.

      IMPLICIT NONE
      INTEGER ISIZE1,ISIZE2,MA,NA,ISIZE3,ISIZE4,MB,NB,ISIZE5,ISIZE6,
     $IROW,ICOL,I
      REAL SUM
      REAL A(ISIZE1,ISIZE2),B(ISIZE3,ISIZE4),C(ISIZE5,ISIZE6)

      DO 2 ICOL=1,NB
         DO 3 IROW=1,MA
            SUM=0.
            DO 1 I=1,NA
               SUM=SUM+A(IROW,I)*B(I,ICOL)
1           CONTINUE
            C(IROW,ICOL)=SUM
3        CONTINUE
2     CONTINUE
      RETURN
      END


      SUBROUTINE DCOSQF (N,X,WSAVE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION       X(*)       ,WSAVE(*)
      DATA SQRT2 /1.41421356237309504880D0/
      IF (N-2) 102,101,103
  101 TSQX = SQRT2*X(2)
      X(2) = X(1)-TSQX
      X(1) = X(1)+TSQX
  102 RETURN
  103 CALL COSQF1 (N,X,WSAVE,WSAVE(N+1))
      RETURN
      END


      SUBROUTINE CalculateKinematics()
      ! Subroutine calculating the kinematics and free surface elevation in the entire
      ! domain.
      !
      ! Input:
      !
      ! Output: The global variables UOF, VOF, WOF and dOF are updated
      !
      ! Written by Bo Terp Paulsen (botp), botp@mek.dtu.dk
      !

      USE GlobalVariables
      IMPLICIT NONE
      ! Local variables
      !
      INTEGER ::  i, j, k, Nx, Ny, Nz
      REAL(KIND=long), DIMENSION(:,:), POINTER :: x, y, h, hx, hy, eta, etax, etay
      REAL(KIND=long), DIMENSION(:), POINTER   :: z

      ! Assign local grid range
      !
      Nx = FineGrid%Nx+2*GhostGridX
      Ny = FineGrid%Ny+2*GhostGridY
      Nz = FineGrid%Nz+GhostGridZ

      ! Assign the local pointers
      !
      x => FineGrid%x; y => FineGrid%y; z => FineGrid%z; h => FineGrid%h
      hx => FineGrid%hx
      hy => FineGrid%hy; eta => WaveField%E; etax => WaveField%Ex
      etay => WaveField%Ey

      ! Ensure that matrices are cleaned
      !
      UOF = zero
      VOF = zero
      WOF = zero
      dOF = zero

      ! Shift the horizontal grid point position to account for the ghost points.
      !
      !
      ! The fluid thickness d=h+eta
      !
      DO j=1,Ny
         DO i=1,Nx
            dOF(i,j)=h(i,j)+eta(i,j);
         end DO
      End DO
      !
      ! Then the velocity potential at all points in this horizontal slice and at all sigma (vertical) locations.
      !
      !
      ! Then the velocities at all points in this horizontal slice and at all sigma
      ! (vertical) locations.
      !
      !
      ! Compute dphi/dsigma
      !
      CALL DiffZArbitrary(phi,WOF,1,FineGrid%Nx+2*GhostGridX,FineGrid%Ny+2*GhostGridY,  &
           FineGrid%Nz+GhostGridZ,FineGrid%DiffStencils,gamma)
      IF (FineGrid%Nx>1) THEN
         !
         ! Compute dphi/dx
         !
         CALL DiffXEven(phi,UOF,1,FineGrid%Nx+2*GhostGridX,FineGrid%Ny+2*GhostGridY,  &
              FineGrid%Nz+GhostGridZ,FineGrid%DiffStencils,alpha)
         IF ( LinearOnOff /= 0) THEN
            !
            ! Add in the chain rule contribution to get the velocity
            !
            DO j=1,Ny
               DO i=1,Nx
                  DO k=1,Nz
                  UOF(k,i,j) = UOF(k,i,j) + ((1-z(k))/dOF(i,j)*hx(i,j)-z(k)/dOF(i,j)*etax(i,j))*WOF(k,i,j)
                  END DO
               END DO
            END DO
         END IF
      ELSE
         UOF=zero
      END IF

      IF (FineGrid%Ny>1) THEN
         ! dphi/dy
         CALL DiffYEven(phi,VOF,1,FineGrid%Nx+2*GhostGridX,FineGrid%Ny+2*GhostGridY,  &
              FineGrid%Nz+GhostGridZ,FineGrid%DiffStencils,beta)
         IF ( LinearOnOff /= 0) THEN
            Do j=1,Ny
               Do i=1,Nx
                  Do k=1,Nz
                  VOF(k,i,j) = VOF(k,i,j)+((1-z(k))/dOF(i,j)*hy(i,j)-z(k)/dOF(i,j)*etay(i,j))*WOF(k,i,j)
                  END Do
               END Do
            END Do
         END IF
      ELSE
         VOF=zero
      END IF

      IF ( LinearOnOff /= 0) THEN
            Do j=1,Ny
               Do i=1,Nx
                  Do k=1,Nz
                  WOF(k,i,j) = WOF(k,i,j)/dOF(i,j)
                  END Do
               END Do
            END Do
         END IF

END SUBROUTINE CalculateKinematics


!*==chetrd_2stage.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CHETRD_2STAGE
!
!  @generated from zhetrd_2stage.f, fortran z -> c, Sun Nov  6 19:34:06 2016
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CHETRD_2STAGE + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CHETRD_2STAGE( VECT, UPLO, N, A, LDA, D, E, TAU,
!                                 HOUS2, LHOUS2, WORK, LWORK, INFO )
!
!       IMPLICIT NONE
!
!      .. Scalar Arguments ..
!       CHARACTER          VECT, UPLO
!       INTEGER            N, LDA, LWORK, LHOUS2, INFO
!      ..
!      .. Array Arguments ..
!       REAL               D( * ), E( * )
!       COMPLEX            A( LDA, * ), TAU( * ),
!                          HOUS2( * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CHETRD_2STAGE reduces a complex Hermitian matrix A to real symmetric
!> tridiagonal form T by a unitary similarity transformation:
!> Q1**H Q2**H* A * Q2 * Q1 = T.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] VECT
!> \verbatim
!>          VECT is CHARACTER*1
!>          = 'N':  No need for the Housholder representation,
!>                  in particular for the second stage (Band to
!>                  tridiagonal) and thus LHOUS2 is of size max(1, 4*N);
!>          = 'V':  the Householder representation is needed to
!>                  either generate Q1 Q2 or to apply Q1 Q2,
!>                  then LHOUS2 is to be queried and computed.
!>                  (NOT AVAILABLE IN THIS RELEASE).
!> \endverbatim
!>
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading
!>          N-by-N upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading N-by-N lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>          On exit, if UPLO = 'U', the band superdiagonal
!>          of A are overwritten by the corresponding elements of the
!>          internal band-diagonal matrix AB, and the elements above
!>          the KD superdiagonal, with the array TAU, represent the unitary
!>          matrix Q1 as a product of elementary reflectors; if UPLO
!>          = 'L', the diagonal and band subdiagonal of A are over-
!>          written by the corresponding elements of the internal band-diagonal
!>          matrix AB, and the elements below the KD subdiagonal, with
!>          the array TAU, represent the unitary matrix Q1 as a product
!>          of elementary reflectors. See Further Details.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[out] D
!> \verbatim
!>          D is REAL array, dimension (N)
!>          The diagonal elements of the tridiagonal matrix T.
!> \endverbatim
!>
!> \param[out] E
!> \verbatim
!>          E is REAL array, dimension (N-1)
!>          The off-diagonal elements of the tridiagonal matrix T.
!> \endverbatim
!>
!> \param[out] TAU
!> \verbatim
!>          TAU is COMPLEX array, dimension (N-KD)
!>          The scalar factors of the elementary reflectors of
!>          the first stage (see Further Details).
!> \endverbatim
!>
!> \param[out] HOUS2
!> \verbatim
!>          HOUS2 is COMPLEX array, dimension (LHOUS2)
!>          Stores the Householder representation of the stage2
!>          band to tridiagonal.
!> \endverbatim
!>
!> \param[in] LHOUS2
!> \verbatim
!>          LHOUS2 is INTEGER
!>          The dimension of the array HOUS2.
!>          If LWORK = -1, or LHOUS2=-1,
!>          then a query is assumed; the routine
!>          only calculates the optimal size of the HOUS2 array, returns
!>          this value as the first entry of the HOUS2 array, and no error
!>          message related to LHOUS2 is issued by XERBLA.
!>          If VECT='N', LHOUS2 = max(1, 4*n);
!>          if VECT='V', option not yet available.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX array, dimension (LWORK)
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK = MAX(1, dimension)
!>          If LWORK = -1, or LHOUS2 = -1,
!>          then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>          LWORK = MAX(1, dimension) where
!>          dimension   = max(stage1,stage2) + (KD+1)*N
!>                      = N*KD + N*max(KD+1,FACTOPTNB)
!>                        + max(2*KD*KD, KD*NTHREADS)
!>                        + (KD+1)*N
!>          where KD is the blocking size of the reduction,
!>          FACTOPTNB is the blocking used by the QR or LQ
!>          algorithm, usually FACTOPTNB=128 is a good choice
!>          NTHREADS is the number of threads used when
!>          openMP compilation is enabled, otherwise =1.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2017
!
!> \ingroup complexHEcomputational
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Implemented by Azzam Haidar.
!>
!>  All details are available on technical report, SC11, SC13 papers.
!>
!>  Azzam Haidar, Hatem Ltaief, and Jack Dongarra.
!>  Parallel reduction to condensed forms for symmetric eigenvalue problems
!>  using aggregated fine-grained and memory-aware kernels. In Proceedings
!>  of 2011 International Conference for High Performance Computing,
!>  Networking, Storage and Analysis (SC '11), New York, NY, USA,
!>  Article 8 , 11 pages.
!>  http://doi.acm.org/10.1145/2063384.2063394
!>
!>  A. Haidar, J. Kurzak, P. Luszczek, 2013.
!>  An improved parallel singular value algorithm and its implementation
!>  for multicore hardware, In Proceedings of 2013 International Conference
!>  for High Performance Computing, Networking, Storage and Analysis (SC '13).
!>  Denver, Colorado, USA, 2013.
!>  Article 90, 12 pages.
!>  http://doi.acm.org/10.1145/2503210.2503292
!>
!>  A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra.
!>  A novel hybrid CPU-GPU generalized eigensolver for electronic structure
!>  calculations based on fine-grained memory aware tasks.
!>  International Journal of High Performance Computing Applications.
!>  Volume 28 Issue 2, Pages 196-209, May 2014.
!>  http://hpc.sagepub.com/content/28/2/196
!>
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE CHETRD_2STAGE(Vect,Uplo,N,A,Lda,D,E,Tau,Hous2,Lhous2,  &
     &                         Work,Lwork,Info)
!
      IMPLICIT NONE
!*--CHETRD_2STAGE229
!
!  -- LAPACK computational routine (version 3.8.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2017
!
!     .. Scalar Arguments ..
      CHARACTER Vect , Uplo
      INTEGER N , Lda , Lwork , Lhous2 , Info
!     ..
!     .. Array Arguments ..
      REAL D(*) , E(*)
      COMPLEX A(Lda,*) , Tau(*) , Hous2(*) , Work(*)
!     ..
!
!  =====================================================================
!     ..
!     .. Local Scalars ..
      LOGICAL lquery , upper , wantq
      INTEGER kd , ib , lwmin , lhmin , lwrk , ldab , wpos , abpos
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA , CHETRD_HE2HB , CHETRD_HB2ST
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV2STAGE
      EXTERNAL LSAME , ILAENV2STAGE
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      Info = 0
      wantq = LSAME(Vect,'V')
      upper = LSAME(Uplo,'U')
      lquery = (Lwork==-1) .OR. (Lhous2==-1)
!
!     Determine the block size, the workspace size and the hous size.
!
      kd = ILAENV2STAGE(1,'CHETRD_2STAGE',Vect,N,-1,-1,-1)
      ib = ILAENV2STAGE(2,'CHETRD_2STAGE',Vect,N,kd,-1,-1)
      lhmin = ILAENV2STAGE(3,'CHETRD_2STAGE',Vect,N,kd,ib,-1)
      lwmin = ILAENV2STAGE(4,'CHETRD_2STAGE',Vect,N,kd,ib,-1)
!      WRITE(*,*),'CHETRD_2STAGE N KD UPLO LHMIN LWMIN ',N, KD, UPLO,
!     $            LHMIN, LWMIN
!
      IF ( .NOT.LSAME(Vect,'N') ) THEN
         Info = -1
      ELSEIF ( .NOT.upper .AND. .NOT.LSAME(Uplo,'L') ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -5
      ELSEIF ( Lhous2<lhmin .AND. .NOT.lquery ) THEN
         Info = -10
      ELSEIF ( Lwork<lwmin .AND. .NOT.lquery ) THEN
         Info = -12
      ENDIF
!
      IF ( Info==0 ) THEN
         Hous2(1) = lhmin
         Work(1) = lwmin
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('CHETRD_2STAGE',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) THEN
         Work(1) = 1
         RETURN
      ENDIF
!
!     Determine pointer position
!
      ldab = kd + 1
      lwrk = Lwork - ldab*N
      abpos = 1
      wpos = abpos + ldab*N
      CALL CHETRD_HE2HB(Uplo,N,kd,A,Lda,Work(abpos),ldab,Tau,Work(wpos),&
     &                  lwrk,Info)
      IF ( Info/=0 ) THEN
         CALL XERBLA('CHETRD_HE2HB',-Info)
         RETURN
      ENDIF
      CALL CHETRD_HB2ST('Y',Vect,Uplo,N,kd,Work(abpos),ldab,D,E,Hous2,  &
     &                  Lhous2,Work(wpos),lwrk,Info)
      IF ( Info/=0 ) THEN
         CALL XERBLA('CHETRD_HB2ST',-Info)
         RETURN
      ENDIF
!
!
      Hous2(1) = lhmin
      Work(1) = lwmin
!
!     End of CHETRD_2STAGE
!
      END SUBROUTINE CHETRD_2STAGE


      subroutine convert_SLvr(vr_p,vrL_p,iflag)

******************************************
cc     Written by Lin-Wang Wang, March 30, 2001.
*************************************************************************
**  copyright (c) 2003, The Regents of the University of California,
**  through Lawrence Berkeley National Laboratory (subject to receipt of any
**  required approvals from the U.S. Dept. of Energy).  All rights reserved.
*************************************************************************

******************************************

ccc    iflag.eq.1, from vr_p to vrL_p
cc     iflag.eq.-1, from vrL_p to vr_p

      use fft_data
      use load_data
      use data

      implicit double precision (a-h,o-z)

      include 'param.escan_real'
      include 'mpif.h'

      real*8 vr_p(mr_n),vrL_p(mr_nL)
      complex*16,allocatable, dimension(:) :: vg_p,vgL_p
      real*8, allocatable, dimension(:)  :: workr_n

*******************************************************
cccccccccccccccccccccccccccccccccccccccccccc
      if(n1.eq.n1L.and.n2.eq.n2L.
     &                 and.n3.eq.n3L) then
       if(iflag.eq.1) vrL_p=vr_p
       if(iflag.eq.-1) vr_p=vrL_p
       return
      endif
cccccccccccccccccccccccccccccccccccccccccccc

       nrL=n1L*n2L*n3L
       nr_nL=nrL/nnodes

      allocate(vg_p(mr_n/2))
      allocate(vgL_p(mr_nL/2))

      if(iflag.eq.1) then     ! from vr_n to vrL_n

      allocate(workr_n(mr_n))

      workr_n=vr_p

      call d3fft_real2(vg_p,workr_n,1,0)         ! workr_n will be destroyed

      ng2_n=ngtotnod2(inode)

      vgL_p=dcmplx(0.d0,0.d0)
      do ig=1,ng2_n
      vgL_p(map_StoL(ig))=vg_p(ig)         ! the mapping is on the same node !
      enddo

      call d3fft_real2L(vgL_p,vrL_p,-1,0)

      deallocate(workr_n)

      endif

cccccccccccccccccccccccccccccccccccccccccccccc

      if(iflag.eq.-1) then       ! from vrL_n to vr_n

      allocate(workr_n(mr_nL))

      workr_n=vrL_p

      call d3fft_real2L(vgL_p,workr_n,1,0)

      ng2_n=ngtotnod2(inode)

      vg_p=dcmplx(0.d0,0.d0)
      do ig=1,ng2_n
      vg_p(ig)=vgL_p(map_StoL(ig))
      enddo

      call d3fft_real2(vg_p,vr_p,-1,0)

      deallocate(workr_n)

      endif
cccccccccccccccccccccccccccccccccccccccccccccc

      deallocate(vg_p)
      deallocate(vgL_p)

      return
      end


      subroutine H1f(xi,eta,phi,m,n,lambda,H0,AN,AM,pt,crea_par)
      doubleprecision xi
      doubleprecision eta
      doubleprecision phi
      doubleprecision m
      doubleprecision n
      doubleprecision lambda
      doubleprecision H0
      doubleprecision AN
      doubleprecision AM
      doubleprecision pt
      doubleprecision crea_par(3)

      doubleprecision H1(3)
      doubleprecision t1
      doubleprecision t10
      doubleprecision t100
      doubleprecision t103
      doubleprecision t108
      doubleprecision t11
      doubleprecision t112
      doubleprecision t12
      doubleprecision t13
      doubleprecision t15
      doubleprecision t16
      doubleprecision t166
      doubleprecision t17
      doubleprecision t2
      doubleprecision t21
      doubleprecision t22
      doubleprecision t23
      doubleprecision t25
      doubleprecision t28
      doubleprecision t3
      doubleprecision t30
      doubleprecision t32
      doubleprecision t35
      doubleprecision t39
      doubleprecision t4
      doubleprecision t44
      doubleprecision t45
      doubleprecision t46
      doubleprecision t5
      doubleprecision t52
      doubleprecision t56
      doubleprecision t57
      doubleprecision t62
      doubleprecision t68
      doubleprecision t7
      doubleprecision t71
      doubleprecision t78
      doubleprecision t79
      doubleprecision t8
      doubleprecision t83
      doubleprecision t94
      doubleprecision t95
      doubleprecision t99

      t1 = xi**2
      t2 = eta**2
      t3 = t1-t2
      t4 = sqrt(t3)
      t5 = 1/t4
      t7 = S(eta)
      t8 = R(xi)
      t10 = AM*t5*t7*t8
      t11 = (-1)**pt
      t12 = t11*m
      t13 = T(phi)
      t15 = -1+t1
      t16 = sqrt(t15)
      t17 = 1/t16
      t21 = 1/c
      t22 = t21*t16
      t23 = 1-t2
      t25 = 1/t3
      t28 = c**2
      t30 = t2**2
      t32 = m**2
      t35 = (eta-1)**2
      t39 = (eta+1)**2
      t44 = 1/t23
      t45 = 1/t15
      t46 = t44*t45
      t52 = t23*t25
      t56 = t3**2
      t57 = 1/t56
      t62 = diff(R(xi),xi)
      t68 = eta*t25
      t71 = -t23
      t78 = diff(S(eta),eta)
      t79 = t78*t8
      t83 = 1/t4/t3
      H1(1) = (-t10*t12*t13*eta*t17+((-t22*t5*(xi*t23*t25*(-lambda+lam
     #     bda*t2+t28*t2-t28*t30+t32)/t35/t39-t32*xi*t46)*t8+t22*t5*(t52
     &     -2*t2*t25+2*t2*t23*t57)*t62)*t7-t22*t5*xi*(-2*t68+2*t23*t57
     &     *eta-2*t52*eta/t71)*t79+t22*t83*eta*t23*t78*t62)*t13*AN)*H0
      t94 = sqrt(t23)
      t95 = 1/t94
      t99 = t21*t94
      t100 = eta*t15
      t103 = t1**2
      t108 = (xi-1)**2
      t112 = (xi+1)**2
      H1(2) = (t10*t12*t13*xi*t95+((t99*t5*(-t100*t25*(lambda*t1-lambd
     #     a-t28*t103+t28*t1+t32)/t108/t112+t32*eta*t46)*t8+2*t99/t4/t56
     &     *t100*t62*xi)*t7+t99*t5*t78*(t15*t25+2*t1*t25-2*t1*t15*t57)
     &     *t8+t99*t83*t78*xi*t15*t62)*t13*AN)*H0
      t166 = t21*m
      H1(3) = ((t71*t62*eta*t16*t25*t95*t7-t71*t78*t8*xi*t16*t25*t95)*
     #     t13*AM+((t166*t94*t16*t25*(-t45-t44)*t11*t8-t166*t95*t16*t25
     &     *xi*t62*t11)*t7-t166*t94*t17*t68*t79*t11)*t13*AN)*H0
      crea_par(1) = H1(1)
      crea_par(2) = H1(2)
      crea_par(3) = H1(3)
      return
      return
      end


!>
!> @brief       Parallel tri-diagonal matrix solver using cyclic reduction (CR), parallel CR (PCR),
!>              and Thomas+PCR hybrid algorithm
!> @details     The CR algorithm is described on Parallel Scientific Computing in C++ and MPI
!>              by Karniadakis and Kirby. CR algorithm removes odd rows recursively,
!>              so MPI processes begin to drop out after single row is left per MPI process,
!>              while PCR can use full parallelism. Therefore, PCR is a good solution from
!>              the level where single row is left per MPI process. In this implementation,
!>              we can choose CR or PCR algorithm from the single-row level.
!>              Odd-rows are removed successively and we obtain two reduced equations finally.
!>              Obtained solutions from 2x2 matrix equations are used to obtain other unknowns.
!>              Hybrid Thomas-PCR algorithm is from the work of Laszlo, Gilles and Appleyard,
!>              Manycore Algorithms for Batch Scalar and Block Tridiagonal Solvers, ACM TOMS,
!>              42, 31 (2016).
!>
!> @author      Ji-Hoon Kang (jhkang@kisti.re.kr), Korea Institute of Science and Technology Information
!> @date        20 January 2019
!> @version     0.1
!> @par         Copyright
!>              Copyright (c) 2018 by Ji-Hoon Kang. All rights reserved.
!> @par         License
!>              This project is release under the terms of the MIT License (see LICENSE in )
!>

module tdma_parallel

    use mpi

    implicit none

    integer(4), private :: n_mpi                    !< Number of rows per MPI process and should be 2^n.
    integer(4), private :: nprocs                   !< Number of MPI process and should be also 2^m.
    integer(4), private :: myrank                   !< MPI process ID

    real(8), pointer, dimension(:), private :: a    !< Local private pointer for coefficient maxtix a
    real(8), pointer, dimension(:), private :: b    !< Local private pointer for coefficient maxtix a
    real(8), pointer, dimension(:), private :: c    !< Local private pointer for coefficient maxtix a
    real(8), pointer, dimension(:), private :: r    !< Local private pointer for RHS vector r
    real(8), pointer, dimension(:), private :: x    !< Local private pointer for solution vector x

    contains

    !>
    !> @brief   Initialize local private variables from global input parameters.
    !> @param   n Size of global array
    !> @param   np_world Number of MPI process
    !> @param   rank_world rank ID in MPI_COMM_WORLD
    !>
    subroutine tdma_setup(n, np_world, rank_world)

        integer(4), intent(in) :: n
        integer(4), intent(in) :: np_world
        integer(4), intent(in) :: rank_world

        nprocs = np_world
        myrank = rank_world
        n_mpi  = n / nprocs

    end subroutine tdma_setup

    !>
    !> @brief   CR solver: cr_forward_multiple + cr_forward_single + cr_backward_single + cr_backward_multiple
    !> @param   a_mpi (input) Lower off-diagonal coeff., which is assigned to local private pointer a
    !> @param   b_mpi (input) Diagonal coeff., which is assigned to local private pointer b
    !> @param   c_mpi (input) Upper off-diagonal coeff.,, which is assigned to local private pointer c
    !> @param   r_mpi (input) RHS vector, which is assigned to local private pointer r
    !> @param   x_mpi (output) Solution vector, which is assigned to local private pointer x
    !>
    subroutine cr_solver(a_mpi, b_mpi, c_mpi, r_mpi, x_mpi)

        implicit none

        real(8), intent(inout), target :: a_mpi(0:n_mpi+1)
        real(8), intent(inout), target :: b_mpi(0:n_mpi+1)
        real(8), intent(inout), target :: c_mpi(0:n_mpi+1)
        real(8), intent(inout), target :: r_mpi(0:n_mpi+1)
        real(8), intent(inout), target :: x_mpi(0:n_mpi+1)

        a => a_mpi
        b => b_mpi
        c => c_mpi
        r => r_mpi
        x => x_mpi

        call cr_forward_multiple_row
        call cr_forward_single_row ! Including 2x2 solver
        call cr_backward_single_row
        call cr_backward_multiple_row

        nullify(a, b, c, r, x)

    end subroutine cr_solver

    !>
    !> @brief   CR-PCR solver: cr_forward_multiple + pcr_forward_single + cr_backward_multiple
    !> @param   a_mpi (input) Lower off-diagonal coeff., which is assigned to local private pointer a
    !> @param   b_mpi (input) Diagonal coeff., which is assigned to local private pointer b
    !> @param   c_mpi (input) Upper off-diagonal coeff.,, which is assigned to local private pointer c
    !> @param   r_mpi (input) RHS vector, which is assigned to local private pointer r
    !> @param   x_mpi (output) Solution vector, which is assigned to local private pointer x
    !>
    subroutine cr_pcr_solver(a_mpi, b_mpi, c_mpi, r_mpi, x_mpi)

        implicit none

        real(8), intent(inout), target :: a_mpi(0:n_mpi+1)
        real(8), intent(inout), target :: b_mpi(0:n_mpi+1)
        real(8), intent(inout), target :: c_mpi(0:n_mpi+1)
        real(8), intent(inout), target :: r_mpi(0:n_mpi+1)
        real(8), intent(inout), target :: x_mpi(0:n_mpi+1)

        a => a_mpi
        b => b_mpi
        c => c_mpi
        r => r_mpi
        x => x_mpi

        call cr_forward_multiple_row
        call pcr_forward_single_row       ! Including 2x2 solver
        call cr_backward_multiple_row

        nullify(a, b, c, r, x)

    end subroutine cr_pcr_solver

    !>
    !> @brief   Thomas-PCR solver: pThomas_forward_multiple + pcr_forward_double + pThomas_backward_multiple
    !> @param   a_mpi (input) Lower off-diagonal coeff., which is assigned to local private pointer a
    !> @param   b_mpi (input) Diagonal coeff., which is assigned to local private pointer b
    !> @param   c_mpi (input) Upper off-diagonal coeff.,, which is assigned to local private pointer c
    !> @param   r_mpi (input) RHS vector, which is assigned to local private pointer r
    !> @param   x_mpi (output) Solution vector, which is assigned to local private pointer x
    !>
    subroutine Thomas_pcr_solver(a_mpi, b_mpi, c_mpi, r_mpi, x_mpi)

        implicit none

        real(8), intent(inout), target :: a_mpi(0:n_mpi+1)
        real(8), intent(inout), target :: b_mpi(0:n_mpi+1)
        real(8), intent(inout), target :: c_mpi(0:n_mpi+1)
        real(8), intent(inout), target :: r_mpi(0:n_mpi+1)
        real(8), intent(inout), target :: x_mpi(0:n_mpi+1)

        a => a_mpi
        b => b_mpi
        c => c_mpi
        r => r_mpi
        x => x_mpi

        call pThomas_forward_multiple_row()
        call pcr_double_row_substitution()

        nullify(a, b, c, r, x)

    end subroutine Thomas_pcr_solver

    !>
    !> @brief   Forward elimination of CR until a single row per MPI process remains.
    !> @details After a single row per MPI process remains, PCR or CR between a single row is performed.
    !>
    subroutine cr_forward_multiple_row

        use mpi

        implicit none

        integer(4)  :: i, l
        integer(4)  :: nlevel
        integer(4)  :: ip, in, start, dist_row, dist2_row
        real(8)     :: alpha, gamma
        real(8)     :: sbuf(4), rbuf(4)

        integer(4)  :: status(MPI_STATUS_SIZE)
        integer(4)  :: request(2)
        integer(4)  :: ierr

        nlevel      = log(dble(n_mpi))/log(dble(2))         ! Variable nlevel is used to indicates when single row remains.
        dist_row    = 1
        dist2_row   = 2

        do l = 0, nlevel-1
            start = dist2_row
            ! Data exchange is performed using MPI send/recv for each succesive reduction
            if(myrank < nprocs-1) then
                call mpi_irecv(rbuf, 4, MPI_REAL8, myrank+1, 0, MPI_COMM_WORLD, request(1), ierr)
            endif

            if(myrank > 0) then
                sbuf(1) = a(dist_row)
                sbuf(2) = b(dist_row)
                sbuf(3) = c(dist_row)
                sbuf(4) = r(dist_row)
                call mpi_isend(sbuf, 4, MPI_REAL8, myrank-1, 0, MPI_COMM_WORLD, request(2), ierr)
            endif

            if(myrank < nprocs-1) then
                call mpi_wait(request(1), status, ierr)
                a(n_mpi+1) = rbuf(1)
                b(n_mpi+1) = rbuf(2)
                c(n_mpi+1) = rbuf(3)
                r(n_mpi+1) = rbuf(4)
            endif

            ! Odd rows of remained rows are reduced to even rows of remained rows in each reduction step.
            ! Index in of global last row is out of range, but we treat it as a = c = r = 0 and b = 1 in main function.
            do i = start, n_mpi, dist2_row
                ip = i - dist_row
                in = min(i+dist_row, n_mpi+1)
                alpha = -a(i) / b(ip)
                gamma = -c(i) / b(in)

                b(i) = b(i) + alpha * c(ip) + gamma * a(in)
                a(i) = alpha * a(ip)
                c(i) = gamma * c(in)
                r(i) = r(i) + alpha * r(ip) + gamma * r(in)
            enddo

            ! As reduction continues, the indices of required coefficients doubles.
            dist2_row = dist2_row * 2
            dist_row  = dist_row * 2

            if(myrank > 0) then
                call mpi_wait(request(2), status, ierr)
            endif

        enddo

    end subroutine cr_forward_multiple_row

    !>
    !> @brief   Backward substitution of CR after single-row solution per MPI process is obtained.
    !>
    subroutine cr_backward_multiple_row

        use mpi

        implicit none

        integer(4)  :: i, l
        integer(4)  :: nlevel
        integer(4)  :: ip, in, dist_row, dist2_row

        integer(4)  :: status(MPI_STATUS_SIZE)
        integer(4)  :: request(2)
        integer(4)  :: ierr

        nlevel      = log(dble(n_mpi))/log(dble(2))
        dist_row    = n_mpi / 2

        ! Each rank requires a solution on last row of previous rank.
        if(myrank > 0) then
            call mpi_irecv(x(0), 1, MPI_REAL8, myrank-1, 100, MPI_COMM_WORLD, request(1),ierr)
        endif

        if(myrank < nprocs-1) then
            call mpi_isend(x(n_mpi), 1, MPI_REAL8, myrank+1, 100, MPI_COMM_WORLD, request(2),ierr)
        endif

        if(myrank > 0) then
            call mpi_wait(request(1), status,ierr)
        endif

        do l = nlevel-1, 0, -1
            dist2_row = dist_row * 2
            do i = n_mpi-dist_row, 0, -dist2_row
                ip = i - dist_row
                in = i + dist_row
                x(i) = r(i)-c(i)*x(in) - a(i)*x(ip)
                x(i) = x(i) / b(i)
            enddo
            dist_row = dist_row / 2
        enddo

        if(myrank < nprocs-1) then
            call mpi_wait(request(2), status,ierr)
        endif

    end subroutine cr_backward_multiple_row

    !>
    !> @brief   Forward elimination of CR between a single row per MPI process.
    !>
    subroutine cr_forward_single_row

        use mpi

        implicit none

        integer(4)  :: i, l
        integer(4)  :: nlevel, nhprocs
        integer(4)  :: ip, in, dist_rank, dist2_rank
        real(8)     :: alpha, gamma, det
        real(8)     :: sbuf(4), rbuf0(4), rbuf1(4)

        integer(4)  :: status(MPI_STATUS_SIZE)
        integer(4)  :: request(4)
        integer(4)  :: ierr

        nlevel      = log(dble(nprocs))/log(dble(2))
        nhprocs     = nprocs / 2

        dist_rank  = 1
        dist2_rank = 2

        ! Cyclic reduction continues until 2x2 matrix are made in rank of nprocs-1 and nprocs/2-1
        do l = 0, nlevel-2

            ! Odd rows of remained rows are reduced to even rows of remained rows in each reduction step.
            ! Coefficients are updated for even rows only.

            print *, myrank , l

            if(mod((myrank+1),dist2_rank) == 0) then
                if(myrank-dist_rank>=0) then
                    call mpi_irecv(rbuf0, 4, MPI_REAL8, myrank-dist_rank, 400, MPI_COMM_WORLD, request(3), ierr)
                endif
                if(myrank+dist_rank<nprocs) then
                    call mpi_irecv(rbuf1, 4, MPI_REAL8, myrank+dist_rank, 401, MPI_COMM_WORLD, request(4), ierr)
                endif
                if(myrank-dist_rank>=0) then
                    call mpi_wait(request(3), status, ierr)
                    a(0) = rbuf0(1)
                    b(0) = rbuf0(2)
                    c(0) = rbuf0(3)
                    r(0) = rbuf0(4)
                endif
                if(myrank+dist_rank<nprocs) then
                    call mpi_wait(request(4), status, ierr)
                    a(n_mpi+1) = rbuf1(1)
                    b(n_mpi+1) = rbuf1(2)
                    c(n_mpi+1) = rbuf1(3)
                    r(n_mpi+1) = rbuf1(4)
                endif

                i = n_mpi
                ip = 0
                in = i + 1
                alpha = -a(i) / b(ip)
                gamma = -c(i) / b(in)

                b(i) = b(i) + (alpha * c(ip) + gamma * a(in))
                a(i) = alpha * a(ip)
                c(i) = gamma * c(in)
                r(i) = r(i) + (alpha * r(ip) + gamma * r(in))

            else if(mod((myrank+1),dist2_rank) == dist_rank) then

                sbuf(1) = a(n_mpi)
                sbuf(2) = b(n_mpi)
                sbuf(3) = c(n_mpi)
                sbuf(4) = r(n_mpi)

                if(myrank+dist_rank<nprocs) then
                    call mpi_isend(sbuf, 4, MPI_REAL8, myrank+dist_rank, 400, MPI_COMM_WORLD, request(1), ierr);
                endif
                if(myrank-dist_rank>=0) then
                    call mpi_isend(sbuf, 4, MPI_REAL8, myrank-dist_rank, 401, MPI_COMM_WORLD, request(2), ierr);
                endif
                if(myrank+dist_rank<nprocs) then
                    call mpi_wait(request(1), status, ierr)
                endif
                if(myrank-dist_rank>=0) then
                    call mpi_wait(request(2), status, ierr)
                endif
            endif

            dist_rank  = dist_rank * 2
            dist2_rank = dist2_rank * 2

        enddo

        ! Solving 2x2 matrix. Rank of nprocs-1 and nprocs/2-1 solves it simultaneously.

        if(myrank==nhprocs-1) then
            call mpi_irecv(rbuf1, 4, MPI_REAL8, myrank+nhprocs, 402, MPI_COMM_WORLD, request(3), ierr)

            sbuf(1) = a(n_mpi)
            sbuf(2) = b(n_mpi)
            sbuf(3) = c(n_mpi)
            sbuf(4) = r(n_mpi)
            call mpi_isend(sbuf, 4, MPI_REAL8, myrank+nhprocs, 403, MPI_COMM_WORLD, request(1), ierr)

            call mpi_wait(request(3), status, ierr)
            a(n_mpi+1) = rbuf1(1)
            b(n_mpi+1) = rbuf1(2)
            c(n_mpi+1) = rbuf1(3)
            r(n_mpi+1) = rbuf1(4)

            i = n_mpi
            in = n_mpi+1
            det = b(i)*b(in) - c(i)*a(in)
            x(i) = (r(i)*b(in) - r(in)*c(i))/det
            x(in) = (r(in)*b(i) - r(i)*a(in))/det
            call mpi_wait(request(1), status, ierr)

        else if(myrank==nprocs-1) then
            call mpi_irecv(rbuf0, 4, MPI_REAL8, myrank-nhprocs, 403, MPI_COMM_WORLD, request(4), ierr)

            sbuf(1) = a(n_mpi)
            sbuf(2) = b(n_mpi)
            sbuf(3) = c(n_mpi)
            sbuf(4) = r(n_mpi)
            call mpi_isend(sbuf, 4, MPI_REAL8, myrank-nhprocs, 402, MPI_COMM_WORLD, request(2), ierr)

            call mpi_wait(request(4), status, ierr)
            a(0) = rbuf0(1)
            b(0) = rbuf0(2)
            c(0) = rbuf0(3)
            r(0) = rbuf0(4)

            ip = 0
            i = n_mpi
            det = b(ip)*b(i) - c(ip)*a(i)
            x(ip) = (r(ip)*b(i) - r(i)*c(ip))/det
            x(i) = (r(i)*b(ip) - r(ip)*a(i))/det
            call mpi_wait(request(2), status, ierr)
        endif

    end subroutine cr_forward_single_row

    !>
    !> @brief   Backward substitution of CR until every MPI process gets solution for its single row.
    !>
    subroutine cr_backward_single_row

        use mpi

        implicit none

        integer(4)  :: i, l
        integer(4)  :: nlevel, nhprocs
        integer(4)  :: ip, in, dist_rank, dist2_rank

        integer(4)  :: status(MPI_STATUS_SIZE)
        integer(4)  :: request(4)
        integer(4)  :: ierr

        nlevel      = log(dble(nprocs))/log(dble(2))
        nhprocs     = nprocs/2
        dist_rank   = nhprocs/2
        dist2_rank  = nhprocs

        ! Back substitution continues until all ranks obtains a solution on last row.
        do l=nlevel-2, 0, -1

            if(mod((myrank+1),dist2_rank) == 0) then
                if(myrank+dist_rank<nprocs) then
                    call mpi_isend(x(n_mpi), 1, MPI_REAL8, myrank+dist_rank, 500, MPI_COMM_WORLD, request(1), ierr)
                endif
                if(myrank-dist_rank>=0) then
                    call mpi_isend(x(n_mpi), 1, MPI_REAL8, myrank-dist_rank, 501, MPI_COMM_WORLD, request(2), ierr)
                endif
                if(myrank+dist_rank<nprocs) then
                    call mpi_wait(request(1), status, ierr)
                endif
                if(myrank-dist_rank>=0) then
                    call mpi_wait(request(2), status, ierr)
                endif
            ! Only Odd rows of each level calculate new solution using a couple of even rows.
            else if(mod((myrank+1),dist2_rank) == dist_rank) then
                if(myrank-dist_rank>=0) then
                    call mpi_irecv(x(0),       1, MPI_REAL8, myrank-dist_rank, 500, MPI_COMM_WORLD, request(3), ierr)
                endif
                if(myrank+dist_rank<nprocs) then
                    call mpi_irecv(x(n_mpi+1), 1, MPI_REAL8, myrank+dist_rank, 501, MPI_COMM_WORLD, request(4), ierr)
                endif
                if(myrank-dist_rank>=0) then
                    call mpi_wait(request(3), status, ierr)
                endif
                if(myrank+dist_rank<nprocs) then
                    call mpi_wait(request(4), status, ierr)
                endif

                i=n_mpi
                ip = 0
                in = n_mpi+1
                x(i) = r(i)-c(i)*x(in)-a(i)*x(ip)
                x(i) = x(i)/b(i)
            endif
            dist_rank  = dist_rank / 2
            dist2_rank = dist_rank / 2
        enddo

    end subroutine cr_backward_single_row

    !>
    !> @brief   PCR between a single row per MPI process and 2x2 matrix solver between i and i+nprocs/2 rows.
    !>
    subroutine pcr_forward_single_row

        use mpi

        implicit none

        integer(4)  :: i, l
        integer(4)  :: nlevel, nhprocs
        integer(4)  :: myrank_level, nprocs_level
        integer(4)  :: ip, in, dist_rank, dist2_rank
        real(8)     :: alpha, gamma, det
        real(8)     :: sbuf(4), rbuf0(4), rbuf1(4)

        integer(4)  :: status(MPI_STATUS_SIZE)
        integer(4)  :: request(4)
        integer(4)  :: ierr

        nlevel      = log(dble(nprocs))/log(dble(2))
        nhprocs     = nprocs/2
        dist_rank   = 1
        dist2_rank  = 2

        ! Parallel cyclic reduction continues until 2x2 matrix are made between a pair of rank,
        ! (myrank, myrank+nhprocs).
        do l = 0, nlevel-2

            ! Rank is newly calculated in each level to find communication pair.
            ! Nprocs is also newly calculated as myrank is changed.
            myrank_level = myrank / dist_rank
            nprocs_level = nprocs / dist_rank

            sbuf(1) = a(n_mpi)
            sbuf(2) = b(n_mpi)
            sbuf(3) = c(n_mpi)
            sbuf(4) = r(n_mpi)

            ! All rows exchange data for reduction and perform reduction successively.
            ! Coefficients are updated for every rows.
            if(mod((myrank_level+1), 2) == 0) then
                if(myrank+dist_rank<nprocs) then
                    call mpi_irecv(rbuf1, 4, MPI_REAL8, myrank+dist_rank, 202, MPI_COMM_WORLD, request(1), ierr)
                    call mpi_isend(sbuf,  4, MPI_REAL8, myrank+dist_rank, 203, MPI_COMM_WORLD, request(2), ierr)
                endif
                if(myrank-dist_rank>=0) then
                    call mpi_irecv(rbuf0, 4, MPI_REAL8, myrank-dist_rank, 200, MPI_COMM_WORLD, request(3), ierr)
                    call mpi_isend(sbuf,  4, MPI_REAL8, myrank-dist_rank, 201, MPI_COMM_WORLD, request(4), ierr)
                endif
                if(myrank+dist_rank<nprocs) then
                    call mpi_wait(request(1), status, ierr)
                    a(n_mpi+1) = rbuf1(1)
                    b(n_mpi+1) = rbuf1(2)
                    c(n_mpi+1) = rbuf1(3)
                    r(n_mpi+1) = rbuf1(4)
                    call mpi_wait(request(2), status, ierr)
                endif
                if(myrank-dist_rank>=0) then
                    call mpi_wait(request(3), status, ierr)
                    a(0) = rbuf0(1)
                    b(0) = rbuf0(2)
                    c(0) = rbuf0(3)
                    r(0) = rbuf0(4)
                    call mpi_wait(request(4), status, ierr)
                endif
            else if(mod((myrank_level+1), 2) == 1) then
                if(myrank+dist_rank<nprocs) then
                    call mpi_irecv(rbuf1, 4, MPI_REAL8, myrank+dist_rank, 201, MPI_COMM_WORLD, request(1), ierr)
                    call mpi_isend(sbuf,  4, MPI_REAL8, myrank+dist_rank, 200, MPI_COMM_WORLD, request(2), ierr)
                endif
                if(myrank-dist_rank>=0) then
                    call mpi_irecv(rbuf0, 4, MPI_REAL8, myrank-dist_rank, 203, MPI_COMM_WORLD, request(3), ierr)
                    call mpi_isend(sbuf,  4, MPI_REAL8, myrank-dist_rank, 202, MPI_COMM_WORLD, request(4), ierr)
                endif
                if(myrank+dist_rank<nprocs) then
                    call mpi_wait(request(1), status, ierr)
                    a(n_mpi+1) = rbuf1(1)
                    b(n_mpi+1) = rbuf1(2)
                    c(n_mpi+1) = rbuf1(3)
                    r(n_mpi+1) = rbuf1(4)
                    call mpi_wait(request(2), status, ierr)
                endif
                if(myrank-dist_rank>=0) then
                    call mpi_wait(request(3), status, ierr)
                    a(0) = rbuf0(1)
                    b(0) = rbuf0(2)
                    c(0) = rbuf0(3)
                    r(0) = rbuf0(4)
                    call mpi_wait(request(4), status, ierr)
                endif
            endif

            i = n_mpi
            ip = 0
            in = i + 1
            if(myrank_level == 0) then
                alpha = 0.0
            else
                alpha = -a(i) / b(ip)
            endif
            if(myrank_level == nprocs_level-1) then
                gamma = 0.0
            else
                gamma = -c(i) / b(in)
            endif

            b(i) = b(i) + alpha * c(ip) + gamma * a(in)
            a(i) = alpha * a(ip)
            c(i) = gamma * c(in)
            r(i) = r(i) + alpha * r(ip) + gamma * r(in)

            dist_rank  = dist_rank * 2
            dist2_rank = dist2_rank * 2
        enddo

        ! Solving 2x2 matrix. All pair of ranks, myrank and myrank+nhprocs, solves it simultaneously.

        sbuf(1) = a(n_mpi)
        sbuf(2) = b(n_mpi)
        sbuf(3) = c(n_mpi)
        sbuf(4) = r(n_mpi)
        if(myrank<nhprocs) then
            call mpi_irecv(rbuf1, 4, MPI_REAL8, myrank+nhprocs, 300, MPI_COMM_WORLD, request(1), ierr)
            call mpi_isend(sbuf,  4, MPI_REAL8, myrank+nhprocs, 301, MPI_COMM_WORLD, request(2), ierr)

            call mpi_wait(request(1), status, ierr)
            a(n_mpi+1) = rbuf1(1)
            b(n_mpi+1) = rbuf1(2)
            c(n_mpi+1) = rbuf1(3)
            r(n_mpi+1) = rbuf1(4)

            i = n_mpi
            in = n_mpi+1

            det = b(i)*b(in) - c(i)*a(in)
            x(i) = (r(i)*b(in) - r(in)*c(i))/det
            x(in) = (r(in)*b(i) - r(i)*a(in))/det
            call mpi_wait(request(2), status, ierr)
        else if(myrank>=nhprocs) then
            call mpi_irecv(rbuf0, 4, MPI_REAL8, myrank-nhprocs, 301, MPI_COMM_WORLD, request(3), ierr)
            call mpi_isend(sbuf,  4, MPI_REAL8, myrank-nhprocs, 300, MPI_COMM_WORLD, request(4), ierr)

            call mpi_wait(request(3), status, ierr)
            a(0) = rbuf0(1)
            b(0) = rbuf0(2)
            c(0) = rbuf0(3)
            r(0) = rbuf0(4)

            ip = 0
            i = n_mpi

            det = b(ip)*b(i) - c(ip)*a(i)
            x(ip) = (r(ip)*b(i) - r(i)*c(ip))/det
            x(i) = (r(i)*b(ip) - r(ip)*a(i))/det
            call mpi_wait(request(4), status, ierr)
        endif

    end subroutine pcr_forward_single_row

    !>
    !> @brief   First phase of hybrid Thomas and PCR algorithm
    !> @details Forward and backward elimination to remain two equations of first and
    !>          last rows for each MPI processes
    subroutine pThomas_forward_multiple_row

        implicit none

        integer(4)  :: i
        real(8)     :: alpha, beta

        do i = 3, n_mpi
            alpha = - a(i) / b(i-1)
            a(i) = alpha * a(i-1)
            b(i) = b(i) + alpha * c(i-1)
            r(i) = r(i) + alpha * r(i-1)
        enddo

        do i = n_mpi-2, 1, -1
            beta = - c(i) / b(i+1)
            c(i) = beta * c(i+1)
            r(i) = r(i) + beta * r(i+1)
            if(i==1) then
                b(1) = b(1) + beta * a(2)
            else
                a(i) = a(i) + beta * a(i+1)
            endif
        enddo

    end subroutine pThomas_forward_multiple_row

    !>
    !> @brief   PCR solver for two equations per each MPI process
    !> @details Forward CR to remain a single equation per each MPI process.
    !>          PCR solver for single row is, then, executed.
    !>          Substitution is also performed to obtain every solution.
    !>
    subroutine pcr_double_row_substitution

        use mpi

        implicit none

        integer(4)  :: i, ip, in
        real(8)     :: alpha, gamma
        real(8)     :: sbuf(4), rbuf(4)

        integer(4)  :: status(MPI_STATUS_SIZE)
        integer(4)  :: request(2)
        integer(4)  :: ierr

        !< Cyclic reduction until single row remains per MPI process.
        !< First row of next rank is sent to current rank at the row of n_mpi+1 for reduction.
        if(myrank<nprocs-1) then
            call mpi_irecv(rbuf, 4, MPI_REAL8, myrank+1, 0, MPI_COMM_WORLD, request(1), ierr)
        endif
        if(myrank>0) then
            sbuf(1) = a(1);
            sbuf(2) = b(1);
            sbuf(3) = c(1);
            sbuf(4) = r(1);
            call mpi_isend(sbuf, 4, MPI_REAL8, myrank-1, 0, MPI_COMM_WORLD, request(2), ierr)
        endif
        if(myrank<nprocs-1) then
            call mpi_wait(request(1), status, ierr)
            a(n_mpi+1) = rbuf(1)
            b(n_mpi+1) = rbuf(2)
            c(n_mpi+1) = rbuf(3)
            r(n_mpi+1) = rbuf(4)
        endif

        !< Every first row are reduced to the last row (n_mpi) in each MPI rank.
        i = n_mpi
        ip = 1
        in = i + 1
        alpha = -a(i) / b(ip)
        gamma = -c(i) / b(in)

        b(i) = b(i) + (alpha * c(ip) + gamma * a(in))
        a(i) = alpha * a(ip)
        c(i) = gamma * c(in)
        r(i) = r(i) + (alpha * r(ip) + gamma * r(in))

        if(myrank>0) then
            call mpi_wait(request(2), status, ierr)
        endif

        !< Solution of last row in each MPI rank is obtained in pcr_forward_single_row().
        call pcr_forward_single_row

        !< Solution of first row in each MPI rank.
        if(myrank>0) then
            call mpi_irecv(x(0),   1, MPI_REAL8, myrank-1, 100, MPI_COMM_WORLD, request(1), ierr)
        endif
        if(myrank<nprocs-1) then
            call mpi_isend(x(n_mpi), 1, MPI_REAL8, myrank+1, 100, MPI_COMM_WORLD, request(2), ierr)
        endif
        if(myrank>0) then
            call mpi_wait(request(1), status, ierr)
        endif
        i = 1
        ip = 0
        in = n_mpi
        x(1) = r(1)-c(1)*x(n_mpi)-a(1)*x(0)
        x(1) = x(1)/b(1)

        if(myrank<nprocs-1) then
            call mpi_wait(request(2), status, ierr)
        endif
        !< Solution of other rows in each MPI rank.
        do i = 2, n_mpi-1
            x(i) = r(i)-c(i)*x(n_mpi)-a(i)*x(1)
            x(i) = x(i)/b(i)
        enddo
    end subroutine pcr_double_row_substitution

    !>
    !> @brief   Solution check
    !> @param   *a_ver Coefficients of a with original values
    !> @param   *b_ver Coefficients of b with original values
    !> @param   *c_ver Coefficients of c with original values
    !> @param   *r_ver RHS vector with original values
    !> @param   *x_sol Solution vector
    !>
    subroutine verify_solution(a_ver, b_ver, c_ver, r_ver, x_sol)

        use mpi

        implicit none

        real(8), intent(inout), target :: a_ver(0:n_mpi+1)
        real(8), intent(inout), target :: b_ver(0:n_mpi+1)
        real(8), intent(inout), target :: c_ver(0:n_mpi+1)
        real(8), intent(inout), target :: r_ver(0:n_mpi+1)
        real(8), intent(inout), target :: x_sol(0:n_mpi+1)

        integer(4)  :: i
        real(8), allocatable, dimension(:)     :: y

        integer(4)  :: status(MPI_STATUS_SIZE)
        integer(4)  :: request(4)
        integer(4)  :: ierr

        a => a_ver
        b => b_ver
        c => c_ver
        r => r_ver
        x => x_sol

        allocate(y(n_mpi+2))

        if(myrank>0) then
            call mpi_isend(x(1), 1, MPI_REAL8, myrank-1, 900, MPI_COMM_WORLD, request(1), ierr)
            call mpi_irecv(x(0), 1, MPI_REAL8, myrank-1, 901, MPI_COMM_WORLD, request(2), ierr)
        endif
        if(myrank<nprocs-1) then
            call mpi_isend(x(n_mpi),   1, MPI_REAL8, myrank+1, 901, MPI_COMM_WORLD, request(3), ierr)
            call mpi_irecv(x(n_mpi+1), 1, MPI_REAL8, myrank+1, 900, MPI_COMM_WORLD, request(4), ierr)
        endif

        if(myrank>0) then
            call mpi_wait(request(1), status, ierr)
            call mpi_wait(request(2), status, ierr)
        endif
        if(myrank<nprocs-1) then
            call mpi_wait(request(3), status, ierr)
            call mpi_wait(request(4), status, ierr)
        endif

        do i = 1, n_mpi
            y(i) = a(i)*x(i-1)+b(i)*x(i)+c(i)*x(i+1)
!            print '("Verify solution1 : myrank = ", i3, " a=", f12.6, " b=", f12.6, " c=", f12.6, " x=", f12.6, " r[", i3,"]=", f12.6, " y[", i3,"]=", f12.6)', myrank,a(i),b(i),c(i),x(i),i+n_mpi*myrank,r(i),i+n_mpi*myrank,y(i)
            print '("Verify solution1 : myrank = ", i3, " x=", f15.9, " r[", i3,"]=", f15.9, " y[", i3,"]=", f15.9)', myrank,x(i),i+n_mpi*myrank,r(i),i+n_mpi*myrank,y(i)
        enddo
        deallocate(y)

        nullify(a, b, c, r, x)

    end subroutine verify_solution

end module tdma_parallel


module init_diffusion_module

  use bl_types
  use bl_constants_module
  use multifab_module
  use define_bc_module
  use bc_module
  use multifab_physbc_module
  use multifab_coefbc_module
  use ml_layout_module
  use convert_stag_module
  use convert_rhoc_to_c_module
  use probin_common_module, only: prob_lo, prob_hi, prob_type, molmass
  use probin_multispecies_module, only: alpha1, beta, delta, sigma, Dbar, &
                                        c_init, nspecies

  implicit none

  private

  public :: init_rho  ! used in diffusion code

  ! IMPORTANT: In the diffusion only code (init_rho), c_init specifies initial values for DENSITY
  ! In the low-Mach code (init_rho_and_umac), c_init specifies initial MASS FRACTIONS (should sum to unity!)
  ! The density follows from the EOS in the LM case so it cannot be specified
  ! Same applies to boundary conditions

  ! prob_type codes for LowMach:
  ! 0=thermodynamic equilibrium, v=0, rho/c=c_init(1,1:nspecies)
  ! 1=bubble test, v=0, rho/c=c_init(1,1:nspecies) inside and c_init(2,1:nspecies) outside the bubble
  ! 2=gradient along y, v=0, rho/c=c_init(1,1:nspecies) on bottom (y=0) and c_init(2,1:nspecies) on top (y=Ly)
  ! 3=one fluid on top of another: v=0, rho/c=c_init(1,1:nspecies) on bottom (y<Ly/2) and c_init(2,1:nspecies) on top (y=L_y)
  ! 4=reserved for future use generic case (any nspecies)
  ! 5-onward=manufactured solutions for testing, limited to specific setups and nspecies

contains

  subroutine init_rho(rho,dx,time,the_bc_level)

    type(multifab) , intent(inout) :: rho(:)
    real(kind=dp_t), intent(in   ) :: dx(:,:)
    real(kind=dp_t), intent(in   ) :: time
    type(bc_level) , intent(in   ) :: the_bc_level(:)

    ! local variables
    integer                        :: lo(rho(1)%dim), hi(rho(1)%dim)
    integer                        :: dm, ng_r, i, n, nlevs
    real(kind=dp_t), pointer       :: dp(:,:,:,:)   ! pointer for rho (last dim:nspecies)

    type(bl_prof_timer), save :: bpt

    call build(bpt,"init_rho")

    dm = rho(1)%dim
    ng_r = rho(1)%ng
    nlevs = size(rho,1)

    ! assign values of parameters for the gaussian rho, rhototal
    alpha1 = 0.5d0
    beta   = 0.1d0
    delta  = 0.5d0
    sigma  = (prob_hi(1)-prob_lo(1))/10.0d0  ! variance of gaussian distribution

    ! looping over boxes
    do n=1,nlevs
       do i=1,nfabs(rho(n))
          dp => dataptr(rho(n),i)
          lo = lwb(get_box(rho(n),i))
          hi = upb(get_box(rho(n),i))
          select case(dm)
          case (2)
             call init_rho_2d(dp(:,:,1,:),ng_r,lo,hi,dx(n,:),time)
          case (3)
             call init_rho_3d(dp(:,:,:,:),ng_r,lo,hi,dx(n,:),time)
          end select
       end do

       ! fill ghost cells for two adjacent grids including periodic boundary ghost cells
       call multifab_fill_boundary(rho(n))

       ! fill non-periodic domain boundary ghost cells
       call multifab_physbc(rho(n),1,c_bc_comp,nspecies,the_bc_level(n), &
                            dx_in=dx(n,:))

    end do

    call destroy(bpt)

  end subroutine init_rho

  subroutine init_rho_2d(rho,ng_r,lo,hi,dx,time)

    integer          :: lo(2), hi(2), ng_r
    real(kind=dp_t)  :: rho(lo(1)-ng_r:,lo(2)-ng_r:,:)  ! last dimension for species
    real(kind=dp_t)  :: dx(:)
    real(kind=dp_t)  :: time

    ! local varables
    integer          :: i,j,n
    real(kind=dp_t)  :: x,y,w1,w2,rsq,rhot,L(2),sum,r,y1,rho_loc,rand

    L(1:2) = prob_hi(1:2)-prob_lo(1:2) ! Domain length

    ! for specific box, now start loop over alloted cells
    select case (prob_type)

    case(0)
    !============================================================
    ! Thermodynamic equilibrium
    !============================================================

    do j=lo(2),hi(2)
       do i=lo(1),hi(1)

          rho(i,j,1:nspecies) = c_init(1,1:nspecies)

       end do
    end do

    case(1)
    !=============================================================
    ! Initializing rho's in concentric circle with radius^2 = 0.1
    !=============================================================

    do j=lo(2),hi(2)
       y = prob_lo(2) + (dble(j)+half)*dx(2) - half*(prob_lo(2)+prob_hi(2))
       do i=lo(1),hi(1)
          x = prob_lo(1) + (dble(i)+half)*dx(1) - half*(prob_lo(1)+prob_hi(1))

          rsq = x**2 + y**2
          if (rsq .lt. L(1)*L(2)*0.1d0) then
             rho(i,j,1:nspecies) = c_init(1,1:nspecies)
          else
             rho(i,j,1:nspecies) = c_init(2,1:nspecies)
          end if

       end do
    end do

    case(2)
    !=========================================================
    ! Initializing rho's with constant gradient
    !=========================================================

    do j=lo(2),hi(2)
       y = prob_lo(2) + (dble(j)+half)*dx(2)
       do i=lo(1),hi(1)
          x = prob_lo(1) + (dble(i)+half)*dx(1)

            ! linear gradient in rho
            rho(i,j,1:nspecies) = c_init(1,1:nspecies) + &
               (c_init(2,1:nspecies) - c_init(1,1:nspecies))*(y-prob_lo(2))/L(2)

         end do
      end do

    case(3)
    !===========================================================
    ! Initializing rho's in Gaussian so as rhotot=constant=1.0
    ! Here rho_exact = e^(-r^2/4Dt)/(4piDt)
    !===========================================================

    do j=lo(2),hi(2)
         y = prob_lo(2) + (dble(j)+half) * dx(2) - half*(prob_lo(2)+prob_hi(2))
         do i=lo(1),hi(1)
            x = prob_lo(1) + (dble(i)+half) * dx(1) - half*(prob_lo(1)+prob_hi(1))

            rsq = x**2 + y**2
            rho(i,j,1) = 1.0d0/(4.0d0*M_PI*Dbar(1)*time)*dexp(-rsq/(4.0d0*Dbar(1)*time))
            rho(i,j,2) = 1.0d0-1.0d0/(4.0d0*M_PI*Dbar(1)*time)*dexp(-rsq/(4.0d0*Dbar(1)*time))

         end do
      end do

    case(4)
    !==================================================================================
    ! Initializing rho1,rho2=Gaussian and rhototal=1+alpha*exp(-r^2/4D)/(4piD) (no-time
    ! dependence). Manufactured solution rho1_exact = exp(-r^2/4Dt-beta*t)/(4piDt)
    !==================================================================================

    do j=lo(2),hi(2)
         y = prob_lo(2) + (dble(j)+half) * dx(2) - half
         do i=lo(1),hi(1)
            x = prob_lo(1) + (dble(i)+half) * dx(1) - half

            rsq = (x-L(1)*half)**2 + (y-L(2)*half)**2
            rhot = 1.0d0 + alpha1/(4.0d0*M_PI*Dbar(1))*dexp(-rsq/(4.0d0*Dbar(1)))
            rho(i,j,1) = 1.0d0/(4.0d0*M_PI*Dbar(1)*time)*dexp(-rsq/(4.0d0*Dbar(1)*time)-&
                         beta*time)*rhot
            rho(i,j,2) = rhot - rho(i,j,1)

         end do
      end do

    case(5)
    !==================================================================================
    ! Initializing m2=m3, D12=D13 where Dbar(1)=D12, Dbar(2)=D13,
    ! Dbar(3)=D23, Grad(w2)=0, manufactured solution for rho1 and rho2
    ! (to benchmark eqn1) Initializing rho1, rho2=Gaussian and rhototal has no-time dependence.
    !==================================================================================

    do j=lo(2),hi(2)
         y = prob_lo(2) + (dble(j)+half) * dx(2) - half
         do i=lo(1),hi(1)
            x = prob_lo(1) + (dble(i)+half) * dx(1) - half

            rsq = (x-L(1)*half)**2 + (y-L(2)*half)**2
            w1  = alpha1*dexp(-rsq/(2.0d0*sigma**2))
            w2  =  delta*dexp(-beta*time)
            rhot = 1.0d0 + (molmass(2)*Dbar(3)/(molmass(1)*Dbar(1))-1.0d0)*w1
            rho(i,j,1) = rhot*w1
            rho(i,j,2) = rhot*w2
            rho(i,j,3) = rhot-rho(i,j,1)-rho(i,j,2)

         end do
    end do

    case(6)
    !=========================================================
    ! Test of thermodiffusion steady-state for 2 species
    !=========================================================

    do j=lo(2),hi(2)
       y = prob_lo(2) + (dble(j)+half)*dx(2)
       do i=lo(1),hi(1)
          x = prob_lo(1) + (dble(i)+half)*dx(1)

            ! Solution to diff(c(y),y)=-K*c(y)*(1-c(y))
            ! Here K=grad(T)*S_T=0.15
            ! Height of domain H=32
            ! And average <rho1>=.4830852506
            rho(i,j,1) = 1.0d0/(1.0d0+0.1d0*exp(0.15d0*y))
            rho(i,j,2) = 1.0d0 - rho(i,j,1)

         end do
      end do

   case default

      call bl_error("init_rho_2d: prob_type not supported")

    end select

  end subroutine init_rho_2d

  subroutine init_rho_3d(rho,ng_r,lo,hi,dx,time)

    integer          :: lo(3), hi(3), ng_r
    real(kind=dp_t)  :: rho(lo(1)-ng_r:,lo(2)-ng_r:,lo(3)-ng_r:,:) ! Last dimension for species
    real(kind=dp_t)  :: dx(:)
    real(kind=dp_t)  :: time

    ! local variables
    integer          :: i,j,k,n
    real(kind=dp_t)  :: x,y,z,rsq,w1,w2,rhot,L(3),sum,rand,rho_loc,y1,r

    L(1:3) = prob_hi(1:3)-prob_lo(1:3) ! Domain length

    ! for specific box, now start loop over alloted cells
    select case (prob_type)

    case(0)
    !================================================================================
    ! Thermodynamic equilibrium
    !================================================================================

    !$omp parallel do private(i,j,k)
    do k=lo(3),hi(3)
       do j=lo(2),hi(2)
          do i=lo(1),hi(1)

             rho(i,j,k,1:nspecies) = c_init(1,1:nspecies)

          end do
       end do
    end do
    !$omp end parallel do

    case(1)
    !================================================================================
    ! Initializing rho's in concentric circle
    !================================================================================

    !$omp parallel do private(i,j,k,x,y,z,rsq)
    do k=lo(3),hi(3)
       z = prob_lo(3) + (dble(k)+half)*dx(3) - half*(prob_lo(3)+prob_hi(3))
       do j=lo(2),hi(2)
          y = prob_lo(2) + (dble(j)+half)*dx(2) - half*(prob_lo(2)+prob_hi(2))
          do i=lo(1),hi(1)
             x = prob_lo(1) + (dble(i)+half)*dx(1) - half*(prob_lo(1)+prob_hi(1))

               rsq = x**2 + y**2 + z**2
               if (rsq .lt. L(1)*L(2)*L(3)*0.001d0) then
                  rho(i,j,k,1:nspecies) = c_init(1,1:nspecies)
               else
                  rho(i,j,k,1:nspecies) = c_init(2,1:nspecies)
               end if

          end do
       end do
    end do
    !$omp end parallel do

    case(2)
    !========================================================
    ! Initializing rho's with constant gradient
    !========================================================

    !$omp parallel do private(i,j,k,x,y,z)
    do k=lo(3),hi(3)
       z = prob_lo(3) + (dble(k)+half)*dx(3)
       do j=lo(2),hi(2)
          y = prob_lo(2) + (dble(j)+half)*dx(2)
          do i=lo(1),hi(1)
             x = prob_lo(1) + (dble(i)+half)*dx(1)

               rho(i,j,k,1:nspecies) = c_init(1,1:nspecies) + &
                   (c_init(2,1:nspecies) - c_init(1,1:nspecies))*(y-prob_lo(2))/L(2)

          end do
       end do
     end do
     !$omp end parallel do

     case(3)
     !================================================================================
     ! Initializing rho's in Gaussian so as rhotot=constant=1.0. Here rho_exact =
     ! e^(-r^2/4Dt)/(4piDt)^3/2, For norm, sigma/dx >2 (at t=0) & L/sigma < 8 (at t=t)
     !================================================================================

     !$omp parallel do private(i,j,k,x,y,z,rsq)
     do k=lo(3),hi(3)
        z = prob_lo(3) + (dble(k)+half)*dx(3) - half*(prob_lo(3)+prob_hi(3))
        do j=lo(2),hi(2)
           y = prob_lo(2) + (dble(j)+half)*dx(2) - half*(prob_lo(2)+prob_hi(2))
           do i=lo(1),hi(1)
              x = prob_lo(1) + (dble(i)+half)*dx(1) - half*(prob_lo(1)+prob_hi(1))

              rsq = x**2 + y**2 + z**2
              rho(i,j,k,1) = dexp(-rsq/(4.0d0*Dbar(1)*time))/(4.0d0*M_PI*&
                             Dbar(1)*time)**1.5d0
              rho(i,j,k,2) = 1.0d0 - dexp(-rsq/(4.0d0*Dbar(1)*time))/(4.0d0*&
                             M_PI*Dbar(1)*time)**1.5d0

           end do
        end do
     end do
     !$omp end parallel do

     case(4)
     !==============================================================================
     ! Initializing rho1,rho2=Gaussian and rhot=space varying-constant
     ! in time. Manufactured solution rho1_exact = e^(-r^2/4Dt-t/tau)/(4piDt)^(3/2)
     !==============================================================================

     !$omp parallel do private(i,j,k,x,y,z,rsq,rhot)
     do k=lo(3),hi(3)
        z = prob_lo(3) + (dble(k)+half) * dx(3) - half
        do j=lo(2),hi(2)
           y = prob_lo(2) + (dble(j)+half) * dx(2) - half
           do i=lo(1),hi(1)
              x = prob_lo(1) + (dble(i)+half) * dx(1) - half

              rsq = (x-L(1)*half)**2 + (y-L(2)*half)**2 + (z-L(3)*half)**2
              rhot = 1.0d0 + alpha1*dexp(-rsq/(4.0d0*Dbar(1)))/(4.0d0*M_PI*&
                     Dbar(1))**1.5d0

              rho(i,j,k,1) = 1.0d0/(4.0d0*M_PI*Dbar(1)*time)**1.5d0*dexp(-rsq/&
                             (4.0d0*Dbar(1)*time) - time*beta)*rhot
              rho(i,j,k,2) = rhot - rho(i,j,k,1)

           end do
        end do
     end do
     !$omp end parallel do

     case(5)
     !==================================================================================
     ! Initializing m2=m3, D12=D13 where Dbar(1)=D12, Dbar(2)=D13, Dbar(3)=D23,
     ! Grad(w2)=0, manufactured solution for rho1 and rho2
     !==================================================================================

     !$omp parallel do private(i,j,k,x,y,z,rsq,w1,w2,rhot)
     do k=lo(3),hi(3)
        z = prob_lo(3) + (dble(k)+half) * dx(3) - half
        do j=lo(2),hi(2)
           y = prob_lo(2) + (dble(j)+half) * dx(2) - half
           do i=lo(1),hi(1)
              x = prob_lo(1) + (dble(i)+half) * dx(1) - half

              rsq = (x-L(1)*half)**2 + (y-L(2)*half)**2 + (z-L(3)*half)**2
              w1  = alpha1*dexp(-rsq/(2.0d0*sigma**2))
              w2  =  delta*dexp(-beta*time)
              rhot = 1.0d0 + (molmass(2)*Dbar(3)/(molmass(1)*Dbar(1))-1.0d0)*w1
              rho(i,j,k,1) = rhot*w1
              rho(i,j,k,2) = rhot*w2
              rho(i,j,k,3) = rhot-rho(i,j,k,1)-rho(i,j,k,2)

              if(rho(i,j,k,1).lt.0.d0 .or. rho(i,j,k,2).lt.0.d0 .or. rho(i,j,k,3).lt.0.d0) then
                 write(*,*), "rho1 / rho2 / rho3 is negative: STOP"
                 write(*,*), i, j, " w1=", w1, " w2=", w2, " rho1=",rho(i,j,k,1)," rho2=",&
                             rho(i,j,k,2), " rho3=",rho(i,j,k,3), " rhot=",rhot
              end if

          end do
       end do
    end do
    !$omp end parallel do

    case default

      call bl_error("init_rho_3d: prob_type not supported")

    end select

  end subroutine init_rho_3d

end module init_diffusion_module


      SUBROUTINE KEPLER(I,DTI)
*
*
*       Step reduction of hierarchy.
*       ----------------------------
*
*
      INCLUDE 'common6.h'
*
*
*       Only examine hierarchical configurations (NP < 5 OR STEP < DTMIN).
      I1 = 2*(I - N) - 1
      IF (LIST(1,I1).GT.4.AND.DTI.GT.DTMIN) GO TO 30
*
*       Set list membership & Kepler period.
      NP1 = LIST(1,I1) + 1
      SEMI = -0.5D0*BODY(I)/H(I-N)
      TK = TWOPI*SEMI*SQRT(SEMI/BODY(I))
*
*       Consider the most dominant perturbers having comparable step to c.m.
      DO 20 L = 2,NP1
          J = LIST(L,I1)
          IF (STEP(J).GT.4.0*STEP(I)) GO TO 20
          RIJ2 = (X(1,I) - X(1,J))**2 + (X(2,I) - X(2,J))**2 +
     &                                  (X(3,I) - X(3,J))**2
          RIJ = SQRT(RIJ2)
          DT2 = 0.1*RIJ*SQRT(ETAI*RIJ/(BODY(I) + BODY(J)))
          DT = 0.25D0*SQRT(ETAI)*RIJ*TK/SEMI
*       Compare predicted c.m. step with conservative Kepler expressions.
          DT = MIN(DT,DT2)
          IF (DTI.LT.DT) GO TO 20
          DTI = DT
*
*       Check whether to reduce step of dominant perturber.
          IF (STEP(J).LT.DT) GO TO 20
          IF (T0(J).EQ.TIME) THEN
              STEP(J) = 0.5D0*STEP(J)
              TIMENW(J) = T0(J) + STEP(J)
              GO TO 20
          END IF
          JCLOSE = J
   20 CONTINUE
*
   30 RETURN
*
      END