c     program DRDUCOM2
c>> 1996-06-20 DRDUCOM2 Krogh Format changes for C conversion.
c>> 1996-05-28 DRDUCOM2 Krogh Added external statement.
c>> 1994-11-02 DRDUCOM2 Krogh  Changes to use M77CON
c>> 1994-08-12 DRDUCOM2 CLL New subroutine: DUSETN
c>> 1992-05-15 CLL Removed "stop '... finished'"
c>> 1992-04-21 CLL
c>> 1992-03-16 CLL
c>> 1992-03-12 CLL
c>> 1987-10-30 Original time stamp
c  Demo driver for the DUCOMP package.  This code was adapted from the
c  test driver to reduce the number of tests and the amount of output.
c  Here we have NCASES = 2 and MM(3:4) = (0,2), whereas the test driver
c  had NCASES = 12 and MM(3:4) = (0,0).
c     The DUCOMP package computes first and second
c     partial derivatives.
c     C.L.Lawson,JPL, 1969 Dec 4
c     CLL, JPL, Jan 1987, Modified for Fortran 77
c     CLL, JPL, Sept 1987, Added DUSINH, DUCOSH, DUTANH, DUTAN
c     1992-05-15 CLL Removed "stop '... finished'" to simplify
c     comparison of output from different systems.
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c--D replaces "?": DR?UCOM2, ?UCOMP,  ?MXDIF, ?USETN
c--&    ?COPY , ?UACOS, ?UASIN, ?UATAN, ?UATN2, ?UCOS
c--&    ?UCOSH, ?UDIF , ?UDIF1, ?UEXP , ?ULOG , ?UPRO , ?UPRO1
c--&    ?UPWRI, ?UQUO , ?UQUO1, ?USET , ?USIN , ?USINH, ?USQRT
c--&    ?USUM , ?USUM1, ?UTAN , ?UTANH
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      integer N, M1, M2
      integer I, IANG, IANG4, ICOUNT, IMAX, IPWR, IPWR7
      integer J, JMAX, KEY, KK, L, L2, LOC
      integer MM(24), NCASES
      parameter(IMAX = 10, JMAX = 72, NCASES = 12)
      external DMXDIF
      double precision DMXDIF
      double precision U(IMAX, JMAX), TEST(IMAX), ZERO, TEN, ONE
      double precision A1, A2, ANG, C, C8, C9, ERRMAX, ERROR
      parameter( ZERO = 0.0d0, TEN = 10.0d0, ONE = 1.0d0)
      parameter(A1 = -2.62d0, A2 = 1.57 d0, C8 = 0.8d0, C9 = 0.9d0)
      data MM/-1,-1,  0,2,  1,1,2,2,-1,-1,0,0,1,2,-1,-1,
     *        0,1,2,2,-1,-1,0,2/
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      print'('' DRDUCOM2..  Demo driver for the DUCOMP package.''/
     *   '' Computation of partial derivatives.''/
     *   '' Will print the numerical error in various calculations.''/
     *   '' These errors should be zero or small.'')'
      C=TEN
      N=3
      L=1 + N + (N*(N+1))/2
      M1=0
      M2=2
c
      do 900  KK=1, 2*NCASES-1, 2
         if(MM(KK) .lt. 0) then
            print '(1x/'' Test U-computation.  Set U(,) = 0.'')'

c                                 Zero the U() array.
            do 20 I=1,IMAX
               do 10 J=1,JMAX
                  U(I,J)=ZERO
   10          continue
   20       continue
c                                 Store values into U(,1) and U(,2)
            U(1,1) = C8
            U(1,2) = -C9

            do 30 I=2,L
                U(I,1) = -C8 * U(I-1,1)
                U(I,2) = -C9 * U(I-1,2)
   30       continue
c
            go to 800
         endif
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c                                  Set M1 and M2 for new case.
      M1=MM(KK)
      M2=MM(KK+1)
      call DUSETN(N, M1, M2)
      print '(1x/,'' N, M1, M2 ='',3i10/1x)', N,M1,M2
      if(M2 .eq. 0) then
         L2 = 1
      elseif(M2 .eq. 1) then
         L2 = 1 + N
      elseif(M2 .eq. 2) then
         L2 = 1 + N + (N*(N+1))/2
      endif
      ERRMAX = ZERO
c
      call DUPRO(U(1,1), U(1,2), U(1,3) )
      call DUQUO (U(1,3),U(1,1),U(1,4) )
      ERROR =  DMXDIF(L2,U(1,4),1, U(1,2),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in (u1*u2)/u1 - u2               ='', g11.3)',
     *  ERROR
c
      call DUSQRT (U(1,1), U(1,5) )
      call DUPWRI (2,U(1,5), U(1,6) )
      ERROR =  DMXDIF(L2,U(1,6),1, U(1,1),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in  sqrt(u1)**2 - u1             ='', g11.3)',
     *  ERROR
c
      call DUSIN  (U(1,1),U(1,7))
      call DUCOS  (U(1,1),U(1,8))
      call DUATN2(U(1,7), U(1,8), U(1,9))
      ERROR =  DMXDIF(L2,U(1,9),1, U(1,1),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in atan2(sin(u1),cos(u1)) - u1   ='', g11.3)',
     *  ERROR
c
      call DUEXP  (U(1,1), U(1,10))
      call DULOG  (U(1,10), U(1,11))
      ERROR =  DMXDIF(L2,U(1,11),1, U(1,1),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in log(exp(u1) - u1              ='', g11.3)',
     *  ERROR
c
      call DUQUO (U(1,7), U(1,8), U(1,12) )
      call DUATAN (U(1,12), U(1,13))
      ERROR =  DMXDIF(L2,U(1,13),1, U(1,1),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in atan(sin(u1)/cos(u1)) - u1    ='', g11.3)',
     *  ERROR
c
      call DUTAN(U(1,1), U(1,44))
      ERROR =  DMXDIF(L2,U(1,12),1, U(1,44),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in sin(u1)/cos(u1) - tan(u1)     ='', g11.3)',
     *  ERROR
c
      call DUSINH(U(1,1), U(1,45))
      call DUCOSH(U(1,1), U(1,46))
      call DUTANH(U(1,1), U(1,47))
      call DUQUO (U(1,45), U(1,46), U(1,48) )
      ERROR =  DMXDIF(L2,U(1,48),1, U(1,47),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in sinh(u1)/cosh(u1) - tanh(u1)  ='',g11.3)',
     *  ERROR
c
      call DUSUM  (U(1,1), U(1,2), U(1,14))
      call DUDIF   (U(1,14), U(1,1), U(1,15))
c
      ERROR =  DMXDIF(L2,U(1,15),1, U(1,2),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '(1x,''Error in ((u1+u2)-u1) - u2             ='',g11.3)',
     *  ERROR
c
      call DUSUM1 (C,U(1,1),U(1,16))
      call DUDIF1 (C,U(1,16),U(1,17))
      call DUPRO1 (C,U(1,17),U(1,18))
      call DUQUO1 (C,U(1,18),U(1,19))
      call DUQUO1 (-ONE,U(1,19),U(1,20))
      ERROR =  DMXDIF(L2,U(1,20),1, U(1,1),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in -1/(c/(c*(c-(c+u1)))) - u1    ='',g11.3)',
     *  ERROR
c
      call DUASIN(U(1,7), U(1,21))
      ERROR =  DMXDIF(L2,U(1,21),1, U(1,1),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in asin(sin(u1)) - u1            ='',g11.3)',
     *  ERROR
c
      call DUACOS(U(1,8), U(1,22))
      ERROR =  DMXDIF(L2,U(1,22),1, U(1,1),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in acos(cos(u1)) - u1            ='',g11.3)',
     *  ERROR
c
c        Test of DUSET.  We first use DUSUM1 to copy U(,1)
c        to U(,23+KEY) so it will have nonzero contents.
c        After calling DUSET it should be all zero except for 1 or 2
c        elements.  C will be stored to U(1,23+KEY).
c        When KEY = 0, everything else will be set to zero.
c        When KEY = 1, 2, or 3, and it will also set
c        U(KEY+1,23+KEY) = 1.0
c
      do 50 KEY = 0,3
         call DUSUM1(ZERO, U(1,1), U(1,23+KEY))
         call DUSET(C,KEY, U(1,23+KEY))
         do 40 I = 1,L
            TEST(I) = ZERO
   40    continue
         TEST(1) = C
         if(KEY .gt. 0) TEST(KEY+1) = ONE
      ERROR =  DMXDIF(L2,U(1,23+KEY),1, TEST,1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in DUSET(C,KEY,...)              ='',g11.3)',
     *  ERROR
   50 continue
c
c     Check quadrant resolution of DUATN2.
c
c                                 Store values into U(,1).
      ANG = A1 - A2
      do 60 IANG = 1,4
         IANG4 = 4*(IANG-1)
         ANG = ANG + A2
         call DCOPY(L, U(1,1),1, U(1,27+IANG4),1)
         U(1,27+IANG4) = ANG
         call DUSIN(U(1,27+IANG4), U(1,28+IANG4))
         call DUCOS(U(1,27+IANG4), U(1,29+IANG4))
         call DUATN2(U(1,28+IANG4), U(1,29+IANG4), U(1,30+IANG4))
         ERROR =  DMXDIF(L2,U(1,30+IANG4),1, U(1,27+IANG4),1)
         ERRMAX = max(ERRMAX, ERROR)
         print '('' Error in atan2(sin(u1),cos(u1)) - u1   ='',g11.3)',
     *     ERROR
   60 continue
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c                                           Test of DUPWRI( ,0, , )
c
         call DUPWRI( 0, U(1,1), U(1,49))
         call DUSET ( ONE, 0, U(1,50))
      ERROR =  DMXDIF(L2,U(1,49),1, U(1,50),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in x**0 - 1                      ='',g11.3)',
     *  ERROR
c
c                                     Loop through tests of DUPWRI
         do 80 IPWR = 1,3
            IPWR7 = 7*(IPWR-1)
            print '(1x/'' Test DUPWRI using I = '',i3)', IPWR
            call DUPWRI( IPWR, U(1,1), U(1,51+IPWR7))
            call DCOPY(L2, U(1,1),1, U(1,56+IPWR7),1)
            LOC = 0
            do 70 ICOUNT = 2,IPWR
               call DUPRO( U(1,1), U(1,56+LOC+IPWR7), U(1,57+LOC+IPWR7))
               LOC = LOC + 1
   70       continue
            ERROR =  DMXDIF(L2,U(1,51+IPWR7),1, U(1,56+LOC+IPWR7),1)
            ERRMAX = max(ERRMAX, ERROR)
            print '('' Error in x**I - x * x * ... * x        ='',
     *         g11.3)', ERROR
            call DUPWRI( -IPWR, U(1,1), U(1,53+IPWR7))
            call DUPRO( U(1,53+IPWR7), U(1,51+IPWR7), U(1,54+IPWR7))
            call DUSET ( ONE, 0, U(1,55+IPWR7))
            ERROR =  DMXDIF(L2,U(1,54+IPWR7),1, U(1,55+IPWR7),1)
            ERRMAX = max(ERRMAX, ERROR)
            print '('' Error in x**(-I) * x**I - 1            ='',
     *         g11.3)', ERROR
   80    continue
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

         print '('' ***>>> ERRMAX ='',g11.3)', ERRMAX
  800    continue
  900 continue
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      end
c     ==================================================================
      double precision function DMXDIF(N,X,INCX, Y,INCY)
c
c     Compute max norm of difference between the N-vectors x and y.
c     The vectors are stored with a storage increment of INCX and INCY
c     between successive components.
c     C. L. Lawson, JPL, Sept 1987.
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      integer I, N, INCX, INCY, IX, IY
      double precision X(*), Y(*), ZERO, TEMP
      parameter(ZERO = 0.0d0)
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      TEMP = ZERO
      IX = 1 - INCX
      IY = 1 - INCY
      do 10 I = 1,N
         IX = IX + INCX
         IY = IY + INCY
         TEMP = max(TEMP, abs(X(IX) - Y(IY)))
   10 continue
      DMXDIF = TEMP
      return
      end


module fortmod

   implicit none

   ! parameters are not exported as shared library symbols
   ! TODO: automatically import by parsing and setting value
   double precision, parameter  :: twopi = 6.28318530717958d0

   double precision :: member
   double precision, dimension(3) :: member_array
   complex(8), dimension(:), allocatable :: alloc_array

contains

  subroutine modify_vector(z, k)
    double precision, dimension(:), intent(inout) :: z
    integer, intent(in) :: k

    z = sin(k*twopi*z)
  end subroutine

  subroutine modify_matrix(A, x)
    double precision, dimension(:,:), intent(inout) :: A
    double precision, intent(in) :: x

    A = x*transpose(A)
  end subroutine

  subroutine init()
    member = 1.0
    member_array = 1.0
  end subroutine

  subroutine side_effects()
    member = member + 1.0
    member_array = 2.0*member_array
  end subroutine

  subroutine alloc_member()
    allocate(alloc_array(5))
    alloc_array = (1d0, 2d0)
  end subroutine

end module fortmod


c
c
c =========================================================
      subroutine src1(maxmx,meqn,mbc,mx,xlower,dx,q,maux,aux,t,dt)
c =========================================================
      implicit double precision (a-h,o-z)
      dimension q(1-mbc:maxmx+mbc, meqn)
c
c
c     # solve the diffusion equation q_t = q_{xx} using Crank-Nicolson
c     # The LAPACK tridiagonal solver dgtsv is used, which is in tridiag.f
c
c
c     # local storage:
      parameter (maxldb = 5000)
      dimension b(maxldb,1), d(maxldb), dl(maxldb), du(maxldb)
      common /comsrc/ dcoef

      if (mx .gt. maxldb) then
          write(6,*) 'ERROR:  increase maxldb in src1.f'
          endif

      ldb = maxldb
      nrhs = 1
      dtdx2 = dcoef * dt / (2.d0*dx*dx)
c
c     # set coefficients in tridiagonal matrix and RHS:
      do i=1,mx
        dl(i) = -dtdx2
        d(i) = 1.d0 + 2.d0*dtdx2
        du(i) = -dtdx2
        b(i,1) = q(i,1) + dtdx2 * (q(i-1,1) - 2.d0*q(i,1) + q(i+1,1))
        enddo
c
c     # no-flux boundary conditions for diffusion step:
c     # Adjust matrix entries to use q(0,1)=q(1,1) and q(mx+1,1)=q(mx,1)
c     # at end of time step:
      d(1) = d(1) - dtdx2
      d(mx) = d(mx) - dtdx2

c     # to instead set boundary values to specific values,
c     # comment out the above changes to d(1) and d(mx) and instead
c     # modify the right-hand side:
c     q0 = 2.d0
c     qmx1 = 0.d0
c     b(1,1) = b(1,1) + dtdx2*q0
c     b(mx,1) = b(mx,1) + dtdx2*qmx1

c
c     # solve the tridiagonal system:
      call dgtsv(mx,nrhs,dl,d,du,b,ldb,info)

      if (info .ne. 0) then
         write(6,*) 'ERROR in src1 from call to dgtsv... info = ',info
         stop
         endif

      do i=1,mx
         q(i,1) = b(i,1)
	 enddo
c
      return
      end


!# define PP_SPLIT_FORM 1

module two_point_flux_mod

use constants_mod

private

public :: xflux, yflux, zflux

contains

pure elemental function logmean(a,b) result(r)

    real(dp), intent(in)    :: a,b
    real(dp)                :: x,u,r

    real(dp),parameter  :: eps = 1e-4_dp
    real(dp), parameter :: c1 = 1.0_dp/6.0_dp
    real(dp), parameter :: c2 = 2.0_dp/45.0_dp
    real(dp), parameter :: c3 = 22.0_dp/945.0_dp

    x = a/b

    if (abs(a-b) < eps) then
        u  = (x*(x-2.0_dp)+1.0_dp)/(x*(x+2.0_dp)+1.0_dp)
        r = (a+b)*(0.5_dp - u*(c1 - u*(c2 - c3*u)))
    else
        r = (a-b)/log(x)
    endif

end function

pure function xflux(u,v) result(f)

    use equations_const_mod
    use setup_config_mod, only: kappa
    use equations_mod, only: pressure

    real(dp), intent(in)    :: u(N_VARS)
    real(dp), intent(in)    :: v(N_VARS)
    real(dp)                :: f(N_VARS)

    real(dp)                :: dens,pres,velx,vely,velz,enth
    real(dp)                :: bu,bv !! beta
    real(dp)                :: pu,pv !! pressure
    real(dp)                :: uu(3),vv(3) !! velocity

    pu = pressure(u)
    pv = pressure(v)

    bu = 0.5_dp*u(DENS_VAR)/pu
    bv = 0.5_dp*v(DENS_VAR)/pv

    uu(1) = u(MOMX_VAR)/u(DENS_VAR)
    uu(2) = u(MOMY_VAR)/u(DENS_VAR)
    uu(3) = u(MOMZ_VAR)/u(DENS_VAR)

    vv(1) = v(MOMX_VAR)/v(DENS_VAR)
    vv(2) = v(MOMY_VAR)/v(DENS_VAR)
    vv(3) = v(MOMZ_VAR)/v(DENS_VAR)

    dens = logmean(u(DENS_VAR),v(DENS_VAR))
    velx = 0.5_dp*(uu(1) + vv(1))
    vely = 0.5_dp*(uu(2) + vv(2))
    velz = 0.5_dp*(uu(3) + vv(3))
    pres = 0.5_dp*(u(DENS_VAR)+v(DENS_VAR))/(bu+bv)

    enth = 0.5_dp/(kappa-1.0_dp)/logmean(bu,bv) + pres/dens + velx*velx + vely*vely + velz*velz - 0.25_dp*sum(uu*uu + vv*vv)

    f(DENS_VAR) = dens * velx
    f(MOMX_VAR) = f(DENS_VAR) * velx + pres
    f(MOMY_VAR) = f(DENS_VAR) * vely
    f(MOMZ_VAR) = f(DENS_VAR) * velz
    f(ENER_VAR) = f(DENS_VAR) * enth

end function

pure function yflux(uL,uR) result(f)

    use equations_const_mod

    real(dp), intent(in) :: uL(N_VARS), uR(N_VARS)
    real(dp)             :: f(N_VARS)

    real(dp) :: ruL(N_VARS), ruR(N_VARS), rf(N_VARS) !! rotated

    ruL(DENS_VAR) = uL(DENS_VAR)
    ruL(MOMX_VAR) = uL(MOMY_VAR)
    ruL(MOMY_VAR) = uL(MOMZ_VAR)
    ruL(MOMZ_VAR) = uL(MOMX_VAR)
    ruL(ENER_VAR) = uL(ENER_VAR)

    ruR(DENS_VAR) = uR(DENS_VAR)
    ruR(MOMX_VAR) = uR(MOMY_VAR)
    ruR(MOMY_VAR) = uR(MOMZ_VAR)
    ruR(MOMZ_VAR) = uR(MOMX_VAR)
    ruR(ENER_VAR) = uR(ENER_VAR)

    rf = xflux(ruL,ruR)

    f(DENS_VAR) = rf(DENS_VAR)
    f(MOMX_VAR) = rf(MOMZ_VAR)
    f(MOMY_VAR) = rf(MOMX_VAR)
    f(MOMZ_VAR) = rf(MOMY_VAR)
    f(ENER_VAR) = rf(ENER_VAR)

end function

pure function zflux(uL,uR) result(f)

    use equations_const_mod

    real(dp), intent(in) :: uL(N_VARS), uR(N_VARS)
    real(dp)             :: f(N_VARS)

    real(dp) :: ruL(N_VARS), ruR(N_VARS), rf(N_VARS) !! rotated

    ruL(DENS_VAR) = uL(DENS_VAR)
    ruL(MOMX_VAR) = uL(MOMZ_VAR)
    ruL(MOMY_VAR) = uL(MOMX_VAR)
    ruL(MOMZ_VAR) = uL(MOMY_VAR)
    ruL(ENER_VAR) = uL(ENER_VAR)

    ruR(DENS_VAR) = uR(DENS_VAR)
    ruR(MOMX_VAR) = uR(MOMZ_VAR)
    ruR(MOMY_VAR) = uR(MOMX_VAR)
    ruR(MOMZ_VAR) = uR(MOMY_VAR)
    ruR(ENER_VAR) = uR(ENER_VAR)

    rf = xflux(ruL,ruR)

    f(DENS_VAR) = rf(DENS_VAR)
    f(MOMX_VAR) = rf(MOMY_VAR)
    f(MOMY_VAR) = rf(MOMZ_VAR)
    f(MOMZ_VAR) = rf(MOMX_VAR)
    f(ENER_VAR) = rf(ENER_VAR)

end function

end module


module material_mod

    use vec3_class
    use ray_mod

    implicit none

    type, abstract :: material
        contains
        procedure(matInterface), deferred :: scatter
    end type material

    type :: hit_record
        type(vec3) :: p, normal
        real       :: t
        logical    :: front_face
        class(material), pointer :: mat_ptr => null()
        contains
        procedure :: set_face_normal
    end type hit_record

    abstract interface
        logical function matInterface(this, ray_in, rec, attenuation, scattered)
            use vec3_class
            use ray_mod
            import material, hit_record
            implicit none
            class(material)  :: this
            type(hit_record), intent(IN)  :: rec
            type(ray_t),      intent(IN)  :: ray_in
            type(vec3),       intent(OUT) :: attenuation
            type(ray_t),      intent(OUT) :: scattered
        end function matInterface
    end interface

    type, abstract :: hittable
        contains
        procedure(hitInterface), deferred :: hit
    end type hittable

    abstract interface
        logical function hitInterface(this, ray, t_min, t_max, rec)
            use vec3_class
            use ray_mod
            import hittable, hit_record
            implicit none
            class(hittable) :: this
            real,             intent(IN)  :: t_min, t_max
            type(ray_t),      intent(IN)  :: ray
            type(hit_record), intent(OUT) :: rec
        end function hitInterface
    end interface

!===============================================================

        type, extends(material) :: lambertian
            type(vec3) :: albedo
            contains
            procedure :: scatter => scatter_lamb
        end type lambertian

        type, extends(material) :: metal
            type(vec3) :: albedo
            real :: fuzz
            contains
            procedure :: scatter => scatter_metal
        end type metal

        interface metal
            module procedure init_metal
        end interface metal

        type, extends(material) :: dielectric
            real :: ir
            contains
            procedure :: scatter => scatter_dielectric
        end type dielectric

    contains

        logical function scatter_lamb(this, ray_in, rec, attenuation, scattered)

            implicit none

            class(lambertian) :: this

            type(ray_t), intent(IN)      :: ray_in
            type(ray_t), intent(OUT)     :: scattered
            type(vec3), intent(OUT)      :: attenuation
            type(hit_record), intent(IN) :: rec

            type(vec3) :: scatter_direction

            scatter_direction = rec%normal + random_unit_vector()
            !catch degenerate scatter direction
            if(scatter_direction%near_zero())scatter_direction = rec%normal

            scattered = ray_t(rec%p, scatter_direction)
            attenuation = this%albedo
            scatter_lamb = .true.

        end function scatter_lamb

        type(metal) function init_metal(albedo, f)

            implicit none

            type(vec3), intent(IN) :: albedo
            real,       intent(IN) :: f

            init_metal%albedo = albedo
            if(f < 1.)then
                init_metal%fuzz = f
            else
                init_metal%fuzz = 1.
            end if

        end function init_metal

        logical function scatter_metal(this, ray_in, rec, attenuation, scattered)

            implicit none

            class(metal) :: this

            type(ray_t),      intent(IN)  :: ray_in
            type(ray_t),      intent(OUT) :: scattered
            type(vec3),       intent(OUT) :: attenuation
            type(hit_record), intent(IN)  :: rec

            type(vec3) :: reflected, dir

            dir = ray_in%direction()
            dir = dir%magnitude()
            reflected = reflect(dir, rec%normal)
            scattered = ray_t(rec%p, reflected + this%fuzz * random_in_unit_sphere())
            attenuation = this%albedo
            scatter_metal = (scattered%direction() .dot. rec%normal) > 0.

        end function scatter_metal

        logical function scatter_dielectric(this, ray_in, rec, attenuation, scattered)

            use vec3_class, only : refract
            use utils,      only : random

            implicit none

            class(dielectric) :: this

            type(ray_t),      intent(IN)  :: ray_in
            type(ray_t),      intent(OUT) :: scattered
            type(vec3),       intent(OUT) :: attenuation
            type(hit_record), intent(IN)  :: rec

            type(vec3) :: unit_direction, dir
            real       :: refraction_ratio, cos_theta, sin_theta
            logical    :: cannot_refract

            attenuation = vec3(1., 1., 1.)
            if(rec%front_face)then
                refraction_ratio = 1./this%ir
            else
                refraction_ratio = this%ir
            end if

            unit_direction = ray_in%direction()
            unit_direction = unit_direction%magnitude()

            cos_theta = min((-1.)*unit_direction .dot. rec%normal, 1.0)
            sin_theta = sqrt(1.0 - cos_theta*cos_theta)

            cannot_refract = refraction_ratio * sin_theta > 1.0

            if(cannot_refract .or. reflectance(cos_theta, refraction_ratio) > random())then
                dir = reflect(unit_direction, rec%normal)
            else
                dir = refract(unit_direction, rec%normal, refraction_ratio)
            end if
            scattered = ray_t(rec%p, dir)
            scatter_dielectric = .true.

        end function scatter_dielectric

        real function reflectance(cosine, ref_idx)

            implicit none

            real, intent(IN) :: cosine, ref_idx

            real :: r0

            r0 = (1. - ref_idx) / (1. + ref_idx)
            r0 = r0**2
            reflectance = r0 + (1-r0) * (1.-cosine)**5

        end function reflectance

        subroutine set_face_normal(this, ray, outward_normal)

        implicit none

        class(hit_record) :: this

        type(ray_t), intent(IN) :: ray
        type(vec3),  intent(IN) :: outward_normal

        this%front_face = (ray%direction() .dot. outward_normal) < 0.

        if(this%front_face)then
            this%normal = outward_normal
        else
            this%normal = (-1.)*outward_normal
        end if

    end subroutine set_face_normal

end module material_mod


Submodule ( statistical_data_mod ) statistical_kurtosis_smod
!
  Use kind_parameters_mod
!
  Implicit None
!
Contains
!
  Module Procedure Statistical_Kurtosis
!
    Real(KIND=rkind) :: mn, sd
    If ( Size(this%data) .ne. 0 ) Then
       If ( Present ( mean ) ) Then
          mn = mean
       Else
          If ( this%Dmean ) Then
             mn = this%mean
          Else
             mn = Statistical_Mean ( this )
          End If
       End If
       If ( Present ( std_dev ) ) Then
          sd = std_dev
       Else
          If ( this%Dstd_dev ) Then
             sd = this%std_dev
          Else
             sd = Statistical_Std_Dev ( this, mn )
          End If
       End If
       If ( sd .ne. 0.0d0 ) Then
          kurtosis = Sum ( (this%data-mn)**4 ) / Size ( this%data ) / sd**4 - 3.0_rkind
       Else
          kurtosis = Huge ( kurtosis )
       End If
    Else
       kurtosis = Huge ( kurtosis )
    End If
    this%kurtosis = kurtosis
    this%Dkurtosis = .true.
!
  End Procedure Statistical_Kurtosis
!
End Submodule statistical_kurtosis_smod


!> Author:   Jabir Ali Ouassou
!> Category: Programs
!>
!> This program calculates the current-phase relation of a one-dimensional superconducting structure.

program phase_p
  use :: structure_m
  use :: stdio_m
  use :: math_m

  !--------------------------------------------------------------------------------!
  !                                GLOBAL VARIABLES                                !
  !--------------------------------------------------------------------------------!

  ! Declare the superconducting structure
  type(structure)                 :: stack
  type(superconductor), target    :: sa, sb

  ! Declare program control parameters
  real(wp), parameter             :: threshold   = 1e-2
  real(wp), parameter             :: tolerance   = 1e-8
  integer,  parameter             :: iterations  = 51

  ! Declare variables used by the program
  real(wp), dimension(:), allocatable :: phase
  real(wp), dimension(:), allocatable :: current
  real(wp)                            :: critical
  integer                             :: n, m

  !--------------------------------------------------------------------------------!
  !                           INITIALIZATION PROCEDURE                             !
  !--------------------------------------------------------------------------------!

  ! Redefine stdout and stderr
  stdout = output('output.log')
  stderr = output('error.log')

  ! Construct the central material stack
  stack = structure()

  ! Construct the surrounding superconductors
  call sa % construct()
  call sb % construct()

  ! Disable the superconductors from updates
  call sa % conf('order','0')
  call sb % conf('order','0')

  ! Connect the superconductors to the stack
  stack % a % material_a => sa
  stack % b % material_b => sb

  ! Count the number of superconductors
  n = stack % superconductors()

  ! Depending on the number of enabled superconductors in the junction, we might get a
  ! 2πn-periodicity instead of a 2π-periodicity, and should therefore account for that.
  m = (n+1)*(iterations-1) + 1
  allocate(phase(m), current(m))
  call linspace(phase, 1e-6_wp, 2*(n+1) - 1e-6_wp)

  ! Start with a non-selfconsistent bootstrap procedure
  call stack % converge(threshold = threshold, bootstrap = .true.)

  !--------------------------------------------------------------------------------!
  !                           LINEAR SEARCH PROCEDURE                              !
  !--------------------------------------------------------------------------------!

  ! Calculate the charge current as a function of phase difference
  do n=1,size(phase)
    ! Update the phase
    sa % correlation = exp(((0.0,-0.5)*pi)*phase(n))
    sb % correlation = exp(((0.0,+0.5)*pi)*phase(n))

    ! Reset the states
    call sa % initialize
    call sb % initialize

    ! Update the state
    call stack % converge(threshold = tolerance, prehook = prehook, posthook = posthook)

    ! Save the charge current to array
    current(n) = stack % a % supercurrent(0,1)
  end do

  ! Calculate the critical current
  critical = maxval(abs(current))

  ! Write out the final results
  call finalize

  !--------------------------------------------------------------------------------!
  !                                 SUBROUTINES                                    !
  !--------------------------------------------------------------------------------!

contains
  impure subroutine prehook
    ! Write out status information.
    call status_body('Phase difference', phase(n))
  end subroutine

  impure subroutine posthook
    ! Write results to output files.
    character(len=5) :: filename
    write(filename,'(f5.3)') phase(n)
!   call stack % write_supercurrent('current.' // filename // '.dat')
!   call stack % write_gap(         'gap.'     // filename // '.dat')
  end subroutine

  impure subroutine finalize
    ! Status information
    call status_head('CRITICAL CURRENT')
    call status_body('Result', critical)
    call status_foot

    ! Write the current-phase relation to file
    call dump('current.dat', [phase, current], ['Phase             ', 'Charge current    '])

    ! Write the critical current to file
    call dump('critical.dat', critical)

    ! Close output files
    close(stdout)
    close(stderr)
  end subroutine
end program


module CottonCandy
    include "cottoncandy_consts.f90"
    contains
    include "Integral.f90"
    include "special_function.f90"
    include "cottoncandy_ode.f90"
    include "FourierTransform.f90"
end module CottonCandy

module CottonCandy_Matrix
    include "cottoncandy_matrix.f90"
end module CottonCandy_Matrix


      complex*16 function dsordc(j,a,dg,dp,ag,ap)
c              * calculation of overlap integrals*
c        integration by simpson method of the   hg*(r**0)
c        hg(l)=dg(l)*cg(l,j)+dp(l)*cp(l,j)
c                cg,cp(l,j)  orbital j
c        a is such that dg,dp or hg following the case
c        behave at the origin as cte*r**a
c        the development limits at the origin (used for calculation
c        of integral form 0 to dr(1) ) of functions dg,dp and hg are
c        supposed to be in blocks ag,ap and chg respectively
c        this program uses   aprdec
c
      implicit double precision (a-h,o-z)
      include '../HEADERS/dim.h'
      complex*16 aprdec
      common/dff/ cg(nrptx,30), cp(nrptx,30), bg(10,30), bp(10,30),
     1              fl(30), fix(30), ibgp
      complex*16 dg(nrptx),ag(10),dp(nrptx),ap(10)
      complex*16 hg(nrptx),chg(10)
c     common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
c    1   nq(30),kap(30),nmax(30)
      common/tabtec/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idim
      dimension bgj(10),bpj(10)

c        construction of the array hg
      do  15 l= 1,ibgp
        bgj(l) = bg(l,j)
 15     bpj(l) = bp(l,j)

      do 221 l=1,idim
 221  hg(l)=dg(l)*cg(l,j)+dp(l)*cp(l,j)
      b=a+fl(j)
      do 241 l=1,ndor
 241     chg(l) = aprdec(ag,bgj,l) + aprdec(ap,bpj,l)

c        integration of the hg
      dsordc = (0.0d0, 0.0d0)
      do 305 l=1,idim
 305     hg(l)=hg(l)*dr(l)
      do 311 l=2,idim,2
 311     dsordc=dsordc+hg(l)+hg(l)+hg(l+1)
      dsordc=hx*(dsordc+dsordc+hg(1)-hg(idim))/3.0d0
c        integral from 0 to dr(1)
      do 331 l=1,ndor
         b=b+1.0d 00
 331     dsordc=dsordc+chg(l)*(dr(1)**b)/b
      return
      end


                    subroutine flatrot(rh, rm, rs, isign,
     +                                 dd, dm, ds, vr,
     +                                 gl, glat, rc, pa,
     +                                 rd1, vt1, pm1,
     +                                 rd2, vt2, pm2, istat)
*
*     estimates Galactocentric distance 'rc' (kpc), position angle 'pa'
*     (degree) of the Galactic parallel, distance 'rd' (kpc) from the
*     Sun, velocity perpendicular to the line of sight 'vt' (km / sec)
*     and proper motion 'pm' (mas / year) of a Galactic plane object
*     with RA(J2000) 'rh, rm, rs', Dec(J2000) 'isign, dd, dm, ds' and
*     peak LSR radial velocity 'vr' (km / sec) on the basis of the
*     flat circular rotation model of the Galaxy. Position angle 'pa'
*     of the Galactic parallel (direction of increasing galactic
*     longitude) at the source is measured eastward from the north.
*     On the other hand, 'vt' and 'pm' are positive if the object
*     moves towards direction of decreasing galactic longitude.
*     Distance to the Galactic Center 'R0' (kpc) and rotational
*     velocity 'V0' (km / sec) at the solar circle are assumed.
*     istat :
*        0  : normal
*        1  : warning, galactic latitude might be too large for the
*             flat circular rotation model
*        2  : radial velocity is out of applicability of the flat
*             circular rotation model
*
      implicit real * 8 (a - h, o - z)
*
C standard GR
C        data R0, V0 /8.5d0, 220.0d0/
C  M.R. (2009) GR
C      data R0, V0 /8.4d0, 254.0d0/
C  B.A. (2011) GR (to use with the Schoenrich et al. (2010) solar motion)
C      data R0, V0 /8.3d0, 239.0d0/
C  M.R. (2014) B1 solution (to use with the Schoenrich et al. (2010) solar motion)
      data R0, V0 /8.33d0, 243.0d0/
C
      data pi /3.141592654d0/
*
      write (*, *)
      write (*, *) 'Assumed R0 = ', R0, ' kpc and V0 = ', V0, ' km/s'
      write (*, *)
*
      rad = pi / 180.0d0
*
      call eqtogalp(rh, rm, rs, isign, dd, dm, ds, gl, glat, pa)
*
      if (gl .lt. 0.0d0) then
        gl = gl + 360.0d0
      endif
*
      rgl = rad * gl
      sgl = sin(rgl)
      cgl = cos(rgl)
*
      rc = R0 * V0 * sgl / (vr + V0 * sgl)
*       *** distance of the object from the Galactic center ***
*
      if (abs(glat) .le. 5.0d0) then
        istat = 0
      else
        istat = 1
*       WARNING : the galactic latitude might be too large for the
*                 flat circular rotation model.
      endif
*
      v1 = V0 * (1.0d0 - abs(sgl))
      v2 = V0 * abs(sgl)
      v3 = 0.0d0
*
      if (((gl .ge.   0.0d0 .and. gl .lt.  90.0d0) .and.
     +         (vr .gt. v1 .or. vr .lt. -v2)) .or.
     +    ((gl .ge.  90.0d0 .and. gl .lt. 180.0d0) .and.
     +         (vr .gt. v3 .or. vr .lt. -v2)) .or.
     +    ((gl .ge. 180.0d0 .and. gl .lt. 270.0d0) .and.
     +         (vr .gt. v2 .or. vr .lt.  v3)) .or.
     +    ((gl .ge. 270.0d0 .and. gl .lt. 360.0d0) .and.
     +         (vr .gt. v2 .or. vr .lt. -v1))) then
        istat = 2
*       The flat circular rotation model is inadequate for this case.
*       Setting dummy values
        rd1 = 9999.99d0
        vt1 = 9999.99d0
        pm1 = 9999.99d0
        rd2 = 9999.99d0
        vt2 = 9999.99d0
        pm2 = 9999.99d0
      else if (rc .ge. R0) then
        rd1 = R0 * cgl + sqrt(rc * rc - R0 * R0 * sgl * sgl)
        vt1 = - V0 * ((R0 - rc) * cgl - rd1) / rc
        pm1 = 0.2108 * vt1 / rd1
*       Setting dummy values
        rd2 = 9999.99d0
        vt2 = 9999.99d0
        pm2 = 9999.99d0
      else
        rd1 = R0 * cgl - sqrt(rc * rc - R0 * R0 * sgl * sgl)
        rd2 = R0 * cgl + sqrt(rc * rc - R0 * R0 * sgl * sgl)
        vt1 = - V0 * ((R0 - rc) * cgl - rd1) / rc
        vt2 = - V0 * ((R0 - rc) * cgl - rd2) / rc
        pm1 = 0.2108 * vt1 / rd1
        pm2 = 0.2108 * vt2 / rd2
      endif
*
      return
      end


      real*8 function cgc(j1,j2,j,m1,m2)
      implicit real*8(a-h,o-z)
      common/factoriall/factl(0:200),ifactl
      if (ifactl.eq.0) call factlog(200)
      m=m1+m2
      ia=(j1+j2-j)/2
      ib=(j1-m1)/2
      ic=(j2+m2)/2
      id=(j-j2+m1)/2
      ie=(j-j1-m2)/2

      t1=dlog(dfloat(j+1))+factl((j1+j2-j)/2)+factl((j+j1-j2)/2)+
     &         factl((j+j2-j1)/2)-factl((j+j1+j2+2)/2)
      t2=factl((j1+m1)/2)+factl((j1-m1)/2)+factl((j2+m2)/2)+
     &         factl((j2-m2)/2)+factl((j+m)/2)+factl((j-m)/2)

      imin=min(id,ie)
      if(imin.lt.0)then
        imin=iabs(imin)
      else
        imin=0
      endif

      t3=0.0d0
      do i=imin,min(ia,ib,ic)
        term=factl(i)+factl(ia-i)+factl(ib-i)
     &        +factl(ic-i)+factl(id+i)+factl(ie+i)
        t3=t3+(-1)**i*dexp(-term)
      enddo
      cgc=dexp(0.5d0*(t1+t2))*t3
      end


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED 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
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Make damping matrices.
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] nn number of 1-D GLL nodes
!> @param[in] xq GLL nodes
!> @param[in] wq GLL weights
!> @param[in] dd spectral derivatives matrix
!> @param[in] rho mass density
!> @param[in] gamma damping coefficient
!> @param[in] A11 costant values for the bilinear map
!> @param[in] A12 costant values for the bilinear map
!> @param[in] A13 costant values for the bilinear map
!> @param[in] A21 costant values for the bilinear map
!> @param[in] A22 costant values for the bilinear map
!> @param[in] A23 costant values for the bilinear map
!> @param[in] A31 costant values for the bilinear map
!> @param[in] A32 costant values for the bilinear map
!> @param[in] A33 costant values for the bilinear map
!> @param[in] B11 costant values for the bilinear map
!> @param[in] B12 costant values for the bilinear map
!> @param[in] B13 costant values for the bilinear map
!> @param[in] B21 costant values for the bilinear map
!> @param[in] B22 costant values for the bilinear map
!> @param[in] B23 costant values for the bilinear map
!> @param[in] B31 costant values for the bilinear map
!> @param[in] B32 costant values for the bilinear map
!> @param[in] B33 costant values for the bilinear map
!> @param[in] GG1 costant values for the bilinear map
!> @param[in] GG2 costant values for the bilinear map
!> @param[in] GG3 costant values for the bilinear map
!> @param[in] DD1 costant values for the bilinear map
!> @param[in] DD2 costant values for the bilinear map
!> @param[in] DD3 costant values for the bilinear map
!> @param[out] mc_el viscous forces proportional to the velocity field
!> @param[out] mck_el viscous forces proportional to the displacement field

      subroutine MAKE_DAMPING_MATRIX(nn,ct,ww,dd,rho,gamma,&
                           A11,A12,A13,A21,A22,A23,&
                           A31,A32,A33,B11,B12,B13,&
                           B21,B22,B23,B31,B32,B33,&
                           GG1,GG2,GG3,DD1,DD2,DD3,&
                           mc_el,mck_el)

      implicit none

      integer*4 :: nn
      integer*4 :: i,j,k

      real*8 :: A11,A12,A13,A21,A22,A23,A31,A32,A33
      real*8 :: B11,B12,B13,B21,B22,B23,B31,B32,B33
      real*8 :: GG1,GG2,GG3,DD1,DD2,DD3
      real*8 :: dxdx,dxdy,dxdz,dydx,dydy,dydz,dzdx,dzdy,dzdz,det_j
      real*8, dimension(nn) :: ct,ww

      real*8, dimension(nn,nn) :: dd

      real*8, dimension(nn,nn,nn) :: rho,gamma
      real*8, dimension(nn,nn,nn) :: mc_el,mck_el

      do k = 1,nn
         do j = 1,nn
            do i = 1,nn
               dxdx = A11 +B12*ct(k) +B13*ct(j) &
                    + GG1*ct(j)*ct(k)
               dydx = A21 +B22*ct(k) +B23*ct(j) &
                    + GG2*ct(j)*ct(k)
               dzdx = A31 +B32*ct(k) +B33*ct(j) &
                    + GG3*ct(j)*ct(k)

               dxdy = A12 +B11*ct(k) +B13*ct(i) &
                    + GG1*ct(k)*ct(i)
               dydy = A22 +B21*ct(k) +B23*ct(i) &
                    + GG2*ct(k)*ct(i)
               dzdy = A32 +B31*ct(k) +B33*ct(i) &
                    + GG3*ct(k)*ct(i)

               dxdz = A13 +B11*ct(j) +B12*ct(i) &
                    + GG1*ct(i)*ct(j)
               dydz = A23 +B21*ct(j) +B22*ct(i) &
                    + GG2*ct(i)*ct(j)
               dzdz = A33 +B31*ct(j) +B32*ct(i) &
                    + GG3*ct(i)*ct(j)

               det_j = dxdz * (dydx*dzdy - dzdx*dydy) &
                     - dydz * (dxdx*dzdy - dzdx*dxdy) &
                     + dzdz * (dxdx*dydy - dydx*dxdy)

                    mc_el(i,j,k) = 2* gamma(i,j,k) * rho(i,j,k) &
                                 * det_j * ww(i) * ww(j) * ww(k)

                   mck_el(i,j,k) = (gamma(i,j,k)**2) * rho(i,j,k) &
                                * det_j * ww(i) * ww(j) * ww(k)

            enddo
         enddo
      enddo

      return

      end subroutine MAKE_DAMPING_MATRIX


! =====================================================================
! subroutine LHSR
!
! This subroutine constructs the left-hand side matrix of the
! Peaceman-Rachford step involving the radial kinetic energy
! terms. It has been modified for imaginary time propagation.
! ---------------------------------------------------------------------
      subroutine LHSR(nR,dT,TRL,TRD,TRU,VS,DL,D,DU)
      implicit none

      integer :: nR
      double precision :: dT
      double precision :: TRL(nR-1)
      double precision :: TRD(nR)
      double precision :: TRU(nR-1)
      double precision :: VS(nR)
      double complex :: DL(nR-1)
      double complex :: D(nR)
      double complex :: DU(nR-1)

      integer :: i

      do i = 1, nR-1
         DL(i) = dcmplx(-0.5d0*dT*TRL(i),0.0d0)
         D(i) = dcmplx(1.0d0+0.5d0*dT*TRD(i)+0.25d0*dT*VS(i),0.0d0)
         DU(i) = dcmplx(-0.5d0*dT*TRU(i),0.0d0)
      enddo
      D(nR) = dcmplx(1.0d0+0.5d0*dT*TRD(nR)+0.25d0*dT*VS(nR),0.0d0)

      return
      end
! =====================================================================


  !density-density interaction: same orbital, opposite spins:
  ! = \sum_\a U_\a*(n_{\a,up}*n_{\a,dw})
  htmp = zero
  do iorb=1,Norb
     htmp = htmp + Uloc(iorb)*nup(iorb)*ndw(iorb)
  enddo
  if(Norb>1)then
     !density-density interaction: different orbitals, opposite spins:
     ! =   U'   *     sum_{i/=j} [ n_{i,up}*n_{j,dw} + n_{j,up}*n_{i,dw} ]
     ! =  (Uloc-2*Jh)*sum_{i/=j} [ n_{i,up}*n_{j,dw} + n_{j,up}*n_{i,dw} ]
     do iorb=1,Norb
        do jorb=iorb+1,Norb
           htmp = htmp + Ust*(nup(iorb)*ndw(jorb) + nup(jorb)*ndw(iorb))
        enddo
     enddo
     !density-density interaction: different orbitals, parallel spins
     ! = \sum_{i<j}    U''     *[ n_{i,up}*n_{j,up} + n_{i,dw}*n_{j,dw} ]
     ! = \sum_{i<j} (Uloc-3*Jh)*[ n_{i,up}*n_{j,up} + n_{i,dw}*n_{j,dw} ]
     do iorb=1,Norb
        do jorb=iorb+1,Norb
           htmp = htmp + (Ust-Jh)*(nup(iorb)*nup(jorb) + ndw(iorb)*ndw(jorb))
        enddo
     enddo
  endif
  !if using the Hartree-shifted chemical potential: mu=0 for half-filling
  !sum up the contributions of hartree terms:
  if(hfmode)then
     do iorb=1,Norb
        htmp = htmp - 0.5d0*Uloc(iorb)*(nup(iorb)+ndw(iorb)) + 0.25d0*uloc(iorb)
     enddo
     if(Norb>1)then
        do iorb=1,Norb
           do jorb=iorb+1,Norb
              htmp=htmp-0.5d0*Ust*(nup(iorb)+ndw(iorb)+nup(jorb)+ndw(jorb))+0.25d0*Ust
              htmp=htmp-0.5d0*(Ust-Jh)*(nup(iorb)+ndw(iorb)+nup(jorb)+ndw(jorb))+0.25d0*(Ust-Jh)
           enddo
        enddo
     endif
  endif
  !
  Hmat(i,i) = Hmat(i,i) + htmp
  !
  !
  !
  ! SPIN-EXCHANGE (S-E) and PAIR-HOPPING TERMS
  !    S-E: J c^+_iorb_up c^+_jorb_dw c_iorb_dw c_jorb_up  (i.ne.j)
  !    S-E: J c^+_{iorb} c^+_{jorb+Ns} c_{iorb+Ns} c_{jorb}
  if(Norb>1.AND.Jhflag)then
     do iorb=1,Norb
        do jorb=1,Norb
           Jcondition=(&
                (iorb/=jorb).AND.&
                (ib(jorb)==1).AND.&
                (ib(iorb+Ns)==1).AND.&
                (ib(jorb+Ns)==0).AND.&
                (ib(iorb)==0))
           if(Jcondition)then
              call c(jorb,m,k1,sg1)
              call c(iorb+Ns,k1,k2,sg2)
              call cdg(jorb+Ns,k2,k3,sg3)
              call cdg(iorb,k3,k4,sg4)
              j=binary_search(H%map,k4)
              htmp = one*Jx*sg1*sg2*sg3*sg4
              !
              if(j/=0)Hmat(i,j) = Hmat(i,j) + htmp
              !
           endif
        enddo
     enddo
  endif
  !
  ! PAIR-HOPPING (P-H) TERMS
  !    P-H: J c^+_iorb_up c^+_iorb_dw   c_jorb_dw   c_jorb_up  (i.ne.j)
  !    P-H: J c^+_{iorb}  c^+_{iorb+Ns} c_{jorb+Ns} c_{jorb}
  if(Norb>1.AND.Jhflag)then
     do iorb=1,Norb
        do jorb=1,Norb
           Jcondition=(&
                (iorb/=jorb).AND.&
                (ib(jorb)==1).AND.&
                (ib(jorb+Ns)==1).AND.&
                (ib(iorb+Ns)==0).AND.&
                (ib(iorb)==0))
           if(Jcondition)then
              call c(jorb,m,k1,sg1)
              call c(jorb+Ns,k1,k2,sg2)
              call cdg(iorb+Ns,k2,k3,sg3)
              call cdg(iorb,k3,k4,sg4)
              j=binary_search(H%map,k4)
              htmp = one*Jp*sg1*sg2*sg3*sg4
              !
              if(j/=0)Hmat(i,j) = Hmat(i,j) + htmp
              !
           endif
        enddo
     enddo
  endif


c
c
c     =====================================================
      subroutine limiter(maxm,meqn,mwaves,mbc,mx,wave,s,mthlim)
c     =====================================================
c
c     # Apply a limiter to the waves.
c     # The limiter is computed by comparing the 2-norm of each wave with
c     # the projection of the wave from the interface to the left or
c     # right onto the current wave.  For a linear system this would
c     # correspond to comparing the norms of the two waves.  For a
c     # nonlinear problem the eigenvectors are not colinear and so the
c     # projection is needed to provide more limiting in the case where the
c     # neighboring wave has large norm but points in a different direction
c     # in phase space.
c
c     # The specific limiter used in each family is determined by the
c     # value of the corresponding element of the array mthlim, as used in
c     # the function philim.
c     # Note that a different limiter may be used in each wave family.
c
c     # dotl and dotr denote the inner product of wave with the wave to
c     # the left or right.  The norm of the projections onto the wave are then
c     # given by dotl/wnorm2 and dotr/wnorm2, where wnorm2 is the 2-norm
c     # of wave.
c
      implicit real*8(a-h,o-z)
      dimension mthlim(mwaves)
      dimension wave(1-mbc:maxm+mbc, meqn, mwaves)
      dimension    s(1-mbc:maxm+mbc, mwaves)
      common /comlim/ phiM,phiMdx2
c
c
      do 50 mw=1,mwaves
         if (mthlim(mw) .eq. 0) go to 50
         dotr = 0.d0
         do 40 i = 0, mx+1
            wnorm2 = 0.d0
            dotl = dotr
            dotr = 0.d0
            do 20 m=1,meqn
               wnorm2 = wnorm2 + wave(i,m,mw)**2
               dotr = dotr + wave(i,m,mw)*wave(i+1,m,mw)
   20          continue
            if (i.eq.0) go to 40
            if (wnorm2.eq.0.d0) go to 40
c
	    wnorm = dsqrt(wnorm2)
            if (s(i,mw) .gt. 0.d0) then
                wlimitr = philim(wnorm2, dotl + phiMdx2*wnorm,
     &		                 mthlim(mw))
              else
                wlimitr = philim(wnorm2, dotr + phiMdx2*wnorm,
     &		                 mthlim(mw))
              endif
c
            do 30 m=1,meqn
               wave(i,m,mw) = wlimitr * wave(i,m,mw)
   30          continue
   40       continue
   50    continue
c
      return
      end


*> \brief \b SSYRFS
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SSYRFS + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
*                          X, LDX, FERR, BERR, WORK, IWORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * ), IWORK( * )
*       REAL               A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
*      $                   BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SSYRFS improves the computed solution to a system of linear
*> equations when the coefficient matrix is symmetric indefinite, and
*> provides error bounds and backward error estimates for the solution.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \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] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrices B and X.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          The symmetric 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.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] AF
*> \verbatim
*>          AF is REAL array, dimension (LDAF,N)
*>          The factored form of the matrix A.  AF contains the block
*>          diagonal matrix D and the multipliers used to obtain the
*>          factor U or L from the factorization A = U*D*U**T or
*>          A = L*D*L**T as computed by SSYTRF.
*> \endverbatim
*>
*> \param[in] LDAF
*> \verbatim
*>          LDAF is INTEGER
*>          The leading dimension of the array AF.  LDAF >= max(1,N).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (N)
*>          Details of the interchanges and the block structure of D
*>          as determined by SSYTRF.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is REAL array, dimension (LDB,NRHS)
*>          The right hand side matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*>          X is REAL array, dimension (LDX,NRHS)
*>          On entry, the solution matrix X, as computed by SSYTRS.
*>          On exit, the improved solution matrix X.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*>          LDX is INTEGER
*>          The leading dimension of the array X.  LDX >= max(1,N).
*> \endverbatim
*>
*> \param[out] FERR
*> \verbatim
*>          FERR is REAL array, dimension (NRHS)
*>          The estimated forward error bound for each solution vector
*>          X(j) (the j-th column of the solution matrix X).
*>          If XTRUE is the true solution corresponding to X(j), FERR(j)
*>          is an estimated upper bound for the magnitude of the largest
*>          element in (X(j) - XTRUE) divided by the magnitude of the
*>          largest element in X(j).  The estimate is as reliable as
*>          the estimate for RCOND, and is almost always a slight
*>          overestimate of the true error.
*> \endverbatim
*>
*> \param[out] BERR
*> \verbatim
*>          BERR is REAL array, dimension (NRHS)
*>          The componentwise relative backward error of each solution
*>          vector X(j) (i.e., the smallest relative change in
*>          any element of A or B that makes X(j) an exact solution).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (3*N)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*> \par Internal Parameters:
*  =========================
*>
*> \verbatim
*>  ITMAX is the maximum number of steps of iterative refinement.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup realSYcomputational
*
*  =====================================================================
      SUBROUTINE SSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
     $                   X, LDX, FERR, BERR, WORK, IWORK, INFO )
*
*  -- LAPACK computational routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      REAL               A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
     $                   BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            ITMAX
      PARAMETER          ( ITMAX = 5 )
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E+0 )
      REAL               ONE
      PARAMETER          ( ONE = 1.0E+0 )
      REAL               TWO
      PARAMETER          ( TWO = 2.0E+0 )
      REAL               THREE
      PARAMETER          ( THREE = 3.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            COUNT, I, J, K, KASE, NZ
      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
*     ..
*     .. Local Arrays ..
      INTEGER            ISAVE( 3 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           SAXPY, SCOPY, SLACN2, SSYMV, SSYTRS, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               SLAMCH
      EXTERNAL           LSAME, SLAMCH
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -12
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SSYRFS', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
         DO 10 J = 1, NRHS
            FERR( J ) = ZERO
            BERR( J ) = ZERO
   10    CONTINUE
         RETURN
      END IF
*
*     NZ = maximum number of nonzero elements in each row of A, plus 1
*
      NZ = N + 1
      EPS = SLAMCH( 'Epsilon' )
      SAFMIN = SLAMCH( 'Safe minimum' )
      SAFE1 = NZ*SAFMIN
      SAFE2 = SAFE1 / EPS
*
*     Do for each right hand side
*
      DO 140 J = 1, NRHS
*
         COUNT = 1
         LSTRES = THREE
   20    CONTINUE
*
*        Loop until stopping criterion is satisfied.
*
*        Compute residual R = B - A * X
*
         CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
         CALL SSYMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
     $               WORK( N+1 ), 1 )
*
*        Compute componentwise relative backward error from formula
*
*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
*
*        where abs(Z) is the componentwise absolute value of the matrix
*        or vector Z.  If the i-th component of the denominator is less
*        than SAFE2, then SAFE1 is added to the i-th components of the
*        numerator and denominator before dividing.
*
         DO 30 I = 1, N
            WORK( I ) = ABS( B( I, J ) )
   30    CONTINUE
*
*        Compute abs(A)*abs(X) + abs(B).
*
         IF( UPPER ) THEN
            DO 50 K = 1, N
               S = ZERO
               XK = ABS( X( K, J ) )
               DO 40 I = 1, K - 1
                  WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
                  S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
   40          CONTINUE
               WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + S
   50       CONTINUE
         ELSE
            DO 70 K = 1, N
               S = ZERO
               XK = ABS( X( K, J ) )
               WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK
               DO 60 I = K + 1, N
                  WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
                  S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
   60          CONTINUE
               WORK( K ) = WORK( K ) + S
   70       CONTINUE
         END IF
         S = ZERO
         DO 80 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
            ELSE
               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
     $             ( WORK( I )+SAFE1 ) )
            END IF
   80    CONTINUE
         BERR( J ) = S
*
*        Test stopping criterion. Continue iterating if
*           1) The residual BERR(J) is larger than machine epsilon, and
*           2) BERR(J) decreased by at least a factor of 2 during the
*              last iteration, and
*           3) At most ITMAX iterations tried.
*
         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
     $       COUNT.LE.ITMAX ) THEN
*
*           Update solution and try again.
*
            CALL SSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
     $                   INFO )
            CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
            LSTRES = BERR( J )
            COUNT = COUNT + 1
            GO TO 20
         END IF
*
*        Bound error from formula
*
*        norm(X - XTRUE) / norm(X) .le. FERR =
*        norm( abs(inv(A))*
*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
*
*        where
*          norm(Z) is the magnitude of the largest component of Z
*          inv(A) is the inverse of A
*          abs(Z) is the componentwise absolute value of the matrix or
*             vector Z
*          NZ is the maximum number of nonzeros in any row of A, plus 1
*          EPS is machine epsilon
*
*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
*        is incremented by SAFE1 if the i-th component of
*        abs(A)*abs(X) + abs(B) is less than SAFE2.
*
*        Use SLACN2 to estimate the infinity-norm of the matrix
*           inv(A) * diag(W),
*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
*
         DO 90 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
            ELSE
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
            END IF
   90    CONTINUE
*
         KASE = 0
  100    CONTINUE
         CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
     $                KASE, ISAVE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.1 ) THEN
*
*              Multiply by diag(W)*inv(A**T).
*
               CALL SSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
     $                      INFO )
               DO 110 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  110          CONTINUE
            ELSE IF( KASE.EQ.2 ) THEN
*
*              Multiply by inv(A)*diag(W).
*
               DO 120 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  120          CONTINUE
               CALL SSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
     $                      INFO )
            END IF
            GO TO 100
         END IF
*
*        Normalize error.
*
         LSTRES = ZERO
         DO 130 I = 1, N
            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
  130    CONTINUE
         IF( LSTRES.NE.ZERO )
     $      FERR( J ) = FERR( J ) / LSTRES
*
  140 CONTINUE
*
      RETURN
*
*     End of SSYRFS
*
      END


      module e3metric_m
c
c----------------------------------------
c    aims to calculate the element
c    metrics for interface elements
c----------------------------------------
        use workfc_m
        use global_const_m
        use propar_m
        use number_def_m
        implicit none
c
      contains
c
      subroutine e3metric(shg,dxidx,shgl,xl)
c
        implicit none
c
        real*8, dimension(:,:,:), pointer, intent(out) :: shg
        real*8, dimension(:,:,:), pointer, intent(out) :: dxidx ! added
        real*8, dimension(:,:,:), pointer, intent(in)  :: xl, shgl
c
        real*8, dimension(:,:,:), allocatable  :: dxdxi
        real*8, dimension(npro)  :: tmp
c
        integer :: n, nshl, err0,err1,nenl
c
        allocate(dxdxi(npro,nsd,nsd))
c
c
c.... compute the deformation gradient
c
      dxdxi = zero
      nenl = size(xl,2)
c
       do n = 1, nenl
          dxdxi(:,1,1) = dxdxi(:,1,1) + xl(:,n,1) * shgl(:,1,n)
          dxdxi(:,1,2) = dxdxi(:,1,2) + xl(:,n,1) * shgl(:,2,n)
          dxdxi(:,1,3) = dxdxi(:,1,3) + xl(:,n,1) * shgl(:,3,n)
          dxdxi(:,2,1) = dxdxi(:,2,1) + xl(:,n,2) * shgl(:,1,n)
          dxdxi(:,2,2) = dxdxi(:,2,2) + xl(:,n,2) * shgl(:,2,n)
          dxdxi(:,2,3) = dxdxi(:,2,3) + xl(:,n,2) * shgl(:,3,n)
          dxdxi(:,3,1) = dxdxi(:,3,1) + xl(:,n,3) * shgl(:,1,n)
          dxdxi(:,3,2) = dxdxi(:,3,2) + xl(:,n,3) * shgl(:,2,n)
          dxdxi(:,3,3) = dxdxi(:,3,3) + xl(:,n,3) * shgl(:,3,n)
c      write(*,10) n,xl(1,n,1:3),shgl(1,1:3,n)
       enddo
10    format('n,xl,shgl:',i4,6e24.16)
c
C$C        call calc_deform_grad(dxdxi,xl,shgl)
c
c.... compute the inverse of deformation gradient
c
       dxidx(:,1,1) =   dxdxi(:,2,2) * dxdxi(:,3,3)
     &                - dxdxi(:,3,2) * dxdxi(:,2,3)
       dxidx(:,1,2) =   dxdxi(:,3,2) * dxdxi(:,1,3)
     &                - dxdxi(:,1,2) * dxdxi(:,3,3)
       dxidx(:,1,3) =  dxdxi(:,1,2) * dxdxi(:,2,3)
     &                - dxdxi(:,1,3) * dxdxi(:,2,2)
       tmp          = one / ( dxidx(:,1,1) * dxdxi(:,1,1)
     &                       + dxidx(:,1,2) * dxdxi(:,2,1)
     &                       + dxidx(:,1,3) * dxdxi(:,3,1) )
       dxidx(:,1,1) = dxidx(:,1,1) * tmp
       dxidx(:,1,2) = dxidx(:,1,2) * tmp
       dxidx(:,1,3) = dxidx(:,1,3) * tmp
       dxidx(:,2,1) = (dxdxi(:,2,3) * dxdxi(:,3,1)
     &                - dxdxi(:,2,1) * dxdxi(:,3,3)) * tmp
       dxidx(:,2,2) = (dxdxi(:,1,1) * dxdxi(:,3,3)
     &                - dxdxi(:,3,1) * dxdxi(:,1,3)) * tmp
       dxidx(:,2,3) = (dxdxi(:,2,1) * dxdxi(:,1,3)
     &                - dxdxi(:,1,1) * dxdxi(:,2,3)) * tmp
       dxidx(:,3,1) = (dxdxi(:,2,1) * dxdxi(:,3,2)
     &                - dxdxi(:,2,2) * dxdxi(:,3,1)) * tmp
       dxidx(:,3,2) = (dxdxi(:,3,1) * dxdxi(:,1,2)
     &                - dxdxi(:,1,1) * dxdxi(:,3,2)) * tmp
       dxidx(:,3,3) = (dxdxi(:,1,1) * dxdxi(:,2,2)
     &                - dxdxi(:,1,2) * dxdxi(:,2,1)) * tmp
c
c.... compute the global gradient of shape-functions
c
       nshl = size(shgl,3)
c
       do n = 1, nshl
          shg(:,n,1) = shgl(:,1,n) * dxidx(:,1,1) +
     &                 shgl(:,2,n) * dxidx(:,2,1) +
     &                 shgl(:,3,n) * dxidx(:,3,1)
          shg(:,n,2) = shgl(:,1,n) * dxidx(:,1,2) +
     &                 shgl(:,2,n) * dxidx(:,2,2) +
     &                 shgl(:,3,n) * dxidx(:,3,2)
          shg(:,n,3) = shgl(:,1,n) * dxidx(:,1,3) +
     &                 shgl(:,2,n) * dxidx(:,2,3) +
     &                 shgl(:,3,n) * dxidx(:,3,3)
       enddo
c
       deallocate(dxdxi,stat=err0)
c      print*, myrank,npro,nsd,err0,err1
c
       return
c
      end subroutine e3metric
c
      subroutine calc_deform_grad(dxdxi,xl,shgl)
c
        real*8, dimension(npro,nsd,nsd), intent(out) :: dxdxi
        real*8, dimension(:,:,:), intent(in)  :: xl, shgl
c
        integer :: nenl,n,i,j
c
        nenl = size(xl,2)
c
        dxdxi = zero
c
        do n = 1, nenl
          do i = 1, nsd
            do j = 1, nsd
              dxdxi(:,i,j) = dxdxi(:,i,j) + xl(:,n,i)*shgl(:,j,n)
            enddo
          enddo
        enddo
c
      end subroutine calc_deform_grad
c
      end module e3metric_m


c******************************************************************************
c
c			Mosher Function
c		(called by the C bridge in pho_routines.c)
c
c ******************************************************************************
	SUBROUTINE XMOSHER( arg, con, ref)

	INCLUDE 'pho'

	double precision arg(3), con(6), ref

        CI = COS(con(1)*rad_deg)
        CE = COS(con(2)*rad_deg)
	xg = con(3)
        REF = (CON(1)+CON(2)*XG+CON(3)*EXP(-CON(4)*XG)) *
     &   (CI*CE)**(CON(5)+CON(6)*XG)/CE

	return
	end

c ******************************************************************************


      SUBROUTINE INIT
C
C THIS ROUTINE INITIALIZES VARIABLES FOR THE VARIOUS TEST CASES.
C FOR STEADY-STATE FLOWS, THE INFORMATION IS STORED IN COMMON
C BLOCK /CONST2/, ARRAYS UIC12,VIC12,PIC12,DIC12 AND EIC12.
C THE CASE IS DETERMINED BY THE VARIABLE ICOND:
C    CASE 1: ADVECTION EQUATION FOR SOLID BODY FLOW
C    CASE 2: SOLID BODY ROTATION STEADY STATE FLOW
C    CASE 3: JETSTREAM STEADY STATE FLOW
C    CASE 4: FORCED LOW IN JETSTREAM
C    CASE 5: ZONAL FLOW OVER ISOLATED MOUNTAIN
C    CASE 6: ROSSBY-HAURWITZ WAVE
C    CASE 7: REAL DATA (500MB) TEST CASE
C
C CALLED BY: STSWM
C CALLS: BUBFNC, D01AHE, FU, FUNC2, GLAT, GLON, ROTATE,
C        SHTRNS, US, ZD
C
C REVISIONS:
C 7-13-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C---- Model Parameters -------------------------------------------------
C
      INCLUDE 'params.i'
C
C---- Common Blocks ----------------------------------------------------
C
C CONSTANTS & TIMESTEPS
      INCLUDE 'consts.i'
C INITIAL CONDITIONS
      INCLUDE 'finit.i'
      INCLUDE 'case4.i'
C
C------ Local Parameters -----------------------------------------------
C
      REAL PI
      PARAMETER (PI=3.141592653589793)
C
C------ Local Variables ------------------------------------------------
C
C     TEMPORARY ARRAYS FOR COMPUTING INITIAL DIVERGENCE,VORTICITY
C
      COMPLEX DIVSC(NALP), ZETASC(NALP)
C
C     TEMPORARIES
C
      INTEGER I,J
      REAL SINA, COSA, RLON, COSL, RLAT, ETAAMP, UBAR, PHIAMP,
     $     SINL, SINT, COST, ROTLON, ROTLAT, PHITMP, RELERR,
     $     RADIUS, DIST, MOUNTA
C
C     NAG INTEGRATION ROUTINE ARGUMENTS
C
      INTEGER NLIMIT, IFAIL, NPTS
C
C----- External Functions ----------------------------------------------
C
C     Actual function arguments for balance equations
C
      EXTERNAL BUBFNC, FU, FUNC2, US
      REAL BUBFNC, FU, FUNC2, US
C
C     GRID LATITUDE AND LONGITUDE
C
      EXTERNAL GLAT, GLON
      REAL GLAT, GLON
C
C     QUADRATURE ROUTINE
C
      EXTERNAL D01AHE
      REAL D01AHE
C
C----- Executable Statements -------------------------------------------
C
C     DETERMINE WHICH INITIAL CONDITION TO USE
C
      IF (ICOND .EQ. 1) THEN
C
C-------------------INITIAL CONDITION 1 ---------------------------
C
C     ANALYTIC SPECIFICATION FOR ADVECTION OF COSINE BELL
C     SOLUTION AS SPECIFIED BY WILLIAMSON AND
C     RASCH, 1989, MON. WEATHER REVIEW
C
      WRITE (6,70) ALPHA
   70 FORMAT(/,' TEST CASE #1: ADVECTION OF COSINE BELL',
     $       /,' ROTATED BY AN ANGLE ALPHA = ',F5.3)
C
C     INITIAL LOCATION AND AMPLITUDE
C
      RLON0 = -90.0*(PI/180.0)
      RLAT0 = + 0.0*(PI/180.0)
      PHI0  = 1000.0
C
C     ONLY EXPLICIT TIMESTEPPING WITH ADVECTION EQUATION !
C
      IF (SITS) THEN
         WRITE(0,75)
   75 FORMAT(/,' STSWM: CANNOT RUN TEST 1 WITH SEMI-IMPLICIT',
     $       /,' TIMESTEPPING. CHANGE PARAMETER SITS = .FALSE.',
     $       /,' IN NAMELIST INPUT FILE')
         STOP
      ENDIF
C
C     CHOOSE VELOCITY FOR ONE ROTATION IN 12 DAYS
C
      SU0  = 2.0*PI*A/(3600.0*24*12)
      SINA = SIN(ALPHA)
      COSA = COS(ALPHA)
      ETAAMP = 2.0*(SU0/A + OMEGA)
      DO 85 I=1,NLON
         RLON = GLON(I)
         DO 80 J=1,NLAT
            RLAT = GLAT(J)
C
C           LONGITUDE = RLON = GLON(I)
C           LATITUDE = RLAT = GLAT(J)
C
C           SET UP STEADY FLOW FIELD
C
            IF (ALPHA .NE. 0.0) THEN
               UIC12(I,J) = SU0*(COS(RLAT)*COSA+COS(RLON)*
     $                      SIN(RLAT)*SINA)
               VIC12(I,J) = -SU0*SIN(RLON)*SINA
            ELSE
              UIC12(I,J) = SU0*COS(RLAT)
              VIC12(I,J) = 0.0
            ENDIF
C
            DIC12(I,J) = 0.0
            EIC12(I,J) = ETAAMP*(-COS(RLON)*COS(RLAT)*SINA
     $                   +SIN(RLAT)*COSA)
   80    CONTINUE
   85 CONTINUE
C
      RETURN
C
      ELSEIF (ICOND .EQ. 2) THEN
C
C-------------------INITIAL CONDITION 2 ---------------------------
C
C     ANALYTIC SPECIFICATION OF U, V, PHI, DIV, ZETA FIELD ON GAUSSIAN
C     GRID. STEADY STATE SOLUTION (WILLIAMSON AND BROWNING, 1973 JAM)
C
      WRITE (6,90) ALPHA
   90 FORMAT(/,' TEST CASE #2: STEADY STATE NONLINEAR GEOSTROPHIC FLOW',
     $       /,' ROTATED BY AN ANGLE ALPHA = ',F5.3)
C
C     INITIAL LOCATION AND AMPLITUDE
C
      RLON0 = -90.0*(PI/180.0)
      RLAT0 = + 0.0*(PI/180.0)
C
      UBAR = (2.0*PI*A)/(12.0*24.0*3600.0)
      PHI0 = 2.94E4
C
      SINA = SIN(ALPHA)
      COSA = COS(ALPHA)
      ETAAMP = 2.0*(UBAR/A + OMEGA)
      PHIAMP = A*OMEGA*UBAR + (UBAR**2)/2.0
      DO 100 I=1,NLON
         RLON = GLON(I)
         SINL = SIN(RLON)
         COSL = COS(RLON)
         DO 95 J=1,NLAT
            RLAT = GLAT(J)
C
C           LONGITUDE = RLON = GLON(I)
C           LATITUDE = RLAT = GLAT(J)
C
            SINT = SIN(RLAT)
            COST = COS(RLAT)
            UIC12(I,J) = UBAR*(COST*COSA + COSL*SINT*SINA)
            VIC12(I,J) = - UBAR*SINL*SINA
            PIC12(I,J) = (PHI0-PHIAMP*(- COSL*COST*SINA +
     $                   SINT*COSA)**2)/GRAV
            DIC12(I,J) = 0.0
            EIC12(I,J) = ETAAMP*(- COSL*COST*SINA + SINT*COSA)
   95    CONTINUE
  100 CONTINUE
C
      RETURN
C
      ELSE IF (ICOND .EQ. 3) THEN
C
C--------------------INITIAL CONDITION 3 --------------------------
C
C     INITIAL U SPECIFIED AS BUMP (INFINITELY DIFFERENTABLE) FUNCTION
C     V=0; SOLVE FOR PHI BY INTEGRATING 1 DIMENSIONAL BALANCE EQUATION
C     SEE PAPER BY BROWNING ET. AL., (MONTHLY WEATHER REVIEW, 1989)
C
      WRITE (6,120) ALPHA
  120 FORMAT(/,' TEST CASE #3: STEADY STATE NONLINEAR GEOSTROPHIC FLOW',
     $       /,' WITH COMPACT SUPPORT',
     $       /,' ROTATED BY AN ANGLE ALPHA = ',F5.3)
C
      PHI0   = 2.94E4
      NLIMIT = -1
      IFAIL  =  0
      DO 150 J=1,NLAT
         RLAT = GLAT(J)
         DO 145 I = 1, NLON
            RLON = GLON(I)
C
C           LONGITUDE = RLON = GLON(I)
C           LATITUDE = RLAT = GLAT(J)
C
C           COMPUTE COORDINATES IN ROTATED SYSTEM
C
            CALL ROTATE(RLON,RLAT,ALPHA,ROTLON,ROTLAT)
C
C        CALL NUMERICAL INTEGRATION PROCEDURE FROM NAG FOR PHI
C        WHAT FOLLOWS IS A QUICK DESCRIPTION OF THE ARGUMENT LIST SO THE
C        USER CAN REPLACE THIS ROUTINE WITH ANOTHER ONE IF NECESSARY
C
C        FUNCTION D01AHE (A, B, EPSR, NPTS, RELERR, F, NLIMIT, IFAIL)
C           A      - SPECIFIES THE LOWER LIMIT OF INTEGRATION
C           B      - SPECIFIES THE UPPER LIMIT OF INTEGRATION
C           EPSR   - SPECIFIES THE RELATIVE ACCURACY REQUIRED
C           NPTS   - NUMBER OF POINTS AT WHICH TO EVALUATE THE INTEGRAL
C           RELERR - CONTAINS ROUGH ESTIMATE OF RELATIVE ERROR ON EXIT
C           F      - REAL FUNCTION, SUPPLIED BY THE USER
C           NLIMIT - SPECIFIES A LIMIT TO NUMBER OF FUNCTION EVALUATIONS
C                       NLIMIT.LE.0 => LIMIT OF 10,000
C           IFAIL  - MUST BE PREASSIGNED WHEN ROUTINE IS CALLED
C                       CONTAINS 0 ON OUTPUT IF NO ERROR OCCURRED
C
            PHITMP = D01AHE(-0.5*PI, ROTLAT, 100.0*EPS, NPTS,
     $                RELERR, FU, NLIMIT, IFAIL)
            IF (IFAIL .NE. 0) THEN
               WRITE (0,140) IFAIL
  140          FORMAT(/,' STSWM: FATAL ERROR IN ROUTINE INIT:',/,
     $             ' FAILURE IN NAG INTEGRATION ROUTINE D01AHE',/,
     $             ' IFAIL = ',I4)
               STOP
            ENDIF
C
C           ROTATE FIELD VARIABLES
C
            IF (ALPHA .NE. 0.0) THEN
               UIC12(I,J) = US(ROTLAT)*(COS(ALPHA)*SIN(ROTLON)
     $                      *SIN(RLON)+COS(RLON)*COS(ROTLON))
               VIC12(I,J) = US(ROTLAT)*(COS(ALPHA)*COS(RLON)
     $                      * SIN(ROTLON)*SIN(RLAT)
     $                      - COS(ROTLON)*SIN(RLON)*SIN(RLAT)
     $                      - SIN(ALPHA)*SIN(ROTLON)*COS(RLAT))
               PIC12(I,J) = (PHI0-PHITMP)/GRAV
            ELSE
C
C              NO ROTATION -> ORIGINAL FIELD
C
               UIC12(I,J) = US(RLAT)
               VIC12(I,J) = 0.0
               PIC12(I,J) = (PHI0-PHITMP)/GRAV
            ENDIF
  145    CONTINUE
  150 CONTINUE
C
C     GET SPECTRAL COEFFICIENTS FOR ZETA AND DIV
C     (STEADY STATE)
C
      CALL ZD(UIC12,VIC12,DIVSC,ZETASC)
C
C     INVERSE TRANSFORM ZETA,DIV FOR INITIAL CONDITION INFORMATION
C     DESTROYS ZETASC, DIVSC !
C
      CALL SHTRNS (1,1,+1,EIC12,ZETASC)
      CALL SHTRNS (1,1,+1,DIC12,DIVSC)
C
      RETURN
C
      ELSE IF (ICOND .EQ. 4) THEN
C
C-----------------------INITIAL CONDITION 4 -----------------------
C
C     STEADY STATE NONLINEAR ZONAL GEOSTROPHIC FLOW WITH COMPACT
C     SUPPORT, SEE BROWNING ET AL, MONTHLY WEATHER REVIEW, 1989
C
      WRITE(6,200)
  200 FORMAT(/,' TEST CASE #4: FORCED NONLINEAR SYSTEM WITH',
     $       ' ADVECTING LOW')
C
      IF (.NOT. FORCED) THEN
         WRITE(0,205)
  205    FORMAT(/,' STSWM: FORCING TERMS MUST BE INCLUDED FOR',
     $          /,' TEST 4. SET PARAMETER FORCED = .TRUE. IN',
     $          /,' NAMELIST INPUT FILE')
         STOP
      ENDIF
C
C     FORCED NONLINEAR SOLUTION
C
C     DETERMINE INITIAL CONDITION ON TIME DEPENDENT VARIABLES FOR FIRST
C     TWO TIME STEPS (NO TIME TRUNCATION ERROR TO START LEAPFROG PROC.)
C
C     CONSTANTS FOR ANALYTIC STREAM FUNCTION (FORCED CASE)
C
C     BASIC ZONAL FLOW AMPLITUDE
C
      SU0    = 20.0
      PHI0   = 1.0E5
C
C     USE A TRANSLATING LOW INSTEAD OF A TRANSLATING HIGH
C     (PRODUCE PLOTS AS IN PAPER)
C
C
C     AMPLITUDE OF LOW
C     TO REMOVE LOW, SET TO ZERO
C
      ALFA   = -0.03*(PHI0/(2.0*OMEGA*SIN(PI/4.0)))
C*****ALFA   = 0.0
C
C     INITIAL POSITION OF LOW (GREENWICH)
C
      RLON0  = 0.0*(PI/180.0)
      RLAT0  = +45.0*(PI/180.0)
C
C     AREAL EXTENT OF LOW
C
      SIGMA  = (2.0*A/1.0E6)**2
      NPWR   =  14
C
C     BALANCED PHI (PHICON), UCON, VCON IS USED IN ANLYTC FOR
C     GEOPOTENTIAL THAT BALANCES STEADY ZONAL FLOW
C
      NLIMIT = -1
      IFAIL  = 0
      DO 210 J=1,NLAT
         RLAT = GLAT(J)
C
C        LONGITUDE = RLON = GLON(I)
C        LATITUDE = RLAT = GLAT(J)
C
C        SOLVE NON-LINEAR BALANCE EQUATION FOR PHI;
C
         PHICON(J) = D01AHE(-0.5*PI, RLAT, 100*EPS,
     $               NPTS, RELERR, FUNC2, NLIMIT, IFAIL)
C
         IF (IFAIL .NE. 0) THEN
            WRITE (0,140) IFAIL
            STOP
         ENDIF
         PHICON(J) = (PHI0 - PHICON(J))/GRAV
         UCON(J) = BUBFNC(RLAT)
         VCON(J) = 0.0
  210 CONTINUE
C
      RETURN
C
      ELSE IF (ICOND .EQ. 5) THEN
C
C-------------------INITIAL CONDITION 5 ---------------------------
C
C     ZONAL FLOW OVER AN ISOLATED MOUNTAIN AS USED BY TAKACS.
C     ANALYTIC SPECIFICATION OF U, V, PHI, DIV, ZETA FIELD ON GAUSSIAN
C     GRID. STEADY STATE SOLUTION (WILLIAMSON AND BROWNING, 1973 JAM)
C
      WRITE (6,280)
  280 FORMAT(/,' TEST CASE #5: ZONAL FLOW OVER AN ISOLATED MOUNTAIN')
C
C     SET MOUNTAIN SURFACE
C
      FTOPO = .TRUE.
      MOUNTA = 2000.0
      RADIUS = PI/9.0
      DO 50 J = 1, NLAT
         RLAT = GLAT(J)
         DO 40 I = 1, NLON
            RLON = GLON(I)
            DIST = SQRT((RLON -  1.5*PI)**2 + (RLAT - PI/6.0)**2)
            IF (DIST .LT. RADIUS) THEN
               MOUNT(I,J) = MOUNTA*(1.0 - DIST/RADIUS)
            ELSE
               MOUNT(I,J) = 0.0
            ENDIF
C
C           TEMPORARY COPY FOR SPECTRAL TRANSFORM
C
            PIC12(I,J)=MOUNT(I,J)
   40    CONTINUE
   50 CONTINUE
C
C     COMPUTE SPECTRAL COEFFICIENTS
C
      CALL SHTRNS(1,1,-1,PIC12,TOPOSC)
C
C     INITIAL CONDITIONS
C
      PHI0 = 5960.0
      UBAR = 20.0
C
      SINA = 0.0
      COSA = 1.0
      ETAAMP = 2.0*(UBAR/A + OMEGA)
      PHIAMP = A*OMEGA*UBAR + (UBAR**2)/2.0
      DO 295 I=1,NLON
         RLON = GLON(I)
         SINL = SIN(RLON)
         COSL = COS(RLON)
         DO 290 J=1,NLAT
            RLAT = GLAT(J)
C
C           LONGITUDE = RLON = GLON(I)
C           LATITUDE = RLAT = GLAT(J)
C
            SINT = SIN(RLAT)
            COST = COS(RLAT)
            UIC12(I,J) = UBAR*COST
            VIC12(I,J) = 0.0
C
C           FREE SURFACE HEIGHT (INCLUDE MOUNTAINS)
C
            PIC12(I,J) = PHI0-PHIAMP*SINT**2/GRAV
            DIC12(I,J) = 0.0
            EIC12(I,J) = ETAAMP*SINT
  290    CONTINUE
  295 CONTINUE
C
      RETURN
C
      ELSE IF (ICOND .EQ. 6) THEN
C
C-----------------------INITIAL CONDITION 6 -----------------------
C
C     ROSSBY-HAURWITZ WAVE AS USED BY PHILIPS IN
C     MONTHLY WEATHER REVIEW, 1959
C
      R = 4
      K = 7.848E-6
      OMG = 7.848E-6
      PHI0 = 8000.0
      WRITE(6,300) R
  300 FORMAT(/,' TEST CASE #6: ROSSBY-HAURWITZ WAVE, WAVENUMBER ',
     $       I2)
C
C     COMPUTE LATITUDE-DEPENDENT FACTORS FOR GEOPOTENTIAL
C     PHIA(NLAT),PHIB(NLAT) AND PHIC(NLAT)
C
      DO 310 J=1,NLAT
         RLAT = GLAT(J)
C
C        LONGITUDE = RLON = GLON(I)
C        LATITUDE = RLAT = GLAT(J)
C
         COST = COS(RLAT)
         PHIA(J) = 0.5*OMG*(2.0*OMEGA+OMG)*COST*COST +
     $             0.25*K*K*COST**(2*R) *
     $             ((R+1)*COST*COST+(2*R*R-R-2) -
     $             2.0*R*R/(COST*COST))
         PHIB(J) = (2.0*(OMEGA+OMG)*K)/((R+1)*(R+2))*
     $             COST**R*((R*R+2*R+2)-(R+1)**2*COST*COST)
         PHIC(J) = 0.25*K*K*COST**(2*R)*
     $             ((R+1)*COST*COST-(R+2))
  310 CONTINUE
C
      RETURN
C
      ELSE IF (ICOND .EQ. 7) THEN
C
C-----------------------INITIAL CONDITION 7 -----------------------
C
C     REAL DATA TEST CASE
C
      WRITE(6,400)
  400 FORMAT(/,' TEST CASE #7: 500 MB GEOPOTENTIAL FROM ECMWF ',
     $       'ANALYSIS')
C
      RETURN
C
C----------------------------------------------------------------------
C
      ELSE
C
         WRITE (0,900) ICOND
  900    FORMAT(/,' STSWM: FATAL ERROR IN SUBROUTINE INIT:',/,
     $       ' MISSING SPECIFICATION OF ',
     $       'INITIAL CONDITION CASE = ',I3)
         STOP
      ENDIF
C
      END