c***FROM: http://www.netlib.org/quadpack/dqagse.f
      subroutine dqagse(f,a,b,epsabs,epsrel,limit,result,abserr,neval,
     *   ier,alist,blist,rlist,elist,iord,last)
c***begin prologue  dqagse
c***date written   800101   (yymmdd)
c***revision date  830518   (yymmdd)
c***category no.  h2a1a1
c***keywords  automatic integrator, general-purpose,
c             (end point) singularities, extrapolation,
c             globally adaptive
c***author  piessens,robert,appl. math. & progr. div. - k.u.leuven
c           de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***purpose  the routine calculates an approximation result to a given
c            definite integral i = integral of f over (a,b),
c            hopefully satisfying following claim for accuracy
c            abs(i-result).le.max(epsabs,epsrel*abs(i)).
c***description
c
c        computation of a definite integral
c        standard fortran subroutine
c        double precision version
c
c        parameters
c         on entry
c            f      - double precision
c                     function subprogram defining the integrand
c                     function f(x). the actual name for f needs to be
c                     declared e x t e r n a l in the driver program.
c
c            a      - double precision
c                     lower limit of integration
c
c            b      - double precision
c                     upper limit of integration
c
c            epsabs - double precision
c                     absolute accuracy requested
c            epsrel - double precision
c                     relative accuracy requested
c                     if  epsabs.le.0
c                     and epsrel.lt.max(50*rel.mach.acc.,0.5d-28),
c                     the routine will end with ier = 6.
c
c            limit  - integer
c                     gives an upperbound on the number of subintervals
c                     in the partition of (a,b)
c
c         on return
c            result - double precision
c                     approximation to the integral
c
c            abserr - double precision
c                     estimate of the modulus of the absolute error,
c                     which should equal or exceed abs(i-result)
c
c            neval  - integer
c                     number of integrand evaluations
c
c            ier    - integer
c                     ier = 0 normal and reliable termination of the
c                             routine. it is assumed that the requested
c                             accuracy has been achieved.
c                     ier.gt.0 abnormal termination of the routine
c                             the estimates for integral and error are
c                             less reliable. it is assumed that the
c                             requested accuracy has not been achieved.
c            error messages
c                         = 1 maximum number of subdivisions allowed
c                             has been achieved. one can allow more sub-
c                             divisions by increasing the value of limit
c                             (and taking the according dimension
c                             adjustments into account). however, if
c                             this yields no improvement it is advised
c                             to analyze the integrand in order to
c                             determine the integration difficulties. if
c                             the position of a local difficulty can be
c                             determined (e.g. singularity,
c                             discontinuity within the interval) one
c                             will probably gain from splitting up the
c                             interval at this point and calling the
c                             integrator on the subranges. if possible,
c                             an appropriate special-purpose integrator
c                             should be used, which is designed for
c                             handling the type of difficulty involved.
c                         = 2 the occurrence of roundoff error is detec-
c                             ted, which prevents the requested
c                             tolerance from being achieved.
c                             the error may be under-estimated.
c                         = 3 extremely bad integrand behaviour
c                             occurs at some points of the integration
c                             interval.
c                         = 4 the algorithm does not converge.
c                             roundoff error is detected in the
c                             extrapolation table.
c                             it is presumed that the requested
c                             tolerance cannot be achieved, and that the
c                             returned result is the best which can be
c                             obtained.
c                         = 5 the integral is probably divergent, or
c                             slowly convergent. it must be noted that
c                             divergence can occur with any other value
c                             of ier.
c                         = 6 the input is invalid, because
c                             epsabs.le.0 and
c                             epsrel.lt.max(50*rel.mach.acc.,0.5d-28).
c                             result, abserr, neval, last, rlist(1),
c                             iord(1) and elist(1) are set to zero.
c                             alist(1) and blist(1) are set to a and b
c                             respectively.
c
c            alist  - double precision
c                     vector of dimension at least limit, the first
c                      last  elements of which are the left end points
c                     of the subintervals in the partition of the
c                     given integration range (a,b)
c
c            blist  - double precision
c                     vector of dimension at least limit, the first
c                      last  elements of which are the right end points
c                     of the subintervals in the partition of the given
c                     integration range (a,b)
c
c            rlist  - double precision
c                     vector of dimension at least limit, the first
c                      last  elements of which are the integral
c                     approximations on the subintervals
c
c            elist  - double precision
c                     vector of dimension at least limit, the first
c                      last  elements of which are the moduli of the
c                     absolute error estimates on the subintervals
c
c            iord   - integer
c                     vector of dimension at least limit, the first k
c                     elements of which are pointers to the
c                     error estimates over the subintervals,
c                     such that elist(iord(1)), ..., elist(iord(k))
c                     form a decreasing sequence, with k = last
c                     if last.le.(limit/2+2), and k = limit+1-last
c                     otherwise
c
c            last   - integer
c                     number of subintervals actually produced in the
c                     subdivision process
c
c***references  (none)
c***routines called  d1mach,dqelg,dqk21,dqpsrt
c***end prologue  dqagse
c
      double precision a,abseps,abserr,alist,area,area1,area12,area2,a1,
     *  a2,b,blist,b1,b2,correc,dabs,defabs,defab1,defab2,d1mach,dmax1,
     *  dres,elist,epmach,epsabs,epsrel,erlarg,erlast,errbnd,errmax,
     *  error1,error2,erro12,errsum,ertest,f,oflow,resabs,reseps,result,
     *  res3la,rlist,rlist2,small,uflow
      integer id,ier,ierro,iord,iroff1,iroff2,iroff3,jupbnd,k,ksgn,
     *  ktmin,last,limit,maxerr,neval,nres,nrmax,numrl2
      logical extrap,noext
c
      dimension alist(limit),blist(limit),elist(limit),iord(limit),
     * res3la(3),rlist(limit),rlist2(52)
c
      external f
c
c            the dimension of rlist2 is determined by the value of
c            limexp in subroutine dqelg (rlist2 should be of dimension
c            (limexp+2) at least).
c
c            list of major variables
c            -----------------------
c
c           alist     - list of left end points of all subintervals
c                       considered up to now
c           blist     - list of right end points of all subintervals
c                       considered up to now
c           rlist(i)  - approximation to the integral over
c                       (alist(i),blist(i))
c           rlist2    - array of dimension at least limexp+2 containing
c                       the part of the epsilon table which is still
c                       needed for further computations
c           elist(i)  - error estimate applying to rlist(i)
c           maxerr    - pointer to the interval with largest error
c                       estimate
c           errmax    - elist(maxerr)
c           erlast    - error on the interval currently subdivided
c                       (before that subdivision has taken place)
c           area      - sum of the integrals over the subintervals
c           errsum    - sum of the errors over the subintervals
c           errbnd    - requested accuracy max(epsabs,epsrel*
c                       abs(result))
c           *****1    - variable for the left interval
c           *****2    - variable for the right interval
c           last      - index for subdivision
c           nres      - number of calls to the extrapolation routine
c           numrl2    - number of elements currently in rlist2. if an
c                       appropriate approximation to the compounded
c                       integral has been obtained it is put in
c                       rlist2(numrl2) after numrl2 has been increased
c                       by one.
c           small     - length of the smallest interval considered up
c                       to now, multiplied by 1.5
c           erlarg    - sum of the errors over the intervals larger
c                       than the smallest interval considered up to now
c           extrap    - logical variable denoting that the routine is
c                       attempting to perform extrapolation i.e. before
c                       subdividing the smallest interval we try to
c                       decrease the value of erlarg.
c           noext     - logical variable denoting that extrapolation
c                       is no longer allowed (true value)
c
c            machine dependent constants
c            ---------------------------
c
c           epmach is the largest relative spacing.
c           uflow is the smallest positive magnitude.
c           oflow is the largest positive magnitude.
c
c***first executable statement  dqagse
      epmach = d1mach(4)
c
c            test on validity of parameters
c            ------------------------------
      ier = 0
      neval = 0
      last = 0
      result = 0.0d+00
      abserr = 0.0d+00
      alist(1) = a
      blist(1) = b
      rlist(1) = 0.0d+00
      elist(1) = 0.0d+00
      if(epsabs.le.0.0d+00.and.epsrel.lt.dmax1(0.5d+02*epmach,0.5d-28))
     *   ier = 6
      if(ier.eq.6) go to 999
c
c           first approximation to the integral
c           -----------------------------------
c
      uflow = d1mach(1)
      oflow = d1mach(2)
      ierro = 0
      call dqk21(f,a,b,result,abserr,defabs,resabs)
c
c           test on accuracy.
c
      dres = dabs(result)
      errbnd = dmax1(epsabs,epsrel*dres)
      last = 1
      rlist(1) = result
      elist(1) = abserr
      iord(1) = 1
      if(abserr.le.1.0d+02*epmach*defabs.and.abserr.gt.errbnd) ier = 2
      if(limit.eq.1) ier = 1
      if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs).or.
     *  abserr.eq.0.0d+00) go to 140
c
c           initialization
c           --------------
c
      rlist2(1) = result
      errmax = abserr
      maxerr = 1
      area = result
      errsum = abserr
      abserr = oflow
      nrmax = 1
      nres = 0
      numrl2 = 2
      ktmin = 0
      extrap = .false.
      noext = .false.
      iroff1 = 0
      iroff2 = 0
      iroff3 = 0
      ksgn = -1
      if(dres.ge.(0.1d+01-0.5d+02*epmach)*defabs) ksgn = 1
c
c           main do-loop
c           ------------
c
      do 90 last = 2,limit
c
c           bisect the subinterval with the nrmax-th largest error
c           estimate.
c
        a1 = alist(maxerr)
        b1 = 0.5d+00*(alist(maxerr)+blist(maxerr))
        a2 = b1
        b2 = blist(maxerr)
        erlast = errmax
        call dqk21(f,a1,b1,area1,error1,resabs,defab1)
        call dqk21(f,a2,b2,area2,error2,resabs,defab2)
c
c           improve previous approximations to integral
c           and error and test for accuracy.
c
        area12 = area1+area2
        erro12 = error1+error2
        errsum = errsum+erro12-errmax
        area = area+area12-rlist(maxerr)
        if(defab1.eq.error1.or.defab2.eq.error2) go to 15
        if(dabs(rlist(maxerr)-area12).gt.0.1d-04*dabs(area12)
     *  .or.erro12.lt.0.99d+00*errmax) go to 10
        if(extrap) iroff2 = iroff2+1
        if(.not.extrap) iroff1 = iroff1+1
   10   if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1
   15   rlist(maxerr) = area1
        rlist(last) = area2
        errbnd = dmax1(epsabs,epsrel*dabs(area))
c
c           test for roundoff error and eventually set error flag.
c
        if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2
        if(iroff2.ge.5) ierro = 3
c
c           set error flag in the case that the number of subintervals
c           equals limit.
c
        if(last.eq.limit) ier = 1
c
c           set error flag in the case of bad integrand behaviour
c           at a point of the integration range.
c
        if(dmax1(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03*epmach)*
     *  (dabs(a2)+0.1d+04*uflow)) ier = 4
c
c           append the newly-created intervals to the list.
c
        if(error2.gt.error1) go to 20
        alist(last) = a2
        blist(maxerr) = b1
        blist(last) = b2
        elist(maxerr) = error1
        elist(last) = error2
        go to 30
   20   alist(maxerr) = a2
        alist(last) = a1
        blist(last) = b1
        rlist(maxerr) = area2
        rlist(last) = area1
        elist(maxerr) = error2
        elist(last) = error1
c
c           call subroutine dqpsrt to maintain the descending ordering
c           in the list of error estimates and select the subinterval
c           with nrmax-th largest error estimate (to be bisected next).
c
   30   call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax)
c ***jump out of do-loop
        if(errsum.le.errbnd) go to 115
c ***jump out of do-loop
        if(ier.ne.0) go to 100
        if(last.eq.2) go to 80
        if(noext) go to 90
        erlarg = erlarg-erlast
        if(dabs(b1-a1).gt.small) erlarg = erlarg+erro12
        if(extrap) go to 40
c
c           test whether the interval to be bisected next is the
c           smallest interval.
c
        if(dabs(blist(maxerr)-alist(maxerr)).gt.small) go to 90
        extrap = .true.
        nrmax = 2
   40   if(ierro.eq.3.or.erlarg.le.ertest) go to 60
c
c           the smallest interval has the largest error.
c           before bisecting decrease the sum of the errors over the
c           larger intervals (erlarg) and perform extrapolation.
c
        id = nrmax
        jupbnd = last
        if(last.gt.(2+limit/2)) jupbnd = limit+3-last
        do 50 k = id,jupbnd
          maxerr = iord(nrmax)
          errmax = elist(maxerr)
c ***jump out of do-loop
          if(dabs(blist(maxerr)-alist(maxerr)).gt.small) go to 90
          nrmax = nrmax+1
   50   continue
c
c           perform extrapolation.
c
   60   numrl2 = numrl2+1
        rlist2(numrl2) = area
        call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres)
        ktmin = ktmin+1
        if(ktmin.gt.5.and.abserr.lt.0.1d-02*errsum) ier = 5
        if(abseps.ge.abserr) go to 70
        ktmin = 0
        abserr = abseps
        result = reseps
        correc = erlarg
        ertest = dmax1(epsabs,epsrel*dabs(reseps))
c ***jump out of do-loop
        if(abserr.le.ertest) go to 100
c
c           prepare bisection of the smallest interval.
c
   70   if(numrl2.eq.1) noext = .true.
        if(ier.eq.5) go to 100
        maxerr = iord(1)
        errmax = elist(maxerr)
        nrmax = 1
        extrap = .false.
        small = small*0.5d+00
        erlarg = errsum
        go to 90
   80   small = dabs(b-a)*0.375d+00
        erlarg = errsum
        ertest = errbnd
        rlist2(2) = area
   90 continue
c
c           set final result and error estimate.
c           ------------------------------------
c
  100 if(abserr.eq.oflow) go to 115
      if(ier+ierro.eq.0) go to 110
      if(ierro.eq.3) abserr = abserr+correc
      if(ier.eq.0) ier = 3
      if(result.ne.0.0d+00.and.area.ne.0.0d+00) go to 105
      if(abserr.gt.errsum) go to 115
      if(area.eq.0.0d+00) go to 130
      go to 110
  105 if(abserr/dabs(result).gt.errsum/dabs(area)) go to 115
c
c           test on divergence.
c
  110 if(ksgn.eq.(-1).and.dmax1(dabs(result),dabs(area)).le.
     * defabs*0.1d-01) go to 130
      if(0.1d-01.gt.(result/area).or.(result/area).gt.0.1d+03
     * .or.errsum.gt.dabs(area)) ier = 6
      go to 130
c
c           compute global integral sum.
c
  115 result = 0.0d+00
      do 120 k = 1,last
         result = result+rlist(k)
  120 continue
      abserr = errsum
  130 if(ier.gt.2) ier = ier-1
  140 neval = 42*last-21
  999 return
      end


!> calculate Berry curvature
!> ref : Physical Review B 74, 195118(2006)
!> eqn (34)
!> Sep. 22 2015 by Quansheng Wu @ ETHZ
  subroutine berry_curvarture

     use para
     implicit none

     integer :: iR
     integer :: ik
     integer :: nk1, nk2

     integer :: m, n, i, j

     integer :: knv2
     integer :: ierr

     real(dp) :: kdotr
     real(dp) :: k(3)
     real(dp) :: k11(3), k12(3), k21(3), k22(3)

     !> R points coordinates (3, nrpts)
     real(dp), allocatable :: crvec(:, :)

     !> k points slice
     real(dp), allocatable :: kslice(:, :)
     real(dp), allocatable :: kslice_shape(:, :)

     ! eigen value of H
	  real(dp), allocatable :: W(:)
     complex(dp), allocatable :: Hamk_bulk(:, :)
     complex(dp), allocatable :: Amat(:, :)
     complex(dp), allocatable :: UU(:, :)
     complex(dp), allocatable :: UU_dag(:, :)

     !> velocities
     complex(dp), allocatable :: vx(:, :)
     complex(dp), allocatable :: vy(:, :)
     complex(dp), allocatable :: vz(:, :)
     complex(dp), allocatable :: DHDk(:, :, :)
     complex(dp), allocatable :: DHDkdag(:, :, :)

     !> Berry curvature  (3, bands, k)
     complex(dp), allocatable :: Omega(:, :)
     complex(dp), allocatable :: Omega_mpi(:, :)

     nk1= Nk
     nk2= Nk
     knv2= nk1*nk2
     allocate( kslice(3, knv2))
     allocate( kslice_shape(3, knv2))
     allocate( W       (Num_wann))
     allocate( crvec    (3, nrpts))
     allocate( Omega    (3, knv2))
     allocate( Omega_mpi(3, knv2))
     allocate( vx      (Num_wann, Num_wann))
     allocate( vy      (Num_wann, Num_wann))
     allocate( vz      (Num_wann, Num_wann))
     allocate( Hamk_bulk(Num_wann, Num_wann))
     allocate( Amat(Num_wann, Num_wann))
     allocate( UU(Num_wann, Num_wann))
     allocate( UU_dag(Num_wann, Num_wann))
     allocate( DHDk    (Num_wann, Num_wann, 3))
     allocate( DHDkdag (Num_wann, Num_wann, 3))
     kslice=0d0
     kslice_shape=0d0

     !TB
    !k11=(/-0.5d0,  0.0d0, -0.5d0/) !
    !k12=(/ 0.5d0,  0.0d0,  0.5d0/) ! X
    !k21=(/ 0.0d0,  0.5d0,  0.5d0/) !
    !k22=(/ 0.0d0, -0.5d0, -0.5d0/) ! Y
     !DFT
    !k11=(/ 0.0d0, -1.0d0, -1.0d0/) ! -X
    !k12=(/ 0.0d0,  1.0d0,  1.0d0/) ! X
    !k21=(/-1.0d0,  0.0d0, -1.0d0/) ! -Y
    !k22=(/ 1.0d0,  0.0d0,  1.0d0/) ! Y
     k11=(/ 0.0d0, -0.5d0, -0.5d0/) ! -X
     k12=(/ 0.0d0,  0.5d0,  0.5d0/) ! X
     k21=(/-0.5d0,  0.0d0, -0.5d0/) ! -Y
     k22=(/ 0.5d0,  0.0d0,  0.5d0/) ! Y

     ik =0
     do i= 1, nk1
        do j= 1, nk2
           ik =ik +1
           kslice(:, ik)= k11+ (k12-k11)*(i-1)/dble(nk1-1)  &
                     + k21+ (k22-k21)*(j-1)/dble(nk2-1)
           kslice_shape(:, ik)= kslice(1, ik)* Kua+ kslice(2, ik)* Kub+ kslice(3, ik)* Kuc
        enddo
     enddo

     !> get R coordinates
     do iR=1, Nrpts
        crvec(:, iR)= Rua*irvec(1,iR) + Rub*irvec(2,iR) + Ruc*irvec(3,iR)
     enddo

     do ik= 1+ cpuid, knv2, num_cpu
        if (cpuid==0) print *, ik, knv2

        !> diagonalize hamiltonian
        k= kslice(:, ik)

        ! calculation bulk hamiltonian
        UU= 0d0
        call ham_bulk(k, Hamk_bulk)

        !> diagonalization by call zheev in lapack
        W= 0d0
       !call eigensystem_c( 'V', 'U', Num_wann, UU, W)
        call utility_diagonalize(hamk_bulk,Num_wann, W, UU)

        UU_dag= conjg(transpose(UU))

        vx= 0d0
        vy= 0d0
        vz= 0d0
        do iR= 1, Nrpts
           kdotr= k(1)*irvec(1,iR) + k(2)*irvec(2,iR) + k(3)*irvec(3,iR)
           vx= vx+ zi*crvec(1, iR)*HmnR(:,:,iR)*Exp(pi2zi*kdotr)/ndegen(iR)
           vy= vy+ zi*crvec(2, iR)*HmnR(:,:,iR)*Exp(pi2zi*kdotr)/ndegen(iR)
           vz= vz+ zi*crvec(3, iR)*HmnR(:,:,iR)*Exp(pi2zi*kdotr)/ndegen(iR)
        enddo ! iR

        !> unitility rotate velocity
        call mat_mul(Num_wann, vx, UU, Amat)
        call mat_mul(Num_wann, UU_dag, Amat, vx)
        call mat_mul(Num_wann, vy, UU, Amat)
        call mat_mul(Num_wann, UU_dag, Amat, vy)
        call mat_mul(Num_wann, vz, UU, Amat)
        call mat_mul(Num_wann, UU_dag, Amat, vz)

        DHDk= 0d0
        DHDkdag= 0d0
        do m= 1, Num_wann
           do n= 1, Num_wann
              if (W(n) > 0d0 .and. W(m)<0d0) then
                 DHDk(n, m, 1)= zi*vx(n, m)/(W(m)-W(n))
                 DHDk(n, m, 2)= zi*vy(n, m)/(W(m)-W(n))
                 DHDk(n, m, 3)= zi*vz(n, m)/(W(m)-W(n))
              else
                 DHDk(n, m, 1)= 0d0
                 DHDk(n, m, 2)= 0d0
                 DHDk(n, m, 3)= 0d0
              endif
           enddo ! m
        enddo ! n

        do m= 1, Num_wann
           do n= 1, Num_wann
              if (W(m) > 0d0 .and. W(n)< 0d0) then
                 DHDkdag(n, m, 1)= zi*vx(n, m)/(W(m)-W(n))
                 DHDkdag(n, m, 2)= zi*vy(n, m)/(W(m)-W(n))
                 DHDkdag(n, m, 3)= zi*vz(n, m)/(W(m)-W(n))
              else
                 DHDkdag(n, m, 1)= 0d0
                 DHDkdag(n, m, 2)= 0d0
                 DHDkdag(n, m, 3)= 0d0
              endif
           enddo ! m
        enddo ! n

        !> rotate DHDk and DHDkdag to diagonal basis
        do i=1, 3
           call mat_mul(Num_wann, DHDk(:, :, i), UU_dag, Amat)
           call mat_mul(Num_wann, UU, Amat, DHDk(:, :, i))
           call mat_mul(Num_wann, DHDkdag(:, :, i), UU_dag, Amat)
           call mat_mul(Num_wann, UU, Amat, DHDkdag(:, :, i))
        enddo

        call mat_mul(Num_wann, DHDk(:, :, 1), DHDkdag(:, :, 2), vz)
        call mat_mul(Num_wann, DHDk(:, :, 2), DHDkdag(:, :, 3), vx)
        call mat_mul(Num_wann, DHDk(:, :, 3), DHDkdag(:, :, 1), vy)

        call Im_trace(Num_wann, vx, Omega(1, ik))
        call Im_trace(Num_wann, vy, Omega(2, ik))
        call Im_trace(Num_wann, vz, Omega(3, ik))

     enddo ! ik

     Omega_mpi= 0d0
     call mpi_allreduce(Omega,Omega_mpi,size(Omega_mpi),&
                       mpi_dc,mpi_sum,mpi_cmw,ierr)

     if (cpuid==0) then
        open(unit=18, file='berry.dat')
        ik= 0
        do i= 1, nk1
           do j= 1, nk2
              ik= ik+ 1
              write(18, '(20f18.10)')kslice_shape(:, ik), Omega_mpi(:, ik)
           enddo
           write(18, *) ' '
        enddo

        close(18)

     endif

     return

  end subroutine berry_curvarture

  subroutine Fourier_R_to_k(k, ham)
     use para
     implicit none

     real(dp), intent(in) :: k(3)
     complex(dp), intent(out) :: ham(Num_wann, Num_wann)
     integer :: iR
     real(dp) :: R(3)
     real(dp) :: kdotr

     ham= 0d0
     do iR= 1, Nrpts
        R= Rua*irvec(1,iR) + Rub*irvec(2,iR) + Ruc*irvec(3,iR)
        kdotr= k(1)*irvec(1,iR) + k(2)*irvec(2,iR) + k(3)*irvec(3,iR)
        Ham= Ham+ HmnR(:,:,iR)*Exp(2d0*pi*zi*kdotr)/ndegen(iR)
     enddo

     return
  end subroutine Fourier_R_to_k

  subroutine Im_trace(ndim, A, tr)
     use para, only : dp
     implicit none
     integer :: ndim
     complex(dp), intent(out) :: tr
     complex(dp), intent(in) :: A(ndim, ndim)

     integer :: i

     tr = 0d0
     do i=1, ndim
        tr= tr+ aimag(A(i, i))
     enddo

     return
  end subroutine Im_trace

  subroutine trace(ndim, A, tr)
     use para, only : dp
     implicit none
     integer :: ndim
     complex(dp), intent(out) :: tr
     complex(dp), intent(in) :: A(ndim, ndim)

     integer :: i

     tr = 0d0
     do i=1, ndim
        tr= tr+ (A(i, i))
     enddo

     return
  end subroutine trace


      implicit none
      integer ns,nt
      double precision, allocatable :: source(:,:)
      double precision, allocatable :: targ(:,:)
      double precision, allocatable :: charge(:)
      double precision, allocatable :: pot(:),potex(:)
      double precision, allocatable :: grad(:,:),gradex(:,:)
      double precision, allocatable :: pottarg(:),gradtarg(:,:)
      double precision, allocatable :: pottargex(:),gradtargex(:,:)

      double precision eps
      integer i,j,k,ntest
      double precision hkrand,thet,pi,erra,ra,thresh
      double precision tmp1,tmp2,tmp3,errg,rg

      pi = atan(1.0d0)*4.0d0

c
cc      initialize printing routine
c
      call prini(6,13)
      write(*,*)
      write(*,*)
      write(*,*) "================================="
      call prin2("This code is an example fortran driver*",i,0)
      call prin2("On output, the code prints sample pot,grad*",i,0)
      write(*,*)
      write(*,*)

      ns = 12716
      nt = 7500

      allocate(source(3,ns))
      allocate(targ(3,nt))
      allocate(charge(ns))
      allocate(pot(ns))
      allocate(grad(3,ns))
      allocate(pottarg(nt))
      allocate(gradtarg(3,nt))

      eps = 1.0d-6

      write(*,*) "=========================================="

c
c
c       example demonstrating use of
c        source to source, charges, pot + gradient
c

c
cc      generate sources uniformly in the unit cube
c
c
      open(unit=33,file='examples/srcloc1.txt')
      do i=1,ns
        read(33,*) tmp1,tmp2,tmp3
        source(1,i) = tmp1
        source(2,i) = tmp2
        source(3,i) = tmp3
        charge(i) = hkrand(0)
        pot(i) = 0
        grad(1,i) = 0
        grad(2,i) = 0
        grad(3,i) = 0
      enddo
      close(33)

      open(unit=33,file='examples/targloc1.txt')
      do i=1,nt
        read(33,*) tmp1,tmp2,tmp3
        targ(1,i) = tmp1
        targ(2,i) = tmp2
        targ(3,i) = tmp3
        pottarg(i) = 0
        gradtarg(1,i) = 0
        gradtarg(2,i) = 0
        gradtarg(3,i) = 0
      enddo
      close(33)

      call prin2('targ=*',targ,12)

      call lfmm3d_st_c_g(eps,ns,source,charge,pot,grad,
     1      nt,targ,pottarg,gradtarg)
      call prin2("pot at sources=*",pot,12)
cc      call prin2("grad at sources=*",grad,3*nt)

c
c      test accuracy
c

      ntest = 10
      allocate(potex(ntest),gradex(3,ntest))
      allocate(pottargex(ntest),gradtargex(3,ntest))
      thresh = 1.0d-16
      do i=1,ntest
        potex(i) = 0
        gradex(1,i) = 0
        gradex(2,i) = 0
        gradex(3,i) = 0

        pottargex(i) = 0
        gradtargex(1,i) = 0
        gradtargex(2,i) = 0
        gradtargex(3,i) = 0
      enddo
      call l3ddirectcg(1,source,charge,ns,source,ntest,
     1       potex,gradex,thresh)

      erra = 0
      ra = 0
      errg = 0
      rg = 0
      do i=1,ntest
         ra = ra + abs(potex(i))**2
         erra = erra + abs(pot(i)-potex(i))**2
         rg = rg + gradex(1,i)**2 + gradex(2,i)**2 + gradex(3,i)**2
         errg = errg + (gradex(1,i)-grad(1,i))**2
         errg = errg + (gradex(2,i)-grad(2,i))**2
         errg = errg + (gradex(3,i)-grad(3,i))**2
      enddo

      call prin2('potex=*',potex,ntest)
      call prin2('pot=*',pot,ntest)
      call prin2('gradex=*',gradex,3*ntest)
      call prin2('grad=*',grad,3*ntest)

      erra = sqrt(erra/ra)
      errg = sqrt(errg/rg)

      call prin2('error=*',erra,1)
      call prin2('error gradient=*',errg,1)

      call l3ddirectcg(1,source,charge,ns,targ,ntest,
     1       pottargex,gradtargex,thresh)

      erra = 0
      ra = 0
      errg = 0
      rg = 0
      do i=1,ntest
         ra = ra + abs(pottargex(i))**2
         erra = erra + abs(pottarg(i)-pottargex(i))**2
         rg = rg + gradtargex(1,i)**2 + gradtargex(2,i)**2 +
     1      gradtargex(3,i)**2
         errg = errg + (gradtargex(1,i)-gradtarg(1,i))**2
         errg = errg + (gradtargex(2,i)-gradtarg(2,i))**2
         errg = errg + (gradtargex(3,i)-gradtarg(3,i))**2
      enddo

      call prin2('potex=*',pottargex,ntest)
      call prin2('pot=*',pottarg,ntest)
      call prin2('gradex=*',gradtargex,3*ntest)
      call prin2('grad=*',gradtarg,3*ntest)

      erra = sqrt(erra/ra)
      errg = sqrt(errg/rg)

      call prin2('error=*',erra,1)
      call prin2('error gradient=*',errg,1)

      stop
      end
c----------------------------------------------------------
c
cc
c
c


      SUBROUTINE fourfs(iunit,nn,ndim,isign)
      INTEGER ndim,nn(ndim),isign,iunit(4),KBF
      PARAMETER (KBF=128)
CU    USES fourew
      INTEGER j,j12,jk,k,kk,n,mm,kc,kd,ks,kr,nr,ns,nv,jx,mate(4),na,nb,
     *nc,nd
      REAL tempr,tempi,afa(KBF),afb(KBF),afc(KBF)
      DOUBLE PRECISION wr,wi,wpr,wpi,wtemp,theta
      SAVE mate
      DATA mate /2,1,4,3/
      n=1
      do 11 j=1,ndim
        n=n*nn(j)
        if (nn(j).le.1)pause 'invalid dimension or wrong ndim in fourfs'
11    continue
      nv=ndim
      jk=nn(nv)
      mm=n
      ns=n/KBF
      nr=ns/2
      kc=0
      kd=KBF/2
      ks=n
      call fourew(iunit,na,nb,nc,nd)
1     continue
        theta=3.141592653589793d0/(isign*n/mm)
        wpr=-2.d0*sin(0.5d0*theta)**2
        wpi=sin(theta)
        wr=1.d0
        wi=0.d0
        mm=mm/2
        do 13 j12=1,2
          kr=0
2         continue
            read (iunit(na)) (afa(jx),jx=1,KBF)
            read (iunit(nb)) (afb(jx),jx=1,KBF)
            do 12 j=1,KBF,2
              tempr=sngl(wr)*afb(j)-sngl(wi)*afb(j+1)
              tempi=sngl(wi)*afb(j)+sngl(wr)*afb(j+1)
              afb(j)=afa(j)-tempr
              afa(j)=afa(j)+tempr
              afb(j+1)=afa(j+1)-tempi
              afa(j+1)=afa(j+1)+tempi
12          continue
            kc=kc+kd
            if (kc.eq.mm) then
              kc=0
              wtemp=wr
              wr=wr*wpr-wi*wpi+wr
              wi=wi*wpr+wtemp*wpi+wi
            endif
            write (iunit(nc)) (afa(jx),jx=1,KBF)
            write (iunit(nd)) (afb(jx),jx=1,KBF)
          kr=kr+1
          if (kr.lt.nr) goto 2
          if(j12.eq.1.and.ks.ne.n.and.ks.eq.KBF) then
            na=mate(na)
            nb=na
          endif
          if (nr.eq.0) goto 3
13      continue
3       call fourew(iunit,na,nb,nc,nd)
        jk=jk/2
4       if (jk.eq.1) then
          mm=n
          nv=nv-1
          jk=nn(nv)
        goto 4
        endif
        ks=ks/2
        if (ks.gt.KBF) then
          do 16 j12=1,2
            do 15 kr=1,ns,ks/KBF
              do 14 k=1,ks,KBF
                read (iunit(na)) (afa(jx),jx=1,KBF)
                write (iunit(nc)) (afa(jx),jx=1,KBF)
14            continue
              nc=mate(nc)
15          continue
            na=mate(na)
16        continue
          call fourew(iunit,na,nb,nc,nd)
          goto 1
        else if (ks.eq.KBF) then
          nb=na
          goto 1
        endif
      continue
      j=1
5     continue
        theta=3.141592653589793d0/(isign*n/mm)
        wpr=-2.d0*sin(0.5d0*theta)**2
        wpi=sin(theta)
        wr=1.d0
        wi=0.d0
        mm=mm/2
        ks=kd
        kd=kd/2
        do 18 j12=1,2
          do 17 kr=1,ns
            read (iunit(na)) (afc(jx),jx=1,KBF)
            kk=1
            k=ks+1
6           continue
              tempr=sngl(wr)*afc(kk+ks)-sngl(wi)*afc(kk+ks+1)
              tempi=sngl(wi)*afc(kk+ks)+sngl(wr)*afc(kk+ks+1)
              afa(j)=afc(kk)+tempr
              afb(j)=afc(kk)-tempr
              afa(j+1)=afc(kk+1)+tempi
              afb(j+1)=afc(kk+1)-tempi
              j=j+2
              kk=kk+2
            if (kk.lt.k) goto 6
            kc=kc+kd
            if (kc.eq.mm) then
              kc=0
              wtemp=wr
              wr=wr*wpr-wi*wpi+wr
              wi=wi*wpr+wtemp*wpi+wi
            endif
            kk=kk+ks
            if (kk.le.KBF) then
              k=kk+ks
              goto 6
            endif
            if (j.gt.KBF) then
              write (iunit(nc)) (afa(jx),jx=1,KBF)
              write (iunit(nd)) (afb(jx),jx=1,KBF)
              j=1
            endif
17        continue
          na=mate(na)
18      continue
        call fourew(iunit,na,nb,nc,nd)
        jk=jk/2
      if (jk.gt.1) goto 5
      mm=n
7     if (nv.gt.1) then
        nv=nv-1
        jk=nn(nv)
        if (jk.eq.1) goto 7
        goto 5
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/fourfs.for


program climate_simulation
    use systemparams
    implicit none
	read(*,*) parameter_file
	read(*,*) run_status
	result_path = "./outputs/results/"//"result."//parameter_file
	parameter_path = "./outputs/parameters/"//parameter_file
    print*,
    print*,"simulating ",parameter_file
    open(61,file = result_path,status="replace")
    allocate(f_time(nx+1))
    f_time = 0.0
    call system_setup
    call paramters_update
    r_p = 2*pi / phidot

    dt = sim_time
    call step_forwards
    time =time+dt
    call paramters_update
    T_max = freeze + 0.9*(boil - freeze)
    timeyr = time/year
    T_mean_old = sum(T)/size(T)
    do while (timeyr<sim_time)
        call grid_updator
        call paramters_update
        timeyr = time/year
        if (timeyr>freq*snapshot) then
            if(snapshot<=9) then
               write(fileno,'(I1)') snapshot
            else if(snapshot>9.and.snapshot<=99) then
               write(fileno,'(I2)') snapshot
            else if(snapshot>99.and.snapshot<=999) then
               write(fileno,'(I3)') snapshot
            else if(snapshot>999.and.snapshot<=9999) then
               write(fileno,'(I4)') snapshot
            else if(snapshot>9999.and.snapshot<=99999) then
               write(fileno,'(I5)') snapshot
            end if
            filename = './outputs/snapshots/'//trim(fileno)
            snapshot = snapshot +1

            open(12,file=filename, status="replace")
            do i=1,nx
                write(12,*) timeyr, latdeg(i), T(i)
            end do
                write(12,*)
            close(12)

         end if
         call step_forwards
         time =time+dt
        if (timeyr >= yr10/year - r_p/year) then
            do i=1,nx+1
                f_time(i) = f_time(i) + hab(i)*dt/r_p
            end do
        end if

        do i=1,nx+1
            habfraction = habfraction + 0.5*hab(i)*cos(lat(i))*dlat
        end do
        counter = counter + 1
        mean_hab = mean_hab + habfraction
        mean2_hab = mean2_hab + habfraction*habfraction

        if (timeyr >= yr10/year) then
            old_mean_hab = mean_hab
			old_mean2_hab = mean2_hab
			old_counter = counter
			mean_hab = 0.0
			mean2_hab = 0.0
			counter = 0
			T_mean_new = sum(T)/size(T)
			temp_int = yr10/year
            yr10 = yr10 + year*10
            if (run_status == "multi_planet") then
                if (abs(T_mean_new-T_mean_old) < 0.01.or. (timeyr >= sim_time - yr10/year)) then
                    exit
                else
                f_time = 0.0
                end if
		    end if
        end if
        T_mean_new = sum(T)/size(T)
        T_mean_old = T_mean_new
	    habfraction = 0.0

    end do

    if ( T_mean_new > T_min .or. T_mean_new < T_max ) then
	    do i=1,nx+1
            hh = hh + 0.5*f_time(i)*COS(lat(i))*dlat
		end do
        do i=1,nx+1
            if (f_time(i) > 0.98 ) then
                hc = hc + 0.5*f_time(i)*COS(lat(i))*dlat
            else
                hc = hc + 0.0
            end if
        end do
	else
		 hh = 0.0
		 hc = 0.0
    end if

    write(temp_str,*) habfrac
    write(61,*) adjustl(trim(temp_str))
    write(temp_str,*) meanT
    write(61,*) adjustl(trim(temp_str))

	old_mean_hab = old_mean_hab/(old_counter+0.01)
	old_mean2_hab = old_mean2_hab/(old_counter+0.01)
	old_mean2_hab = sqrt(old_mean2_hab-old_mean_hab**2)

	if (old_mean_hab < 0.1) then
		if (sum(T)/size(T) >= 373) then
			write(temp_str,*) 1  ! for hot
			write(61,'(a)') adjustl(trim(temp_str))
		else
			write(temp_str,*) -1 ! for snowball
			write(61,'(a)') adjustl(trim(temp_str))
		end if
	else if (old_mean_hab > 0.1 .and. old_mean2_hab <  0.1*old_mean_hab)  then
	  write(temp_str,*) 0 ! for habitable
			write(61,'(a)') adjustl(trim(temp_str))
	else if (old_mean_hab > 0.1 .and. old_mean2_hab > 0.1*old_mean_hab) then
		write(temp_str,*) 10  !for tansient
		write(61,'(a)') adjustl(trim(temp_str))
	end if
    write(temp_str,*) maxval(T)
    write(61,*) adjustl(trim(temp_str))
    write(temp_str,*) minval(T)
    write(61,*) adjustl(trim(temp_str))
    close(76)
	close(61)
end program climate_simulation


!>
!! Solve linear system Ax=b using multigrid method
!! By Allan P. Engsig-Karup.
!<
RECURSIVE SUBROUTINE MultiGridSolver(x,b,k,gam,cyclet,Nxf,Nyf,Nzf,Nxc,Nyc,Nzc,GhostGridX,GhostGridY,GhostGridZ,alpha,beta,gamma)
USE Constants
USE MGLevels
USE HSL_LU
USE GlobalVariables, ONLY: curvilinearONOFF, filename, formattype
IMPLICIT NONE
INTEGER               :: gam, i, k, GhostGridX, GhostGridY, GhostGridZ, nnz, n_rows, alpha, beta, gamma
INTEGER               :: Nxf,Nyf,Nzf,Nxc,Nyc,Nzc, ii, jj, kk, count
CHARACTER(len=1)      :: cyclet
REAL(KIND=long), DIMENSION((Nxf+2*GhostGridX)*(Nyf+2*GhostGridY)*(Nzf+GhostGridZ)), INTENT(INOUT) :: x
REAL(KIND=long), DIMENSION((Nxf+2*GhostGridX)*(Nyf+2*GhostGridY)*(Nzf+GhostGridZ)) :: dxf, r, Ax, tmp
REAL(KIND=long), DIMENSION((Nxf+2*GhostGridX)*(Nyf+2*GhostGridY)*(Nzf+GhostGridZ)), INTENT(IN) :: b
REAL(KIND=long), DIMENSION((Nxc+2*GhostGridX)*(Nyc+2*GhostGridY)*(Nzc+GhostGridZ)) :: dxc, rc

!print*,'k=',k
!print*,'b=',b
!print*,'x=',x
!print*,'***************************************'
!read*

! If we are on the coarsest grid:
IF (k == 1) THEN

if (1==1) THEN
	! FIXME: LET'S NOT DETERMINE nnz AND Nr EVERY TIME WE SOLVE... BUT NEVERMIND FOR NOW
	nnz = SIZE(arrLevels(k)%PreconditioningMatrix%val)
    n_rows = (arrLevels(k)%Nx+2*GhostGridX)*(arrLevels(k)%Ny+2*GhostGridY)*(arrLevels(k)%Nz+GhostGridZ)

    ! Gaussian elimination:
    JOB = 3 ! Solution:
	x = b; ! Use right hand side as input using the vector x which will contain the output (=solution) on return
!print*,'MA41AD:'
!print*,'xIN=',x
!print*,'arrLevels(k)%PreconditioningMatrix%val     = ',arrLevels(k)%PreconditioningMatrix%val
!print*,'arrLevels(k)%PreconditioningMatrix%col_ind = ',arrLevels(k)%PreconditioningMatrix%col_ind
!print*,'arrLevels(k)%PreconditioningMatrix%row_ptr = ',arrLevels(k)%PreconditioningMatrix%row_ptr
	CALL MA41AD(JOB, n_rows, nnz, arrLevels(k)%PreconditioningMatrix%row_ptr, &
	    arrLevels(k)%PreconditioningMatrix%col_ind, arrLevels(k)%PreconditioningMatrix%val, x, COLSCA, ROWSCA, KEEP, &
	    IS_HSL, MAXIS, SS, MAXS, CNTL, ICNTL, INFOHSL, RINFO)
	IF (INFOHSL(1) .LT. 0) THEN ! Check for problems
		PRINT *, 'Problems with MA41, JOB = 3 (Solution), direct LU solver on coarsest level of the Multigrid method.'
    END IF

!print*,'MA41AD:'
!print*,'xOUT=',x
!read*

ELSE
! Check that smoother works
    DO i = 1 , 200
		CALL GaussSeidel(x,b,arrLevels(k)%IterationMatrix)
    END DO

END IF

    ! Choose cycle type:
    IF (cyclet == 'F') gam = 1

ELSE

IF (0==1) THEN
	! Test operators
    ! Restrict -> Prolongate -> check fine grid solution
    tmp = zero
    count = 0
    print*,'Nx=',arrLevels(k)%Nx
    print*,'Ny=',arrLevels(k)%Ny
    print*,'Nz=',arrLevels(k)%Nz
    DO jj = 1+GhostGridY, arrLevels(k)%Ny+2*GhostGridY
        DO ii = 1+GhostGridX, arrLevels(k)%Nx+2*GhostGridX
            DO kk = 1+GhostGridZ, arrLevels(k)%Nz
            print*,'(i,j,k) = (',ii,',',jj,',',kk,')'
                count = kk + (jj-1)*(arrLevels(k)%Nx+2*GhostGridX)*(arrLevels(k)%Nz+GhostGridZ)&
                      + (ii-1)*(arrLevels(k)%Nz+GhostGridZ)
                tmp(count) = arrLevels(k)%x(ii,jj)
                tmp(count) = arrLevels(k)%z(kk)
!                print*,'x=',tmp(count)
                print*,'z=',tmp(count)
                print*,'count=',count
            END DO
        END DO
    END DO
    print*,'tmp=',tmp
!	tmp = arrLevels(k)%x
	CALL MGRestriction3DExplicit(tmp,rc,arrLevels(k),arrLevels(k-1),GhostGridX,GhostGridY,GhostGridZ,arrLevels(k)%Nz+GhostGridZ,&
    	arrLevels(k)%Nx+2*GhostGridX,arrLevels(k)%Ny+2*GhostGridY,arrLevels(k-1)%Nz+GhostGridZ,arrLevels(k-1)%Nx+2*GhostGridX,&
        arrLevels(k-1)%Ny+2*GhostGridY )
	filename = "R.bin"
	CALL StoreRealArray3D(rc,arrLevels(k-1)%Nx+2*GhostGridX,arrLevels(k-1)%Ny+2*GhostGridY,arrLevels(k-1)%Nz+GhostGridZ,filename,&
	formattype)
    print*,'rc=',rc
!		rc = one
!        print*,'rc=',rc
        print*,'arrLEvels%x=',arrLevels(k-1)%x
!        rc = arrLevels(k-1)%x
			CALL MGProlongation3DExplicit(tmp,rc,arrLevels(k),arrLevels(k-1),GhostGridX,GhostGridY,GhostGridZ,arrLevels(k)%Nz+GhostGridZ,&
	     arrLevels(k)%Nx+2*GhostGridX,arrLevels(k)%Ny+2*GhostGridY,arrLevels(k-1)%Nz+GhostGridZ,arrLevels(k-1)%Nx+2*GhostGridX,&
         arrLevels(k-1)%Ny+2*GhostGridY )
	filename = "P.bin"
	CALL StoreRealArray3D(tmp,arrLevels(k)%Nx+2*GhostGridX,arrLevels(k)%Ny+2*GhostGridY,arrLevels(k)%Nz+GhostGridZ,filename,formattype)
    print*,'tmp=',tmp
	STOP
END IF

! Check that smoother works
!    DO i = 1 , 200
!		CALL GaussSeidel(x,b,arrLevels(k)%IterationMatrix)
!    END DO

if (1==1) THEN
    ! Pre-smoothing;
		CALL GaussSeidelSpecialPoints(x,b,arrLevels(k)%IterationMatrix,arrLevels(k)%iGhost,arrLevels(k)%mapNp)
!        print*,'x before smoothing=',x
    DO i = 1 , nu(1)
		CALL GaussSeidel(x,b,arrLevels(k)%IterationMatrix)
!        print*,'ighostpoints=',arrLevels(k)%iGhost
!        print*,'mapNp=',arrLevels(k)%mapNp
!        stop
		CALL GaussSeidelSpecialPoints(x,b,arrLevels(k)%IterationMatrix,arrLevels(k)%iGhost,arrLevels(k)%mapNp)
!		CALL GaussSeidelARRAYback(x,b,arrLevels(k),GhostGridX, GhostGridY, GhostGridZ, alpha, beta, gamma ) ! Initial guess is always zero, so call this one instead
!		CALL GaussSeidelARRAY(x,b,arrLevels(k),GhostGridZ, alpha, beta, gamma )
    END DO
!        print*,'x after smoothing=',x

    ! Residual/defect
!	IF (curvilinearONOFF==1) THEN
!		CALL BuildLinearSystemTransformedCurvilinear(arrLevels(k)%Nx+2*GhostGridX,arrLevels(k)%Ny+2*GhostGridY,arrLevels(k)%Nz+GhostGridZ,x,Ax,arrLevels(k),alpha,beta,gamma)
!	ELSE
!		CALL BuildLinearSystem(arrLevels(k)%Nx+2*GhostGridX,arrLevels(k)%Ny+2*GhostGridY,arrLevels(k)%Nz+GhostGridZ,x,Ax,arrLevels(k),alpha,beta,gamma)
!	ENDIF
	! Sparse matrix-vector product (SPARSKIT2 lib routine)
!	Ax = zero
!print*,'x=',x
!print*,'b=',b
!print*,'matrx=',arrLevels(k)%IterationMatrix%val
	CALL amux(arrLevels(k)%IterationMatrix%nrow, x, Ax, arrLevels(k)%IterationMatrix%val,arrLevels(k)%IterationMatrix%col_ind,&
    	arrLevels(k)%IterationMatrix%row_ptr)
	r = b-Ax
!    print*,'r=',r

!print*,'========================================================================='
!    read*
    ! Source on coarser grid:
	! We restrict the residual for the computational domain, but what about the ghost layer?
!	rc = zero
	CALL MGRestriction3DExplicit(r,rc,arrLevels(k),arrLevels(k-1),GhostGridX,GhostGridY,GhostGridZ,arrLevels(k)%Nz+GhostGridZ,&
    	arrLevels(k)%Nx+2*GhostGridX,arrLevels(k)%Ny+2*GhostGridY,arrLevels(k-1)%Nz+GhostGridZ,arrLevels(k-1)%Nx+2*GhostGridX,&
        arrLevels(k-1)%Ny+2*GhostGridY )
    dxc = zero
    DO i = 1, gam
        ! Recursive call to MultiGrid solver
		CALL MultiGridSolver(dxc,rc,k-1,gam,cyclet,Nxc,Nyc,Nzc,arrLevels(k-1)%Nx,arrLevels(k-1)%Ny,arrLevels(k-1)%Nz,&
		     GhostGridX, GhostGridY, GhostGridZ, alpha, beta, gamma)
        IF (k==MG_N_levels .AND. cyclet == 'W') EXIT
        IF (k==MG_N_levels .AND. cyclet == 'F') EXIT
    END DO

    ! Correct the guess (u = u* + u'):
!	dxf = zero
	CALL MGProlongation3DExplicit(dxf,dxc,arrLevels(k),arrLevels(k-1),GhostGridX,GhostGridY,GhostGridZ,arrLevels(k)%Nz+GhostGridZ,&
	     arrLevels(k)%Nx+2*GhostGridX,arrLevels(k)%Ny+2*GhostGridY,arrLevels(k-1)%Nz+GhostGridZ,arrLevels(k-1)%Nx+2*GhostGridX,&
         arrLevels(k-1)%Ny+2*GhostGridY )
	x = x + dxf
    ! impose BCs
!    CALL GaussSeidelSpecialPoints(x,b,arrLevels(k)%IterationMatrix,arrLevels(k)%iGhost,arrLevels(k)%mapNp)

    ! Post-smooting;
		CALL GaussSeidelSpecialPoints(x,b,arrLevels(k)%IterationMatrix,arrLevels(k)%iGhost,arrLevels(k)%mapNp)
    DO i = 1 , nu(2)
		CALL GaussSeidel(x,b,arrLevels(k)%IterationMatrix)
!	filename = "u.bin"
!	CALL StoreRealArray3D(x,arrLevels(k)%Nx+2*GhostGridX,arrLevels(k)%Ny+2*GhostGridY,arrLevels(k)%Nz+GhostGridZ,filename,formattype)
!	STOP
		CALL GaussSeidelSpecialPoints(x,b,arrLevels(k)%IterationMatrix,arrLevels(k)%iGhost,arrLevels(k)%mapNp)
!	filename = "u2.bin"
!	CALL StoreRealArray3D(x,arrLevels(k)%Nx+2*GhostGridX,arrLevels(k)%Ny+2*GhostGridY,arrLevels(k)%Nz+GhostGridZ,filename,formattype)
!	STOP
!		CALL GaussSeidelReverse(x,b,arrLevels(k)%IterationMatrix)
!		CALL GaussSeidelARRAY(x,b,arrLevels(k),GhostGridX,GhostGridY,GhostGridZ, alpha, beta, gamma )
    END DO

END IF

END IF

END SUBROUTINE MultiGridSolver


!---------------------------------------------------!
! Copyright (c) 2020 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine add_impulsive_distortion
  use global_variables
  implicit none
  integer :: ikr,ikz,ik
  complex(8) :: alpha

!$omp parallel do private(ikz)
  do ikz = -NKz,NKz
    kz(ikz) = kz0(ikz) + Act(0)
  end do

  call set_deps

!$omp parallel do private(ikz,ikr,alpha)
  do ikz = -NKz,NKz
    do ikr = 1,NKr
      alpha = piz_vc*kick_impulsive/deps(ikr,ikz)
      zCt(1,ikr,ikz) = 1d0/sqrt(1d0 + alpha**2)
      zCt(2,ikr,ikz) = -alpha/sqrt(1d0 + alpha**2)
    end do
  end do

end subroutine add_impulsive_distortion


!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||

 module operators

!BOP
! !MODULE: operators
!
! !DESCRIPTION:
! This module contains routines for various common
! mathematical operators, including gradient, divergence, curl,
! and a vertical velocity calculation. Note that these routines
! do {\em not} update ghost cells so results contain invalid
! entries in some ghost cells.
!
! !REVISION HISTORY:
! CVS:$Id: operators.F90,v 1.5 2002/11/27 17:53:21 pwjones Exp $
! CVS:$Name: POP_2_0_1 $

! !USES:

   use kinds_mod
   use blocks
   use domain_size
   use domain
   use constants
   use grid

   implicit none
   private
   save

! !PUBLIC MEMBER FUNCTIONS:
   public :: div, &
             grad, &
             zcurl, &
             wcalc

!EOP
!BOC
!EOC
!***********************************************************************

 contains

!***********************************************************************
!BOP
! !IROUTINE: div
! !INTERFACE:

 subroutine div(k,DIV_OUT,UX,UY,this_block)

! !DESCRIPTION:
! This routine returns the divergence at T points (times the cell
! area) of a vector field defined at U points. The divergence
! operator is defined as:
!
! \begin{equation}
! \nabla\cdot{\bf\rm u} = {1\over{\Delta_y}} \delta_x (\Delta_y u_x) +
! {1\over{\Delta_x}} \delta_y (\Delta_x u_y)
! \end{equation}
!
! !REVISION HISTORY:
! same as module

! !INPUT PARAMETERS

   integer (int_kind), intent(in) :: k ! vertical level

   real (r8), dimension(nx_block,ny_block), intent(in) :: &
      UX,UY ! vector field defined at U-points

   type (block), intent(in) :: &
      this_block ! block information for current block

! !OUTPUT PARAMETERS:

   real (r8), dimension(nx_block,ny_block), intent(out) :: &
      DIV_OUT ! divergence at T-points times cell area

!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------

   integer (int_kind) :: &
      i,j, &! dummy counters
      bid ! local block id

!-----------------------------------------------------------------------
!
! compute divergence using a 4 point stencil
!
!-----------------------------------------------------------------------

   bid = this_block%local_id

! DIV_OUT(1,:) = c0
! DIV_OUT(:,1) = c0
!
! do j=2,ny_block
! do i=2,nx_block
! DIV_OUT(i,j) = p5*(UX(i ,j )*DYU(i ,j ,bid) + &
! UX(i ,j-1)*DYU(i ,j-1,bid) - &
! UX(i-1,j )*DYU(i-1,j ,bid) - &
! UX(i-1,j-1)*DYU(i-1,j-1,bid) + &
! UY(i ,j )*DXU(i ,j ,bid) + &
! UY(i-1,j )*DXU(i-1,j ,bid) - &
! UY(i ,j-1)*DXU(i ,j-1,bid) - &
! UY(i-1,j-1)*DXU(i-1,j-1,bid))
! end do
! end do
!
! where (k > KMT(:,:,bid)) DIV_OUT = c0
    call div_1d(k,DIV_OUT,UX,UY,DXU(:,:,bid),DYU(:,:,bid),KMT(:,:,bid))

!-----------------------------------------------------------------------
!EOC

 end subroutine div

!DIR$ ATTRIBUTES FORCEINLINE :: div_1d
 subroutine div_1d(k,DIV_OUT,UX,UY,DXU,DYU,KMT)

! !DESCRIPTION:
!
! !REVISION HISTORY:
! same as module

! !INPUT PARAMETERS

   integer (int_kind), intent(in) :: k ! vertical level

   real (r8), dimension(1:nx_block*ny_block), intent(in) :: &
      UX,UY, &! vector field defined at U-points
      DXU,DYU ! vector field defined at U-points

   integer (int_kind), dimension(1:nx_block*ny_block), intent(in) :: &
      KMT

! !OUTPUT PARAMETERS:

   real (r8), dimension(1:nx_block*ny_block), intent(out) :: &
      DIV_OUT ! divergence at T-points times cell area

!EOP
!BOC

!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------

   integer (int_kind) :: &
     i,j ! dummy indices

!-----------------------------------------------------------------------
!
! compute divergence using a 4 point stencil
!
!-----------------------------------------------------------------------

   DIV_OUT(1+(1-1)*nx_block:1+(ny_block-1)*nx_block) = c0
   DIV_OUT(1+(1-1)*nx_block:nx_block+(1-1)*nx_block) = c0

   do j=2,ny_block
   do i=2,nx_block
      DIV_OUT((i)+(j-1)*nx_block) = p5*(UX((i )+(j -1)*nx_block)*DYU((i )+(j -1)*nx_block) + &
                         UX((i )+(j-1-1)*nx_block)*DYU((i )+(j-1-1)*nx_block) - &
                         UX((i-1)+(j -1)*nx_block)*DYU((i-1)+(j -1)*nx_block) - &
                         UX((i-1)+(j-1-1)*nx_block)*DYU((i-1)+(j-1-1)*nx_block) + &
                         UY((i )+(j -1)*nx_block)*DXU((i )+(j -1)*nx_block) + &
                         UY((i-1)+(j -1)*nx_block)*DXU((i-1)+(j -1)*nx_block) - &
                         UY((i )+(j-1-1)*nx_block)*DXU((i )+(j-1-1)*nx_block) - &
                         UY((i-1)+(j-1-1)*nx_block)*DXU((i-1)+(j-1-1)*nx_block))
   end do
   end do

   where (k > KMT) DIV_OUT = c0

!-----------------------------------------------------------------------
!EOC

 end subroutine div_1d

!***********************************************************************
!BOP
! !IROUTINE: grad
! !INTERFACE:

 subroutine grad(k, GRADX, GRADY, F, this_block)

! !DESCRIPTION:
! This routine computes the gradient in i,j directions at U points
! based on field defined at T-points.
!
! \begin{eqnarray}
! \nabla_x(F) &=& \delta_x F \! \nabla_y(F) &=& \delta_y F

! \end{eqnarray}
!
! !REVISION HISTORY:
! same as module

! !INPUT PARAMETERS:

   integer (int_kind), intent(in) :: k ! vertical level

   real (r8), dimension(nx_block,ny_block), intent(in) :: &
      F ! field defined at T points

   type (block), intent(in) :: &
      this_block ! block information for current block

! !OUTPUT PARAMETERS:

   real (r8), dimension(nx_block,ny_block), intent(out) :: &
      GRADX,GRADY ! gradient in (i,j) direction at U points

!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------

   integer (int_kind) :: &
      i,j, &! dummy counters
      bid ! local block id

!-----------------------------------------------------------------------
!
! compute gradient with a 4 point stencil
!
!-----------------------------------------------------------------------

   bid = this_block%local_id

   GRADX = c0
   GRADY = c0

   do j=1,ny_block-1
   do i=1,nx_block-1
      GRADX(i,j) = DXUR(i,j,bid)*p5*(F(i+1,j+1) - F(i ,j) - &
                                     F(i ,j+1) + F(i+1,j))
      GRADY(i,j) = DYUR(i,j,bid)*p5*(F(i+1,j+1) - F(i ,j) + &
                                     F(i ,j+1) - F(i+1,j))
   end do
   end do

   where (k > KMU(:,:,bid))
      GRADX = c0 ! zero at land points
      GRADY = c0
   endwhere

!-----------------------------------------------------------------------
!EOC

 end subroutine grad

!***********************************************************************
!BOP
! !IROUTINE: zcurl
! !INTERFACE:

 subroutine zcurl(k,CURL,UX,UY,this_block)

! !DESCRIPTION:
! This function returns the z-component of the curl of a vector
! field defined at U points.
!
! \begin{equation}
! \hat{\bf\rm z}\cdot\nabla\times{\bf\rm u} =
! {1\over{\Delta_y}} \delta_x(\Delta_y u_y) -
! {1\over{\Delta_x}} \delta_y(\Delta_x u_x)
! \end{equation}
!
! The result is actually multiplied by cell area and returned at
! T points.
!
! !REVISION HISTORY:
! same as module

! !INPUT PARAMETERS:

   integer (int_kind), intent(in) :: k ! vertical level

   real (r8), dimension(nx_block,ny_block), intent(in) :: &
      UX,UY ! vector field defined at U-points

   type (block), intent(in) :: &
      this_block ! block information for current block

! !OUTPUT PARAMETERS:

   real (r8), dimension(nx_block,ny_block), intent(out) :: &
      CURL ! z.curl(Ux,Uy) at T-points times cell area

!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------

   integer (int_kind) :: &
      i,j, &! dummy counters
      bid ! local block index

!-----------------------------------------------------------------------
!
! compute curl using stencil similar to divergence 4 point stencil
!
!-----------------------------------------------------------------------

   bid = this_block%local_id

   CURL(1,:) = c0
   CURL(:,1) = c0

   do j=2,ny_block
   do i=2,nx_block
      CURL(i,j) = p5*(UY(i ,j )*DYU(i ,j ,bid) + &
                      UY(i ,j-1)*DYU(i ,j-1,bid) - &
                      UY(i-1,j )*DYU(i-1,j ,bid) - &
                      UY(i-1,j-1)*DYU(i-1,j-1,bid) - &
                      UX(i ,j )*DXU(i ,j ,bid) - &
                      UX(i-1,j )*DXU(i-1,j ,bid) + &
                      UX(i ,j-1)*DXU(i ,j-1,bid) + &
                      UX(i-1,j-1)*DXU(i-1,j-1,bid))
   end do
   end do

   where (k > KMT(:,:,bid)) CURL = c0

!-----------------------------------------------------------------------
!EOC

 end subroutine zcurl

!***********************************************************************
!BOP
! !IROUTINE: wcalc
! !INTERFACE:

 subroutine wcalc(WWW,UUU,VVV,this_block)

! !DESCRIPTION:
! This function calculates vertical velocity $w$ at tops of T-cells
! from horizontal velocity field (at U points) by integrating the
! continuity equation.
!
! !REVISION HISTORY:
! same as module

! !INPUT PARAMETERS:

   real (r8), dimension(nx_block,ny_block,km), intent(in) :: &
      UUU, VVV ! horizontal velocity at all vertical levels

   type (block), intent(in) :: &
      this_block ! block information for current block

! !OUTPUT PARAMETERS:

   real (r8), dimension(nx_block,ny_block,km), intent(out) :: &
      WWW ! vertical velocity at T points for all levels

!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------

   integer (int_kind) :: &
      i,j, &! dummy counters
      k, &! vert level index
      bid ! local block id

   real (r8) :: &
      fvn,fvs,fue,fuw, &! advective fluxes across sides of box
      wtkb ! vertical velocity at bottom of box

!-----------------------------------------------------------------------
!
! calculate velocity by integrating continuity equation at
! each horizontal grid point
!
!-----------------------------------------------------------------------

   bid = this_block%local_id

   WWW = c0

!-----------------------------------------------------------------------
!
! partial bottom cell case
!
!-----------------------------------------------------------------------

   if (partial_bottom_cells) then

!-----------------------------------------------------------------------
!
! integrate from bottom up for every horizontal grid point
!
!-----------------------------------------------------------------------

      do j=this_block%jb,this_block%je
      do i=this_block%ib,this_block%ie

         wtkb = c0 ! vertical velocity zero at bottom of bottom cell

         do k=KMT(i,j,bid),1,-1

            !***
            !*** advection fluxes
            !***

            fue = p5*(UUU(i ,j ,k)*DYU(i ,j ,bid)* &
                                     DZU(i ,j ,k,bid) + &
                      UUU(i ,j-1,k)*DYU(i ,j-1 ,bid)* &
                                     DZU(i ,j-1,k,bid))
            fuw = p5*(UUU(i-1,j ,k)*DYU(i-1,j ,bid)* &
                                     DZU(i-1,j ,k,bid) + &
                      UUU(i-1,j-1,k)*DYU(i-1,j-1 ,bid)* &
                                     DZU(i-1,j-1,k,bid))
            fvn = p5*(VVV(i ,j ,k)*DXU(i ,j ,bid)* &
                                     DZU(i ,j ,k,bid) + &
                      VVV(i-1,j ,k)*DXU(i-1,j ,bid)* &
                                     DZU(i-1,j ,k,bid))
            fvs = p5*(VVV(i ,j-1,k)*DXU(i ,j-1 ,bid)* &
                                     DZU(i ,j-1,k,bid) + &
                      VVV(i-1,j-1,k)*DXU(i-1,j-1 ,bid)* &
                                     DZU(i-1,j-1,k,bid))

            !***
            !*** vertical velocity at top of box from continuity eq.
            !***

            WWW(i,j,k) = wtkb - &
                    (fvn - fvs + fue - fuw)*TAREA_R(i,j,bid)

            wtkb = WWW(i,j,k) ! top value becomes bottom for next pass

         enddo

      end do ! horizontal loops
      end do

!-----------------------------------------------------------------------
!
! no partial bottom cells
!
!-----------------------------------------------------------------------

   else ! no partial bottom cells

!-----------------------------------------------------------------------
!
! integrate from bottom up for every horizontal grid point
!
!-----------------------------------------------------------------------

      do j=this_block%jb,this_block%je
      do i=this_block%ib,this_block%ie

         wtkb = c0 ! vertical velocity zero at bottom of bottom cell

         do k=KMT(i,j,bid),1,-1

            !***
            !*** advection fluxes
            !***

            fue = p5*(UUU(i ,j ,k)*DYU(i ,j ,bid) + &
                      UUU(i ,j-1,k)*DYU(i ,j-1,bid))
            fuw = p5*(UUU(i-1,j ,k)*DYU(i-1,j ,bid) + &
                      UUU(i-1,j-1,k)*DYU(i-1,j-1,bid))
            fvn = p5*(VVV(i ,j ,k)*DXU(i ,j ,bid) + &
                      VVV(i-1,j ,k)*DXU(i-1,j ,bid))
            fvs = p5*(VVV(i ,j-1,k)*DXU(i ,j-1,bid) + &
                      VVV(i-1,j-1,k)*DXU(i-1,j-1,bid))

            !***
            !*** vertical velocity at top of box from continuity eq.
            !***

            WWW(i,j,k) = wtkb - dz(k)* &
                         (fvn - fvs + fue - fuw)*TAREA_R(i,j,bid)

            wtkb = WWW(i,j,k) ! top value becomes bottom for next pass

         end do ! vertical loop

      end do ! horizontal loops
      end do

   endif ! partial bottom cells

!-----------------------------------------------------------------------
!EOC

 end subroutine wcalc

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

 end module operators

!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||


module debye
use types, only: dp
use debye_potential, only: V0, V1, V2, V3, V4, qp
use debye_potential_series, only: S0, S1, S2, S3, S4
use utils, only: stop_error, str
use constants, only: pi
use special_functions, only: Inu_asympt_sum, Inu_series, Knu_asympt_sum, &
    Inu_formula, Knu_formula, Inu_formula2, Knu_formula2
implicit none

private
public Vk, Sk, Vk2, Vk3

contains

real(dp) function Vk(k, D, r1, r2) result(res)
! Uses direct formula. Depending on r1, r2, typically the result cannot be
! trusted for D >= 100. The accuracy gets worse with increasing "k".
integer, intent(in) :: k
real(dp), intent(in) :: D, r1, r2
real(qp) :: D_, r1_, r2_, res_
D_ = real(D, qp)
r1_ = real(r1, qp)
r2_ = real(r2, qp)
select case (k)
    case (0)
        res_ = V0(D_, r1_, r2_)
    case (1)
        res_ = V1(D_, r1_, r2_)
    case (2)
        res_ = V2(D_, r1_, r2_)
    case (3)
        res_ = V3(D_, r1_, r2_)
    case (4)
        res_ = V4(D_, r1_, r2_)
    case default
        res_ = 0 ! silence gfortran warning
        call stop_error("k = " // str(k) // " not implemented.")
end select
res = real(res_, dp)
end function

real(dp) function Sk(k, D, r1, r2) result(res)
! Uses series expansion in "alpha".
! The convergence depends on two parameters:
!     alpha = max(r1, r2) / D
!     t = min(r1, r2) / max(r1, r2)
! The series satisfies the folling properties:
!     I  : From the definition, t <= 1
!     II : The series contains a few "t" terms for each power of alpha
!     III: For a given power of alpha, all "t" terms have equal or higher power
! Three cases can happen in terms of convergence:
!     a) If alpha <= 1, the series always converges (I and II)
!     b) If alpha >  1, but alpha * t <= 1, the series always converges (III)
!     c) If alpha >  1  and alpha * t >  1, the series can diverge and in this
!        case the results are usually not accurate. A warning is issed.
! In the a) and b) cases, the accuracy should be at least 8 significant
! digits. In the c) case, typically the accuracy is much lower, sometimes not
! even a single digit is correct.
! There doesn't seem to be significant loss of accuracy with increasing "k".
integer, intent(in) :: k
real(dp), intent(in) :: D, r1, r2
real(dp) :: alpha, t, D_, r1_, r2_, res_, rmin, rmax
D_ = real(D, dp)
r1_ = real(r1, dp)
r2_ = real(r2, dp)
! r1 >= r2
rmin = r2_
rmax = r1_
alpha = rmax / D_
t = rmin / rmax
! Don't issue the warning, because we also need to allow t > 1.
!if (alpha > 1 .and. alpha * t > 1) then
!    print *, "alpha =", alpha, "t =", t
!    print *, "WARNING: alpha > 1 and alpha*t > 1; The series for V_k(r1, r2)"
!    print *, "         might diverge. The results cannot be trusted."
!end if
select case (k)
    case (0)
        res_ = S0(alpha, t)
    case (1)
        res_ = S1(alpha, t)
    case (2)
        res_ = S2(alpha, t)
    case (3)
        res_ = S3(alpha, t)
    case (4)
        res_ = S4(alpha, t)
    case default
        res_ = 0 ! silence gfortran warning
        call stop_error("k = " // str(k) // " not implemented.")
end select
res_ = res_ * exp(-alpha) / rmax
res = real(res_, dp)
end function

real(dp) function Vk2(k, D, r1, r2) result(r)
! Uses the modified Bessel functions
integer, intent(in) :: k
real(dp), intent(in) :: D, r1, r2
real(dp) :: rmin, rmax, a, b, C
rmin = r2
rmax = r1
a = Knu_asympt_sum(k+0.5_dp, rmax/D) * sqrt(pi/(2*rmax/D))
if (rmin/D > -log(epsilon(1._dp))/2) then
    b = Inu_asympt_sum(k+0.5_dp, rmin/D) / sqrt(2*pi*rmin/D)
    C = exp((rmin-rmax)/D)
else
    a = a * exp(-rmax/D)
    b = Inu_series(k+0.5_dp, rmin/D)
    C = 1
end if
r = (2*k+1)*C*a*b/sqrt(rmin*rmax)
end function

real(dp) function Vk3(k, D, r1, r2) result(r)
! Uses the modified Bessel functions
integer, intent(in) :: k
real(dp), intent(in) :: D, r1, r2
real(dp) :: rmin, rmax, a, b, C
rmin = r2
rmax = r1
b = Inu_formula2(k, rmin/D)
a = Knu_formula2(k, rmax/D)
C = exp((rmin-rmax)/D)
r = (2*k+1)*C*a*b/sqrt(rmin*rmax)
end function

end module


      PROGRAM xvegas
C     driver for routine vegas
      INTEGER idum,init,itmax,j,ncall,ndim,nprn
      REAL avgi,chi2a,sd,xoff
      COMMON /ranno/ idum
      COMMON /tofxn/ xoff,ndim
      REAL region(20)
      EXTERNAL fxn
      write(*,*) 'IDUM='
      read(*,*) idum
      idum=-abs(idum)
1     write(*,*) 'ENTER NDIM,XOFF,NCALL,ITMAX,NPRN'
      read(*,*,END=999) ndim,xoff,ncall,itmax,nprn
      avgi=0.
      sd=0.
      chi2a=0.
      do 11 j=1,ndim
        region(j)=0.
        region(j+ndim)=1.
11    continue
      init = -1
      call vegas(region,ndim,fxn,init,ncall,itmax,nprn,avgi,sd,chi2a)
      write(*,*) 'Number of iterations performed:',itmax
      write(*,*) 'Integral, Standard Dev., Chi-sq.',avgi,sd,chi2a
      init = 1
      call vegas(region,ndim,fxn,init,ncall,itmax,nprn,avgi,sd,chi2a)
      write(*,*) 'Additional iterations performed:',itmax
      write(*,*) 'Integral, Standard Dev., Chi-sq.',avgi,sd,chi2a
999   write(*,*) 'NORMAL COMPLETION'
      STOP
      END
      REAL FUNCTION fxn(pt,wgt)
      INTEGER j,ndim
      REAL sum,xoff,wgt
      COMMON /tofxn/ xoff,ndim
      REAL pt(*)
      sum=0.
      do 11 j=1,ndim
        sum=sum+100.*(pt(j)-xoff)**2
11    continue
      if (sum.lt.80.) then
        fxn=exp(-sum)
      else
        fxn=0.
      endif
      fxn=fxn*(5.64189**ndim)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xvegas.for


program test_sch1d_eig

use types, only: dp
use constants, only: i_, pi
use ofdft, only: read_pseudo
use ofdft_fft, only: free_energy, radial_potential_fourier, &
    reciprocal_space_vectors, free_energy_min, real2fourier, integral, &
    fourier2real, real_space_vectors, vtk_save, integralG
use utils, only: loadtxt, stop_error, assert, linspace, strfmt
use splines, only: spline3pars, iixmin, poly3, spline3ders
use interp3d, only: trilinear
use md, only: positions_fcc, positions_bcc
use arpack, only: eig
implicit none
integer :: Ng
real(dp), allocatable :: G(:), G2(:)
real(dp), allocatable :: ne(:)
real(dp), allocatable :: Xn(:), Vn(:), r(:)
real(dp), allocatable :: d(:), v(:,:)
complex(dp), allocatable, dimension(:) :: psi, psiG
real(dp) :: L
integer :: i, j, nev, ncv
integer, parameter :: nelec = 1
real(dp) :: dt, psi_norm, E_tot, alpha
integer :: u, u2, k
real(dp) :: t, r0, V0
!real(dp), parameter :: Ng_list(*) = [2, 4, 8, 16, 64, 128, 256, 512]
integer, parameter :: Ng_list(*) = [2, 3, 4, 5, 6, 8, 9, 10, 12, 15, 16, 18, &
    20, 24, 25, 27, 30, 32, 36, 40, 45, 48, 50, 54, 60, 64, 72, 75, 80, 81, &
    90, 96, 100, 108, 120, 125, 128, 135, 144, 150, 160, 162, 180, 192, 200, &
    216, 225, 240, 243, 250, 256, 270, 288, 300, 320, 324, 360, 375, 384, 512, &
    1024]
real(dp), allocatable :: Xion(:)

L = 5
!allocate(Xion(2))
!Xion = L/2 + [-1, 1]
allocate(Xion(1))
Xion = L/2 - 1e-4_dp

Ng = 1024*8
allocate(ne(Ng))
allocate(G(Ng), G2(Ng))
allocate(Xn(Ng), Vn(Ng), r(Ng), psiG(Ng))

call real_space_vectors(L, Xn)
call reciprocal_space_vectors(L, G, G2)
open(newunit=u, file="sch1d_grid.txt", status="replace")
write(u, *) Ng
write(u, *) Xn
!Vn = gaussian_potential(Xn, 12._dp, L/2)
r0 = 0.5_dp
r = abs(Xn-2.5_dp)
V0 = 16
Vn = -V0*exp(-r**2/r0**2)
!alpha = 2
!Vn = 0
!do i = 1, size(Xion)
!    r = abs((Xn-Xion(i)))
!    Vn = Vn -V0*alpha*erfr(alpha*r)
!end do
write(u, *) Vn
!psi = gaussian_density(Xn, 12._dp, L/2)
ne = V0*(2*r**2 - r0**2)*exp(-r**2/r0**2)/(2*pi*r0**4)
!ne = 0
!do i = 1, size(Xion)
!    do k = -5, 5
!        r = abs((Xn-Xion(i)+k*L))
!        ne = ne + V0*(-alpha**3*exp(-alpha**2*r**2)/pi**(3./2) - &
!            alpha*exp(-alpha**2*r**2)/(pi**(3./2)*r**2) + &
!            alpha*erfr(alpha*r)/(2*pi*r**2))
!    end do
!end do
write(u, *) ne

! Solve Poisson
call real2fourier(ne, psiG)
psiG(1) = 0; psiG(2:) = 4*pi*psiG(2:) / G2(2:)
call fourier2real(psiG, Vn)

write(u, *) Vn
r = abs(Xn-L/2)
!write(u, *) -V0*alpha*erfr(alpha*r)
write(u,*) -V0*exp(-r**2/r0**2)
close(u)

deallocate(ne, G, G2, Xn, Vn, r, psiG)

open(newunit=u2, file="pw.txt", status="replace")
do j = 1, size(Ng_list)
    Ng = Ng_list(j)
    allocate(ne(Ng))
    allocate(G(Ng), G2(Ng), psi(Ng))
    allocate(psiG(Ng))
    allocate(Xn(Ng), Vn(Ng))

    call real_space_vectors(L, Xn)
    call reciprocal_space_vectors(L, G, G2)
    call load_potential(Xn, .true., Vn)

    nev = min(6, Ng-1)
    ncv = min(160, Ng)
    allocate(v(Ng,ncv), d(ncv))
    call eig(Ng, nev, ncv, "SA", av, d, v)
    print *, "n  eig  eig_integral"
    open(newunit=u, file="sch1d_psi.txt", status="replace")
    do i = 1, nev
        psi = v(:,i)
        ne = real(psi*conjg(psi), dp)
        psi_norm = integral(L, ne)
        psi = sqrt(nelec / psi_norm) * psi

        ne = real(psi*conjg(psi), dp)
        call real2fourier(psi, psiG)
        E_tot = 1._dp/2 * integralG(G2*abs(psiG)**2, L) + integral(L, Vn*ne)
        print *, i, d(i), E_tot
        write(u, *) real(psi, dp)
    end do
    close(u)

    write(u2,*) Ng, L, d(:nev)

    deallocate(ne, G, G2, psi, psiG, Xn, Vn, v, d)
end do
close(u)

contains

    pure function gaussian_density(x, alpha, x0) result(n)
    ! Returns a Gaussian charge.
    !
    ! This function returns the particle density `n` corresponding to the
    ! following radial potential `V`:
    !     V = -erf(alpha*r)/r
    ! by solving the radial Poisson equation (r*V(r))'' = -4*pi*r*n(r), e.g. in
    ! SymPy:
    !
    !     >>> var("alpha r", positive=True)
    !     >>> V = -erf(alpha*r)/r
    !     >>> n = (r*V).diff(r, 2) / (-4*pi*r)
    !     >>> n
    !     -alpha**3*exp(-alpha**2*r**2)/pi**(3/2)
    !
    ! Note that in 1D the potential `V` as calculated from the 1D Poisson
    ! equation V''(x) = -4*pi*n(x) is equal to:
    !
    !     >>> simplify(integrate(integrate(-4*pi*n, r), r))
    !     2*alpha**2*r*erf(alpha*r) + 2*alpha*exp(-alpha**2*r**2)/sqrt(pi)
    !
    ! The last potential is returned by gaussian_potential().
    real(dp), intent(in) :: x(:), alpha, x0
    real(dp) :: n(size(x))
    n = -alpha**3 * exp(-alpha**2*(x-x0)**2)/pi**(3._dp/2)
    end function

    pure function gaussian_potential(x, alpha, x0) result(V)
    ! Returns a Gaussian potential. See gaussian_density() for details.
    real(dp), intent(in) :: x(:), alpha, x0
    real(dp) :: V(size(x)), r(size(x))
    r = abs(x-x0)
    V = 2*alpha**2*r*erf(alpha*r) + 2*alpha*exp(-alpha**2*r**2)/sqrt(pi)
    end function

    subroutine av(x, y)
    ! Compute y = A*x
    real(dp), intent(in) :: x(:)
    real(dp), intent(out) :: y(:)
    complex(dp), dimension(Ng) :: psi, psiG
    call real2fourier(x, psiG)
    call fourier2real(G2/2*psiG, psi)
    y = real(psi,dp) + Vn*x
    end

    subroutine load_potential(x, periodic, V)
    real(dp), intent(in) :: x(:)
    logical, intent(in) :: periodic
    real(dp), intent(out) :: V(:)
    real(dp), allocatable :: Xn(:), Vn(:), c(:,:)
    integer :: u, n, i, ip
    ! Load the numerical potential
    open(newunit=u, file="sch1d_grid.txt", status="old")
    read(u, *) n
    allocate(Xn(n), Vn(n))
    read(u, *) Xn
    read(u, *) Vn ! atomic potential
    if (periodic) then
        read(u, *) Vn ! skip: density
        read(u, *) Vn ! periodic potential
    end if
    close(u)
    ! Interpolate using cubic splines
    allocate(c(0:4, n-1))
    call spline3pars(Xn, Vn, [2, 2], [0._dp, 0._dp], c)
    ip = 0
    do i = 1, size(x)
        ip = iixmin(x(i), Xn, ip)
        V(i) = poly3(x(i), c(:, ip))
    end do
    end subroutine

    real(dp) elemental function erfr(x) result(r)
    real(dp), intent(in) :: x
    if (x < 1e-12_dp) then
        r = 2/sqrt(pi)
    else
        r = erf(x) / x
    end if
    end function

end program


subroutine read_topo(ar)
character*8 md,ar
common/topo/nxx,xmin,xmax,nyy,ymin,ymax,htopo(1500,1500),topomin,topomax

nfi=0
topomin=0
topomax=0

open(1,file='../../DATA/'//ar//'/inidata/topo_xyz.grd',status='old',err=1)

read(1,*)
read(1,*)nxx,nyy
read(1,*)xmin,xmax
read(1,*)ymin,ymax
read(1,*)hmin,hmax
do iyy=1,nyy
	read(1,*)(htopo(ixx,iyy),ixx=1,nxx)
end do
close(1)

topomin=999999
topomax=-999999

do ixx=1,nxx
    do iyy=1,nyy
        if(htopo(ixx,iyy).gt.topomax) topomax=htopo(ixx,iyy)
        if(htopo(ixx,iyy).lt.topomin) topomin=htopo(ixx,iyy)
    end do
end do
!write(*,*)' nar=',nar

1 continue

!write(*,*)' nxx=',nxx,' nyy=',nyy
!write(*,*)' xmin=',xmin,' xmax=',xmax
!write(*,*)' ymin=',ymin,' ymax=',ymax
!write(*,*)' topomin=',topomin,' topomax=',topomax
return
end


C	This program sorting the droplet distributions
C	into a certain number of catergories.

	subroutine mov_rsp(NE,radius_drop,con_drop,rdr,mov_fcon
     $   ,NBIN,NARRAY, r_mean, r2_mean, r3_mean)

	real*8 rdr(101)
        real*8 radius_drop(NARRAY),con_drop(NARRAY)
	real   mov_fcon(36)
        real   r_mean(36), r2_mean(36), r3_mean(36)

	Ra_max=35.e-6
	Ra_min=0.
	w0=0.
	NBIN=35

	call DROPPROB2(1,NE,Ra_min,Ra_max,radius_drop,con_drop,
     1  mov_fcon,rdr,NBIN,DDX,NARRAY,
     2  r_mean, r2_mean, r3_mean)

	return
	end

c***************************************************************************
c
c       This is a subroutine to calculate the pdf distribution
c       of the scalar. There are 100 bins.
c
c       PDF: pwer density function
c       SCALAR: scalar values divided by 100 intervals
c       NBIN: bin numbers for PDF
c       Ipe: every period of one realization, if periods=25 iteration
c       then they are 25, 50, 75, 100...... iteration for periods 1,
c       2, 3, 4, ......
c
c***************************************************************************
        SUBROUTINE DROPPROB2(M1,M4,pNmin,pNmax,A,con_drop,
     1  mov_fcon,SCALAR,NBIN,DDX,NARRAY, r_mean, r2_mean, r3_mean)

        real*8 A(NARRAY), PDF(101),SCALAR(101)
	real*8 con_drop(NARRAY)
	real mov_fcon(36)
* add variables for r_mean, r2_mean and r3_mean
        real r_sum(36), r2_sum(36), r3_sum(36)
        real r_mean(36), r2_mean(36), r3_mean(36)
        integer n_r(36)

        DO K=1,NBIN
c
c set initail PDF values zero
c
        mov_fcon(k)=0.
* initialize r_sum and r_mean, and n_r
        r_sum(k)  = 0.
        r2_sum(k) = 0.
        r3_sum(k) = 0.
        n_r(k)    = 0

        END DO

	If((M4.GE.Narray).or.(M1.GE.Narray))then
	write(*,*)'M4 or M1 is > Narray',M4,M1,Narray
	endif

c
c       PDFAREA: the total area of PDF
c       JJ: locate the A(K) into approciate bin #
c       pNmin: min. of scalar value
c       pNmax: max. of scalar value
c

        pNlength=pNmax-pNmin
        DDX=(pNlength)/float(NBIN)*1.e6
        PDFAREA=0.
        DO K=M1,M4
         JJ=INT(NBIN*((A(K)-pNmin)/pNlength))+1

        if(jj.ge.36.or. jj.le.0)then
           write(*,*)'In sort, jj,a(k)',jj,a(k)
           jj=1
         endif
c
c accumulate the count # at each interval of JJ
c
         mov_fcon(jj)=(mov_fcon(jj)+con_drop(k))
* also accumulate for r, r2, and r3
         r_sum (jj) = a(k) + r_sum(jj)
         r2_sum(jj) = a(k) * a(K) + r2_sum(jj)
         r3_sum(jj) = a(k) * a(k) * a(k) + r3_sum(jj)
         n_r(jj) = n_r(jj) + 1
        END DO
c
c       calculate the total PDFAREA
c

	DO K=1,NBIN+1
	  mov_fcon(k)=mov_fcon(k)/(1.0e6)
          SCALAR(K)=(K-1.)*DDX*1.e-6+pNmin
        END DO
* add calculations on r, r2 and r3
        do k = 1, NBIN + 1
          if( n_r(k) .eq. 0) then
            r_mean(k) = 0.
            r2_mean(k) = 0.
            r3_mean(k) = 0.
          else
            r_mean(k) = r_sum(k) / float( n_r(k))
            r2_mean(k) = r2_sum(k) / float( n_r(k))
            r3_mean(k) = r3_sum(k) / float( n_r(k))
          endif
        enddo

        RETURN
        END


program scalapack_d
! minimal Scalapack demo
use, intrinsic :: iso_fortran_env, only: real64
implicit none

integer :: ictxt, myid, nprocs, mycol, myrow, npcol, nprow
real(real64) :: eps
real(real64), external :: pdlamch

! arbitrary test parameters
npcol = 2
nprow = 2

call blacs_pinfo(myid, nprocs)
call blacs_get(-1, 0, ictxt)
call blacs_gridinit(ictxt, "C", nprocs, 1)

call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)

eps = pdlamch(ictxt, 'E')

if(myrow == mycol) print '(A, F10.6)', "OK: Scalapack Fortran  eps=", eps

call blacs_gridexit(ictxt)
call blacs_exit(0)

end program


!
!  Written by Leandro Martínez, 2009-2011.
!  Copyright (c) 2009-2011, Leandro Martínez, Jose Mario Martinez,
!  Ernesto G. Birgin.
!

!
! Subroutine that performs finite difference and analytical gradient
! comparision. Used only for test purpouses
!

subroutine comparegrad(n,x)

  use sizes
  implicit none

  integer :: n, i, iworst
  double precision :: x(n), fx, step, gcomp, gbest, eworst, &
                      error, steperror, stepbest
  double precision, allocatable :: g(:)
  real :: time0, tarray(2), etime

  ! Allocate local array

  allocate(g(nn))

  write(*,*)
  write(*,*) ' Comparing analytical and finite-difference '
  write(*,*) ' gradients... may take a while. '
  write(*,*)
  write(*,*) ' Five first center of masses and angles of tested point: '
  do i = 1, 15, 3
    write(*,"( i4,6(tr2,f8.3) )") (i+2)/3, x(i), x(i+1), x(i+2), x(n/2+i),&
                                  x(n/2+i+1),x(n/2+i+2)
  end do
  write(*,*)
  write(*,*) ' Computing gradient ... '

  call computef(n,x,fx)
  write(*,*) ' Function value on test point: ', fx
  open(98, file = 'chkgrad.log',status='unknown')
  write(98, *)'Function Value = ', fx
  call computeg(n,x,g)

  write(98,"( t2,'Component',t16,'Analytical',t33,'Discrete', &
             &t51,'Error',t62,'Best step' )")
  time0 = etime(tarray)
  eworst = 0.d0
  do i = 1, n
    if(etime(tarray)-time0.gt.10.) then
      time0 = etime(tarray)
      write(*,*) ' Computing the ',i,'th of ',n,' components. '
    end if
    error = 1.d20
    step = 1.d-2
    do while(error.gt.1.d-6.and.step.ge.1.d-20)
      call discret(i,n,x,gcomp,step)
      if(dmin1(abs(g(i)),abs(gcomp)).gt.1.d-10) then
        steperror = abs( ( gcomp - g(i) ) / g(i) )
      else
        steperror = abs( gcomp - g(i) )
      end if
      if( steperror .lt. error ) then
        error = steperror
        gbest = gcomp
        stepbest = step
      end if
      step = step / 10.d0
    end do
    write(98,"(i10,4(tr2,d13.7))") i, g(i), gbest, error, stepbest
    if(error.gt.eworst) then
      iworst = i
      eworst = error
    end if
  end do
  write(98,*) 'Maximum difference = ', iworst,' Error= ', eworst
  write(*,*) ' Done. '
  stop

end subroutine comparegrad

subroutine discret(icomp,n,x,gcomp,step)

  implicit none
  integer :: n, icomp
  double precision :: save, step, x(n), fplus, fminus, gcomp

  save = x(icomp)
  x(icomp) = save + step
  call computef(n,x,fplus)
  x(icomp) = save - step
  call computef(n,x,fminus)
  gcomp = (fplus - fminus) / (2.d0 * step)
  x(icomp) = save

  return
end subroutine discret