c
c -------------------------------------------------------------
c     LLF ON PHYSICAL VARIABLES

      subroutine vrm(qr,ql,rx,ixmin,ixmax,iflip,msize)

      implicit double precision (a-h,o-z)
      common /userdt/ cfl,gamma,gamma1,xprob,yprob,alpha,Re,iprob,
     .                ismp,gradThreshold

      common /order2/ ssw, quad, nolimiter
      logical quad
      parameter ( m1size = 5000 )

      dimension qr(msize,4),ql(msize,4)
      dimension uconl(4), uconr(4)
      dimension rx(msize,4),fl(4),fr(4)

      dimension clsqp(m1size),clsqm(m1size),pstar(m1size)
      dimension zp(m1size),zm(m1size),ustarm(m1size),ustarp(m1size)
      dimension zsum(m1size)
      data      itno/2/, small/1.d-6/
c
      if (ixmax .gt. m1size) then
         write(6,*)" need to increase m1size in vrm to ", ixmax
         stop
      endif

c
c
c      iflip = 1 indicates the normal velocity is in
c                qr(k,2) and the tangential in qr(k,3)
c            = 0 indicates the reverse.
c
      inorm = 3 - iflip
      itan  = 2 + iflip
      do 10 k = ixmin, ixmax

         if(quad) then ! everything is in primitive variables
         rhol = ql(k,1)
         ul   = ql(k,inorm)
         utl  = ql(k,itan)
         pl   = ql(k,4)
         El   = pl / (gamma-1.d0) + 0.5d0 * rhol * (ul**2 + utl**2)
         cl   = dsqrt(gamma * pl / rhol)
         sl   = max(dabs(ul + cl), dabs(ul - cl) )

         rhor = qr(k,1)
         ur   = qr(k,inorm)
         utr  = qr(k,itan)
         pr   = qr(k,4)
         Er   = pr / (gamma-1.d0) + 0.5d0 * rhor * (ur**2 + utr**2)
         cr   = dsqrt(gamma * pr / rhor)
         sr   = max(dabs(ur + cr), dabs(ur - cr) )

         s = max(sl,sr)

         uconl(1) = rhol
         uconl(inorm) = rhol*ul
         uconl(itan) = rhol*utl
         uconl(4) = El

         uconr(1) = rhor
         uconr(inorm) = rhor*ur
         uconr(itan) = rhor*utr
         uconr(4) = Er

         fl(1) = rhol * ul
         fl(inorm) = rhol*ul*ul + pl
         fl(itan) = rhol*ul*utl
         fl(4) = (El + pl) * ul

         fr(1) = rhor * ur
         fr(inorm) = rhor * ur * ur + pr
         fr(itan) = rhor * ur * utr
         fr(4) = (Er + pr) * ur
         else ! things are in conserved variables
         rhol = ql(k,1)
         ul   = ql(k,inorm)/ql(k,1)
         pl   = (gamma - 1.d0) * (ql(k,4)
     .               -0.5d0*(ql(k,inorm)**2 + ql(k,itan)**2)/ ql(k,1) )
         cl   = dsqrt(gamma * pl / rhol)
         sl   = max(dabs(ul + cl), dabs(ul - cl) )

         rhor = qr(k,1)
         ur   = qr(k,inorm)/qr(k,1)
         pr   = (gamma - 1.d0) * (qr(k,4)
     .                -0.5d0*(qr(k,inorm)**2 + qr(k,itan)**2)/ qr(k,1) )
         cr   = dsqrt(gamma * pr / rhor)
         sr   = max(dabs(ur + cr), dabs(ur - cr) )

         s = max(sl,sr)

         uconl(1) = ql(k,1)
         uconl(inorm) = ql(k,inorm)
         uconl(itan) = ql(k,itan)
         uconl(4) = ql(k,4)

         uconr(1) = qr(k,1)
         uconr(inorm) = qr(k,inorm)
         uconr(itan) = qr(k,itan)
         uconr(4) = qr(k,4)

         fl(1) = ql(k,inorm)
         fl(inorm) = (ql(k,inorm)**2)/ql(k,1) + pl
         fl(itan) = ql(k,inorm)*ql(k,itan)/ql(k,1)
         fl(4) = (ql(k,4) + pl) *  ql(k,inorm) /  ql(k,1)

         fr(1) = qr(k,inorm)
         fr(inorm) = (qr(k,inorm)**2)/qr(k,1) + pr
         fr(itan) = qr(k,inorm)*qr(k,itan)/qr(k,1)
         fr(4) = (qr(k,4) + pr) *  qr(k,inorm) /  qr(k,1)
         endif

         rx(k,:) = 0.5d0*(fl(:)+fr(:)) + 0.5d0*s*(uconl(:)-uconr(:))

  10     continue

      return
      end


************************************************************************
*
*     Subroutine GETDTIME                      Called by: INPUTC,INPUTE
*
*     compute decimal time in fractional years, DECTIME, and set the
*     PERIOD for models 10 and 11
*
*     local variables
*     ---------------
*     IDA      day of month (1 - 31)
*     IMI      number of minutes since midnight
*     IMO      month of year (1-12)
*     NDAY     julian date
*     IDAYS    julian date of the last day of the previous month
*
************************************************************************
      SUBROUTINE GETDTIME(DATE,IYR,TIME,DECTIME,PERIOD,PBMON,PEMON,
     &                    MODNO)
*
*     subroutine arguments
*
      INTEGER*4 DATE,IYR,TIME,PBMON,PEMON,MODNO
      DOUBLE PRECISION DECTIME,PERIOD
*
*     local vars
*
      INTEGER*4 IDA,IMI,IMO,LEAP,NDAY,IDAYS(12)
      DATA IDAYS / 0,31,59,90,120,151,181,212,243,273,304,334 /
*
*     determine year, month, day of month, and minutes since midnight
*
      IYR = DATE/10000
      IMO = (DATE-IYR*10000)/100
      IDA = DATE-(IYR*10000)-(IMO*100)
      IMI = ((TIME/100)*60)+MOD(TIME,100)
*
*     error checks: 1) day of month must be 1-31; 2) month must be
*     1-12; 3) year must be > 1582.
*
      IF ((IDA.LT.1).OR.(IDA.GT.31)) CALL ERROR1(8,DATE)
      IF ((IMO.LT.1).OR.(IMO.GT.12)) CALL ERROR1(9,DATE)
      IF (IYR.LE.1582) CALL ERROR1(10,DATE)
*
*     For models 10 or 11, set PERIOD if the observation falls within
*     the range of PBMON AND PEMON
*
      IF (((MODNO.EQ.10).OR.(MODNO.EQ.11)).AND.
     &    (IMO.GE.PBMON.AND.IMO.LE.PEMON)) THEN
         PERIOD = 1.D0
      ELSE
         PERIOD = 0.D0
      ENDIF
*
*     determine if its a leap year
*
      LEAP = 0
      IF (MOD(IYR,4).EQ.0) LEAP = 1
      IF ((MOD(IYR,100).EQ.0).AND.(MOD(IYR,400).NE.0)) LEAP = 0
*
*     compute the julian date (works for dates after 1582)
*
      NDAY = IDAYS(IMO)+IDA
      IF (IMO.GE.3) NDAY = NDAY + LEAP
*
*     calculate DECTIME
*
      IF (LEAP.EQ.1) THEN
         DECTIME = DBLE(IYR)+(DBLE(NDAY)-
     &        1.D0+(DBLE(IMI)/1440.D0))/366.D0
      ELSE
         DECTIME = DBLE(IYR)+(DBLE(NDAY) -
     &        1.D0+(DBLE(IMI)/1440.D0))/365.D0
      ENDIF

      RETURN
      END


subroutine r_sreadinit(solid_coor_init,solid_coor_curr)
  use r_common
  use solid_variables
  implicit none

  real(8),dimension(1:nsd_solid,1:nn_solid) :: solid_coor_init   !...node position initial
  real(8),dimension(1:nsd_solid,1:nn_solid) :: solid_coor_curr   !...node position current
	integer:: i

!USER'S DEPENDENT
do i=1,nn_solid
	!solid_coor_curr(2,i) = (0.375*solid_coor_init(1,i)+0.925)*solid_coor_init(2,i)
	!solid_coor_curr(2,i) = (-0.3125*(solid_coor_init(1,i))**2+ &
	!		0.625*solid_coor_init(1,i)+0.9875)*solid_coor_init(2,i)
	!solid_coor_curr(2,i) = (-0.625*(solid_coor_init(1,i))**2+ &
	!		1.25*solid_coor_init(1,i)+0.675)*solid_coor_init(2,i)
enddo

  return
end subroutine r_sreadinit


  subroutine testing
!
!  implicit none
  implicit real*8 (a-h,o-z),integer(i-n)
!
  logical :: fullset=.false.
  integer :: is,npoi
  double precision :: pi
  double precision :: s,theta,varphi,A_phi,A_theta,dA_phi_ds,dA_theta_ds,aiota,      &
                      R,Z,alam,dR_ds,dR_dt,dR_dp,dZ_ds,dZ_dt,dZ_dp,dl_ds,dl_dt,dl_dp
  double precision :: ds
  double precision, dimension(3,3) :: cmat,gV,g
  double precision, dimension(3) :: x,bder,hcovar,hctrvr,hcurl
  double precision, dimension(:), allocatable :: dummy,dummy1
  double precision, dimension(:,:), allocatable :: dummy2d
  double precision, dimension(:,:), allocatable :: dummy2d1
!
  pi=4.d0*atan2(1.d0,1.d0)
!
  npoi=100000
  ds=1.d0/npoi
!npoi=100
  vartheta_c=0.5d0
  varphi_c=0.5d0
!
ntheta=100
allocate(dummy(ntheta))
do is=1,npoi
!  do it=1,ntheta
    s=ds*is
    r=s
    mode_secders=2
!    vartheta_c=2.d0*pi*dble(it)/dble(ntheta)
  call vmec_field(s,vartheta_c,varphi_c,A_theta,A_phi,dA_theta_ds,dA_phi_ds,aiota,     &
                  sqg,alam,dl_ds,dl_dt,dl_dp,Bctrvr_vartheta,Bctrvr_varphi,     &
                  Bcovar_r,Bcovar_vartheta,Bcovar_varphi)
write(103,*) s,Bcovar_r,Bcovar_vartheta,Bcovar_varphi,sqg
!
if(.false.) then
    call splint_can_coord(fullset,mode_secders,r,vartheta_c,varphi_c,                      &
                          A_theta,A_phi,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3,     &
                          sqg_c,dsqg_c_dr,dsqg_c_dt,dsqg_c_dp,                             &
                          B_vartheta_c,dB_vartheta_c_dr,dB_vartheta_c_dt,dB_vartheta_c_dp, &
                          B_varphi_c,dB_varphi_c_dr,dB_varphi_c_dt,dB_varphi_c_dp,         &
                          d2sqg_rr,d2sqg_rt,d2sqg_rp,d2sqg_tt,d2sqg_tp,d2sqg_pp,           &
                          d2bth_rr,d2bth_rt,d2bth_rp,d2bth_tt,d2bth_tp,d2bth_pp,           &
                          d2bph_rr,d2bph_rt,d2bph_rp,d2bph_tt,d2bph_tp,d2bph_pp,G_c)
!
!    dummy(it)=B_vartheta_c
!  enddo
!  write(101,*) dummy
write(102,*) r,B_vartheta_c,B_varphi_c,sqg_c
endif
enddo
stop
!
end


      subroutine dpcg(n,a,adiag,acol_ptr,arow_ind,
     +               l,ldiag,lcol_ptr,lrow_ind,
     +               b,rtol,itmax,x,iters,info,p,q,r,z)
      integer n, itmax, iters, info
      integer acol_ptr(n+1), arow_ind(*), lcol_ptr(n+1), lrow_ind(*)
      double precision rtol
      double precision a(*), adiag(n), l(*), ldiag(n), b(n)
      double precision x(n)
      double precision p(n), q(n), r(n), z(n)
c     *********
c
c     Subroutine dpcg
c
c     Given a sparse symmetric matrix A in compressed row storage,
c     this subroutine uses a preconditioned conjugate gradiene method
c     to solve the system A*x = b.
c
c     The subroutine statement is
c
c       subroutine dpcg(n,a,adiag,acol_ptr,arow_ind,
c                       l,ldiag,lcol_ptr,lrow_ind,
c                       b,rtol,itmax,x,iters,info,p,q,r,z)
c
c     where
c
c       n is an integer variable.
c         On entry n is the order of A.
c         On exit n is unchanged.
c
c       a is a double precision array of dimension *.
c         On entry a must contain the strict lower triangular part
c            of A in compressed column storage.
c         On exit a is unchanged.
c
c       adiag is a double precision array of dimension n.
c         On entry adiag must contain the diagonal elements of A.
c         On exit adiag is unchanged.
c
c       acol_ptr is an integer array of dimension n + 1.
c         On entry acol_ptr must contain pointers to the columns of A.
c            The nonzeros in column j of A must be in positions
c            acol_ptr(j), ... , acol_ptr(j+1) - 1.
c         On exit acol_ptr is unchanged.
c
c       arow_ind is an integer array of dimension *.
c         On entry arow_ind must contain row indices for the strict
c            lower triangular part of A in compressed column storage.
c         On exit arow_ind is unchanged.
c
c       l is a double precision array of dimension nnz+n*p.
c         On entry l need not be specified.
c         On exit l contains the strict lower triangular part
c            of L in compressed column storage.
c
c       ldiag is a double precision array of dimension n.
c         On entry ldiag need not be specified.
c         On exit ldiag contains the diagonal elements of L.
c
c       lcol_ptr is an integer array of dimension n + 1.
c         On entry lcol_ptr need not be specified.
c         On exit lcol_ptr contains pointers to the columns of L.
c            The nonzeros in column j of L are in the
c            lcol_ptr(j), ... , lcol_ptr(j+1) - 1 positions of l.
c
c       lrow_ind is an integer array of dimension nnz+n*p.
c         On entry lrow_ind need not be specified.
c         On exit lrow_ind contains row indices for the strict lower
c            triangular part of L in compressed column storage.
c
c       b is a double precision array of dimension n.
c         On entry b must contain the vector b.
c         On exit b is unchanged.
c
c       rtol is a double precision variable.
c         On entry rtol specifies the relative convergence test.
c         On exit rtol is unchanged
c
c       itmax is an integer variable.
c         On entry itmax specifies the limit on the number of
c            conjugate gradient iterations.
c         On exit itmax is unchanged.
c
c       x is a double precision array of dimension n.
c         On entry x need not be specified.
c         On exit x contains the final conjugate gradient iterate.
c
c       iters is an integer variable.
c         On entry iters need not be specified.
c         On exit iters is set to the number of conjugate
c            gradient iterations.
c
c       info is an integer variable.
c         On entry info need not be specified.
c         On exit info is set as follows:
c
c             info = 1  The residual has the relative error
c                       specified by rtol.
c
c             info = 2  Negative curvature is encountered, and
c                       p is a direction of negative curvature.
c
c             info = 3  Failure to converge after itmax iterations.
c
c       p is a double precision work array of dimension n.
c
c       q is a double precision work array of dimension n.
c
c       r is a double precision work array of dimension n.
c
c       z is a double precision work array of dimension n.
c
c     Subprograms called
c
c       MINPACK-2  ......  dstrsol, dssyax
c
c       Level 1 BLAS  ...  daxpy, dcopy, ddot, dnrm2
c
c     MINPACK-2 Project. May 1998.
c     Argonne National Laboratory.
c     Chih-Jen Lin and Jorge J. More'.
c
c     **********
      double precision zero, one
      parameter(zero=0.0d0,one=1.0d0)

      integer i
      double precision alpha, beta, bnorm, ptq, rho, rnorm, rtz

      external dstrsol, dssyax
      external daxpy, dcopy
      double precision ddot, dnrm2

c     Initialize the iterate x and the residual r.

      iters = 0
      do i = 1, n
         x(i) = zero
      end do
      call dcopy(n,b,1,r,1)
      bnorm = dnrm2(n,b,1)
      rnorm = bnorm
      info = 1

c     Exit if b = 0.

      if (bnorm .eq. zero) return

c     Initialize z by solving L*L'*z = r.

      call dcopy(n,r,1,z,1)
      call dstrsol(n,l,ldiag,lcol_ptr,lrow_ind,z,'N')
      call dstrsol(n,l,ldiag,lcol_ptr,lrow_ind,z,'T')

c     Initialize p.

      call dcopy(n,z,1,p,1)

c     Initialize rho.

      rho = ddot(n,r,1,z,1)

      do iters = 1, itmax

c        Compute q = A*p.

         call dssyax(n,a,adiag,acol_ptr,arow_ind,p,q)

c        Check for negative curvature.

         ptq = ddot(n,p,1,q,1)
         if (ptq .le. zero) then
            info = 2
            return
         end if

c        Update x.

         alpha = rho/ptq
         call daxpy(n,alpha,p,1,x,1)

c        Update the residual.

         call daxpy(n,-alpha,q,1,r,1)
         rnorm = dnrm2(n,r,1)

c        Exit if the residual convergence test is satisfied.

         if (rnorm .le. rtol*bnorm) return

c        Solve L*L'*z = r.

         call dcopy(n,r,1,z,1)
         call dstrsol(n,l,ldiag,lcol_ptr,lrow_ind,z,'N')
         call dstrsol(n,l,ldiag,lcol_ptr,lrow_ind,z,'T')

c        Compute new rho.

         rtz = ddot(n,r,1,z,1)

         beta = rtz/rho

c        Compute p = z + beta*p

         call dscal(n,beta,p,1)
         call daxpy(n,one,z,1,p,1)

c        Update rho.

         rho = rtz

      end do

      info = 3
      return

      end


! This is the data of LX-17 condensed phase explosive
! taken from:
! Kapila A K , Schwendeman D W , Bdzil J B , et al.
! A study of detonation diffraction in the ignition-and-growth model[J].
! Combustion Theory and Modelling, 2007, 11(5):781-822.
module material_mxnm
  use EOS_JWL
  implicit none
  integer,parameter :: material_type = 1
  !-------Reactant
  double precision :: a_s     = 30.00e11
  double precision :: b_s     =-0.018003e11
  double precision :: gamma_s = 1.237d0
  double precision :: cv_s    = 1.4272e6
  double precision :: r1_s    = 10.0d0
  double precision :: r2_s    = 1.0d0
  double precision :: rho0_s  = 1137.d0
  NAMELIST/material_mxnmrtt_params/ a_s, b_s, gamma_s, cv_s, r1_s, &
                                  r2_s, rho0_s

  !-------Products
  double precision :: a_g     = 2.092e11
  double precision :: b_g     = 0.05689e11
  double precision :: gamma_g = 0.3d0
  double precision :: cv_g    = 1.0e6
  double precision :: r1_g    = 4.4d0
  double precision :: r2_g    = 1.2d0
  double precision :: rho0_g  = 1905.d0
  double precision :: q_ref   = 0.051e11
  NAMELIST/material_mxnmpdt_params/ a_g, b_g, gamma_g, cv_g, r1_g, &
  r2_g, q_ref

  !-------Reaction
  double precision :: i_r         = 4.0e6
  double precision :: lambda_i_r  = 0.01d0
  double precision :: a_r         = 0.5741d0
  double precision :: b_r         = 0.667d0
  double precision :: x_r         = 4.0d0
  double precision :: g1_r        = 1.21875e8
  double precision :: lambda_g1_r = 0.8d0
  double precision :: c_r         = 0.667d0
  double precision :: d_r         = 0.667d0
  double precision :: y_r         = 4.d0
  double precision :: g2_r        = 2.40000e5
  double precision :: lambda_g2_r = 0.8d0
  double precision :: e_r         = 0.667d0
  double precision :: g_r         = 0.667d0
  double precision :: z_r         = 1.d0
  NAMELIST/material_mxnmrtn_params/ i_r, a_r, b_r, x_r, c_r,  &
                                  d_r, y_r, g1_r, e_r, g_r, &
                                  z_r, g2_r, lambda_i_r,    &
                                  lambda_g1_r, lambda_g2_r

logical :: if_initialized = .false.
interface compute_pressure_mixt_mxnm
  module procedure compute_pressure_mixt1_mxnm
  module procedure compute_pressure_mixt2_mxnm
end interface compute_pressure_mixt_mxnm
contains
subroutine write_material_mxnm_inp(funit)
  implicit none
  integer,intent(in) :: funit
  write(funit,NML=material_mxnmrtt_params)
  write(funit,NML=material_mxnmpdt_params)
  write(funit,NML=material_mxnmrtn_params)
end subroutine write_material_mxnm_inp

subroutine initial_material_mxnm(funit)
  implicit none
  integer,intent(in) :: funit
  if(.not.if_initialized) then
  read(funit,NML=material_mxnmrtt_params)
  read(funit,NML=material_mxnmpdt_params)
  read(funit,NML=material_mxnmrtn_params)
endif
end subroutine initial_material_mxnm

subroutine scale_material_mxnm(rho_rv,u_rv,temp_rv,time_rv, &
                          p_rv,e_rv,l_rv,cv_rv)
  implicit none
  double precision,intent(in) :: rho_rv,u_rv,temp_rv,time_rv, &
                                  p_rv,e_rv,l_rv,cv_rv

    if(.not.if_initialized) then
      !-------Reactant
  a_s     = a_s/p_rv
  b_s     = b_s/p_rv
  cv_s    = cv_s/cv_rv
  rho0_s  = rho0_s/rho_rv
  !-------Products
  a_g    = a_g/p_rv
  b_g    = b_g/p_rv
  cv_g   = cv_g/cv_rv
  rho0_g = rho0_g/rho_rv
  q_ref  = q_ref/p_rv

  !-------Reaction
  i_r  = i_r*time_rv
  g1_r = g1_r*((1.0e11/p_rv)**(-y_r)/(1.0/time_rv))
  g2_r = g2_r*((1.0e11/p_rv)**(-z_r)/(1.0/time_rv))
  if_initialized = .true.
endif
end subroutine scale_material_mxnm

subroutine compute_pref_mixt1_mxnm(p_ref,rho_s,rho_g,lbd)
  implicit none
  double precision,intent(in) :: rho_s,rho_g,lbd
  double precision,intent(inout) :: p_ref
  double precision :: pref_s,pref_g,pref_sg,rhogamma_sg
  call compute_pref_eos_jwl(pref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
  call compute_pref_eos_jwl(pref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)

  pref_sg     = (1.d0-lbd)*pref_s/(rho_s*gamma_s) &
                  +lbd*pref_g/(rho_g*gamma_g)
  rhogamma_sg = (1.d0-lbd)/(rho_s*gamma_s) &
                  +lbd/(rho_g*gamma_g)

  p_ref = pref_sg/rhogamma_sg
end subroutine compute_pref_mixt1_mxnm

subroutine compute_pref_mixt2_mxnm(p_ref,dp_ref,rho_s,rho_g,lbd,drho_s,drho_g)
  implicit none
  double precision,intent(in) :: rho_s,rho_g,lbd
  double precision,intent(in) :: drho_s,drho_g
  double precision,intent(inout) :: p_ref,dp_ref
  double precision :: pref_s,pref_g
  double precision :: dpref_s,dpref_g
  double precision :: pref_num,rhogamma_dom
  double precision :: dpref_num,drhogamma_dom
  double precision :: lbd_s,lbd_g
  call compute_dpref2_eos_jwl(pref_s,dpref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
  call compute_dpref2_eos_jwl(pref_g,dpref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
  lbd_s = (1.d0-lbd)
  lbd_g = lbd
  pref_num     = lbd_s*pref_s/(rho_s*gamma_s) &
                  +lbd_g*pref_g/(rho_g*gamma_g)
  rhogamma_dom = lbd_s/(rho_s*gamma_s) &
                  +lbd_g/(rho_g*gamma_g)
  p_ref = pref_num/rhogamma_dom

  dpref_num     = (lbd_s*dpref_s*rho_s*gamma_s - lbd_s*pref_s*gamma_s)/(rho_s*gamma_s)**2*drho_s &
                 +(lbd_g*dpref_g*rho_g*gamma_g - lbd_g*pref_g*gamma_g)/(rho_g*gamma_g)**2*drho_g
  drhogamma_dom =-lbd_s*gamma_s/(rho_s*gamma_s)**2*drho_s &
                 -lbd_g*gamma_g/(rho_g*gamma_g)**2*drho_g
  dp_ref = (dpref_num*rhogamma_dom - pref_num*drhogamma_dom)/rhogamma_dom**2
end subroutine compute_pref_mixt2_mxnm

subroutine compute_eref_mixt1_mxnm(ei_ref,rho_s,rho_g,lbd)
  implicit none
  double precision,intent(in) :: rho_s,rho_g,lbd
  double precision,intent(inout) :: ei_ref
  double precision :: eref_s,eref_g
  call compute_eiref_eos_jwl(eref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
  call compute_eiref_eos_jwl(eref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
  ei_ref = (1.d0-lbd)*eref_s + lbd*(eref_g - q_ref)
end subroutine compute_eref_mixt1_mxnm

subroutine compute_eref_mixt2_mxnm(ei_ref,dei_ref,rho_s,rho_g,lbd,drho_s,drho_g)
  implicit none
  double precision,intent(in) :: rho_s,rho_g,lbd
  double precision,intent(in) :: drho_s,drho_g
  double precision,intent(inout) :: ei_ref,dei_ref
  double precision :: eref_s,eref_g
  double precision :: deref_s,deref_g
  call compute_deiref2_eos_jwl(eref_s,deref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
  call compute_deiref2_eos_jwl(eref_g,deref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
  ei_ref  = (1.d0-lbd)*eref_s + lbd*(eref_g - q_ref)
  dei_ref = (1.d0-lbd)*deref_s*drho_s + lbd*deref_g*drho_g
end subroutine compute_eref_mixt2_mxnm

subroutine compute_rhogamma_mixt1_mxnm(rhogamma_mixt,rho_s,rho_g,lbd)
  implicit none
  double precision,intent(in) :: rho_s,rho_g,lbd
  double precision,intent(inout) :: rhogamma_mixt
  double precision :: rhogamma_sg
  rhogamma_sg   = (1.d0-lbd)/(rho_s*gamma_s) + lbd/(rho_g*gamma_g)
  rhogamma_mixt = 1.d0/rhogamma_sg
end subroutine compute_rhogamma_mixt1_mxnm

subroutine compute_rhogamma_mixt2_mxnm(rhogamma_mixt,drhogamma_mixt,rho_s,rho_g,lbd,drho_s,drho_g)
  implicit none
  double precision,intent(in) :: rho_s,rho_g,lbd
  double precision,intent(in) :: drho_s,drho_g
  double precision,intent(inout) :: rhogamma_mixt,drhogamma_mixt
  double precision :: rhogamma_dom,drhogamma_dom
  double precision :: lbd_s,lbd_g
  lbd_s = (1.d0-lbd)
  lbd_g = lbd
  rhogamma_dom   = lbd_s/(rho_s*gamma_s) + lbd_g/(rho_g*gamma_g)
  rhogamma_mixt  = 1.d0/rhogamma_dom
  drhogamma_dom  =-lbd_s*gamma_s/(rho_s*gamma_s)**2*drho_s &
                  -lbd_g*gamma_g/(rho_g*gamma_g)**2*drho_g
  drhogamma_mixt =-drhogamma_dom/rhogamma_dom**2
end subroutine compute_rhogamma_mixt2_mxnm

subroutine compute_pressure_mixt1_mxnm(p,e,rho_s,rho_g,lbd)
  implicit none
  double precision,intent(in) :: e,rho_s,rho_g,lbd
  double precision,intent(inout) :: p
  double precision :: pref_s,pref_g,eref_s,eref_g
  double precision :: numerator,denominator
  call compute_eiref_eos_jwl(eref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
  call compute_eiref_eos_jwl(eref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
  call compute_pref_eos_jwl(pref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
  call compute_pref_eos_jwl(pref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
  numerator = e - (1.d0-lbd)*eref_s - lbd*(eref_g - q_ref) &
             +(1.d0-lbd)*pref_s/(rho_s*gamma_s)    &
             +lbd*pref_g/(rho_g*gamma_g)
  denominator = (1.d0-lbd)/(rho_s*gamma_s)+lbd/(rho_g*gamma_g)
  p = numerator/denominator
end subroutine compute_pressure_mixt1_mxnm

subroutine compute_pressure_mixt2_mxnm(p,rho_s,rho_g,lbd)
  implicit none
  double precision,intent(in) :: rho_s,rho_g,lbd
  double precision,intent(inout) :: p
  double precision :: pref_s,pref_g,rgcv_s,rgcv_g
  double precision :: numerator,denominator
  call compute_pref_eos_jwl(pref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
  call compute_pref_eos_jwl(pref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
  rgcv_s = 1.d0/(rho_s*gamma_s*cv_s)
  rgcv_g = 1.d0/(rho_g*gamma_g*cv_g)
  numerator   = pref_s*rgcv_s - pref_g*rgcv_g
  denominator = rgcv_s - rgcv_g
  p = numerator/denominator
end subroutine compute_pressure_mixt2_mxnm

subroutine compute_pressure_mixt3_mxnm(p,numerator,denominator,rho_s,rho_g,lbd)
  implicit none
  double precision,intent(in) :: rho_s,rho_g,lbd
  double precision,intent(inout) :: p,numerator,denominator
  double precision :: pref_s,pref_g,rgcv_s,rgcv_g
  call compute_pref_eos_jwl(pref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
  call compute_pref_eos_jwl(pref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
  rgcv_s = 1.d0/(rho_s*gamma_s*cv_s)
  rgcv_g = 1.d0/(rho_g*gamma_g*cv_g)
  numerator = pref_s*rgcv_s - pref_g*rgcv_g
  denominator = rgcv_s - rgcv_g
  p = numerator/denominator
end subroutine compute_pressure_mixt3_mxnm

subroutine compute_pressure_mixt4_mxnm(num,dom,dnum,ddom,rho_s,rho_g,lbd,drho_s,drho_g)
  implicit none
  double precision,intent(in) :: rho_s,rho_g,lbd
  double precision,intent(in) :: drho_s,drho_g
  double precision,intent(inout) :: num,dom,dnum,ddom
  double precision :: pref_s,pref_g
  double precision :: dpref_s,dpref_g
  double precision :: rgcv_s,rgcv_g
  double precision :: drgcv_s,drgcv_g
  call compute_dpref2_eos_jwl(pref_s,dpref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
  call compute_dpref2_eos_jwl(pref_g,dpref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
  rgcv_s = 1.d0/(rho_s*gamma_s*cv_s)
  rgcv_g = 1.d0/(rho_g*gamma_g*cv_g)
  num = pref_s*rgcv_s - pref_g*rgcv_g
  dom = rgcv_s - rgcv_g

  drgcv_s =-gamma_s*cv_s/(rho_s*gamma_s*cv_s)**2
  drgcv_g =-gamma_g*cv_g/(rho_g*gamma_g*cv_g)**2
  dnum = (dpref_s*rgcv_s + pref_s*drgcv_s)*drho_s &
        -(dpref_g*rgcv_g + pref_g*drgcv_g)*drho_g
  ddom = drgcv_s*drho_s - drgcv_g*drho_g
end subroutine compute_pressure_mixt4_mxnm

! compute the internal energy of reactant
subroutine compute_ei_reac_mxnm(ei,p,r)
  implicit none
  double precision,intent(in) :: p,r
  double precision,intent(inout) :: ei
  double precision :: p_ref,pr_ref,p1_ref
  double precision :: ei_ref,eir_ref,ei1_ref
  call compute_pref_eos_jwl(pr_ref,r,a_s,b_s,r1_s,r2_s,rho0_s)
  call compute_pref_eos_jwl(p1_ref,rho0_s,a_s,b_s,r1_s,r2_s,rho0_s)
  call compute_eiref_eos_jwl(eir_ref,r,a_s,b_s,r1_s,r2_s,rho0_s)
  call compute_eiref_eos_jwl(ei1_ref,rho0_s,a_s,b_s,r1_s,r2_s,rho0_s)
  p_ref  = pr_ref - p1_ref
  ei_ref = eir_ref - ei1_ref
  ei = (p - p_ref)/(r*gamma_s) + ei_ref
end subroutine compute_ei_reac_mxnm

! compute the internal energy of product
subroutine compute_ei_prod_mxnm(ei,p,r)
  implicit none
  double precision,intent(in) :: p,r
  double precision,intent(inout) :: ei
  double precision :: p_ref, ei_ref
  call compute_pref_eos_jwl(p_ref,r,a_g,b_g,r1_g,r2_g,rho0_g)
  call compute_eiref_eos_jwl(ei_ref,r,a_g,b_g,r1_g,r2_g,rho0_g)
  ei = (p - p_ref)/(r*gamma_g) + ei_ref - q_ref
end subroutine compute_ei_prod_mxnm

! compute the internal energy of the mixture
subroutine compute_internal_energy_mixt_mxnm(ei,eia,eib,p,ra,rb,lbd)
  implicit none
  double precision,intent(in) :: p,ra,rb,lbd
  double precision,intent(inout) :: ei,eia,eib
  double precision :: p_ref, ei_ref
  call compute_ei_reac_mxnm(eia,p,ra)
  call compute_ei_prod_mxnm(eib,p,rb)
  ei = (1.d0-lbd)*eia+lbd*eib
end subroutine compute_internal_energy_mixt_mxnm

! compute the sound speed of mixture
subroutine compute_sound_speed2_mxnm(c2,p,rho,rho_s,rho_g,lambda)
  implicit none
  double precision,intent(in) :: p,rho,rho_s,rho_g,lambda
  double precision,intent(inout) :: c2
  double precision :: desdp,desdrs,degdp,degdrg
  double precision :: dersdrs,dergdrg
  double precision :: pref_s,pref_g,dprsdrs,dprgdrg
  double precision :: drsdr,drgdr
  double precision :: dedp,dedrho
  call compute_dedp_eos_jwl(desdp,p,rho_s,gamma_s)
  call compute_dedp_eos_jwl(degdp,p,rho_g,gamma_g)
  dedp  = (1.d0-lambda)*desdp + lambda*degdp

  call compute_dedr_eos_jwl(desdrs,p,rho_s,a_s,b_s,r1_s,r2_s,rho0_s,gamma_s)
  call compute_dedr_eos_jwl(degdrg,p,rho_g,a_g,b_g,r1_g,r2_g,rho0_g,gamma_g)

  drsdr  = rho_s**2/(rho**2*(1.d0-lambda))
  drgdr  = rho_g**2/(rho**2*lambda)
  dedrho = (1.d0-lambda)*desdrs*drsdr + lambda*degdrg*drgdr

  c2 = (p/rho**2-dedrho)/dedp
end subroutine compute_sound_speed2_mxnm

subroutine compute_xi_mxnm(xi,r,ra,rb,lbd)
  implicit none
  double precision,intent(in) :: r,ra,rb,lbd
  double precision,intent(inout) :: xi
  double precision :: ggs,ggg,gg
  ggs = gamma_s + 1.d0
  ggg = gamma_g + 1.d0
  gg = ((1.d0 - lbd)*cv_s*ggs + lbd*cv_g*ggg)/((1.d0 - lbd)*cv_s + lbd*cv_g)
  xi = 1.d0/(gg - 1.d0)
end subroutine compute_xi_mxnm

subroutine compute_temperature_mixt_mxnm(t,cv,p,rho_s,rho_g,lbd)
  implicit none
  double precision,intent(in) :: p,rho_s,rho_g,lbd
  double precision,intent(inout) :: t,cv
  double precision :: t_s,t_g,pref_s,pref0_s,pref_g
  call compute_pref_eos_jwl(pref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
  call compute_pref_eos_jwl(pref0_s,rho0_s,a_s,b_s,r1_s,r2_s,rho0_s)
  call compute_pref_eos_jwl(pref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
  t_s = (p - pref_s)/(rho_s*gamma_s*cv_s)
  t_g = (p - pref_g)/(rho_g*gamma_g*cv_g)
  t  = (1.d0-lbd)*t_s+lbd*t_g
  cv = (1.d0-lbd)*cv_s+lbd*cv_g
end subroutine compute_temperature_mixt_mxnm

! compute the reaction rate of IG model
subroutine compute_source_mxnm(src0, src_num,                     &
  comm_prim, comm_prim_num,          &
  phs_prim, phs_prim_num,            &
  phs_cpnt_prim, phs_cpnt_prim_num)
  implicit none
  integer,intent(in) :: src_num, comm_prim_num, &
                        phs_prim_num, phs_cpnt_prim_num
  double precision,dimension(comm_prim_num),intent(in) :: comm_prim
  double precision,dimension(phs_prim_num),intent(in) :: phs_prim
  double precision,dimension(phs_cpnt_prim_num),intent(in) :: phs_cpnt_prim
  double precision,dimension(src_num),intent(inout) :: src0
  double precision :: rho,p,lbd,z
  double precision :: h0,h1,h2,hv,hp
  p   = comm_prim(4)
  z   = phs_prim(1)
  rho = phs_prim(2)
  lbd = phs_cpnt_prim(3)
  call heaviside_mxnm(hv,rho/rho0_s-1.d0-a_r)
  call heaviside_mxnm(hp,p)
  call heaviside_mxnm(h0,lambda_i_r-lbd)
  call heaviside_mxnm(h1,lambda_g1_r-lbd)
  call heaviside_mxnm(h2,lbd-lambda_g2_r)
  src0(1) = i_r*(1.d0-lbd)**b_r*(rho/rho0_s-1.d0-a_r)**x_r*h0*hv &
        +g1_r*(1.d0-lbd)**c_r*lbd**d_r*p**y_r*h1*hp &
        +g2_r*(1.d0-lbd)**e_r*lbd**g_r*p**z_r*h2*hp
  src0(1) = z*src0(1)*rho
end subroutine compute_source_mxnm

subroutine heaviside_mxnm(h,x)
  implicit none
  double precision,intent(in) :: x
  double precision,intent(inout) :: h
  if(x.lt.0.d0) then
      h=0.d0
  else
      h=1.d0
  endif
end subroutine heaviside_mxnm
end module


	SUBROUTINE PC_INTP  ( vlev, adata, bdata, nparms, intflg,
     +			      angflg, outdat, iret )
C************************************************************************
C* PC_INTP								*
C*									*
C* This subroutine interpolates between two levels of data.  The	*
C* data are interpolated with respect to the log of the pressure.	*
C* Pressure MUST be the first variable in the input data arrays.	*
C* If errors are encountered no output data are changed.  Therefore,	*
C* data should be set to RMISSD before calling this subroutine.		*
C*									*
C* PC_INTP  ( VLEV, ADATA, BDATA, NPARMS, INTFLG, ANGFLG,		*
C*            OUTDAT, IRET )						*
C*									*
C* Input parameters:							*
C*	VLEV		REAL		Pressure to be interpolated	*
C*	ADATA (NPARMS)	REAL		Data at first level		*
C*	BDATA (NPARMS)	REAL		Data at second level		*
C*	NPARMS		INTEGER		Size of data arrays		*
C*	INTFLG (NPARMS)	LOGICAL		Interpolation flags		*
C*	ANGFLG (NPARMS)	LOGICAL		Angle interpolation flags	*
C*									*
C* Output parameters:							*
C*	OUTDAT (NPARMS)	REAL		Data interpolated to VLEV	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					-24 = vlev not between levels	*
C*					-28 = invalid pressure 		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 9/84						*
C* M. desJardins/GSFC	 9/88	GEMPAK4					*
C* G. Huffman/USRA	10/89	Check both pressures for non-positive	*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
C*
	REAL		adata (*), bdata (*), outdat (*)
	LOGICAL		intflg (*), angflg (*)
C*
	LOGICAL		betwen
C*
        INCLUDE         'ERMISS.FNC'
C-------------------------------------------------------------------------
C*	Check that VLEV is between two pressures input.
C
	pres1 = adata (1)
	pres2 = bdata (1)
	betwen = ( ( (pres1 .lt. pres2) .and. (pres1 .lt. vlev) .and.
     +		      (vlev .lt. pres2) )  .or.
     +		    ( (pres2 .lt. pres1) .and. (pres2 .lt. vlev) .and.
     +		      (vlev .lt. pres1) ) )
C
C*	Test for errors - can't interpolate or a non-positive pressure.
C
	IF  ( .not. betwen )  THEN
	    iret = -24
	  ELSE IF  ( ( pres1 .le. 0. ) .or. ( pres2 .le. 0. ) )  THEN
	    iret = -28
	  ELSE
	    iret = 0
C
C*	    Set up interpolation.  Check for interpolation of angles
C*	    through 360 degrees.
C
	    rmult = ALOG ( vlev / adata(1) ) /
     +		    ALOG ( bdata(1) / adata(1) )
	    outdat (1) = vlev
	    DO  i = 2, nparms
		IF  ( intflg (i) )  THEN
		    IF  ( angflg (i) )  THEN
			ang1 = AMOD ( adata(i), 360. )
			ang2 = AMOD ( bdata(i), 360. )
			IF  ( ABS (ang1 - ang2) .gt. 180.)  THEN
			    IF  ( ang1 .lt. ang2 )  THEN
				ang1 = ang1 + 360.
			      ELSE
				ang2 = ang2 + 360.
			    END IF
			END IF
			ang = ang1 + (ang2 - ang1) * rmult
			outdat (i) = amod ( ang, 360. )
		      ELSE
		        outdat (i) = adata (i) +
     +				      ( bdata(i) - adata (i) ) * rmult
		    END IF
		    IF  ( ERMISS ( adata(i) ) .or.
     +				ERMISS ( bdata(i) ) )
     +					outdat (i) = RMISSD
		END IF
	    END DO
	END IF
C*
	RETURN
	END


module lvg_func
use variables
use statis
use atmosfer
use data_write
use maths
implicit none
contains

! *********************************************************
! *********************************************************
! LVG INITIALIZATION ROUTINES
! *********************************************************
! *********************************************************

!-----------------------------------------------------------------
! Calculates Jbar using the LVG approximation
!-----------------------------------------------------------------
	subroutine LVGformal_solver(itr)
	integer, INTENT(IN) :: itr
	integer :: idir, dir, k, k0, k1, kdel, cortes, inout
	real(kind=8) :: Q, tau_lvg, integrand, beta, derv, mu_c
	real(kind=8), allocatable :: chi0(:), s0(:)
	real(kind=8) :: opac, source
	real(kind=8), allocatable :: vel(:)
	real(kind=8), allocatable :: gauss_weights(:), gauss_abs(:)

	allocate(chi0(nfrq))
	allocate(s0(nfrq))
	allocate(gauss_weights(gaussq_n))
	allocate(gauss_abs(gaussq_n))

	Jbar = 0.d0

	call gauleg(0.d0,1.d0,gauss_abs,gauss_weights,gaussq_n)

	allocate(vel(n_radios))

! Calculate outer boundary condition for this transition
	call calcula_fondo(itr)
	call calcula_centro(itr)

	idir = -1 ; k0 = n_radios ; k1 = 1 ; kdel = -1 ; inout = 1

   vel = datph(7,:)

! If the velocity profile is 0. PUT THIS IN A BETTER WAY

	if (maxval(datph(7,:)) == 0.d0 .and. minval(datph(7,:)) == 0.d0) then
   	do k = 1, n_radios
      	vel(k) = (k-1.d0) / (n_radios-1.d0)
      enddo
   endif

! Go through all the shells inside out
	do k = 1, n_radios

		beta = 0.d0
		mu_c = dsqrt(1.d0 - r(1)**2/r(k)**2)

! Calculate the number of intersections between the characteristics and the shell
		cortes = n_cortes(k)

! Calculate radial velocity field gradient.
		if (k /= 1 .and. k /= n_radios) then
!			derv = lag_deriv(r(k-1),r(k),r(k+1),vel(k-1),vel(k),vel(k+1),1)
			derv = deriv(r(k-1),r(k),r(k+1),vel(k-1),vel(k),vel(k+1),1)
		else
			if (k == 1) then
!				derv = lag_deriv(r(1),r(2),r(3),vel(1),vel(2),vel(3),0)
				derv = deriv(r(1),r(2),r(3),vel(1),vel(2),vel(3),0)
			else
				if (k == n_radios) then
!					derv = lag_deriv(r(n_radios-2),r(n_radios-1),r(n_radios),&
!						vel(n_radios-2),vel(n_radios-1),vel(n_radios),2)
					derv = deriv(r(n_radios-2),r(n_radios-1),r(n_radios),&
						vel(n_radios-2),vel(n_radios-1),vel(n_radios),2)
				endif
			endif
		endif

! Calculate line integrated opacity
		chi0 = chil(k) * perfil + kappa(k) + kappa_dust(k)
!		opac = sum(wtnu * chi0) / doppler_width(k,itr)
		opac = chil(k) / doppler_width(k,itr)

! Calculate line integrated source function
		s0 = ( chil(k) * Sl(k) * perfil + kappa(k) * B(k) + kappa_dust(k) * B_dust(k) ) / opac
!		source = sum(wtnu * s0)
		source = Sl(k)

! Integration of beta using gaussian quadrature with 24 points
		beta = 0.d0
		do dir = 1, gaussq_n
			Q = dabs(vel(k)/r(k) * (1.d0 - gauss_abs(dir)**2) + gauss_abs(dir)**2 * derv)

			if (Q /= 0.d0) then
				tau_lvg = opac / Q
				integrand = (1.d0-exp(-tau_lvg))/tau_lvg
			else
				integrand = 0.d0
			endif

			beta = beta + gauss_weights(dir) * integrand
		enddo

! Average intensity in Sobolev approximation
		Jbar(k) = (1.d0 - beta) * source + 0.5d0*(1.d0-mu_c) * beta * dentro(nfrq/2) +&
			beta * fuera(nfrq/2)
	enddo	!k

	deallocate(vel)
	deallocate(chi0)
	deallocate(s0)
	deallocate(gauss_weights)
	deallocate(gauss_abs)

	end subroutine LVGformal_solver

!-----------------------------------------------------------------
! Calculates Jbar using LVG approximation and fills Jbar_total matrix
!-----------------------------------------------------------------

	subroutine calcJbarLVG
	integer :: it, ip, ipt
		do it = 1, nr

! Calculate opacities and source functions
			call opacity(it,n_radios,1,n_radios)

! Do the formal solution of the RTE using LVG approximation
			call LVGformal_solver(it)

! Build up the Lstar_total and Jbar_total matrices. These are necessary for the construction
! of the rate matrix
			do ip = 1, n_radios
				ipt = nr*(ip-1)
				Lstar_total(it+ipt) = 0.d0
				Jbar_total(it+ipt) = Jbar(ip)
			enddo

		enddo
	end subroutine calcJbarLVG

!-----------------------------------------------------------------
! Calcula las poblaciones en LVG
!-----------------------------------------------------------------

	subroutine lvgpops
	integer :: i, j
	real(kind=8), allocatable :: nh_ant(:)
	real(kind=8) :: factor, omega_bak

		omega_bak = omega_sor
		omega_sor = 1.d0
		print *, 'LVG solution to : ', dabs(lvg_flag)
		relat_error = 1.d0
		i = 0

		if (lvg_flag < 0.d0) then
			print *, 'Running LVG in slow mode'
			allocate(nh_ant(n_radios))
			nh_ant = nh
			factor = 1.d10

			do j = 1, 10
				nh = nh_ant * factor
				i = 0
				relat_error = 1.d0
				print *, 'Multiplying density by factor : ', factor

				do while (relat_error > dabs(lvg_flag) .and. i < 1000)
					i = i + 1
					call calcJbarLVG

					call corrige_poblaciones
               print *, 'Relative error : ', relat_error
				enddo
				print *, 'Relative error : ', relat_error

				factor = 10.d0**(9.d0-j)

			enddo

			nh = nh_ant
			deallocate(nh_ant)

		else
			do while (relat_error > dabs(lvg_flag) .and. i < 1000)
				i = i + 1

				call calcJbarLVG
				call corrige_poblaciones

				print *, 'Step: ',i, '  Relat. error : ', relat_error

			enddo
		endif

! Initial population
		popi(1:nl*n_radios) = pop(1:nl*n_radios)
		if (i == 1000) then
			print *, 'Reached 1000 iterations in LVG initialization. Trying these values'
		endif

		omega_sor = omega_bak

	end subroutine lvgpops

end module lvg_func


 SUBROUTINE corr18k(st,ep,efpst,bs,gm,props,a,b, &
                   ierr,flag,is,kh,np,curve,h)
 !-------------------------------------------------------------------
 !
 !     transversal Anisotropy for 3-D Solid element (TLF)
 !
 !-------------------------------------------------------------------
 USE lispa0
 USE mat_dba, ONLY : inte_cr
 IMPLICIT NONE

 REAL (kind=8),INTENT(IN) :: props(:),  & !material properties
                             gm,        & !elasticity shear modulus
                             a(:),b(:)    !yield and potential function matrices
 REAL (kind=8),INTENT(IN OUT) :: st(:),bs(:)  !trial and corrected stresses and back stresses
 REAL (kind=8),INTENT(IN OUT) :: efpst    !effective plastic strain
                                          !(IN) present   (OUT) increment
 REAL (kind=8), POINTER :: curve(:,:)     !(3,np) yield stress
 REAL (kind=8),INTENT(OUT) :: ep(:)       !increment in plastic strains
 INTEGER (kind=4), INTENT(IN) :: is,kh    !isotropic and kinematic hardening model
 INTEGER (kind=4), INTENT(OUT) :: ierr    !error flag (0: O.K., 1:error)
 INTEGER (kind=4), INTENT(IN) :: np       !number of points in CURVE
 LOGICAL, INTENT(OUT) :: flag             !.TRUE. if plastic  .FALSE. if elastic
 REAL (kind=8),INTENT(OUT), OPTIONAL :: h !plastic modulus
 !local variables
  REAL (kind=8), PARAMETER :: toler=1d-4, toler1=1d-6
  INTEGER (kind=4), PARAMETER :: miter=5

  REAL (kind=8) ::  s11,s22,s33,s12,s13,s23,epbar,fi,f0,     &
                    a1,a2,a3,a4,a5,a6,ap,dl,aux,yield,aprim, &
                    b1,b2,b3,b4,b5,b6,hk,hs,fp,de,bsi(6)

  INTEGER (kind=4) k
!  INTEGER (kind=4), SAVE :: kk(miter) = 0  !it is a debug variable

 !------------ begin

 !     setup initial yield FUNCTION radius

 IF( is == 5 ) THEN        !for points defined yield value
   k = 1   !begin at first interval
   yield = inte_cr (curve,np,efpst,k) !c0
   aprim = curve(3,k)                 !c1
                                      !c0 = c0 - c1*efpst  !ordinate at 0
 ELSE
   !c0 = props(1)     !c0 constant or Initial yield
   !c1 = props(2)     !linear hardening or efref
   !c2 = props(3)     !exponent for non-linear hardening
   !c3 = props(4)     !residual flow stress
   CALL isoha14(is,yield,aprim,efpst,props(1),props(2),props(3),props(4))
 END IF

  s11 = st(1)-bs(1)
  s22 = st(2)-bs(2)
  s33 = st(3)-bs(3)
  s12 = st(4)-bs(4)
  s13 = st(5)-bs(5)
  s23 = st(6)-bs(6)
  !     calculate initial effective stress
  a1 =  a(1)*s11+ a(2)*s22 + a(3)*s33
  a2 =  a(2)*s11+ a(4)*s22 + a(5)*s33
  a3 =  a(3)*s11+ a(5)*s22 + a(6)*s33
  a4 =  a(7)*s12
  a5 =  a(8)*s13
  a6 =  a(9)*s23
  fi = SQRT( a1*s11 + a2*s22 + a3*s33 + a4*s12 + a5*s13 + a6*s23 )
  !     check initial yield FUNCTION

  f0 = fi-yield
  IF( f0/yield < toler) THEN

     !   IF the point is elastic

    flag = .FALSE.

  ELSE
    hk = props(6)*2d0   !?????
    hs = props(7)*2.5d0 !?????
    epbar = efpst
    DO k = 1,miter
      ! compute a vector
      a1 = a1/fi
      a2 = a2/fi
      a3 = a3/fi
      a4 = a4/fi
      a5 = a5/fi
      a6 = a6/fi
      ! compute (flow rule) vector
      b1 =  b(1)*s11+ b(2)*s22 + b(3)*s33
      b2 =  b(2)*s11+ b(4)*s22 + b(5)*s33
      b3 =  b(3)*s11+ b(5)*s22 + b(6)*s33
      b4 =  b(7)*s12
      b5 =  b(8)*s13
      b6 =  b(9)*s23
      fp = SQRT( b1*s11 + b2*s22 + b3*s33 + b4*s12 + b5*s13 + b6*s23 )
      b1 = b1/fp
      b2 = b2/fp
      b3 = b3/fp
      b4 = b4/fp
      b5 = b5/fp
      b6 = b6/fp
      ! compute d eps/ d lambda
      de = SQRT( ((b1*b1+b2*b2+b3*b3)*2d0 + b4*b4+b5*b5+b6*b6)/3d0)  !d eps/ d lambda
      ap = (gm+hk/2d0)*(2d0*(a1*b1+a2*b2+a3*b3)+a4*b4+a5*b5+a6*b6)+aprim*de
      IF( kh == 3 ) ap = ap -de*hs*(a1*bs(1)+a2*bs(2)+a3*bs(3)+a4*bs(4)+a5*bs(5)+a6*bs(6))
      dl = f0/ap
      ! increment in back stres
      aux = dl*hk
      bsi(1) = aux*b1
      bsi(2) = aux*b2
      bsi(3) = aux*b3
      bsi(4) = aux*b4/2d0
      bsi(5) = aux*b5/2d0
      bsi(6) = aux*b6/2d0
      IF( kh == 3 ) bsi = bsi - bs*hs*dl*de
      !new effective stresses and back stresses
      aux = dl*gm
      s11 = s11 - aux*b1*2d0 -bsi(1)
      s22 = s22 - aux*b2*2d0 -bsi(2)
      s33 = s33 - aux*b3*2d0 -bsi(3)
      s12 = s12 - aux*b4     -bsi(4)
      s13 = s13 - aux*b5     -bsi(5)
      s23 = s23 - aux*b6     -bsi(6)
      bs = bs + bsi
      !   calculate the effective plastic strain
      epbar = epbar + dl*de
      !   update the radius of the yield surface
      yield = yield + aprim*dl*de
      !   calculate the effective stress
      a1 =  a(1)*s11 + a(2)*s22 + a(3)*s33
      a2 =  a(2)*s11 + a(4)*s22 + a(5)*s33
      a3 =  a(3)*s11 + a(5)*s22 + a(6)*s33
      a4 =  a(7)*s12
      a5 =  a(8)*s13
      a6 =  a(9)*s23
      fi = SQRT( a1*s11 + a2*s22 + a3*s33 + a4*s12 + a5*s13 + a6*s23 )
      f0 = fi-yield     !yield function
      !  IF consistency condition is satisfied exit loop
      flag =  ABS(f0/yield) <= toler1
      IF( flag )EXIT
    END DO

    IF( flag )THEN
      ! total stresses
      s11 = s11 + bs(1)
      s22 = s22 + bs(2)
      s33 = s33 + bs(3)
      s12 = s12 + bs(4)
      s13 = s13 + bs(5)
      s23 = s23 + bs(6)
      !  increment in plastic strains  (twice the deviatoric tensor)
      ep(1) = (st(1) - s11)/gm
      ep(2) = (st(2) - s22)/gm
      ep(3) = (st(3) - s33)/gm
      ep(4) = (st(4) - s12)/gm
      ep(5) = (st(5) - s13)/gm
      ep(6) = (st(6) - s23)/gm
      efpst = epbar - efpst              !increment in effective plastic strain
      !  assign corrected stresses
      st(1) = s11
      st(2) = s22
      st(3) = s33
      st(4) = s12
      st(5) = s13
      st(6) = s23
      !kk(k) = kk(k) + 1
      !k = SUM(kk)
      !IF( MOD(k,10000) == 0 )THEN
      !  WRITE(55,"(5i10)",ERR=9999) kk
      !  kk = 0
      !END IF
      IF( PRESENT(h) ) h = 1.3333d0*gm*(1d0-3d0*gm*(a3/fi)**2/(gm+2d0/3d0*aprim))
    ELSE
      !        IF the iterations are greater than maximum STOP
      WRITE(*,*)' NO convergence in constitutive equation * STOP *'
      ierr=1                               !set flag to error in plastic integration
    END IF
  END IF

  RETURN

 END SUBROUTINE corr18k


c
c This progran calculate the max and min of input variables
c

	subroutine max_min(datamax,datamin,data,m1,m4,igrid)
	integer*4 igrid
	real*8 data(igrid)
c
c maximum
c
        do j=m1,m4
        data_diff=data(j)-datamax
        if(data_diff.gt.0.)then
        datamax=data(j)
	end if
	enddo
c
c calculate minimum
c
	do j=m1,m4
        data_diff=data(j)-datamin
        if(data_diff.lt.0.)then
        datamin=data(j)
        end if
        enddo

	return
	end


!==========================================
! particle3d.f90
! Author: Devansh Shukla
!------------------------------------------
program particle_3D
    ! Program to compute motion of a particle trapped in a 3d box

    implicit none
    real*8 :: x0, y0, z0, t0, tf, dt, t
    real*8 :: x, y, z, vx, vy, vz, lx0, lx1, ly0, ly1, lz0, lz1
    character(len=*), parameter :: fmt1 = "(F10.4,x,F10.4,x,F10.4,x,F10.4,x,F10.4,F10.4,x,F10.4)"

    open(unit=8, file="Particle3D.dat")

    print *, "---------------------------------------"
    print *, "Enter initial position x0, y0, z0"pe
    read *, x0, y0, z0

    print *, "Enter velocity vx, vy, vz"
    read *, vx, vy, vz

    print *, "Enter bounds lx0, lx1"
    read *, lx0, lx1

    print *, "Enter bounds ly0, ly1"
    read *, ly0, ly1

    print *, "Enter bounds lz0, lz1"
    read *, lz0, lz1

    print *, "Enter t0, tf, dt"
    read *, t0, tf, dt
    print *, "---------------------------------------"

    print "(x,A,F10.4,F10.4,F10.4)", "x0, y0, z0=", x0, y0, z0
    print "(x,A,F10.4,F10.4)", "lx0, lx1=", lx0, lx1
    print "(x,A,F10.4,F10.4)", "ly0, ly1=", ly0, ly1
    print "(x,A,F10.4,F10.4)", "lz0, lz1=", lz0, lz1
    print "(x,A,F10.4,F10.4,F10.4)", "t0, tf, dt=", t0, tf, dt
    print *, "---------------------------------------"

    print "(A10,A10,A10,xA10,xA10,xA10,xA10)", "time", "x(t)", "y(t)", "z(t)", "vx(t)", "vy(t)", "vz(t)"
    ! Formatting l0, l1 to our standards for fortran floating point arithmatic
    lx1 = lx1 - dt
    ly1 = ly1 - dt
    lz1 = lz1 - dt
    t = t0
    x = x0
    y = y0
    z = z0
    do while (t <= tf)
        write (*, fmt1) t, x, y, z, vx, vy, vz
        write (8, fmt1) t, x, y, z, vx, vy, vz
        x = x + vx * dt
        y = y + vy * dt
        z = z + vz * dt
        t = t + dt
        if (x < lx0 .or. x > lx1) vx = -vx
        if (y < ly0 .or. y > ly1) vy = -vy
        if (z < lz0 .or. z > lz1) vz = -vz
    enddo
    print *, "---------------------------------------"
    close(8)
end program particle_3D


!##############################################################################
!     ________  _____  ______________
!    / ____/  |/  / / / /_  __/  _/ /
!   / /_  / /|_/ / / / / / /  / // /
!  / __/ / /  / / /_/ / / / _/ // /___
! /_/   /_/  /_/\____/ /_/ /___/_____/
!
! Copyright 2020 Bharat Mahajan
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!    http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
!> \brief       Search Module
!! \details     This module provides functions for search utilities
!! \author      Bharat Mahajan
!! \date        Created: 07/31/2019
!
!##############################################################################

!> Module containing all the utility functions
module Search

    use FMUTILBase

    implicit none

    !> Max iterations for the root-finding
    integer, parameter :: MAX_ITERATIONS = 50

    !> Interface of the function whose root needs to be computed
    abstract interface
        pure function func(x) result(y)
            import :: WP
            implicit none
            real(WP), intent(in) :: x !< independent variable
            real(WP) :: y
        end function func
    end interface

    contains

    !> \brief Performs binary search on a provided sorted array
    !! \details TBD
    pure function BinarySearch(SortedX, SortedDataArray)

        !import :: WP

        implicit none

        real(WP), dimension(1:), intent(in)  :: SortedX    !< Element to find
        real(WP), dimension(:), intent(in)  :: SortedDataArray   !< Ascending-order sorted vector
        integer, dimension(size(SortedX)) :: BinarySearch

        integer :: lb, ub, a, b, m, n, ctr, xloc
        real(WP) :: x

        ! initialize
        lb = 1
        ub = size(SortedDataArray)
        m = lb

        ! for each element
        do ctr = 1, size(SortedX)

            ! element to search for
            x = SortedX(ctr)

            ! current interval. Note we assume that the array of the elements
            ! to search for is also a sorted array.
            a = m
            b = ub

            ! loop for finding the element
            do
                ! size of the current interval
                n = b - a + 1

                ! mid-point
                m = floor((n+1)/2.0) + (a-1)

                if (x < SortedDataArray(m)) then
                    ! search the lower half
                    b = m
                    cycle
                elseif (x > SortedDataArray(m) .AND. (m+1) /= b) then
                    ! search the upper half
                    a = m
                    cycle
                else
                    ! We either have found the exact match
                    ! Or x lies in between Data(m) and Data(m+1)
                    xloc = m
                    exit
                end if
            end do

            ! save the location of the current element
            BinarySearch(ctr) = xloc
        end do

    end function BinarySearch

end module Search


Program cir
Implicit none
Real::a,b,ac,area,mathstuff
write(*,*)"enter val of a,b"
Read(*,*)a,b
ac=3.14*b**2
area=mathstuff(a,b,ac)
write(*,*)"area=",area
end Program cir

real function mathstuff(a,b,ac)
Implicit none
real,intent(in)::a,b,ac
real::x,c,z,s,atri
x=(180-a)/2
c=b/sin(x)*sin(a)
z=a/360*ac
s=(b+b+c)/2
atri=(s*(s-b)*(s-b)*(s-c))**0.5
mathstuff=z-atri
end function mathstuff

S1-ex2 Calculate the Area of a Triangle.f95


MODULE m_vmmp21
!     ************************************************************
!     This subroutine calculates the potential matrix v^{s}_{m,m'}
!     for a given atom 'iType' and l-quantum number 'l'. The l,u,j's for
!     all atoms are stored in lda_u, the density matrix is ns_mmp,
!     and the e-e- interaction potential is u(m1,m2,m3,m4,iType).
!     For details see Eq.(16) of Shick et al. PRB 60, 10765 (1999)
!
!     Additionally, the total energy contribution of LDA+U (Eq.24)
!     is calculated (e_ldau).
!     Part of the LDA+U package                   G.B., Oct. 2000
!     ************************************************************
      USE m_types
      USE m_constants

      IMPLICIT NONE

      CONTAINS

      SUBROUTINE v_mmp_21(atoms,n_mmp21,u,v_mmp21,e_ldau)

      TYPE(t_atoms),    INTENT(IN)     :: atoms
      REAL,             INTENT(IN)     :: u(-lmaxU_const:,-lmaxU_const:,-lmaxU_const:,-lmaxU_const:,:)
      COMPLEX,          INTENT(IN)     :: n_mmp21(-lmaxU_const:,-lmaxU_const:,:)
      COMPLEX,          INTENT(INOUT)  :: v_mmp21(-lmaxU_const:,-lmaxU_const:,:)
      REAL,             INTENT(INOUT)  :: e_ldau

      INTEGER :: l,m,mp,p,q,iType,i_u
      REAL    :: e_dc, e_off
      !
      ! Loop over atoms
      !
      e_off = 0.0
      DO i_u = 1, atoms%n_u+atoms%n_hia
         iType = atoms%lda_u(i_u)%atomType
         l     = atoms%lda_u(i_u)%l
         !
         !-------------------------------------+
         !  offd    --                    offd |
         ! V     =  >  (  <m,p|V|q,m'> ) n     |
         !  m,m'    --                    p,q  |
         !        p,q                          |
         !-------------------------------------+
         v_mmp21(:,:,i_u) = cmplx_0

         DO m = -l,l
            DO mp =-l,l
               DO p = -l,l
                  DO q = -l,l
                     v_mmp21(m,mp,i_u) = v_mmp21(m,mp,i_u) - &
                                          u(m,p,q,mp,i_u) * n_mmp21(p,q,i_u)
                  ENDDO
               ENDDO
            ENDDO ! m' loop
         ENDDO ! m  loop

         !----------------------------------------------------------------------+
         !              s                                                       !
         !  ee      1  ---   s        s                     1        s  1       !
         ! E  (n) = -  >    n      ( V     + d     ( U (n - -) - J (n - -) ))   !
         !          2  ---   m,m'     m,m'    m,m'          2           2       !
         !             m,m'                                                     !
         !----------------------------------------------------------------------+

         e_dc = 0.0
         DO m = -l,l
            DO mp =-l,l
               DO p = -l,l
                  DO q = -l,l
                     e_dc = e_dc + u(m,p,q,mp,i_u) * (&
                                    n_mmp21(m,mp,i_u)*conjg(n_mmp21(q,p,i_u)) +&
                                    conjg(n_mmp21(mp,m,i_u))*n_mmp21(p,q,i_u) )
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
         e_off = e_off + e_dc

      ENDDO ! loop over atoms

      e_ldau = e_ldau + e_off / 2

   END SUBROUTINE v_mmp_21
END MODULE m_vmmp21


use SoilClass
implicit none

! create ground
type(Soil_) :: soil
type(Random_) :: random
type(Mesh_) :: mesh
type(DigitalElevationModel_) ::dem
integer(int32) :: i

! create mesh from Digital Elevetion Model (DEM)

! create dummy DEM data
dem%x = zeros(100)
dem%y = zeros(100)
dem%z = zeros(100)
do i=1, 100
    dem%x(i) = random%gauss(mu=0.0d0,sigma=10.0d0)
    dem%y(i) = random%gauss(mu=0.0d0,sigma=10.0d0)
    dem%z(i) = random%gauss(mu=0.0d0,sigma=1.0d0) + 10.0d0
enddo

mesh%nodcoord = zeros(size(dem%x),3 )
mesh%nodcoord(:,1) = dem%x
mesh%nodcoord(:,2) = dem%y
mesh%nodcoord(:,3) = dem%z

call soil%import(dem=dem,x_num=20,y_num=20,z_num=6)

call soil%msh("DEM")
call soil%vtk("DEM")

soil%YoungModulus = 100.0d0
soil%PoissonRatio = 0.30d0
soil%Density      = 1.60d0
soil%VoidRatio    = 0.50d0

call soil%PreFlightCheck()

! only gravity
call soil%deform()

! set deformation
!call soil%deform(z_max=1.0d0,disp=[0.0d0,0.0d0,0.0d0])

! result
call soil%vtk("DEM_deformed")

end


module xmom_mod
! Berechnet den X-Impuls

USE Variablen
USE derivatives_x_mod
USE derivatives_y_mod
USE derivatives_z_mod
USE neumann_mod
contains

subroutine xmom
integer::i,j,h,d
!delta_u, delta_v ,h, delta_w
! werden als subroutinen genutzt

! dphi Hilfsvariable
! rho_u*u+p-tau_xx
!p(1:m_local,1:n_local,1:o_local)=101307.0

!CALL Dphi_Dx_p_neu(p,delta_v,qxi_i,qxi_nr,qxi_r)

!delta_v(1:m_local,1:n_local,1:o_local)=0.0

!rho_u(1:m_local,1:n_local,1:o_local)=432324.1

dphi(1:m_local,1:n_local,1:o_local)=&
rho_u(1:m_local,1:n_local,1:o_local)*&
u(1:m_local,1:n_local,1:o_local)+&
p(1:m_local,1:n_local,1:o_local)-&
tau_xx(1:m_local,1:n_local,1:o_local)

!ableiten
CALL Dphi_Dx_p(dphi,delta_u,qxi_i,qxi_nr,qxi_r)

!delta_u(1:m_local,1:n_local,1:o_local)=&
!delta_u(1:m_local,1:n_local,1:o_local)+&
!delta_v(1:m_local,1:n_local,1:o_local)

! rho_v*u-tau_xy
dphi(1:m_local,1:n_local,1:o_local)=&
rho_v(1:m_local,1:n_local,1:o_local)*&
u(1:m_local,1:n_local,1:o_local)-&
tau_xy(1:m_local,1:n_local,1:o_local)

!ableiten
CALL Dphi_Dy_p(dphi,delta_v,qyi_i,qyi_nr,qyi_r)

!j=20
!h=20
!do i=1,n_local
!do h=1,n_local
!do i=1,m_local
!	if(delta_v(i,j,h).NE.0)then
!print *, tau_xy(i,j,h),delta_v(i,j,h),i,j,h
!endif
!end do
!end do
!end do

! rho_w*u-tau_xz
dphi(1:m_local,1:n_local,1:o_local)=&
rho_w(1:m_local,1:n_local,1:o_local)*&
u(1:m_local,1:n_local,1:o_local)-&
tau_xz(1:m_local,1:n_local,1:o_local)

!ableiten
CALL Dphi_Dz_p(dphi,delta_w,qzi_i,qzi_nr,qzi_r)

!!bc neumann
!call bcneu

!do I=1,m_local
!print *, delta_u(i,20,20),delta_v(i,20,20),delta_w(i,20,20)
!end do

!rho_u_neu=rho_u-dt*(delta_u+delta_v+delta_w)
rho_u_neu(1:m_local,1:n_local,1:o_local)=&
rho_u(1:m_local,1:n_local,1:o_local)-&
dt*(delta_u(1:m_local,1:n_local,1:o_local)+&
delta_v(1:m_local,1:n_local,1:o_local)+&
delta_w(1:m_local,1:n_local,1:o_local))

end subroutine

end module


subroutine volume(nmin, nmax, ngeom, radius, xa, dx, dvol)

! Calculate zone volume and average area based on geometry of sweep
!---------------------------------------------------------------
! GLOBALS
use sweepsize

IMPLICIT NONE

! LOCALS
INTEGER :: n, nmin, nmax, ngeom
REAL(kind=8) :: radius
REAL(kind=8), DIMENSION(maxsweep) :: xa, dx, dvol
REAL(kind=8), PARAMETER :: third = 1.0/3.0

!------------------------------------------------------------------------

select case (ngeom)
  case (0)
    dvol = dx
  case (1)
    dvol = dx*(xa+0.5*dx)
  case (2)
    dvol = dx*(xa*(xa+dx)+dx*dx*third)
  case (3)
    dvol = dx*radius
  case (4)
    do n = nmin-3, nmax+4
      dvol (n) = (cos(xa(n))-cos(xa(n+1)))*radius
    enddo
  case (5)
    dvol = dx*radius
  case default
    write(*,*) 'Geometry', ngeom, ' not implemented.'
    stop
end select

return
end


!
!     -------------------------------------------------------------
!      N I N E 0
!     -------------------------------------------------------------
!
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF 9j COEFFICIENT         *
!                                                                  *
!     |  J1/2  J2/2  J3/2 |                                        *
!     |  L1/2  L2/2  L3/2 |                                        *
!     |  K1/2  K2/2    0  |                                        *
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Vilnius,  Lithuania                             March 1995   *
!
      SUBROUTINE NINE0(J1, J2, J3, L1, L2, L3, K1, K2, K3, AA)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE CONSTS_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:09:06  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE sixj_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: J1
      INTEGER  :: J2
      INTEGER  :: J3
      INTEGER  :: L1
      INTEGER  :: L2
      INTEGER  :: L3
      INTEGER  :: K1
      INTEGER  :: K2
      INTEGER  :: K3
      REAL(DOUBLE) , INTENT(OUT) :: AA
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: IFA
      REAL(DOUBLE) :: A, B
!-----------------------------------------------
      IF (J1 == 0) THEN
         CALL SIXJ (L2, K2, J2, K3, L3, L1, 0, A)
         B = DBLE((J2 + 1)*(L1 + 1))
         IFA = K2 + J2 + L3 + L1
      ELSE IF (J2 == 0) THEN
         CALL SIXJ (L3, K3, J3, K1, L1, L2, 0, A)
         B = DBLE((J3 + 1)*(L2 + 1))
         IFA = K3 + J3 + L1 + L2
      ELSE IF (J3 == 0) THEN
         CALL SIXJ (L1, K1, J1, K2, L2, L3, 0, A)
         B = DBLE((J1 + 1)*(L3 + 1))
         IFA = K1 + J1 + L2 + L3
      ELSE IF (L1 == 0) THEN
         CALL SIXJ (K2, J2, L2, J3, K3, K1, 0, A)
         B = DBLE((L2 + 1)*(K1 + 1))
         IFA = J2 + L2 + K3 + K1
      ELSE IF (L2 == 0) THEN
         CALL SIXJ (K3, J3, L3, J1, K1, K2, 0, A)
         B = DBLE((L3 + 1)*(K2 + 1))
         IFA = J3 + L3 + K1 + K2
      ELSE IF (L3 == 0) THEN
         CALL SIXJ (K1, J1, L1, J2, K2, K3, 0, A)
         B = DBLE((L1 + 1)*(K3 + 1))
         IFA = J1 + L1 + K2 + K3
      ELSE IF (K1 == 0) THEN
         CALL SIXJ (J2, J3, J1, L3, L2, K2, 0, A)
         B = DBLE((J1 + 1)*(K2 + 1))
         IFA = J3 + J1 + L2 + K2
      ELSE IF (K2 == 0) THEN
         CALL SIXJ (J3, J1, J2, L1, L3, K3, 0, A)
         B = DBLE((J2 + 1)*(K3 + 1))
         IFA = J1 + J2 + L3 + K3
      ELSE IF (K3 == 0) THEN
         CALL SIXJ (J1, J2, J3, L2, L1, K1, 0, A)
         B = DBLE((J3 + 1)*(K1 + 1))
         IFA = J2 + J3 + L1 + K1
      ELSE
         A = ZERO
         B = ONE
      ENDIF
      AA = A/DSQRT(B)
      IF (MOD(IFA,4) /= 0) AA = -AA
      RETURN
      END SUBROUTINE NINE0


SUBROUTINE compute_reference_states(pv,uu,pt,stat,nlon,nlat,kmax,jd,npart,maxits,&
               a,om,dz,eps,h,r,cp,rjac,qref,u,tref,num_of_iter)

    integer, intent(in) :: nlon,nlat,kmax,jd,npart,maxits
    real, intent(in) :: pv(nlon,nlat,kmax),uu(nlon,nlat,kmax),pt(nlon,nlat,kmax),stat(kmax)
    real, intent(in) :: a, om, dz,eps,h, r, cp, rjac
    real, intent(out) :: qref(jd,kmax),u(jd,kmax),tref(jd,kmax)
    integer, intent(out) :: num_of_iter

    real :: pv2(nlon,nlat)
    real :: u2(nlon,nlat)
    real :: pt2(nlon,nlat)
    real :: qn(npart),an(npart),aan(npart),tb(kmax),tg(kmax)
    real :: cn(npart),ccn(npart)
    real :: alat(jd),phi(jd),z(kmax),cbar(jd,kmax)
    real :: ajk(jd,kmax),bjk(jd,kmax),cjk(jd,kmax)
    real :: djk(jd,kmax),ejk(jd,kmax),fjk(jd,kmax)

    real :: cref(jd,kmax)
    real :: qbar(jd,kmax),ubar(jd,kmax),tbar(jd,kmax)
    real :: pi, dp, zero, half, qtr, one, rkappa

    pi = acos(-1.)
    dp = pi/float(nlat-1)
    zero = 0.
    half = 0.5
    qtr = 0.25
    one = 1.
    rkappa = r/cp

    do nn = 1,jd
        phi(nn) = dp*float(nn-1)
        alat(nn) = 2.*pi*a*a*(1.-sin(phi(nn)))
    enddo

    do k = 1,kmax
        z(k) = dz*float(k-1)
    enddo

    ! **** Zonal-mean field ****
    do j = jd,nlat
        qbar(j-(jd-1),:) = 0.
        tbar(j-(jd-1),:) = 0.
        ubar(j-(jd-1),:) = 0.
        do i = 1,nlon
            qbar(j-(jd-1),:) = qbar(j-(jd-1),:)+pv(i,j,:)/float(nlon)
            tbar(j-(jd-1),:) = tbar(j-(jd-1),:)+pt(i,j,:)/float(nlon)
            ubar(j-(jd-1),:) = ubar(j-(jd-1),:)+uu(i,j,:)/float(nlon)
        enddo
    enddo

    ! **** hemispheric-mean potential temperature ****
    tb(:) = 0.
    wt = 0.
    do j = jd,nlat
        phi0 = dp*float(j-1)-0.5*pi
        !tb(:) = tb(:)+cos(phi0)*tbar(j,:)
        tb(:) = tb(:)+cos(phi0)*tbar(j-(jd-1),:)
        wt = wt + cos(phi0)
    enddo
    tb(:) = tb(:)/wt

    do k = 2,KMAX-1
        pv2(:,:) = pv(:,:,k)
        u2(:,:) = uu(:,:,k)
        pt2(:,:) = pt(:,:,k)

        !  **** area analysis ****
        qmax = maxval(pv2)
        qmin = minval(pv2)
        dq = (qmax-qmin)/float(npart-1)
        qn(:) = 0.
        an(:) = 0.
        cn(:) = 0.
        do nn = 1,npart
            qn(nn) = qmax - dq*float(nn-1)
        enddo
        do j = 1,nlat
            phi0 = -0.5*pi+dp*float(j-1)
            do i = 1,nlon
                ind = 1+int((qmax-pv2(i,j))/dq)
                da = a*a*dp*dp*cos(phi0)
                an(ind) = an(ind) + da
                cn(ind) = cn(ind) + da*pv2(i,j)
            enddo
        enddo
        aan(1) = 0.
        ccn(1) = 0.
        do nn = 2,npart
            aan(nn) = aan(nn-1)+an(nn)
            ccn(nn) = ccn(nn-1)+cn(nn)
        enddo
        do j = 1,(jd-1)
            do nn = 1,npart-1
                if(aan(nn).le.alat(j).and.aan(nn+1).gt.alat(j)) then
                    dd = (alat(j)-aan(nn))/(aan(nn+1)-aan(nn))
                    qref(j,k) = qn(nn)*(1.-dd)+qn(nn+1)*dd
                    cref(j,k) = ccn(nn)*(1.-dd)+ccn(nn+1)*dd
                endif
            enddo
        enddo

        qref(jd,k) = qmax

        cbar(jd,k) = 0.
        do j=(jd-1),1,-1
            phi0 = dp*(float(j)-0.5)
            cbar(j,k) = cbar(j+1,k)+0.5*(qbar(j+1,k)+qbar(j,k)) &
            *a*dp*2.*pi*a*cos(phi0)
        enddo

    enddo

    ! ***** normalize QGPV by the Coriolis parameter ****

    do j = 2,jd
        phi0 = dp*float(j-1)
        cor = 2.*om*sin(phi0)
        qref(j,:) = qref(j,:)/cor
    enddo

    do k = 2,KMAX-1
        qref(1,k) = 2.*qref(2,k)-qref(3,k)
    enddo

    ! **** SOR (elliptic solver a la Numerical Recipes) ****

    do j = 2,(jd-1)
        phi0 = float(j-1)*dp
        phip = (float(j)-0.5)*dp
        phim = (float(j)-1.5)*dp
        cos0 = cos(phi0)
        cosp = cos(phip)
        cosm = cos(phim)
        sin0 = sin(phi0)
        sinp = sin(phip)
        sinm = sin(phim)
        do k = 2,KMAX-1
            zp = 0.5*(z(k+1)+z(k))
            zm = 0.5*(z(k-1)+z(k))
            statp = 0.5*(stat(k+1)+stat(k))
            statm = 0.5*(stat(k-1)+stat(k))
            fact = 4.*om*om*h*a*a*sin0*dp*dp/(dz*dz*r*cos0)
            amp = exp(-zp/h)*exp(rkappa*zp/h)/statp
            amp = amp*fact*exp(z(k)/h)
            amm = exp(-zm/h)*exp(rkappa*zm/h)/statm
            amm = amm*fact*exp(z(k)/h)
            ajk(j,k) = 1./(sinp*cosp)
            bjk(j,k) = 1./(sinm*cosm)
            cjk(j,k) = amp
            djk(j,k) = amm
            ejk(j,k) = -ajk(j,k)-bjk(j,k)-cjk(j,k)-djk(j,k)
            fjk(j,k) = -om*a*dp*(qref(j+1,k)-qref(j-1,k))
        enddo
    enddo

    anormf = zero

    do j = 2,(jd-1)
        do k = 2,KMAX-1
            anormf = anormf + abs(fjk(j,k))
        enddo
    enddo

    omega = one

    do nnn = 1,maxits
        anorm = zero
        do j = 2,(jd-1)
            do k = 2,KMAX-1
                if(mod(j+k,2).eq.mod(nnn,2)) then
                    resid = ajk(j,k)*u(j+1,k)+bjk(j,k)*u(j-1,k)+    &
                     cjk(j,k)*u(j,k+1)+djk(j,k)*u(j,k-1)+    &
                     ejk(j,k)*u(j,k)-fjk(j,k)
                    anorm = anorm + abs(resid)
                    if(ejk(j,k).ne.0.) u(j,k) = u(j,k) - omega*resid/ejk(j,k)
                    if(ejk(j,k).eq.0.) u(j,k) = 0.
                endif
            enddo
            u(j,1) = 0.
            phi0 = dp*float(j-1)
            uz = dz*r*cos(phi0)*exp(-z(KMAX-1)*rkappa/h)
            uz = uz*(tbar(j+1,KMAX-1)-tbar(j-1,KMAX-1))/(2.*om*sin(phi0)*dp*h*a)
            u(j,KMAX) = u(j,KMAX-2)-uz
        enddo

        u(jd,:) = 0.
        u(1,:) = ubar(1,:)+(cref(1,:)-cbar(1,:))/(2.*pi*a)
        !        u(1,:) = ubar(1,:)

        if(nnn.eq.1) then
            omega = one/(one-half*rjac**2)
        else
            omega = one/(one-qtr*rjac**2*omega)
        endif

        if((nnn.gt.1).and.(anorm.lt.eps*anormf)) then
            if(nheck.eq.1) nheck = 0
            goto 233
        endif

    enddo

    ! **** In the case of non-convergence ****

    u(:,:) = 0.      ! no correction for the non-converged case

    233  continue

    ! **** Converged! (u is the mass correction) ****

    num_of_iter = nnn

    do j = 2,(jd-1)
        phi0 = dp*float(j-1)
        u(j,:) = u(j,:)/cos(phi0)
    enddo
    u(1,:) = ubar(1,:)
    u(jd,:) = 2.*u((jd-1),:)-u((jd-2),:)

    ! ******** compute tref *******

    do k = 2,KMAX-1
        t00 = 0.
        zz = dz*float(k-1)
        tref(1,k) = t00
        tref(2,k) = t00
        do j = 2,(jd-1)
            phi0 = dp*float(j-1)
            cor = 2.*om*sin(phi0)
            uz = (u(j,k+1)-u(j,k-1))/(2.*dz)
            ty = -cor*uz*a*h*exp(rkappa*zz/h)
            ty = ty/r
            tref(j+1,k) = tref(j-1,k)+2.*ty*dp
        enddo
        tg(k) = 0.
        wt = 0.
        do j = 1,jd
            phi0 = dp*float(j-1)
            tg(k) = tg(k)+cos(phi0)*tref(j,k)
            wt = wt + cos(phi0)
        enddo
        tg(k) = tg(k)/wt
        tres = tb(k)-tg(k)
        tref(:,k) = tref(:,k)+tres
    enddo
    tref(:,1) = tref(:,2)-tb(2)+tb(1)
    tref(:,KMAX) = tref(:,KMAX-1)-tb(KMAX-1)+tb(KMAX)

end subroutine


module cell_to_edge_module

  use amrex_error_module
  use amrex_constants_module, only: HALF
  use base_state_geometry_module, only: max_radial_level, nr_fine, &
                                        r_start_coord, r_end_coord, nr, &
                                        numdisjointchunks, finest_radial_level, &
                                        restrict_base
  use meth_params_module, only: spherical

  implicit none

  private

contains

  subroutine cell_to_edge(s0_cell,s0_edge) bind(C, name="cell_to_edge")

    double precision, intent(in   ) :: s0_cell(0:max_radial_level,0:nr_fine-1)
    double precision, intent(inout) :: s0_edge(0:max_radial_level,0:nr_fine)

    ! local
    double precision :: s0min,s0max,tmp
    integer          ::  n,r,i

    call bl_proffortfuncstart("Maestro::cell_to_edge")

    if (spherical .eq. 1) then
       call amrex_error('calling cell_to_edge with spherical .eq. 1')
    end if

    do n=0,finest_radial_level
       do i=1,numdisjointchunks(n)
          !$OMP PARALLEL DO PRIVATE(r,tmp,s0min,s0max)
          do r=r_start_coord(n,i),r_end_coord(n,i)+1

             if (r .eq. 0) then
                ! if we are at lower domain boundary
                s0_edge(n,r) = s0_cell(n,r)
             else if (r .eq. 1 .or. r .eq. r_start_coord(n,i)) then
                ! if we are at lower domain boundary+1 OR
                ! if we are at bottom of coarse-fine interface that is not a domain boundary
                s0_edge(n,r) = HALF*(s0_cell(n,r-1)+s0_cell(n,r))
             else if (r .eq. nr(n)) then
                ! if we are at upper domain boundary
                s0_edge(n,r) = s0_cell(n,r-1)
             else if (r .eq. nr(n)-1 .or. r .eq. r_end_coord(n,i)+1) then
                ! if we are at upper domain boundary-1 OR
                ! if we are at top of coarse-fine interface that is not a domain boundary
                s0_edge(n,r) = HALF*(s0_cell(n,r)+s0_cell(n,r-1))
             else
                ! fourth order
                tmp = 7.d0/12.d0 * (s0_cell(n,r  ) + s0_cell(n,r-1)) &
                     -1.d0/12.d0 * (s0_cell(n,r+1) + s0_cell(n,r-2))
                s0min      = min(s0_cell(n,r),s0_cell(n,r-1))
                s0max      = max(s0_cell(n,r),s0_cell(n,r-1))
                s0_edge(n,r) = min(max(tmp,s0min),s0max)
             end if

          end do
          !$OMP END PARALLEL DO
       end do
    end do

    ! make the edge values synchronous across levels
    call restrict_base(s0_edge, 0)

    call bl_proffortfuncstop("Maestro::cell_to_edge")

  end subroutine cell_to_edge

end module cell_to_edge_module


      program testit
      INCLUDE 'fftw3.f'
      double complex in, out
      parameter (N=16)
      dimension in(N), out(N)
      integer*8 p,p2
      integer i,j
      real fact
      write(*,*)"stuff in data"
      do i=1,N
        j=i-1
        in(i)=cmplx(j*j,1)
      enddo
      write(*,*)"create plans"
      call dfftw_plan_dft_1d(p ,N,in,out,FFTW_FORWARD,FFTW_ESTIMATE)
      call dfftw_plan_dft_1d(p2,N,in,out,FFTW_BACKWARD,FFTW_ESTIMATE)
      write(*,*)"do it"
      call dfftw_execute_dft(p, in, out)
      do i=1,N
        write(*,"(f12.4,1x,f12.4)")out(i)
      enddo
      write(*,*)
      write(*,*)"undo it"
      call dfftw_execute_dft(p2, out,in)
      fact=1.0/N
      do i=1,N
        write(*,"(f10.2,1x,f10.2)")in(i)*fact
      enddo
      write(*,*)"clean up"
      call dfftw_destroy_plan(p)
      call dfftw_destroy_plan(p2)
      end program


! Calculate 1-D Fourier transform of grid data along each pencil spanning the grid using FFTW. We can always do serial FFTs because
! the memory footprint for pencils is small even for very large grids.

subroutine calc_pencil_fft(overdensity, lo, hi, ng, dir, domain_length, dx, num_bins, k_bin_edges, &
                           overdensity_fft_real, overdensity_fft_imag)
    use, intrinsic :: iso_c_binding
    use fftw3
    implicit none

    integer(c_int), intent(in) :: lo(3), hi(3), ng
    real(c_double), intent(in), target :: overdensity (lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng, lo(3)-ng:hi(3)+ng, 1)
    integer(c_int), intent(in) :: dir
    real(c_double), intent(in) :: domain_length, dx
    integer(c_int), intent(in) :: num_bins
    real(c_double), intent(in) :: k_bin_edges (num_bins+1)

    real(c_double), intent(out), target :: overdensity_fft_real (lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng, lo(3)-ng:hi(3)+ng, 1)
    real(c_double), intent(out), target :: overdensity_fft_imag (lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng, lo(3)-ng:hi(3)+ng, 1)

    integer(c_int) :: i

    type(c_ptr) :: plan

    real(c_double), pointer :: overdensity_data(:)
    complex(c_double_complex), allocatable :: overdensity_fft_pencil (:)
    complex(c_double_complex), allocatable :: overdensity_pencil(:)

    real(c_double), pointer :: overdensity_fft_pencil_real(:)
    real(c_double), pointer :: overdensity_fft_pencil_imag(:)

    ! Align 1-D array pointers along pencils to simplify indexing later in the calculation.
    if (dir == 0) then
        overdensity_data            => overdensity          (lo(1):hi(1), lo(2), lo(3), 1)
        overdensity_fft_pencil_real => overdensity_fft_real (lo(1):hi(1), lo(2), lo(3), 1)
        overdensity_fft_pencil_imag => overdensity_fft_imag (lo(1):hi(1), lo(2), lo(3), 1)
    else if (dir == 1) then
        overdensity_data            => overdensity          (lo(1), lo(2):hi(2), lo(3), 1)
        overdensity_fft_pencil_real => overdensity_fft_real (lo(1), lo(2):hi(2), lo(3), 1)
        overdensity_fft_pencil_imag => overdensity_fft_imag (lo(1), lo(2):hi(2), lo(3), 1)
    else if (dir == 2) then
        overdensity_data            => overdensity          (lo(1), lo(2), lo(3):hi(3), 1)
        overdensity_fft_pencil_real => overdensity_fft_real (lo(1), lo(2), lo(3):hi(3), 1)
        overdensity_fft_pencil_imag => overdensity_fft_imag (lo(1), lo(2), lo(3):hi(3), 1)
    end if

    allocate(overdensity_pencil(size(overdensity_data)))
    allocate(overdensity_fft_pencil(size(overdensity_data)))

    ! The input data is real so the imaginary component of the complex pencil array is zero.
    do i = 1, size(overdensity_pencil)
      overdensity_pencil(i) = cmplx(overdensity_data(i), 0.0, c_double_complex)
    end do

    plan = fftw_plan_dft_1d(size(overdensity_pencil), overdensity_pencil, overdensity_fft_pencil, FFTW_BACKWARD, FFTW_ESTIMATE)

    call fftw_execute_dft(plan, overdensity_pencil, overdensity_fft_pencil)

    call fftw_destroy_plan(plan)

    ! Normalization
    overdensity_fft_pencil (:) = overdensity_fft_pencil (:) * dx

    ! Strip out real and imaginary components and save as separate MultiFabs. This syntax is weird because of the dual meanings of
    ! "real".
    do i = 1, size(overdensity_fft_pencil)
      overdensity_fft_pencil_real (i) = real(real (overdensity_fft_pencil(i)), c_double)
      overdensity_fft_pencil_imag (i) = real(aimag(overdensity_fft_pencil(i)), c_double)
    end do

    deallocate(overdensity_pencil)
    deallocate(overdensity_fft_pencil)

end subroutine calc_pencil_fft


      SUBROUTINE gaussj(a,n,np,b,m,mp)
      INTEGER m,mp,n,np,NMAX
      REAL*8 a(np,np),b(np,mp)
      PARAMETER (NMAX=1000)
      INTEGER i,icol,irow,j,k,l,ll,indxc(NMAX),indxr(NMAX),
     * ipiv(NMAX)
      REAL*8 big,dum,pivinv

      do j=1,n
           ipiv(j)=0
      enddo
      do i=1,n
           big=0.
           do j=1,n
                if(ipiv(j).ne.1)then
                    do k=1,n
                         if (ipiv(k).eq.0) then
                             if (abs(a(j,k)).ge.big)then
                                big=abs(a(j,k))
                                irow=j
                                icol=k
                             endif
                         else if (ipiv(k).gt.1) then
                             pause 'singular matrix in gaussj'
                         endif
                    enddo
                endif
           enddo
           ipiv(icol)=ipiv(icol)+1
           if (irow.ne.icol) then
              do l=1,n
                   dum=a(irow,l)
                   a(irow,l)=a(icol,l)
                   a(icol,l)=dum
              enddo
              do l=1,m
                   dum=b(irow,l)
                   b(irow,l)=b(icol,l)
                   b(icol,l)=dum
              enddo
           endif
           indxr(i)=irow
           indxc(i)=icol
           if (a(icol,icol).eq.0.) pause 'singular matrix in gaussj'
           pivinv=1./a(icol,icol)
           a(icol,icol)=1.
           do l=1,n
                a(icol,l)=a(icol,l)*pivinv
           enddo
           do l=1,m
                b(icol,l)=b(icol,l)*pivinv
           enddo
           do ll=1,n
                if(ll.ne.icol) then
                    dum=a(ll,icol)
                    a(ll,icol)=0.
                    do l=1,n
                         a(ll,l)=a(ll,l)-a(icol,l)*dum
                    enddo
                    do l=1,m
                         b(ll,l)=b(ll,l)-b(icol,l)*dum
                    enddo
                endif
           enddo
      enddo
      do l=n,1,-1
           if(indxr(l).ne.indxc(l))then
               do k=1,n
                    dum=a(k,indxr(l))
                    a(k,indxr(l))=a(k,indxc(l))
                    a(k,indxc(l))=dum
               enddo
           endif
      enddo
      return
      END


*dk,inv3x3
      subroutine inv3x3(a11,a12,a13,a21,a22,a23,a31,a32,a33,b1,b2,b3,
     *                  x1,x2,x3,iflag)
C
C
C #####################################################################
C
C     PURPOSE -
C
C        Solv the 3x3 problem A x = b for x
C
C     INPUT ARGUMENTS -
C
C        a11,a12,a13
C        a21,a22,a23
C        a31,a32,a33 - the A matrix
C        b1,b2,b3    - the b vector
C
C     OUTPUT ARGUMENTS -
C
C        x1,x2,x3 - the solution vector
C        iflag - 0 if matrix was not singular
C                1 if it was and so used "best" schmidt hilbert solution
C                  (optimized for smallest magnitude wrt arbitrary pieces,
C                   and best fit of Ax to b in case no valid solution)
C
C     PROGRAMMING NOTES -
C
C        "epsilon"'s hardwired: could pass...
C
C     CHANGE HISTORY -
C
C        $Log: inv3x3.f,v $
C        Revision 2.00  2007/11/03 00:49:11  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.7   Wed Dec 01 16:15:56 1999   jtg
CPVCS    changed to call Guassian elimination instead of Schmidt-Hilbert
CPVCS
CPVCS       Rev 1.6   Mon Oct 25 17:11:54 1999   jtg
CPVCS    changed to using the "best" Schmidt-Hilbert solution
CPVCS    (optimized wrt arbitrary vectors, as opposed to
CPVCS    simply using x=M^{-1}b) as this gave significantly more
CPVCS    "useful" results in test calculations.
CPVCS
CPVCS       Rev 1.5   Tue Oct 19 15:00:12 1999   jtg
CPVCS    fixed local_debug flag (was non-zero)
CPVCS
CPVCS       Rev 1.4   Tue Oct 19 13:01:42 1999   jtg
CPVCS    If the matrix is singular, it now calls Schidt-Hilbert routines
CPVCS    to find the best-fit magnitude. Also, if the determinant is
CPVCS    small compared to the contributions, it will compare the
CPVCS    magnitudes of the Schidt-Hilbert and Cramer solutions,
CPVCS    using the Cramer solution unless the solutions differ by
CPVCS    a few orders of magnitude, in which case it presumes that
CPVCS    what the user "really" wanted was the low-order Schidt-Hilbert
CPVCS    solution since "trying to get a really good answer" is probably
CPVCS    what caused the Cramer solution to have a large magnitude
CPVCS    in the "nearly singular" case.
CPVCS
CPVCS       Rev 1.3   Fri Jan 29 09:28:46 1999   dcg
CPVCS    define xfuzz
CPVCS
CPVCS       Rev 1.2   11/16/95 17:10:14   het
CPVCS    Correct an error matrix inverter.
CPVCS
CPVCS       Rev 1.1   01/04/95 21:55:32   llt
CPVCS    unicos changes (made by het)
CPVCS
CPVCS       Rev 1.0   11/15/94 16:50:26   llt
CPVCS    Original version
C
C ######################################################################
C
      implicit none
      real*8 a11,a12,a13,a21,a22,a23,a31,a32,a33,b1,b2,b3,
     &                  x1,x2,x3

      integer iflag,i1,i2,j1,j2,i,j,ierr
C$$  &       ,local_debug,iarb(3)

      real*8 mat(3,3),s(3),b(3),xxx,sss
     &       ,work(3,3),scale,det,epsilon
C$$  &       ,matinv(3,3),arb(3,3)

C-----------------------------------------------------------------------

      iflag=0

      xxx=abs(b1)
      if (xxx.lt.abs(b2)) xxx=abs(b2)
      if (xxx.lt.abs(b3)) xxx=abs(b3)

      ! do nothing if vec==0
      if (xxx.eq.0.d0) then
         x1=0.d0
         x2=0.d0
         x3=0.d0
         goto 100
      endif

      mat(1,1)=a11
      mat(2,1)=a21
      mat(3,1)=a31
      mat(1,2)=a12
      mat(2,2)=a22
      mat(3,2)=a32
      mat(1,3)=a13
      mat(2,3)=a23
      mat(3,3)=a33

      ! calculate determinant and adjoint
      scale=0.d0
      det=0.d0
      do i=1,3
         i1=1+mod(i,3)
         i2=1+mod(i1,3)
         xxx=mat(1,i)*mat(2,i1)*mat(3,i2)
         if (abs(xxx).gt.scale) scale=abs(xxx)
         det=det+xxx
         xxx=mat(1,i)*mat(2,i2)*mat(3,i1)
         if (abs(xxx).gt.scale) scale=abs(xxx)
         det=det-xxx
         do j=1,3
            i1=1+mod(i,3)
            i2=1+mod(i1,3)
            j1=1+mod(j,3)
            j2=1+mod(j1,3)
            work(j,i)=mat(i1,j1)*mat(i2,j2)-mat(i1,j2)*mat(i2,j1)
         enddo
      enddo

      ! calculate soln using inverse=adjoint/determinant (Cramer's rule)

      if (det.ne.0.d0) then
         x1=work(1,1)*b1+work(1,2)*b2+work(1,3)*b3
         x1=x1/det
         x2=work(2,1)*b1+work(2,2)*b2+work(2,3)*b3
         x2=x2/det
         x3=work(3,1)*b1+work(3,2)*b2+work(3,3)*b3
         x3=x3/det
      endif

      if (abs(det).le.1.d-2*scale.or.det.eq.0.d0) then

         ! if (nearly) singular, compare to Schmidt-Hilbert soln and
         ! use that instead if magnitudes vastly different

         epsilon=1.d-4

C$$      ! calc Schmidt-Hilbert inv
C$$      call inv_schmidt_hilbert_lg
C$$  &          (epsilon,3,3,3,3
C$$  &           ,mat,matinv,iarb,arb,work)
C$$      ! apply to get soln
C$$      do i=1,3
C$$        s(i)=matinv(i,1)*b1+matinv(i,2)*b2+matinv(i,3)*b3
C$$      enddo

         b(1)=b1
         b(2)=b2
         b(3)=b3
C$       ! calc "best" Schmidt-Hilbert soln
C$       call solv_Mxb_schmidt_hilbert_lg
C$   &          (epsilon,3,3,3,3
C$   &           ,mat,b,s,matinv,iarb,arb,work)
         ! solve using Guassian elimination
         call guass_elim_lg(2,3,3,epsilon,mat,b,s,work,ierr)

         if (det.ne.0.d0) then
            xxx=abs(x1)+abs(x2)+abs(x3)
            sss=abs(s(1))+abs(s(2))+abs(s(3))
            if (xxx.gt.1.d1*sss) then
               ! presume that what the user really wanted was
               ! the "principle part" (M^2+eps^2I)s=Mb soln of the
               ! (nearly) singular matrix
               x1=s(1)
               x2=s(2)
               x3=s(3)
               iflag=1 ! flag as nearly singular
               if (ierr.ne.0) iflag=1+abs(ierr)
            endif
         else
            x1=s(1)
            x2=s(2)
            x3=s(3)
            iflag=1 ! flag as singular
            if (ierr.ne.0) iflag=1+abs(ierr)
         endif

      endif

C$$   local_debug=0
C$$   if (local_debug.gt.0) then
C$$     write(*,*) x1,x2,x3,a11*x1+a12*x2+a13*x3-b1
C$$  &            ,a21*x1+a22*x2+a23*x3-b2
C$$  &            ,a31*x1+a32*x2+a33*x3-b3
C$$   endif

100   return
      end


      ! Returns the inverse of a matrix calculated by finding the LU
      ! decomposition.  Depends on LAPACK.
      function inv(A) result(Ainv)
         integer, parameter :: rp = SELECTED_REAL_KIND(15)
         real(kind = rp), dimension(:,:), intent(in) :: A
         real(kind = rp), dimension(size(A,1),size(A,2)) :: Ainv

         real(kind = rp), dimension(size(A,1)) :: work  ! work array for LAPACK
         integer, dimension(size(A,1)) :: ipiv   ! pivot indices
         integer :: n, info

         ! External procedures defined in LAPACK
         external DGETRF
         external DGETRI

         ! Store A in Ainv to prevent it from being overwritten by LAPACK
         Ainv = A
         n = size(A,1)

         ! DGETRF computes an LU factorization of a general M-by-N matrix A
         ! using partial pivoting with row interchanges.
         call DGETRF(n, n, Ainv, n, ipiv, info)

         if (info /= 0) then
            stop 'Matrix is numerically singular!'
         end if

         ! DGETRI computes the inverse of a matrix using the LU factorization
         ! computed by DGETRF.
         call DGETRI(n, Ainv, n, ipiv, work, n, info)

         if (info /= 0) then
            stop 'Matrix inversion failed!'
         end if
      end function inv

C based on:
C http://fortranwiki.org/fortran/show/Matrix+inversion


      double precision function prho(n, is, ifault)
c
c        Algorithm AS 89   Appl. Statist. (1975) Vol.24, No. 3, P377.
c
c        To evaluate the probability of obtaining a value greater than or
c        equal to is, where is=(n**3-n)*(1-r)/6, r=Spearman's rho and n
c        must be greater than 1
c
c     Auxiliary function required: ALNORM = algorithm AS66
c
      dimension l(6)
      double precision zero, one, two, b, x, y, z, u, six,
     $  c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, alnorm
      data zero, one, two, six /0.0d0, 1.0d0, 2.0d0, 6.0d0/
      data        c1,     c2,     c3,     c4,     c5,     c6,
     $          c7,     c8,     c9,    c10,    c11,    c12/
     $  0.2274d0, 0.2531d0, 0.1745d0, 0.0758d0, 0.1033d0, 0.3932d0,
     $  0.0879d0, 0.0151d0, 0.0072d0, 0.0831d0, 0.0131d0, 0.00046d0/
c
c        Test admissibility of arguments and initialize
c
      prho = one
      ifault = 1
      if (n .le. 1) return
      ifault = 0
      if (is .le. 0) return
      prho = zero
      if (is .gt. n * (n * n -1) / 3) return
      js = is
      if (js .ne. 2 * (js / 2)) js = js + 1
      if (n .gt. 6) goto 6
c
c        Exact evaluation of probability
c
      nfac = 1
      do 1 i = 1, n
        nfac = nfac * i
        l(i) = i
    1 continue
      prho = one / dble(nfac)
      if (js .eq. n * (n * n -1) / 3) return
      ifr = 0
      do 5 m = 1,nfac
        ise = 0
        do 2 i = 1, n
          ise = ise + (i - l(i)) ** 2
    2   continue
        if (js .le. ise) ifr = ifr + 1
        n1 = n
    3   mt = l(1)
        nn = n1 - 1
        do 4 i = 1, nn
          l(i) = l(i + 1)
    4   continue
        l(n1) = mt
        if (l(n1) .ne. n1 .or. n1 .eq. 2) goto 5
        n1 = n1 - 1
        if (m .ne. nfac) goto 3
    5 continue
      prho = dble(ifr) / dble(nfac)
      return
c
c        Evaluation by Edgeworth series expansion
c
    6 b = one / dble(n)
      x = (six * (dble(js) - one) * b / (one / (b * b) -one) -
     $  one) * sqrt(one / b - one)
      y = x * x
      u = x * b * (c1 + b * (c2 + c3 * b) + y * (-c4
     $  + b * (c5 + c6 * b) - y * b * (c7 + c8 * b
     $  - y * (c9 - c10 * b + y * b * (c11 - c12 * y)))))
c
c      Call to algorithm AS 66
c
      prho = u / exp(y / two) + alnorm(x, .true.)
      if (prho .lt. zero) prho = zero
      if (prho .gt. one) prho = one
      return
      end