!Author: Anthea Monod
!Reference: Random Effects Modeling and the Zero-Inflated Poisson Distribution
!Line-Search Optimization without computation of gradient
!To compile, use g95 optfish.f90 -o prog ~/bin/called/*.f90
!To run, use ./optfish > optfish_output to write output in a separate file

module commondata
  save
  integer, parameter :: n=1000 ! sample size
  integer, dimension(n,2) :: y,y_nz,y_z,y_1,y_2
  real, dimension(n,2) :: x,x_nz,x_z,x_1,x_2
  integer :: n_nz,n_z,n_y1,n_y2
  real :: logu!  auxiliary variable to decrease execution time
  real, dimension(n) :: logprod1_y1,logprod2_y2,logprod12_nz ! auxiliary variables to decrease execution time
end module commondata

program test_mle
  use commondata
  use random
  implicit none
  integer :: i,j,k,l,counter
  real :: f,fmax
  real, dimension(4) :: theta0,thetabest,thetatmp,thetatotal,ctm
  real :: alphamax,beta1max,beta2max,umax
  integer, parameter :: partition=20,simus=100
  real :: dummy
  theta0(1)=0.22  ! theta0(1) = alpha, true parameter values
  theta0(2)=0.5  ! theta0(2) = beta1
  theta0(3)=0.5  ! theta0(3) = beta2
  theta0(4)=1.5  ! theta0(4) = u
  alphamax = 0.9
  beta1max = 1.
  beta2max = 1.
  umax = 3.

  thetatotal=0.
  write(*,*) 'theta0=',theta0
  write(*,*) 'observations=',n,'simulations=',simus,'partition=',partition
  write(*,*) 'alphamax=',alphamax,'beta1max=',beta1max,'beta2max=',beta2max,'umax=',umax
  write(*,*) '-----------------------we start-----------------------'
  do counter=1,simus
     call gendata(theta0)
     call sort
     fmax=-huge(dummy) ! smallest real value

!start line search loop
     do l = 1,partition
        thetatmp(4) = (umax*l)/partition
        call aux(thetatmp(4)) ! compute expressions that do not depend upon thetatmp(1,2,3)
        do j = 1,partition
           thetatmp(2) = (beta1max*j)/partition
           do k = 1,partition
              thetatmp(3) = (beta2max*k)/partition
              do i=1,partition
                 thetatmp(1) = (alphamax*i)/partition
                 call mletheta(thetatmp,f)
                 if (f.gt.fmax) then
                    fmax = f
                    thetabest = thetatmp
                 end if
              end do
           end do
        end do
     end do
!Write results of current simulation
     write(*,*) 'thetabest=',thetabest, '   iteration=',counter,'/',simus
     thetatotal(1)=thetatotal(1)+thetabest(1)
     thetatotal(2)=thetatotal(2)+thetabest(2)
     thetatotal(3)=thetatotal(3)+thetabest(3)
     thetatotal(4)=thetatotal(4)+thetabest(4)
     ctm(1)=thetatotal(1)/counter
     ctm(2)=thetatotal(2)/counter
     ctm(3)=thetatotal(3)/counter
     ctm(4)=thetatotal(4)/counter
     write(*,*) 'current thetamean=',ctm
  end do
!Write global result (all simulations)
  write(*,*) '--------------------results---------------------------'
  write(*,*) 'theta0=',theta0
  write(*,*) 'observations=',n,'simulations=',simus,'partition=',partition
  write(*,*) 'alphamax=',alphamax,'beta1max=',beta1max,'beta2max=',beta2max,'umax=',umax
  write(*,*) 'thetamean(1)=',thetatotal(1)/simus
  write(*,*) 'thetamean(2)=',thetatotal(2)/simus
  write(*,*) 'thetamean(3)=',thetatotal(3)/simus
  write(*,*) 'thetamean(4)=',thetatotal(4)/simus
  return
end program test_mle

!Objective function
subroutine mletheta(xx,f) ! xx is proposed solution
  use commondata
  implicit none
  integer :: i
  real,dimension(4) :: xx
  real :: f

  f = 0
  do i=1,n_nz
     f = f + 2*log(1-xx(1)) + y_nz(i,1)*x_nz(i,1)*xx(2) +&
          & y_nz(i,2)*x_nz(i,2)*xx(3) + xx(4)*logu - (xx(4)+y_nz(i&
          &,1)+y_nz(i,2))*log(xx(4)+exp(x_nz(i,1)*xx(2))+exp(x_nz(i,2)&
          &*xx(3))) + logprod12_nz(i)
  end do

  do i=1,n_z
     f = f + log( xx(1)*xx(1) + xx(1)*(1-xx(1))*(&
          & exp(log(xx(4)/(xx(4)+exp(x_z(i,1)*xx(2))))*xx(4)) +&
          & exp(log(xx(4)/(xx(4)+exp(x_z(i,2)*xx(3))))*xx(4)) ) + ((1&
          &-xx(1))**2) * exp( log(xx(4)/(xx(4)+exp(x_z(i,1)*xx(2))+exp(x_z(i,2)*xx(3))))*xx(4) ))
  end do

  do i=1,n_y1
     f = f + log(1-xx(1)) + y_1(i,1)*x_1(i,1)*xx(2)  +&
          & logprod1_y1(i) +  log( xx(1)*exp(log( xx(4)&
          &/(exp(x_1(i,1)*xx(2))+xx(4)) ) *xx(4))&
          &/exp(log(exp(x_1(i,1)*xx(2))+xx(4))*y_1(i,1)) + (1&
          &-xx(1))*exp(log(  xx(4)/(exp(x_1(i,1)*xx(2))+exp(x_1(i,2)&
          &*xx(3))+xx(4)))*xx(4))&
          &/exp(log(exp(x_1(i,1)*xx(2))+exp(x_1(i,2)*xx(3))+xx(4))*y_1(i&
          &,1)))
  end do

  do i=1,n_y2
     f = f + log(1-xx(1)) + y_2(i,2)*x_2(i,2)*xx(3)  +&
          & logprod2_y2(i) + log( xx(1)*exp(log( xx(4)&
          &/(exp(x_2(i,2)*xx(3))+xx(4)) ) *xx(4))&
          &/exp(log(exp(x_2(i,2)*xx(3))+xx(4))*y_2(i,2)) + (1&
          &-xx(1))*exp(log(  xx(4)/(exp(x_2(i,1)*xx(2))+exp(x_2(i,2)&
          &*xx(3))+xx(4)))*xx(4))&
          &/exp(log(exp(x_2(i,1)*xx(2))+exp(x_2(i,2)*xx(3))+xx(4))*y_2(i&
          &,2)))
  end do
  return
end subroutine mletheta

!Function to compute (a+b-1)(a+b-2)...a
!If b.le.0, prod returns 1
function prod(a,b)
  implicit none
  real :: a,prod
  integer :: b,i
  prod = 1.
  do i = 0,b-1
     prod = prod*(a+i)
  end do
  return
end function prod

!Auxiliary subroutine
subroutine aux(u)
  use commondata
  implicit none
  real :: u, prod
  integer :: i
  logu = log(u)
  do i=1,n_nz
     logprod12_nz(i) = log(prod(u,y_nz(i,1)+y_nz(i,2)))
  end do
  do i=1,n_y1
     logprod1_y1(i) = log(prod(u,y_1(i,1)))
  end do
  do i=1,n_y2
     logprod2_y2(i) = log(prod(u,y_2(i,2)))
  end do
end subroutine aux

!Generate data, gives a matrix y of values from a Poisson distribution and zeros
subroutine gendata(theta)
  use random
  use commondata
  implicit none
  real,dimension(4),intent(in) :: theta
  double precision :: t
  real :: lam,delta,lam_re
  integer :: i

  y=0  ! by default
  do i=1,n
     x(i,1) = random_normal() ! Generates random number from N(0,1)
     x(i,2) = random_normal() ! Generates random number from N(0,1)
     call random_number(t)    ! Generates random number uniformly on [0,1]
     if (t.gt.theta(1)) then  ! Checks zero-inflation
        lam = exp(x(i,1)*theta(2)) ! Computes Poisson parameter lambda
        delta = random_gamma(theta(4),.TRUE.) ! Generates random number from Gamma distribution with u0 = shape = scale parameters
        lam_re = lam*delta ! Computes random-effects Poisson parameter
        y(i,1) = random_Poisson(lam_re,.TRUE.) ! Generates random number from Poisson distribution with random-effects parameter
     end if
     call random_number(t)
     if (t.gt.theta(1)) then ! Checks zero-inflation
        lam = exp(x(i,2)*theta(3)) ! Computes Poisson parameter lambda
        delta = random_gamma(theta(4),.TRUE.) ! Generates random number from Gamma distribution with u0 = shape = scale parameters
        lam_re = lam*delta ! Computes random-effects Poisson parameter
        y(i,2) = random_Poisson(lam_re,.TRUE.) ! Generates random number from Poisson distribution with random-effects parameter
     end if
  end do
end subroutine gendata

!Subroutine to count and sort the number of pairs of nonzero, zero, mixed y_i1 & y_i2
subroutine sort
  use commondata
  implicit none
  integer :: i

  n_nz = 0
  n_z = 0
  n_y1 = 0
  n_y2 = 0
  do i = 1,n
     if ((y(i,1).ne.0).and.(y(i,2).ne.0)) then
        n_nz = n_nz + 1
        y_nz(n_nz,1) = y(i,1)
        y_nz(n_nz,2) = y(i,2)
        x_nz(n_nz,1) = x(i,1)
        x_nz(n_nz,2) = x(i,2)
     elseif ((y(i,1).eq.0).and.(y(i,2).eq.0)) then
        n_z = n_z + 1
        y_z(n_z,1) = y(i,1)
        y_z(n_z,2) = y(i,2)
        x_z(n_z,1) = x(i,1)
        x_z(n_z,2) = x(i,2)
     elseif ((y(i,1).ne.0).and.(y(i,2).eq.0)) then
        n_y1 = n_y1 + 1
        y_1(n_y1,1) = y(i,1)
        y_1(n_y1,2) = y(i,2)
        x_1(n_y1,1) = x(i,1)
        x_1(n_y1,2) = x(i,2)
     else
        n_y2 = n_y2 + 1
        y_2(n_y2,1) = y(i,1)
        y_2(n_y2,2) = y(i,2)
        x_2(n_y2,1) = x(i,1)
        x_2(n_y2,2) = x(i,2)
     endif
  end do
end subroutine sort


!==========================================================================
elemental function gsw_sstar_from_sp (sp, p, long, lat)
!==========================================================================
!
! Calculates Preformed Salinity, Sstar, from Practical Salinity, SP.
!
! sp     : Practical Salinity                              [unitless]
! p      : sea pressure                                    [dbar]
! long   : longitude                                       [deg E]
! lat    : latitude                                        [deg N]
!
! gsw_sstar_from_sp  : Preformed Salinity                  [g/kg]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_saar, gsw_sa_from_sp_baltic

use gsw_mod_error_functions, only : gsw_error_code, gsw_error_limit

use gsw_mod_teos10_constants, only : gsw_ups

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sp, p, long, lat

real (r8) :: gsw_sstar_from_sp

real (r8) :: saar, sstar_baltic

character (*), parameter :: func_name = "gsw_sstar_from_sp"

!In the Baltic Sea, Sstar = SA.
sstar_baltic = gsw_sa_from_sp_baltic(sp,long,lat)

if (sstar_baltic .lt. 1e10_r8) then

   gsw_sstar_from_sp = sstar_baltic

else

   saar = gsw_saar(p,long,lat)
   if (saar .gt. gsw_error_limit) then
      gsw_sstar_from_sp = gsw_error_code(1,func_name,saar)
   else
      gsw_sstar_from_sp = gsw_ups*sp*(1 - 0.35_r8*saar)
   end if

end if

return
end function

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


      subroutine kslashU(zk,sp,f)
      implicit none
c-----multiplication of k-slash from the left with a spinor sp
C-----and return resultant spinor f, Majorana representation
      include 'constants.f'
      include 'swapxz.f'
      double complex sp(4),zk(4),f(4)
      double precision spr(4),spi(4),kslash(4,4),fr(4),fi(4),Ek,kx,ky,kz
      integer j
      logical,save::first
      data first/.true./

      if (first) then
      write(6,*) 'kslashU:swapxz=',swapxz
      first=.false.
      endif

      if (swapxz) then
C----create kslash after performing the swap (x<->z),(y->-y)
      Ek=+dble(zk(4))
      kx=+dble(zk(3))
      ky=-dble(zk(2))
      kz=+dble(zk(1))
      else
      Ek=+dble(zk(4))
      kx=+dble(zk(1))
      ky=+dble(zk(2))
      kz=+dble(zk(3))
      endif

C---kslash in Majorana representation with factor of i removed
      kslash(1,1)=-kx
      kslash(1,2)=+kz
      kslash(1,3)=zip
      kslash(1,4)=-ky-Ek

      kslash(2,1)=+kz
      kslash(2,2)=+kx
      kslash(2,3)=+ky+Ek
      kslash(2,4)=zip

      kslash(3,1)=zip
      kslash(3,2)=+ky-Ek
      kslash(3,3)=-kx
      kslash(3,4)=+kz

      kslash(4,1)=-ky+Ek
      kslash(4,2)=zip
      kslash(4,3)=+kz
      kslash(4,4)=+kx

      spr(:)=dble(sp(:))
      spi(:)=dimag(sp(:))
      do j=1,4
      fr(j)=kslash(j,1)*spr(1)+kslash(j,2)*spr(2)
     &     +kslash(j,3)*spr(3)+kslash(j,4)*spr(4)
      fi(j)=kslash(j,1)*spi(1)+kslash(j,2)*spi(2)
     &     +kslash(j,3)*spi(3)+kslash(j,4)*spi(4)
C---recompose complex f restoring factor of i
      f(j)=dcmplx(-fi(j),+fr(j))
      enddo
      return
      end


! Copyright (c) 2017-2018 Etienne Descamps
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation and/or
!    other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be
!    used to endorse or promote products derived from this software without specific prior
!    written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
! INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Program test_emgmm
  use ieee_arithmetic
  use iso_c_binding
  use mlf_utils
  use mlf_kmeans
  use mlf_intf
  use mlf_emgmm
  use mlf_matrix
  use mlf_rand
  use mlf_gaussian
  use mlf_hdf5
  use test_common
  implicit none

  integer :: ND, NC, NX, info
  integer(kind=8) :: Nstep
  real(c_double) :: sigmaC, sigmaX

  info = mlf_init()

  if(COMMAND_ARGUMENT_COUNT()<6) then
    print *, "Error missing arguments: ND NC NX Nstep sigmaC sigmaX"
    stop
  endif

  ND = GetIntParameter(1)
  NC = GetIntParameter(2)
  NX = GetIntParameter(3)
  Nstep = GetIntParameter(4)
  sigmaC = GetRealParameter(5)
  sigmaX = GetRealParameter(6)
  print *,"ND: ", ND, " NC: ", NC, " NX: ", NX, " Nstep: ", Nstep, " sigmaC: ", sigmaC, " sigmaX: ", sigmaX
  call testOrtho()
  call testMN()
  call testGMM()

  info = mlf_quit()
contains
  subroutine testOrtho()
    real(c_double) :: C(ND,ND)
    call randOrthogonal(C)
    print *, "Random Ortho:"
    call PrintMatrix(C)
    print *, "Shall be Id:"
    call PrintMatrix(matmul(transpose(C), C))
  end subroutine testOrtho
  subroutine testMN()
    real(c_double), allocatable :: invC(:,:), C12(:,:), C(:,:), X(:,:)
    real(c_double), allocatable :: weight(:), P(:), Mu(:)
    real(c_double) ::  lnd
    integer :: i
    ALLOCATE(weight(ND), P(NX), Mu(ND), X(ND,NX), C12(ND,ND), C(ND,ND))
    P = 1
    weight = (/ (1d0/real(i), i=1,ND) /)
    weight = sqrt(sigmaX*weight/Mean(weight))
    call randOrthogonal(C12, weight)
    print *, "Random Org:"
    call PrintMatrix(C12)
    print *, "Covariance Matrix:"
    C = matmul(C12, transpose(C12))
    call PrintMatrix(C)
    allocate(invC(ND,ND))
    i = InverseSymMatrix(C, invC, lnd, .TRUE.)
    print *, "Inverse covariance matrix: lnd: ", lnd, " i: ", i
    call PrintMatrix(invC, matmul(C,invC))
    call randN(X, C12 = C12)
    lnd =  mlf_MaxGaussian(X, P, Mu, C)
    print *, "Evaluated Mu"
    print *, Mu
    print *, "Evaluated Covariance Matrix:"
    call PrintMatrix(C)
    i = mlf_EvalGaussian(X, P, Mu, C, 1d0, lnd)
    print *, "Evaluated Probabilities: lnd: ", lnd
    print *, P
  end subroutine testMN

  subroutine testGMM()
    real(c_double), allocatable :: XC(:,:), X(:,:), C12(:,:,:), weight(:)
    real(c_double) :: dt
    type(mlf_algo_emgmm) :: em_algo
    integer :: i, info, r
    integer, allocatable :: idx(:), idc(:)
    type(mlf_hdf5_file) :: mh5
    ALLOCATE(XC(ND,NC), X(ND,NX*NC), C12(ND,ND, NC), weight(ND), idx(NX*NC), idc(NC))
    ! Generates random centres
    call RandN(XC, sigmaC)
    ! Weights used as diagonal matrix (multiplied by orthogonal matrix)
    weight = [(1d0/real(i), i=1,ND)]
    weight = sqrt(sigmaX*weight/Mean(weight))
    do i = 1,NC
      call randOrthogonal(C12(:,:,i), weight)
      call randN(X(:,1+(i-1)*NX:i*NX), X0 = XC(:,i), C12 = C12(:,:,i))
    end do
    idx = [(i, i=1,NX*NC)]
    call randPerm(idx)
    X = X(:,idx)
    info = em_algo%init(X, nC, 1d0)
    if(info<0) then
      print *,"Error initialization"
      RETURN
    endif
    r = em_algo%step(dt, Nstep)
    print *,"Time: ", dt
    print *, "Matrix Mu: (determined by GMM_EMAlgo)/ XC"
    call mlf_match_points(em_algo%Mu, XC, idc)
    call PrintMatrix(em_algo%Mu, XC(:, idc))
    do i=1,NC
      print *, "Matrix Covar:", i
      call PrintMatrix(em_algo%Cov(:,:,i), matmul(C12(:,:,idc(i)), transpose(C12(:,:,idc(i)))))
    end do
    info = mh5%createFile("emgmm.h5")
    info = mh5%pushState(em_algo)
    call mh5%finalize()
    call em_algo%finalize()
  end subroutine testGMM
End Program test_emgmm


module xc

! Exchange and correlation potentials

use types, only: dp
use constants, only: pi
implicit none
private
public get_Vxc_vwn, xc_pz, xc_pz2, xc_vwn2

contains

subroutine get_Vxc_vwn(R, rho, relat, c, exc, Vxc)
real(dp), intent(in) :: R(:) ! radial grid
real(dp), intent(in) :: rho(:) ! charge density
logical, intent(in) :: relat ! .true. return RLDA, otherwise LDA
real(dp), intent(in) :: c ! speed of light
real(dp), intent(out) :: Vxc(:), exc(:)

integer :: i
do i = 1, size(R)
    call xc_vwn(rho(i), relat, c, exc(i), Vxc(i))
end do
end subroutine

subroutine xc_vwn(n, relat, c_light, exc, Vxc)
! Calculates XC LDA density and potential from the charge density "n".
real(dp), intent(in) :: n ! charge density (scalar)
real(dp), intent(in) :: c_light ! speed of light
logical, intent(in) :: relat ! if .true. returns RLDA, otherwise LDA
real(dp), intent(out) :: exc ! XC density
real(dp), intent(out) :: Vxc ! XC potential

real(dp), parameter :: y0 = -0.10498_dp
real(dp), parameter :: b = 3.72744_dp
real(dp), parameter :: c = 12.9352_dp
real(dp), parameter :: A = 0.0621814_dp

real(dp) :: Q, rs, y, ec, ex, Vc, Vx, beta, mu, R, S

if (abs(n) < tiny(1._dp)) then
    exc = 0
    Vxc = 0
    return
end if

Q = sqrt(4*c - b**2)
rs = (3/(4*pi*n))**(1.0_dp/3)
y = sqrt(rs)
ec = A/2 * (log(y**2/get_Y(y, b, c)) + 2*b/Q * atan(Q/(2*y+b))  &
   - b*y0/get_Y(y0, b, c) * ( &
            log((y-y0)**2 / get_Y(y, b, c)) &
            + 2*(b+2*y0) / Q * atan(Q/(2*y+b)) &
          ) )
Vc = ec - A/6 * (c*(y-y0)-b*y0*y)/((y-y0)*get_Y(y, b, c))
ex = -3/(4*pi) * (3*pi**2*n)**(1.0_dp/3)
Vx = 4*ex/3

if (relat) then
    beta = -4 * pi * ex / (3 * c_light)
    mu = sqrt(1 + beta**2)
    R = 1 - 3 * ((beta * mu - log(beta + mu)) / (beta ** 2))**2 / 2
    S = 3 * log(beta + mu) / (2 * beta * mu) - 1.0_dp/2

    ex = ex * R
    Vx = Vx * S
end if
exc = ex + ec
Vxc = Vx + Vc

contains

    real(dp) function get_Y(y, b, c)
    real(dp), intent(in) :: y, b, c
    get_Y = y**2 + b*y + c
    end function

end subroutine

elemental subroutine xc_vwn2(n, exc, Vxc)
! Same as xc_vwn, but an elemental procedure, and non-relativistic only
real(dp), intent(in) :: n ! charge density (scalar)
real(dp), intent(out) :: exc ! XC density
real(dp), intent(out) :: Vxc ! XC potential

real(dp), parameter :: y0 = -0.10498_dp
real(dp), parameter :: b = 3.72744_dp
real(dp), parameter :: c = 12.9352_dp
real(dp), parameter :: A = 0.0621814_dp

real(dp) :: Q, rs, y, ec, ex, Vc, Vx

if (abs(n) < tiny(1._dp)) then
    exc = 0
    Vxc = 0
    return
end if

Q = sqrt(4*c - b**2)
rs = (3/(4*pi*n))**(1.0_dp/3)
y = sqrt(rs)
ec = A/2 * (log(y**2/get_Y(y, b, c)) + 2*b/Q * atan(Q/(2*y+b))  &
   - b*y0/get_Y(y0, b, c) * ( &
            log((y-y0)**2 / get_Y(y, b, c)) &
            + 2*(b+2*y0) / Q * atan(Q/(2*y+b)) &
          ) )
Vc = ec - A/6 * (c*(y-y0)-b*y0*y)/((y-y0)*get_Y(y, b, c))
ex = -3/(4*pi) * (3*pi**2*n)**(1.0_dp/3)
Vx = 4*ex/3

exc = ex + ec
Vxc = Vx + Vc

contains

    real(dp) pure function get_Y(y, b, c)
    real(dp), intent(in) :: y, b, c
    get_Y = y**2 + b*y + c
    end function

end subroutine

elemental subroutine xc_pz(n, exc, Vxc)
! Calculates XC LDA density and potential from the charge density "n".
! Uses the Perdew Zunger [1] parametrization.
!
! [1] Perdew, J. P., & Zunger, A. (1981). Self-interaction correction to
! density-functional approximations for many-electron systems. Physical Review
! B, 23(10), 5048–5079.
real(dp), intent(in) :: n ! charge density
real(dp), intent(out) :: exc ! XC density
real(dp), intent(out) :: Vxc ! XC potential

real(dp), parameter :: gam = -0.1423_dp
real(dp), parameter :: beta1 = 1.0529_dp
real(dp), parameter :: beta2 = 0.3334_dp
real(dp), parameter :: A =  0.0311_dp
real(dp), parameter :: B = -0.048_dp
real(dp), parameter :: C =  0.0020_dp
real(dp), parameter :: D = -0.0116_dp
real(dp) :: ex, ec, Vx, Vc, rs, sqrt_rs, log_rs

if (abs(n) < tiny(1._dp)) then
    exc = 0
    Vxc = 0
    return
end if

ex = -3/(4*pi) * (3*pi**2*n)**(1.0_dp/3)
Vx = 4*ex/3

rs = (3/(4*pi*n))**(1.0_dp/3)
if (rs >= 1) then
    sqrt_rs = sqrt(rs)
    ec = gam / (1+beta1*sqrt_rs+beta2*rs)
    Vc = ec * (1+7*beta1*sqrt_rs/6 + 4*beta2*rs/3) / &
        (1+beta1*sqrt_rs + beta2*rs)
else
    log_rs = log(rs)
    ec = A*log_rs + B + C*rs*log_rs + D*rs
    Vc = A*log_rs + (B-A/3) + 2*C*rs*log_rs/3 + (2*D-C)*rs/3
end if

exc = ex + ec
Vxc = Vx + Vc
end subroutine

elemental subroutine xc_pz2(n, Vxc)
! The same as 'xc_pz', but only calculates Vxc.
real(dp), intent(in) :: n ! charge density
real(dp), intent(out) :: Vxc ! XC potential

real(dp), parameter :: gam = -0.1423_dp
real(dp), parameter :: beta1 = 1.0529_dp
real(dp), parameter :: beta2 = 0.3334_dp
real(dp), parameter :: A =  0.0311_dp
real(dp), parameter :: B = -0.048_dp
real(dp), parameter :: C =  0.0020_dp
real(dp), parameter :: D = -0.0116_dp
real(dp) :: ex, ec, Vx, Vc, rs, sqrt_rs, log_rs

ex = -3/(4*pi) * (3*pi**2*n)**(1.0_dp/3)
Vx = 4*ex/3

rs = (3/(4*pi*n))**(1.0_dp/3)
if (rs >= 1) then
    sqrt_rs = sqrt(rs)
    ec = gam / (1+beta1*sqrt_rs+beta2*rs)
    Vc = ec * (1+7*beta1*sqrt_rs/6 + 4*beta2*rs/3) / &
        (1+beta1*sqrt_rs + beta2*rs)
else
    log_rs = log(rs)
    Vc = A*log_rs + (B-A/3) + 2*C*rs*log_rs/3 + (2*D-C)*rs/3
end if

Vxc = Vx + Vc
end subroutine

end module


       MODULE DATEGNASH

       TYPE DATEBAG
        INTEGER DAY,MONTH,YEAR
       END TYPE DATEBAG

       CHARACTER*9 MONTHNAME(12),DAYNAME(0:6)
       PARAMETER (MONTHNAME = (/"JANUARY","FEBRUARY","MARCH","APRIL",
     1  "MAY","JUNE","JULY","AUGUST","SEPTEMBER","OCTOBER","NOVEMBER",
     2  "DECEMBER"/))
       PARAMETER (DAYNAME = (/"SUNDAY","MONDAY","TUESDAY","WEDNESDAY",
     1  "THURSDAY","FRIDAY","SATURDAY"/))

       INTEGER*4 JDAYSHIFT
       PARAMETER (JDAYSHIFT = 2415020)
       CONTAINS
       INTEGER FUNCTION LSTNB(TEXT)
        CHARACTER*(*),INTENT(IN):: TEXT
        INTEGER L
         L = LEN(TEXT)
    1    IF (L.LE.0) GO TO 2
         IF (ICHAR(TEXT(L:L)).GT.ICHAR(" ")) GO TO 2
         L = L - 1
         GO TO 1
    2    LSTNB = L
        RETURN
       END FUNCTION LSTNB
      CHARACTER*2 FUNCTION I2FMT(N)
       INTEGER*4 N
        IF (N.LT.0) THEN
          IF (N.LT.-9) THEN
            I2FMT = "-!"
           ELSE
            I2FMT = "-"//CHAR(ICHAR("0") - N)
          END IF
        ELSE IF (N.LT.10) THEN
          I2FMT = " " //CHAR(ICHAR("0") + N)
        ELSE IF (N.LT.100) THEN
          I2FMT = CHAR(N/10      + ICHAR("0"))
     1           //CHAR(MOD(N,10) + ICHAR("0"))
        ELSE
          I2FMT = "+!"
        END IF
      END FUNCTION I2FMT
      CHARACTER*8 FUNCTION I8FMT(N)
       INTEGER*4 N
       CHARACTER*8 HIC
        WRITE (HIC,1) N
    1   FORMAT (I8)
        I8FMT = HIC
      END FUNCTION I8FMT

      SUBROUTINE SAY(OUT,TEXT)
       INTEGER OUT
       CHARACTER*(*) TEXT
        WRITE (6,1) TEXT(1:LSTNB(TEXT))
    1   FORMAT (A)
      END SUBROUTINE SAY

       INTEGER*4 FUNCTION DAYNUM(YY,M,D)
        INTEGER*4 JDAYN
        INTEGER YY,Y,M,MM,D
         Y = YY
         IF (Y.LT.1) Y = Y + 1
         MM = (M - 14)/12
         JDAYN = D - 32075
     A    + 1461*(Y + 4800  + MM)/4
     B    +  367*(M - 2     - MM*12)/12
     C    -    3*((Y + 4900 + MM)/100)/4
         DAYNUM = JDAYN - JDAYSHIFT
       END FUNCTION DAYNUM

       TYPE(DATEBAG) FUNCTION MUNYAD(DAYNUM)
        INTEGER*4 DAYNUM,JDAYN
        INTEGER Y,M,D,L,N
         JDAYN = DAYNUM + JDAYSHIFT
         L = JDAYN + 68569
         N = 4*L/146097
         L = L - (146097*N + 3)/4
         Y = 4000*(L + 1)/1461001
         L = L - 1461*Y/4 + 31
         M = 80*L/2447
         D = L - 2447*M/80
         L = M/11
         M = M + 2 - 12*L
         Y = 100*(N - 49) + Y + L
         IF (Y.LT.1) Y = Y - 1
         MUNYAD%YEAR  = Y
         MUNYAD%MONTH = M
         MUNYAD%DAY   = D
       END FUNCTION MUNYAD

       INTEGER FUNCTION PMOD(N,M)
        INTEGER N,M
         PMOD = MOD(MOD(N,M) + M,M)
       END FUNCTION PMOD

      SUBROUTINE CALENDAR(Y1,Y2,COLUMNS)

       INTEGER Y1,Y2,YEAR
       INTEGER M,M1,M2,MONTH
       INTEGER*4 DN1,DN2,DN,D
       INTEGER W,G
       INTEGER L,LINE
       INTEGER COL,COLUMNS,COLWIDTH
       CHARACTER*200 STRIPE(6),SPECIAL(6),MLINE,DLINE
        W = 3
        G = 1
        COLWIDTH = 7*W + G
      Y:DO YEAR = Y1,Y2
          CALL SAY(MSG,"")
          IF (YEAR.EQ.0) THEN
            CALL SAY(MSG,"THERE IS NO YEAR ZERO.")
            CYCLE Y
          END IF
          MLINE = ""
          L = (COLUMNS*COLWIDTH - G - 8)/2
          IF (YEAR.GT.0) THEN
            MLINE(L:) = I8FMT(YEAR)
           ELSE
            MLINE(L - 1:) = I8FMT(-YEAR)//"BC"
          END IF
          CALL SAY(MSG,MLINE)
          DO MONTH = 1,12,COLUMNS
            M1 = MONTH
            M2 = MIN(12,M1 + COLUMNS - 1)
            MLINE = ""
            DLINE = ""
            STRIPE = ""
            SPECIAL = ""
            L0 = 1
            DO M = M1,M2
              L = (COLWIDTH - G - LSTNB(MONTHNAME(M)))/2 - 1
              MLINE(L0 + L:) = MONTHNAME(M)
              DO D = 0,6
                L = L0 + (3 - W) + D*W
                DLINE(L:L + 2) = DAYNAME(D)(1:W - 1)
              END DO
              DN1 = DAYNUM(YEAR,M,1)
              DN2 = DAYNUM(YEAR,M + 1,0)
              COL = MOD(PMOD(DN1,7) + 7,7)
              LINE = 1
              D = 1
              DO DN = DN1,DN2
                L = L0 + COL*W
                STRIPE(LINE)(L:L + 1) = I2FMT(D)
                D = D + 1
                COL = COL + 1
                IF (COL.GT.6) THEN
                  LINE = LINE + 1
                  COL = 0
                END IF
              END DO
              L0 = L0 + 7*W + G
            END DO
            CALL SAY(MSG,MLINE)
            CALL SAY(MSG,DLINE)
            DO LINE = 1,6
              IF (STRIPE(LINE).NE."") THEN
                CALL SAY(MSG,STRIPE(LINE))
              END IF
            END DO
          END DO
        END DO Y
        CALL SAY(MSG,"")
      END SUBROUTINE CALENDAR
      END MODULE DATEGNASH

      PROGRAM SHOW1968
       USE DATEGNASH
       INTEGER NCOL
        DO NCOL = 1,6
          CALL CALENDAR(1969,1969,NCOL)
        END DO
      END


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_CALC_EQK_ADV_N_DIF_Z

    USE MR_KINDS

    USE MR_DEF_CURVED_GEOS
    USE MR_DEF_CONSTS_N_REF_PARS
    USE MR_DEF_FIELD_VARS
    USE MR_DEF_ACTIVITY
    USE MR_DEF_TIMING

    USE MR_MOC_K_EPS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_CALC_EQK_ADV_N_DIF_Z

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

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_EQK_ADV_N_DIF_Z( NI , NJ , NK , EQK_ADV_Z , EQK_DIF_Z )

    USE MR_MOD_CALC_QADV_N_QDIF_Z
    USE MR_MOD_CALC_GRAD_Z

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ
    INTEGER(KKID_KIND) , INTENT(IN ) :: NK

    REAL   (FDRD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:NK) :: EQK_ADV_Z , EQK_DIF_Z

    REAL   (FDRD_KIND) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,0:NK) :: EQK_QADV_Z_W , EQK_QDIF_Z_W

    INTEGER(IJID_KIND) :: I , J

    CALL MR_CALC_QADV_N_QDIF_Z_SS_W( NI , NJ , NK , KI , RB , W , EQK_QADV_Z_W , EKZ/SIK , VZW , EQK_QDIF_Z_W )

  ! CALCULATE ADVECTION
    CALL MR_CALC_GRAD_Z_SS( NI , NJ , NK , EQK_QADV_Z_W , EQK_ADV_Z )

  ! CALCULATE DIFFUSION
    CALL MR_CALC_GRAD_Z_SS( NI , NJ , NK , EQK_QDIF_Z_W , EQK_DIF_Z )

  END SUBROUTINE MR_CALC_EQK_ADV_N_DIF_Z

  END MODULE MR_MOD_CALC_EQK_ADV_N_DIF_Z


!########################################################
!     Program  : AHMMPT
!     TYPE     : Main program
!     PURPOSE  : Solve the attractive Hubbard model using DMFT-IPT
!     AUTHORS  : Adriano Amaricci & Antonio Privitera
!########################################################
program ahmmpt
  USE DMFT_IPT
  USE IOTOOLS

  implicit none
  integer                :: i,ik,Lk,iloop
  logical                :: converged
  real(8)                :: adummy
  logical                :: check1,check2,check

  complex(8)             :: zeta1,zeta2,det
  real(8)                :: n,delta,n0,delta0
  !
  complex(8),allocatable :: sigma(:,:),fg(:,:)
  complex(8),allocatable :: wf0(:,:),calG(:,:)
  complex(8),allocatable :: sold(:,:),zeta(:)
  !
  real(8),allocatable    :: wt(:),epsik(:),wr(:)

  include "revision.inc"
  call version(revision)
  call read_input("inputIPT.in")

  allocate(wr(L))
  wr = linspace(-wmax,wmax,L,mesh=fmesh)
  print*,"|omegamax|",wr(L)

  allocate(fg(2,L),sigma(2,L))
  allocate(wf0(2,L),calG(2,L))
  allocate(sold(2,L),zeta(L))

  D=2.d0*ts; Lk=Nx**2 ; allocate(wt(Lk),epsik(Lk))
  call bethe_lattice(wt,epsik,Lk,D)

  call get_initial_sigma

  iloop=0 ; converged=.false.
  do while (.not.converged)
     iloop=iloop+1
     write(*,"(A,i5)",advance="no")"DMFT-loop",iloop

     fg=zero
     zeta(:) = cmplx(wr(:),eps,8) + xmu - sigma(1,:)
     do i=1,L
        zeta1 = zeta(i)
        zeta2 = conjg(zeta(L+1-i))
        do ik=1,Lk
           det     = (zeta1-epsik(ik))*(zeta2-epsik(ik)) + conjg(sigma(2,L+1-i))*sigma(2,i)
           fg(1,i) =fg(1,i) + wt(ik)*(zeta2-epsik(ik))/det
           fg(2,i) =fg(2,i) - wt(ik)*conjg(sigma(2,L+1-i))/det
        enddo
     enddo

     n    = -sum(aimag(fg(1,:))*fermi(wr,beta))*fmesh/pi ! densita' per spin
     delta= -(u*sum(aimag(fg(2,:))*fermi(wr,beta))*fmesh/pi)

     !Hartree corrected WF is: xmu=xmu0
     !\tilde{\calG0} = [G^-1 + Sigma - \Sigma_HFB]^-1
     do i=1,L
        det     = fg(1,i)*conjg(fg(1,L+1-i)) + conjg(fg(2,L+1-i))*fg(2,i)
        wf0(1,i)= conjg(fg(1,L+1-i))/det  + sigma(1,i)   +  u*(n-0.5d0)
        wf0(2,i)= fg(2,i)/det       + conjg(sigma(2,L+1-i))   + delta
     end do

     do i=1,L
        det      =  wf0(1,i)*conjg(wf0(1,L+1-i)) + conjg(wf0(2,L+1-i))*wf0(2,i)
        calG(1,i)=  conjg(wf0(1,L+1-i))/det
        calG(2,i)=  conjg(wf0(2,L+1-i))/det
     end do

     n0    =  -sum(aimag(calG(1,:))*fermi(wr,beta))*fmesh/pi
     delta0=  -(u*sum(aimag(calG(2,:))*fermi(wr,beta))*fmesh/pi)

     ! halfsummag=sum(-1.d0/pi*dimag(fg(1,-L:0))*fmesh)
     ! summag=sum(-1.d0/pi*dimag(fg(1,:))*fmesh)

     ! halfsummag0=sum(-1.d0/pi*dimag(calG(1,-L:0))*fmesh)
     ! summag0=sum(-1.d0/pi*dimag(calG(1,:))*fmesh)

     !write(*,"(a10,2f10.6,a10,2f10.6)")"fg",summag,halfsummag,"calg0",summag0,halfsummag0

     write(*,"(4(f16.12))",advance="no"),n,n0,delta,delta0
     sold=sigma
     sigma =  solve_mpt_sc_sopt(calG,wr,n,n0,delta,delta0,L)
     sigma = weight*sigma + (1.d0-weight)*sold
     converged = check_convergence(sigma(1,:)+sigma(2,:),eps=eps_error,N1=Nsuccess,N2=Nloop)

     if(nread/=0.d0)call search_mu(converged)

     call splot("nVSiloop.ipt",iloop,n,append=TT)
     call splot("deltaVSiloop.ipt",iloop,delta,append=TT)
     call splot("DOS.ipt",wr,-aimag(fg(1,:))/pi,append=printf)
     call splot("G_realw.ipt",wr,fg(1,:),append=printf)
     call splot("F_realw.ipt",wr,fg(2,:),append=printf)
     call splot("Sigma_realw.ipt",wr,sigma(1,:),append=printf)
     call splot("Self_realw.ipt",wr,sigma(2,:),append=printf)
     call splot("calG0_realw.ipt",wr,calG(1,:),append=printf)
     call splot("calF0_realw.ipt",wr,calG(2,:),append=printf)
     call splot("observables.ipt",xmu,u,n,n0,delta,delta0,beta,dble(iloop),append=printf)
  enddo

  !ndelta=0.01d0  !  serve per evitare che il deltan piccolissimo in uscita
  !  venga resettato da file . Usa chi_trial e' meglio

  open(10,file="used.inputIPT.in")
  write(10,nml=variables) ! in questo modo il potenziale chimico e' updatato e non riparto sempre dallo stesso
  close(10)
  ! problema: lo step nel potenziale chimico cosi' e' salvato e nel ciclo gli step diventano piccolissimi che e' un casino  densita' e'

  call close_file("nVSiloop.ipt")
  call close_file("deltaVSiloop.ipt")
  call splot("DOS.last",wr,-aimag(fg(1,:))/pi,append=FF)
  call splot("G_realw.last",wr,fg(1,:),append=FF)
  call splot("F_realw.last",wr,fg(2,:),append=FF)
  call splot("Sigma_realw.last",wr,sigma(1,:),append=FF)
  call splot("Self_realw.last",wr,sigma(2,:),append=FF)
  call splot("calG0_realw.last",wr,calG(1,:),append=FF)
  call splot("calF0_realw.last",wr,calG(2,:),append=FF)
  call splot("observables.last",xmu,u,n,n0,delta,delta0,beta,dble(iloop),append=printf)

contains

  subroutine search_mu(convergence)
    integer, save         ::nindex
    integer               ::nindex1
    real(8)               :: naverage,ndelta1
    logical,intent(inout) :: convergence
    naverage=n
    nindex1=nindex
    ndelta1=ndelta
    if((naverage >= nread+nerror))then
       nindex=-1
    elseif(naverage <= nread-nerror)then
       nindex=1
    else
       nindex=0
    endif
    if(nindex1+nindex==0)then !avoid loop forth and back
       ndelta=real(ndelta1/2.d0,8) !decreasing the step
       xmu=xmu+real(nindex,8)*ndelta
    else
       ndelta=ndelta1
       xmu=xmu+real(nindex,8)*ndelta
    endif
    write(*,"(A,2f15.12,A,f15.12,A,I3,f15.12)")"mu,n=",xmu,naverage,"/",nread,"| ",nindex,ndelta
    if(abs(naverage-nread)>nerror)convergence=.false.
    call splot("muVSiter.ipt",iloop,xmu,abs(naverage-nread),append=.true.)
  end subroutine search_mu

  subroutine get_initial_sigma()
    inquire(file="Sigma_realw.last",exist=check1)
    inquire(file="Self_realw.last",exist=check2)
    check=check1*check2
    if(check)then
       write(*,*)"Reading Sigma in input:"
       call sread("Sigma_realw.last",wr,sigma(1,:))
       call sread("Self_realw.last",wr,sigma(2,:))
    else
       print*,"Using Hartree-Fock self-energy"
       print*,"===================================="
       n=0.5d0 ;  delta=deltasc
       sigma(2,:)=-delta ; sigma(1,:)=zero ; sold=sigma
    endif
  end subroutine get_initial_sigma

end program ahmmpt


c=======================================================================
c
c     subroutine ALLOCMVTC
c
c     MV allocation srtategy with transaction costs (linear)
c
c     Min[ w*Q*w + alpha*CostTransaction(w)]
c      s.t.
c     C*w <= b                 (linear constraints)
c     Cinf <= w <= Csup        (lower/upper bounds)
c
c        w   : portfolio weights
c        Q   : covariance matrix
c        rho : assets performance
c
c-----------------------------------------------------------------------
      SUBROUTINE allocmvtc ( n, cov, neq, nin, ccst, bcst, cinf, csup,
     &                       cost, wini, alpha,
     &                       iwork, dwork, wopt, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       n      : number of assets                                integer
c       cov    : covariance matrix (n*n)                          double
c       neq    : number of equality constraints                  integer
c       nin    : number of inequality constraints                integer
c       ccst   : matrix of constraints (n*(neq+nin))              double
c       bcst   : vector of constraints (neq+nin)                  double
c       cinf   : lower bound (n)                                  double
c       csup   : upper bound (n)                                  double
c       cost   : cost transaction (n)                             double
c       wini   : initial portfolio (n)                            double
c       alpha  : transaction cost parameter                       double
c
c     WORKSPACE
c       iwork  : 26*n + 2*nin + neq + 1                          integer
c       dwork  : 2*n*(16*n + nin + neq + 44) + 2(2*nin + neq)     double
c
c     OUTPUT
c       wopt   : optimal portfolio (n)                            double
c       info   : diagnostic argument                             integer
c
c     CALL
c       YM      : matrix copy
c       YV      :
c       QP      : quadratic solver
c       CTITCOV :
c       CTITCST :
c       TESTSDP :
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info, neq, nin
      DOUBLE PRECISION alpha
      DOUBLE PRECISION cov(*), cinf(*), csup(*), ccst(n,*), bcst(*),
     &                 wopt(*), cost(*), wini(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER p, i, neqtot, nintot, piwork, pdwork, piwk,
     &        pigk, pdsp, pdss, pdsa, pdwk, piwq, pdlin, pdwq, pdlagr,
     &        pdbcs, pdccs, pdro, pdwopt, pdcov, pdcinf, pdcsup, test
      DOUBLE PRECISION eps, epsilon, maxv
      PARAMETER ( eps = 1.E-8, epsilon = 1.E-15, maxv = 1.E+15 )
c
c     external subroutines
      EXTERNAL qp, YM, YV, ctitcov, ctitcst, testsdp
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
      test = 0
      p = n
c
c     test if cost(i) = 0 for i = 1,...,n
      DO i = 1,n
        IF (cost(i) .GT. epsilon) test = 1
      ENDDO
c
c     case alpha > eps (with trans. costs)
      IF ((alpha .GT. eps).AND.(test .EQ. 1)) p = n + n
c
c     pointers for integer workspace : iwork
c     --------------------------------------
      piwork = 1
      piwk   = piwork
c     piwk  : pointer for workspace of KATAVEP who needs ( 12*p )
      pigk   = piwk + ( 12*p )
c     pigk  : pointer Kato groups, so (p) more
c     the call of KATAVEP needs ( 13*p )
c
c     pointers for QP who uses a part of the same space
      piwq   = piwork
c     piwq  : pointer for QP who needs
c             ( 3*p + 2*nintot + neqtot + 1 ),
c          so ( 3*p + 2*(nin + p) + neq + 1 )
c          so ( 5*p + 2*nin + neq + 1 )
c
c     together KATAVEP and QP need (union of space)
c     ( 13*p + 2*nin + neq + 1 )
c
c     Total size of iwork array = ( 13*p + 2*nin + neq + 1 )
c
c     pointers for double precision workspace  : dwork
c     ------------------------------------------------
      pdwork = 1
      pdwopt  = pdwork
c     pdwopt : pointer for the optimal point, so ( p ) more
      pdcov  = pdwopt + p
c     pdcov  : pointer for quadratic part, so (p*p) more
      pdsp   = pdcov + ( p*p )
c     pdsp   : pointer for vector spectr of KATAVEP, so ( p ) more
      pdss   = pdsp + ( p )
c     pdss   : pointer for vector eigsor of KATAVEP, so ( p ) more
      pdsa   = pdss + ( p )
c     pdsa   : pointer for vector spectr of KATAVEP, so ( p ) more
      pdwk   = pdsa + ( p )
c     pdwk  : pointer for KATAVEP workspace, so p*(4*p + 26) more
      pdro   = pdwk + ( p*(4*p + 26) )
c     pdro   : pointer for the robust quadratic part, so ( p*p ) more
      pdlin  = pdro + ( p*p )
c     pdlin  : pointer for linear part vector, so ( p ) more
      pdwq   = pdlin + ( p )
c     pdwq  : pointer for QP workspace who needs
c                ( p*p + 6*p + 2*nintot)
c             so ( p*p + 6*p + 2*(nin + p) )
c             so ( p*p + 8*p + 2*nin )
      pdlagr  = pdwq + ( p*p + 6*p + 2*nin )
      IF ((alpha .GT. eps).AND.(test .EQ. 1))
     &  pdlagr  = pdwq + ( p*p + 8*p + 2*nin )
c     pdlagr : pointer for Lagrange multipliers vector
c              ( p + nintot + neqtot)
      pdbcs   = pdlagr + ( p + nin + neq )
      IF ((alpha .GT. eps).AND.(test .EQ. 1))
     &   pdbcs   = pdlagr + ( 2*p + nin + neq )
c     pdbcs : pointer for the constraints vector ( nintot + neqtot ),
      pdccs   = pdbcs +  ( nin + neq)
      IF ((alpha .GT. eps).AND.(test .EQ. 1))
     &   pdccs   = pdbcs +  ( p + nin + neq)
c     pdccs : pointer for the constraints matrix
c              p*( nintot + neqtot ),
      pdcinf  = pdccs + ( p*(nin + neq) )
      IF ((alpha .GT. eps).AND.(test .EQ. 1))
     &   pdcinf  = pdccs + ( p*(p + nin + neq) )
c     pdcinf : pointer for the cinf optimal point, so ( p ) more
      pdcsup  = pdcinf + ( p )
c     pdcsup : pointer for the csup optimal point, so ( p ) more
c
c                      = p
c                      + p*p
c                      + p
c                      + p
c                      + p
c                      + P*(4*p + 26)
c                      + p*p
c                      + p
c                      + p*( p + 8 ) + 2*nin
c                      + 2*p + nin + neq
c                      + p + nin + neq
c                      + p*( p + nin + neq )
c                      + p
c                      + p
c                      = p*( 8*p + nin + neq + 44 ) + 4*nin+ + 2*neq
c
c     Total size of dwork array = p*(8*p + nin + neq + 44) + 4*nin + 2*neq
c
c--------------------------------------------------------------------
c
c     linear part and optimal weights initialization
      DO i = 1,n
        dwork(pdlin + i - 1) = epsilon
      ENDDO
c
c     case alpha = 0 (without transaction cost. p=0)
c     quadratic solver (Mean-Variance Optimization)
      IF ((alpha .LE. eps).OR.(test .EQ. 0)) THEN
c
c           copy cov. matrix
            CALL YM ( n, n, cov, dwork(pdro) )
c
c           quadratic term (matrix) SDP test
            CALL testsdp (n, dwork(pdro), iwork(piwk), dwork(pdwk),info)
            IF (info .NE. 0) THEN
                info = -108
                RETURN
            ENDIF
            CALL qp ( n, dwork(pdro), dwork(pdlin),
     &                neq, nin, ccst, bcst, cinf, csup,
     &                iwork(piwq), dwork(pdwq), dwork(pdlagr),
     &                wopt, info )
            RETURN
      ENDIF
c
c     quadratic term (matrix) SDP test
      CALL testsdp (n, cov, iwork(piwk), dwork(pdwk),info)
      IF (info .NE. 0) THEN
        info = -108
        RETURN
      ENDIF
c
c     add transaction cost. in linear part
c     p=[0, ..., 0, alpha*cost(1), ..., alpha*cost(n)]
      DO i = 1,n
        IF ((alpha*cost(i)) .LT. eps) THEN
            dwork(pdlin + n + i - 1) = alpha*eps
        ELSE
            dwork(pdlin + n + i - 1) = alpha*cost(i)
        ENDIF
      ENDDO
c
c     problem formulation: min[x'*Q*x + p'*x]
c
c     quadratic part Gamma := [cov   0             ] (cf. utalloc.f)
c                             [ 0   (alpha*cost)^2 ]
      CALL ctitcov (n, cov, alpha, cost, dwork(pdcov), info)
c
      CALL YM ( p, p, dwork(pdcov), dwork(pdro) )
c
c     quadratic term (matrix) SDP test
      CALL testsdp (p, dwork(pdro), iwork(piwk), dwork(pdwk), info)
      IF (info .NE. 0) THEN
         info = -108
         RETURN
      ENDIF
c
c     constraint modeling (cf. UTALLOC.F)
c     C*w <= b + cost transaction
      CALL ctitcst ( n, cost, neq, nin, ccst, bcst, wini,
     &               neqtot, nintot, dwork(pdccs), dwork(pdbcs), info )
c
c     lower/upper bounds
      DO i = 1,n
        dwork(pdcinf + i - 1)     = cinf(i)
        dwork(pdcinf + n + i - 1) = epsilon
        dwork(pdcsup + i - 1)     = csup(i)
        dwork(pdcsup + n + i - 1) = maxv
      ENDDO
c
c     quadratic solver (QUAPRO)
      CALL qp ( p, dwork(pdro), dwork(pdlin), neqtot, nintot,
     &          dwork(pdccs), dwork(pdbcs), dwork(pdcinf),
     &          dwork(pdcsup),
     &          iwork(piwq), dwork(pdwq), dwork(pdlagr),
     &          dwork(pdwopt), info )
      IF (info .LT. 0) RETURN
c
c     optimal portfolio
      CALL YV (n, dwork(pdwopt), wopt)
      RETURN
      END


module mep_niu
	use constants,		only:		dp
	use input_paras,	only:		kubo_tol,	valence_bands
	use matrix_math,	only:		get_levi_civita,			&
									convert_tens_to_vect
	use omp_lib

	implicit none

	private
	public			::		mep_niu_CS,		&
							mep_niu_IC,		&
							mep_niu_LC

contains

	!
	!MEP RESPONSES
	function mep_niu_CS(A_ka, Om_kab) result(cs_tens)
		complex(dp),	allocatable, 	intent(in)		::	A_ka(:,:,:), Om_kab(:,:,:,:)
		real(dp), 	allocatable							::	cs_tens(:,:,:)
		complex(dp)										::	om_vect(3)
		integer											::	n0, i
		!
		allocate(	cs_tens(3,3,valence_bands)	)
		cs_tens	=	0.0_dp
		!
		if(	allocated(A_ka)		.and.		allocated(Om_kab)		)then
			!$OMP PARALLEL DO 			&
			!$OMP DEFAULT(none)			&
			!$OMP PRIVATE(om_vect,i)	&
			!$OMP SHARED(valence_bands, Om_kab, A_ka, cs_tens)
			do n0 = 1, valence_bands
				call convert_tens_to_vect(	Om_kab(:,:,n0,n0),		om_vect(:)	)
				do i = 1, 3
					cs_tens(i,i,n0)	=	0.5_dp  *	dreal(	 dot_product(	A_ka(:,n0,n0)	,	om_vect(:)	))
				end do
			end do
			!$OMP END PARALLEL DO
		end if
		!
		return
	end function

	function mep_niu_LC(V_ka, en_k) result(F3)
		!	LOCAL KUBO CONTRIBUTION
		!
		complex(dp),		intent(in)		::	V_ka(:,:,:)
		real(dp),			intent(in)		::	en_k(:)
		real(dp),			allocatable		::	F3(:,:,:)
		integer								::	n0, n, n_wf,	&
												j, k, l, leviC(3,3,3)
		real(dp) 							::	pre_fact, velo_nom(3), en_denom
		!
		allocate(	F3(3,3,valence_bands)	)
		F3		= 0.0_dp
		n_wf	= size(en_k,1)
		!
		call get_levi_civita(leviC)
		!
		!$OMP PARALLEL DO 												&
		!$OMP DEFAULT(none)												&
		!$OMP PRIVATE(n, en_denom, j,k,l, pre_fact, velo_nom)			&
		!$OMP SHARED(valence_bands, n_wf, en_k, kubo_tol, leviC, V_ka)	&
		!$OMP REDUCTION(+:F3) 											&
		!$OMP COLLAPSE(2)
		do n0 = 1, valence_bands
			do n = 1, n_wf
			 	if( n/= n0 )	then
			 		en_denom	=	(	en_k(n0) - en_k(n)	)**3
			 		if(abs(en_denom) > kubo_tol) then
			 			!
						!TRIPLE PRODUCT
			 			do j = 1, 3
			 				do k = 1, 3
			 					do l = 1, 3
			 						pre_fact	=	real(			leviC(j,k,l)						,dp)
			 						!
			 						!
			 						if(		 abs(pre_fact) 	> 1e-1_dp	) then
			 							velo_nom(:)		=	real(		V_ka(:,n0,n) * V_ka(k,n,n0) * V_ka(l,n0,n0)		, dp)
			 							F3(:,j,n0)		= 	F3(:,j,n0) 	+	pre_fact   * velo_nom(:)	/	en_denom
			 						end if
			 						!
			 					end do
			 				end do
			 			end do
			 		end if
			 	end if
			 	!
			 	!
			end do
		end do
		!$OMP END PARALLEL DO
		!
		return
	end function

	function mep_niu_IC(V_ka, en_k) result(F2)
		!	ITINERANT KUBO CONTRIBUTION
		!
		complex(dp),		intent(in)		::	V_ka(:,:,:)
		real(dp),			intent(in)		::	en_k(:)
		real(dp),			allocatable		::	F2(:,:,:)
		integer								::	n0, m, n, 		&
												j, k, l,		&
												n_wf, leviC(3,3,3)
		real(dp) 							::	pre_fact, velo_nom(3), en_denom
		!
		allocate(	F2(3,3,valence_bands)	)
		F2		= 0.0_dp
		n_wf	= size(en_k,1)
		call get_levi_civita(leviC)
		!
		!
		!$OMP PARALLEL DO 												&
		!$OMP DEFAULT(none)												&
		!$OMP PRIVATE(n, en_denom, j,k,l, pre_fact, velo_nom)			&
		!$OMP SHARED(valence_bands, n_wf, en_k, kubo_tol, leviC, V_ka)	&
		!$OMP REDUCTION(+:F2) 											&
		!$OMP COLLAPSE(2)
		do n0 = 1, valence_bands
			do m = 1, n_wf
				!
				!
				do n = 1, n_wf
				 	if( n/= n0 .and. m/=n0 )	then
				 		en_denom	=	(	en_k(n0) - en_k(n)	)**2		 * 		(	en_k(n0) - en_k(m)	)
				 		if( abs(en_denom) > kubo_tol) then
				 			!
				 			!TRIPLE PRODUCT
				 			do j = 1, 3
				 				do k = 1, 3
				 					do l = 1, 3
				 						pre_fact	= 	- real(leviC(j,k,l),dp)
				 						!
				 						!
				 						if(		 abs(pre_fact) 	> 1e-1_dp	) then
											velo_nom(:)	=	real(		V_ka(:,n0,n) * V_ka(k,n,m) * V_ka(l,m,n0)	, dp)
				 							F2(:,j,n0)	= 	F2(:,j,n0)		+	pre_fact  * velo_nom(:)	/	en_denom
				 						end if
				 						!
				 					end do
				 				end do
				 			end do
				 		end if
				 	end if
				 	!
				 	!
				end do
			end do
		end do
		!$OMP END PARALLEL DO
		!
		return
	end function

end module mep_niu

!!privat old:
!	subroutine	getF2(nZero,ki, V_ka ,En, F2)
!		!
!		!	F^(2)_ij = + Re \sum_{n/=0,m/=0} \eps_{j,k,l} * (V^k_nm V^l_m0 V^i_mn) / ( (E0-En)**2 (E0-Em) )
!		!
!		integer,		intent(in)		:: nZero, ki
!		complex(dp),	intent(in)		:: V_ka(:,:,:,:)
!		real(dp),		intent(in)		:: En(:,:)			!
!		real(dp),		intent(out)		:: F2(3,3)
!		complex(dp)						:: Vtmp
!		real(dp)						:: eDiff, eDiff1, eDiff2
!		integer							:: i, j, k, l, n,m, nSize
!		!
!		nSize	=	size(V_ka,3)
!		F2		=	0.0_dp
!		!loop bands
!		do n = 1, nSize
!			if( n/=nZero ) then
!				do m = 1, nSize
!					if(  m/=nZero) then
!						!
!						!
!						!ENERGIES
!						eDiff1		= 	( 	En(nZero,ki) - En(n,ki)		)**2
!						eDiff2		=  	( 	En(nZero,ki) - En(m,ki)		)
!						eDiff		= 	eDiff1 * eDiff2
!						!degenerate energy warning
!						if( abs(eDiff) < machineP )  then
!							write(*,*)	"[addF2]: WARNING for k point = ",ki
!							write(*,'(a,i3,a,i3,a,i3,a,e14.6)') "[addF2]: WARNING degenerate bands n0=",nZero,"n=",n," m=",m," eDiff=",eDiff
!							write(*,'(a,i3,a,i3,a,e14.6)')	"[addF2]: ( E(",nZero,")-E(",n,") )**2=", eDiff1
!							write(*,'(a,i3,a,i3,a,e14.6)')	"[addF2]: ( E(",nZero,")-E(",m,") )   =", eDiff2
!							write(*,*)	"[addF2]: E(nZero=",nZero,")=",En(nZero,ki)
!							write(*,*)	"[addF2]: E(n=",n,")=",En(n,ki)
!							write(*,*)	"[addF2]: E(m=",m,")=",En(m,ki)
!						end if
!						!
!						!loop matrix indices
!						do j = 1, 3
!							do i = 1, 3
!								!
!								!loop levi civita
!								do k = 1, 3
!									do l = 1, 3
!										!V_kaCITIES
!										Vtmp		= V_ka(k,n,m,ki) * V_ka(l,m,nZero,ki) * V_ka(i,nZero,n,ki)
!										!if( dimag(Vtmp) > 1e-10_dp ) write(*,*)	"[addF2]: none zero imag V_ka product: ",dimag(Vtmp),"; real part: ",dreal(Vtmp)
!										!MATRIX
!										F2(i,j) 	= F2(i,j) +   real(my_Levi_Civita(j,k,l),dp) *  dreal( Vtmp )  / eDiff
!										!F2(i,j) 	= F2(i,j) +   my_Levi_Civita(j,k,l) *  dreal( Vtmp )  / eDiff
!									end do
!								end do
!								!
!							end do
!						end do
!						!
!					end if
!				end do
!			end if
!		end do
!		!
!		!
!		return
!	end subroutine
!
!
!
!
!	subroutine	getF3(prefactF3, nZero,ki, V_ka ,En, F3)
!		!
!		!	F^(2)_ij = +- Re \sum_{n/=0} \eps_{j,k,l}  * (v^k_0 V^l_nZero V^i_0n) / ( (E0-En)**3  )
!		!
!		integer,		intent(in)		:: nZero, ki
!		complex(dp),	intent(in)		:: V_ka(:,:,:,:)
!		real(dp),		intent(in)		:: prefactF3, En(:,:)
!		real(dp),		intent(out)		:: F3(3,3)
!		complex(dp)						:: Vtmp
!		real(dp)						:: eDiff
!		integer							:: i, j, k, l, n, nSize
!		!
!		nSize 	=	size(V_ka,3)
!		F3		=	0.0_dp
!		!loop bands
!		do n = 1, nSize
!			if( n/=nZero ) then
!				!ENERGIES
!				eDiff		= ( 	En(nZero,ki) - En(n,ki)	 )**3
!				!degenerate energy warning
!				if( abs(eDiff) < machineP ) write(*,*) "[addF3]: WARNING degenerate bands n0=",nZero,"n=",n," eDiff=",eDiff
!				!
!				!loop matrix indices
!				do j = 1, 3
!					do i = 1, 3
!						!
!						!loop levi civita
!						do k = 1, 3
!							do l = 1,3
!								!V_kaCITIES
!								Vtmp		= V_ka(k,nZero,nZero,ki) * V_ka(l,n,nZero,ki) * V_ka(i,nZero,n,ki)
!								!if( dimag(Vtmp) > 1e-10_dp ) write(*,*)	"[addF3]: none zero imag V_ka product: ",dimag(Vtmp),"; real part: ",dreal(Vtmp)
!								!
!								!MATRIX
!								F3(i,j) 	= F3(i,j) + real(prefactF3,dp) * real(my_Levi_Civita(j,k,l),dp) *	 dreal( Vtmp ) / eDiff
!								!F3(i,j) 	= F3(i,j) + prefactF3 * my_Levi_Civita(j,k,l) *	 dreal( Vtmp ) / eDiff
!							end do								!
!						end do
!						!
!					end do
!				end do
!				!
!			end if
!		end do
!		!
!		!
!		return
!	end subroutine
!
!
!
!	subroutine	getF3essin(prefactF3, nZero,ki, V_ka ,En, F3)
!		!
!		!	F^(2)_ij = +- Re \sum_{n/=0} \eps_{j,k,l}  * (v^k_0 V^l_nZero V^i_0n) / ( (E0-En)**3  )
!		!
!		integer,		intent(in)		:: nZero, ki
!		complex(dp),	intent(in)		:: V_ka(:,:,:,:)
!		real(dp),		intent(in)		:: prefactF3, En(:,:)
!		real(dp),		intent(out)		:: F3(3,3)
!		complex(dp)						:: Vtmp
!		real(dp)						:: eDiff
!		integer							:: i, j, k, l, n, nSize
!		!
!		nSize 	=	size(V_ka,3)
!		F3		=	0.0_dp
!		!loop bands
!		do n = 1, nSize
!			if( n/=nZero ) then
!				!ENERGIES
!				eDiff		= ( 	En(nZero,ki) - En(n,ki)	 )**3
!				!degenerate energy warning
!				if( abs(eDiff) < machineP ) write(*,*) "[addF3]: WARNING degenerate bands n0=",nZero,"n=",n," eDiff=",eDiff
!				!
!				!loop matrix indices
!				do j = 1, 3
!					do i = 1, 3
!						!
!						!loop levi civita
!						do k = 1, 3
!							do l = 1,3
!								!V_kaCITIES
!								Vtmp		= V_ka(i,nZero,n,ki)  * V_ka(k,n,nZero,ki) * V_ka(l,nZero,nZero,ki)
!								!if( dimag(Vtmp) > 1e-10_dp ) write(*,*)	"[addF3]: none zero imag V_ka product: ",dimag(Vtmp),"; real part: ",dreal(Vtmp)
!								!
!								!MATRIX
!								F3(i,j) 	= F3(i,j) + real(prefactF3,dp) * real(my_Levi_Civita(j,k,l),dp) *	 dreal( Vtmp ) / eDiff
!								!F3(i,j) 	= F3(i,j) + prefactF3 * my_Levi_Civita(j,k,l) *	 dreal( Vtmp ) / eDiff
!							end do								!
!						end do
!						!
!					end do
!				end do
!				!
!			end if
!		end do
!		!
!		!
!		return
!	end subroutine


subroutine seq_grid2roms(unit,identi, gparam, imax,jmax, lon_seq, lat_seq, angle,topo)

  integer, intent(in), dimension(20) :: identi
  real, intent(in), dimension(6)     :: gparam
  integer, intent(in)                :: imax, jmax, unit
  real, intent(inout),dimension(0:imax+1,0:jmax+1) :: lon_seq, lat_seq, angle
  real, intent(inout),dimension(imax,jmax) :: topo
  !character (len=100), intent(in)    :: seq_grd
  integer :: gridno, igtype, ierr
  real :: xp, yp, dx, ylon
  real :: oy, ox, dy, lon,lat
  real, parameter :: xoff = +1.0
  real, parameter :: yoff = +1.0
  integer :: i, j
  ! --- Mathematical values
  real, parameter :: pi = 3.1415926
  real, parameter :: rad = pi/180.0
  real, parameter :: omega = 2*pi/86400.0
  real, parameter :: Re = 6367.0

! open(12, file=trim(seq_grd),form="unformatted")
!  call getflt(100, unit, 0, identi, imax*jmax, topo_seq, igtype,  gparam, 0, ierr)
 ! print *, imax, jmax

  call getflt(0, unit, 0, identi, imax*jmax, topo, igtype,  gparam, 0, ierr)
  close(unit)
!  print *, "imax",imax,"jmax",jmax

  if (identi(9).ge.1000) then
     gridno = int(identi(9)/1000)
  end if

  if (identi(9).eq.1.or.identi(9).eq.4) then
     ! Polarstereographic grid

     if (identi(17) > 0) then
        ! The standard
        xp = identi(15)*0.01
        yp = identi(16)*0.01
        dx = identi(17)*0.1
        ylon = identi(18)
     else
        ! met.no convention for fine scale grids
        xp = identi(15)
        yp = identi(16)
        dx = -identi(17)*0.1
        ylon = identi(18)
     end if

     ! --- Correct for offset error
     xp = xp + xoff
     yp = yp + yoff
 !    print *, "Polarstereographic grid. Grid-parameters: ", xp, yp, dx, ylon

  elseif (identi(9).eq.2.or.gridno.eq.2) then
     ! spherical grid, lat/lon, true north

     if (identi(9).eq.2) then
        ! Only need data from ident
        oy = real(identi(15)/100.0)  ! origos breddegrad
        ox = real(identi(16)/100.0)  ! origos lengdegrad
        dy = real(identi(17)/100.0)  ! dlat
        dx = real(identi(18)/100.0)  ! dlon
     else
        ! Need data from extra ident
        oy = gparam(2)  ! origos breddegrad
        ox = gparam(1)  ! origos lengdegrad
        dy = gparam(4)  ! dlat
        dx = gparam(3)  ! dlon
 !       print *, "Geographic grid. Grid-parameters: ", oy, ox, dy, dx
     end if
  else
!     print *, 'Input grid is not recognized'
     goto 300

  end if

  if (identi(9).eq.1.or.identi(9).eq.4) then

     do j = 0, jmax+1
        do i = 0, imax+1
           call grid2ll(real(i), real(j), lon, lat)
           lon_seq(i,j) = lon
           lat_seq(i,j) = lat
        end do
     end do

     ! Local rotation angle
     do j = 0, jmax+1
        do i = 0, imax+1
           angle(i,j) = atan2(xp-i, yp-j)
        end do
     end do

  elseif  (identi(9).eq.2.or.gridno.eq.2) then

     lat=oy
     lon=ox

     do j = 0, jmax+1
        lat=lat+dy
        lon=ox
        do i = 0, imax+1
           lon=lon+dx
           lon_seq(i,j) = lon
           lat_seq(i,j) = lat
           angle(i,j) = 0
        end do
     end do
  end if

300 continue
contains

subroutine grid2ll(x,y,lon,lat)
  real, intent(in) :: x, y            ! Grid coordinates
  real, intent(out) :: lon, lat       ! Longitude and latitude
  real, parameter :: deg = 1.0/rad
  real, parameter :: phi0 = 60.0*rad
  real :: r

  lon = ylon + atan2(x-xp, yp-y)*deg
  r   = dx * sqrt((x-xp)*(x-xp) + (y-yp)*(y-yp))
  lat = 90.0 - 2*atan(r / (Re*(1+sin(phi0))))*deg
end subroutine grid2ll
end subroutine seq_grid2roms


      real*8 function sqdist(x1,y1,z1,x2,y2,z2,ind,MAXROT,rotmat)
c-----------------------------------------------------------------------
c
c    Squared Anisotropic Distance Calculation Given Matrix Indicator
c    ***************************************************************
c
c This routine calculates the anisotropic distance between two points
c  given the coordinates of each point and a definition of the
c  anisotropy.
c
c
c INPUT VARIABLES:
c
c   x1,y1,z1         Coordinates of first point
c   x2,y2,z2         Coordinates of second point
c   ind              The rotation matrix to use
c   MAXROT           The maximum number of rotation matrices dimensioned
c   rotmat           The rotation matrices
c
c
c
c OUTPUT VARIABLES:
c
c   sqdist           The squared distance accounting for the anisotropy
c                      and the rotation of coordinates (if any).
c
c
c NO EXTERNAL REFERENCES
c
c
c-----------------------------------------------------------------------
      real*8 rotmat(MAXROT,3,3),cont,dx,dy,dz
c
c Compute component distance vectors and the squared distance:
c
      dx = dble(x1 - x2)
      dy = dble(y1 - y2)
      dz = dble(z1 - z2)
      sqdist = 0.0
      do i=1,3
            cont   = rotmat(ind,i,1) * dx
     +             + rotmat(ind,i,2) * dy
     +             + rotmat(ind,i,3) * dz
            sqdist = sqdist + cont * cont
      end do
      return
      end


module module_parameters

REAL(8),PARAMETER :: ALPHA=1E-2 !Alpha decides how to stretch the grid i.e. alpha=0 means homogenous grid
INTEGER,PARAMETER :: N= 11 	!NUMBER OF NODE POINTS IN FVM
REAL(8),PARAMETER ::RHO=1.225			!kg/m^3
REAL(8),PARAMETER ::DYN_VIS=1.802*1E-5 		!kg/m.s Dynamic Viscosity of Air
REAL(8),PARAMETER ::KIN_VIS=1.4725*1E-5		!m^2/s Kinematic Viscosity of Air
REAL(8),PARAMETER:: CONV_CRIT=1E-10           !convergence criteria ( max permissible error)
CHARACTER(len=1):: PLOT="Y"               !automatic plotting set Yes(Y) or No(N)

CHARACTER(len=15):: OUTPUTFILE="Case_01_sim.dat"
REAL(8),PARAMETER ::VW=12.84, H=66E-3,  PGF=0.0d0

end module module_parameters


program main
    use ShapeFunctionClass
    implicit none

    type(FEmesh_)::shapefunc

    integer i,j

    shapefunc%NumOfNode = 8
    shapefunc%NumOfDim  = 3
    shapefunc%NumOfGp   = 8
    do j=1,shapefunc%NumOfGp
        shapefunc%GpID=j

        call GetGaussPoint(shapefunc)
        call SetGaussPoint(shapefunc)
        call GetShapeFunction(shapefunc)
        call GetShapeFuncDer1(shapefunc)
        call GetShapeFuncDer2(shapefunc)

        do i=1,size(shapefunc%dNdgzi,2)
            print *, shapefunc%dNdgzi(:,i)
        enddo
        print *, shapefunc%ErrorMsg
        print *, shapefunc%ierr
    enddo
end program main


      SUBROUTINE NLPQLP_WRAP (L,M,ME,MMAX,N,NMAX,MNN2,
     /                 X,F,G,DF,DG,U,XL,XU,C,D,
     /                 ACC,ACCQP,STPMIN,MAXFUN,MAXIT,MAXNM,RHOB,MODE,
     /                 IFAIL,IPRINT,IOUT,IFILE,
     /                 WA,LWA,KWA,LKWA,ACTIVE,LACTIV,LQL,
     /                 NFUN,NGRD,NLFUNC,NLGRAD)
C
      IMPLICIT         NONE
      INTEGER          NMAX, MMAX, MNN2, LWA, LKWA, LACTIV,
     /                 KWA(LKWA), N, ME, M, L, MAXIT, MAXFUN,
     /                 IPRINT,MAXNM,IOUT,MODE,IFAIL,NFUN,NGRD
      DOUBLE PRECISION X(NMAX,L), F(L), G(MMAX,L), DF(NMAX),
     /                 DG(MMAX,NMAX), U(MNN2), XL(NMAX), XU(NMAX),
     /                 C(NMAX,NMAX), D(NMAX), WA(LWA), ACC, ACCQP,
     /                 STPMIN, RHOB
      LOGICAL          ACTIVE(LACTIV), LQL
      CHARACTER*(*)    IFILE
      EXTERNAL         QL
      EXTERNAL         NLFUNC,NLGRAD
C
C  OPEN WRITE FILE
C
      IF (IPRINT.NE.0) THEN
        OPEN(UNIT=IOUT,FILE=IFILE,STATUS='UNKNOWN')
      ENDIF
C
C  EVALUATE OBJECTIVE AND CONSTRAINTS
C
   30 CONTINUE
      CALL NLFUNC(L,NMAX,MMAX,X,LACTIV,ACTIVE,F,G)
      NFUN=NFUN+1
      IF (IFAIL.EQ.-1) GOTO 50
C
C  EVALUATE GRADIENTS OF OBJECTIVE AND CONSTRAINTS
C
   40 CONTINUE
      CALL NLGRAD(L,NMAX,MMAX,X,LACTIV,ACTIVE,F,G,DF,DG)
      NGRD=NGRD+1
C
C  CALL NLPQLP
C
   50 CONTINUE
      CALL NLPQLP (     L,      M,     ME,   MMAX,      N,
     /               NMAX,   MNN2,      X,      F,      G,
     /                 DF,     DG,      U,     XL,     XU,
     /                  C,      D,    ACC,  ACCQP, STPMIN,
     /             MAXFUN,  MAXIT,  MAXNM,   RHOB, IPRINT,
     /               MODE,   IOUT,  IFAIL,     WA,    LWA,
     /                KWA,   LKWA, ACTIVE, LACTIV,    LQL,
     /                 QL)
C
C  EVALUATIONS
C
	  IF (IFAIL.EQ.-1) GOTO 30
	  IF (IFAIL.EQ.-2) GOTO 40
C
      RETURN
      END


C * * * * * * * * * * * * * * *
C --- DRIVER FOR RADAR5
C * * * * * * * * * * * * * * *
C       Use make command (relevant to Makefile)

        IMPLICIT REAL*8 (A-H,O-Z)

        INTEGER, PARAMETER :: DP=kind(1D0)
C --->  PARAMETERS FOR RADAR5 (FULL JACOBIAN) <---
        INTEGER, PARAMETER :: ND=2
        INTEGER, PARAMETER :: NRDENS=2
        INTEGER, PARAMETER :: NGRID=0
        INTEGER, PARAMETER :: NLAGS=1
        INTEGER, PARAMETER :: NJACL=2
        INTEGER, PARAMETER :: MXST=10000
        INTEGER, PARAMETER :: LWORK=30
        INTEGER, PARAMETER :: LIWORK=30
        REAL, dimension(2) :: TARRAY
        REAL(kind=DP), dimension(ND) :: Y
        REAL(kind=DP), dimension(NGRID+1) :: GRID
        REAL(kind=DP), dimension(LWORK) :: WORK
        REAL(kind=DP), dimension(1) :: RTOL
        REAL(kind=DP), dimension(1) :: ATOL
        INTEGER, dimension(LIWORK) :: IWORK
        INTEGER, dimension(NRDENS+1) :: IPAST
        INTEGER, dimension(22) :: ISTAT
        EXTERNAL  FCN,PHI,ARGLAG,JACLAG,QFUN,SOLOUT

C ------ FILE TO OPEN ----------
        OPEN(9,FILE='sol.out')
        OPEN(10,FILE='cont.out')
        REWIND 9
        REWIND 10

        WRITE(*,*) 'C = '
	READ(*,*) PAR
        RPAR=PAR

C -----------------------------------------------------------------------
C
C --- DIMENSION OF THE SYSTEM
        N=ND
C --- COMPUTE THE STANDARD JACOBIAN NUMERICALLY
        IJAC=0
C --- JACOBIAN IS A FULL MATRIX
        MLJAC=N
C --- DIFFERENTIAL EQUATION IS IN IMPLICIT FORM
        IMAS=1
        MLMAS=N
C --- OUTPUT ROUTINE IS USED DURING INTEGRATION
        IOUT=0
C --- INITIAL VALUES
        X=0.0D0
        Y(1)= SIN(X)
        Y(2)= COS(X)
C       Consistent with initial function
C --- ENDPOINT OF INTEGRATION
        XEND=3.1415926535897932385D0
C --- REQUIRED (RELATIVE AND ABSOLUTE) TOLERANCE
        ITOL=0
        RTOL=1.D-8
        ATOL=RTOL
C --- INITIAL STEP SIZE
        H=1.0D-6
C --- DEFAULT VALUES FOR PARAMETERS
        DO 10 I=1,20
        IWORK(I)=0
  10    WORK(I)=0.0D0
C --- WORKSPACE FOR PAST
        IWORK(12)=MXST
C --- BOTH COMPONENTS USE RETARDED ARGUMENT
        IWORK(15)=NRDENS
        IPAST(1)=1
        IPAST(2)=2
C --- CONTROL OF NEWTON ITERATION
        IWORK(14)=2

C _____________________________________________________________________
C --- CALL OF THE SUBROUTINE RADAR5
        CALL DTIME(TARRAY)
        CALL RADAR5(N,FCN,PHI,ARGLAG,X,Y,XEND,H,
     &                  RTOL,ATOL,ITOL,
     &                  DUMMY,IJAC,MLJAC,MUJAC,
     &                  JACLAG,NLAGS,NJACL,
     &                  IMAS,SOLOUT,IOUT,
     &                  WORK,IWORK,RPAR,IPAR,IDID,
     &                  GRID,IPAST,QFUN,MLMAS,MUMAS)
        CALL DTIME(TARRAY)

C ---
        WRITE (6,*) 'Time = ',TARRAY(1)
C --- PRINT FINAL SOLUTION SOLUTION
        WRITE (6,90) X,Y(1),Y(2)
C --- PRINT STATISTICS
         DO J=13,20
            ISTAT(J)=IWORK(J)
         END DO
        WRITE(6,*)' ***** TOL=',RTOL,' ****'
        WRITE (6,91) (ISTAT(J),J=14,20)
        WRITE (6,92) ISTAT(13)
 90     FORMAT(1X,'X =',F8.2,'    Y =',2E18.10)
 91     FORMAT(' fcn=',I7,' jac=',I6,' step=',I6,
     &        ' accpt=',I6,' rejct=',I6,' dec=',I6,
     &        ' sol=',I7)
 92     FORMAT(' full Newt. its =',I7)
        WRITE(6,*) 'SOLUTION IS TABULATED IN FILES: sol.out & cont.out'

        STOP
        END
C
C
        SUBROUTINE SOLOUT (NR,XOLD,X,HSOL,Y,CONT,LRC,N,
     &                     RPAR,IPAR,IRTRN)
C ----- PRINTS THE DISCRETE OUTPUT AND THE CONTINUOUS OUTPUT
C       AT EQUIDISTANT OUTPUT-POINTS
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), PARAMETER :: XSTEP=0.01D0
        REAL(kind=DP), dimension(N) :: Y
        REAL(kind=DP), dimension(LRC) :: CONT
        REAL(kind=DP), dimension(1) :: RPAR
        EXTERNAL PHI
C       XOUT IS USED FOR THE DENSE OUTPUT
        COMMON /INTERN/XOUT

        WRITE (9,99) X,Y(1),Y(2)
C
        IF (NR.EQ.1) THEN
           WRITE (10,99) X,Y(1),Y(2)
           XOUT=XSTEP
        ELSE
 10        CONTINUE
           IF (X.GE.XOUT) THEN
              WRITE (10,99) XOUT,CONTR5(1,N,XOUT,CONT,X,HSOL),
     &                           CONTR5(2,N,XOUT,CONT,X,HSOL)
              XOUT=XOUT+XSTEP
              GOTO 10
           END IF
        END IF
 99     FORMAT(1X,'X =',F12.8,'    Y =',2E18.10)
        RETURN
        END
C
        FUNCTION ARGLAG(IL,X,Y,RPAR,IPAR,PHI,PAST,IPAST,NRDS)
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(1) :: Y
	  REAL(kind=DP), dimension(1) :: PAST
        INTEGER, dimension(1) :: IPAST
        INTEGER, dimension(1) :: IPAR
        REAL(kind=DP), dimension(1) :: RPAR

C       ARGLAG=MIN(X,X*Y(1)**2)
        ARGLAG=X*Y(1)**2
        RETURN
        END
C
        SUBROUTINE FCN(N,X,Y,F,ARGLAG,PHI,RPAR,IPAR,
     &                  PAST,IPAST,NRDS)
        IMPLICIT REAL*8 (A-H,K,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(N) :: Y
        REAL(kind=DP), dimension(N) :: F
        REAL(kind=DP), dimension(1) :: PAST
        INTEGER, dimension(1) :: IPAST
        REAL(kind=DP), dimension(1) :: RPAR
        EXTERNAL PHI

        P=RPAR(1)

        CALL LAGR5(1,X,Y,ARGLAG,PAST,THETA,IPOS,RPAR,IPAR,
     &             PHI,IPAST,NRDS)
        Y1L1=YLAGR5(1,THETA,IPOS,PHI,RPAR,IPAR,
     &              PAST,IPAST,NRDS)
        Y2L1=YLAGR5(2,THETA,IPOS,PHI,RPAR,IPAR,
     &              PAST,IPAST,NRDS)

        F(1)= Y(2)
        F(2)=-Y(2)+COS(X)*(1.D0+Y1L1)+ P*Y(1)*Y2L1 +
     &        (1.D0-P)*SIN(X)*COS(X*SIN(X)*SIN(X)) -
     &        SIN(X+X*SIN(X)*SIN(X))

        RETURN
        END
C
        SUBROUTINE JACLAG(N,X,Y,DFYL,ARGLAG,PHI,IVE,IVC,IVL,
     &                    RPAR,IPAR,PAST,IPAST,NRDS)
C ----- JACOBIAN OF DELAY TERMS IN THE EQUATION
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(N) :: Y
        REAL(kind=DP), dimension(1) :: DFYL
        REAL(kind=DP), dimension(1) :: PAST
        INTEGER, dimension(1) :: IPAST
        REAL(kind=DP), dimension(1) :: RPAR
        INTEGER, dimension(1) :: IVE,IVC,IVL
        EXTERNAL PHI

        P=RPAR(1)

        IVL(1)=1
        IVE(1)=2
        IVC(1)=1
        IVL(2)=1
        IVE(2)=2
        IVC(2)=2
        DFYL(1)=COS(X)
        DFYL(2)=P*Y(1)

        RETURN
        END

C
        FUNCTION PHI(I,X,RPAR,IPAR)
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(1) :: RPAR
        SELECT CASE (I)
        CASE (1)
            PHI=0.0D0
        CASE (2)
            PHI=1.0D0
        END SELECT
        RETURN
        END

        SUBROUTINE QFUN(N,Q,LQ,RPAR,IPAR)
C --- MATRIX "M" FOR THE TEST PROBLEM
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(1) :: RPAR
        REAL(kind=DP), dimension(LQ,N) :: Q

        Q(1,1)=1.D0
        Q(1,2)=0.D0
        Q(2,1)=0.D0
        Q(2,2)=0.D0
        RETURN
        END


C File: arrays-sect-21.f
C Illustrates array slicing

      program main
      implicit none

      integer, dimension (5,-2:2) :: A
      integer :: i, j

      A = -1

      do i = 1, 5
          write (*,10) A(i,-2), A(i,-1), A(i,0), A(i,1), A(i,2)
      end do
      write(*,11)

 10   format(5(I5,X))
 11   format('')

C      Modifying elements in two slices of A
       A( 3, ::2) = 555	! A(2,-2)  A(2,0)  A(2,2), A(4,-2), A(4,0), A(4,2)

       do i = 1, 5
          write (*,10) A(i,-2), A(i,-1), A(i,0), A(i,1), A(i,2)
      end do

      stop
      end program main


! { dg-do compile }
! { dg-options "-O3 -ffast-math -floop-interchange -fdump-tree-linterchange-details" }

        subroutine mat_times_vec(y,x,a,axp,ayp,azp,axm,aym,azm,
     $  nb,nx,ny,nz)
        implicit none
        integer nb,nx,ny,nz,i,j,k,m,l,kit,im1,ip1,jm1,jp1,km1,kp1

        real*8 y(nb,nx,ny,nz),x(nb,nx,ny,nz)

        real*8 a(nb,nb,nx,ny,nz),
     1  axp(nb,nb,nx,ny,nz),ayp(nb,nb,nx,ny,nz),azp(nb,nb,nx,ny,nz),
     2  axm(nb,nb,nx,ny,nz),aym(nb,nb,nx,ny,nz),azm(nb,nb,nx,ny,nz)

      do k=1,nz
         km1=mod(k+nz-2,nz)+1
         kp1=mod(k,nz)+1
         do j=1,ny
            jm1=mod(j+ny-2,ny)+1
            jp1=mod(j,ny)+1
            do i=1,nx
               im1=mod(i+nx-2,nx)+1
               ip1=mod(i,nx)+1
               do l=1,nb
                  y(l,i,j,k)=0.0d0
                  do m=1,nb
                     y(l,i,j,k)=y(l,i,j,k)+
     1               a(l,m,i,j,k)*x(m,i,j,k)+
     2               axp(l,m,i,j,k)*x(m,ip1,j,k)+
     3               ayp(l,m,i,j,k)*x(m,i,jp1,k)+
     4               azp(l,m,i,j,k)*x(m,i,j,kp1)+
     5               axm(l,m,i,j,k)*x(m,im1,j,k)+
     6               aym(l,m,i,j,k)*x(m,i,jm1,k)+
     7               azm(l,m,i,j,k)*x(m,i,j,km1)
                  enddo
               enddo
            enddo
         enddo
        enddo
        return
        end

! { dg-final { scan-tree-dump-times "is interchanged" 1 "linterchange" } }


* This file contains the following user-defined fortran functions:
*     fery
*     fo3qy
*     fo3qy2
*     fsum
*     futr
*=============================================================================*

      FUNCTION fery(w)

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
*=  Calculate the action spectrum value for erythema at a given wavelength   =*
** Webb, A.R., H. Slaper, P. Koepke, and A. W. Schmalwieser,
** Know your standard: Clarifying the CIE erythema action spectrum,
** Photochem. Photobiol. 87, 483-486, 2011.
*=  Value at 300 nm = 0.6486                                                 =*
*-----------------------------------------------------------------------------*
*=  PARAMETERS:                                                              =*
*=  W - REAL, wavelength (nm)                                             (I)=*
*-----------------------------------------------------------------------------*

      IMPLICIT NONE

* input:
      REAL w

* function value:
      REAL fery

      IF (w .LT. 250.) THEN
          fery = 1.
C outside the ery spectrum range
      ELSEIF ((w .GT. 250.) .AND. (w .LE. 298)) THEN
          fery = 1.
      ELSEIF ((w .GT. 298.) .AND. (w .LE. 328.)) THEN
          fery = 10.**( 0.094*(298.-w) )
      ELSEIF ((w .GT. 328.) .AND. (w .LE. 400.)) THEN
          fery = 10.**( 0.015*(140.-w) )
      ELSE
         fery = 1.E-36
C outside the ery spectrum range
      ENDIF

      RETURN
      END

*=============================================================================*

      FUNCTION fo3qy(w,t)

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
* function to calculate the quantum yield O3 + hv -> O(1D) + O2,             =*
* according to JPL 2000 recommendation:                                      =*
*-----------------------------------------------------------------------------*

      IMPLICIT NONE
      REAL w, t, kt, fo3qy
      REAL a(3), w0(3), nu(3), om(3)

      DATA a/ 0.887, 2.35, 57./
      DATA w0/ 302., 311.1, 313.9/
      DATA nu/ 0., 820., 1190./
      DATA om/ 7.9, 2.2, 7.4/

      fo3qy = 0.
      kt = 0.695 * t

      IF(w .LE. 300.) THEN
         fo3qy = 0.95
      ELSEIF(w .GT. 300. .AND. w .LE. 330.) THEN
         fo3qy = 0.06 +
     $  a(1)                           *EXP(-((w-w0(1))/om(1))**4)+
     $  a(2)*(T/300.)**4*EXP(-nu(2)/kT)*EXP(-((w-w0(2))/om(2))**2)+
     $  a(3)            *EXP(-nu(3)/kT)*EXP(-((w-w0(3))/om(3))**2)
      ELSEIF(w .GT. 330. .AND. w .LE. 345.) THEN
         fo3qy = 0.06
      ELSEIF(w .GT. 345.) THEN
         fo3qy = 0.
      ENDIF

      END

      FUNCTION fo3qy2(w,t)

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
* function to calculate the quantum yield O3 + hv -> O(1D) + O2,             =*
* according to:
* Matsumi, Y., F. J. Comes, G. Hancock, A. Hofzumanhays, A. J. Hynes,
* M. Kawasaki, and A. R. Ravishankara, QUantum yields for production of O(1D)
* in the ultraviolet photolysis of ozone:  Recommendation based on evaluation
* of laboratory data, J. Geophys. Res., 107, 10.1029/2001JD000510, 2002.
*-----------------------------------------------------------------------------*

      IMPLICIT NONE
      REAL w, t, kt, fo3qy2
      REAL A(3), X(3), om(3)
      REAL q1, q2

      DATA A/ 0.8036, 8.9061, 0.1192/
      DATA X/ 304.225, 314.957, 310.737/
      DATA om/ 5.576, 6.601, 2.187/

      fo3qy2 = 0.
      kt = 0.695 * t
      q1 = 1.
      q2 = exp(-825.518/kt)

      IF(w .LE. 305.) THEN
         fo3qy2 = 0.90
      ELSEIF(w .GT. 305. .AND. w .LE. 328.) THEN

         fo3qy2 = 0.0765 +
     $  a(1)*             (q1/(q1+q2))*EXP(-((x(1)-w)/om(1))**4)+
     $  a(2)*(T/300.)**2 *(q2/(q1+q2))*EXP(-((x(2)-w)/om(2))**2)+
     $  a(3)*(T/300.)**1.5            *EXP(-((x(3)-w)/om(3))**2)

      ELSEIF(w .GT. 328. .AND. w .LE. 340.) THEN
         fo3qy2 = 0.08
      ELSEIF(w .GT. 340.) THEN
         fo3qy2 = 0.
      ENDIF

      END

*=============================================================================*

      FUNCTION fsum(n,x)

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
*=  Compute the sum of the first N elements of a floating point vector.      =*
*-----------------------------------------------------------------------------*
*=  PARAMETERS:                                                              =*
*=  N  - INTEGER, number of elements to sum                               (I)=*
*=  X  - REAL, vector whose components are to be summed                   (I)=*
*-----------------------------------------------------------------------------*

      IMPLICIT NONE

* input:
      INTEGER n
      REAL x(n)

* function value:
      REAL fsum

* local:
      INTEGER i

      fsum = 0.
      DO 10, i = 1, n
         fsum=fsum+x(i)
   10 CONTINUE

      RETURN
      END

*=============================================================================*

      FUNCTION futr(w)

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
*=  Calculate the action spectrum value for skin cancer of albino hairless   =*
*=  mice at a given wavelength according to:  deGRuijl, F.R., H.J.C.M.Steren-=*
*=  borg, P.D.Forbes, R.E.Davies, C.Colse, G.Kelfkens, H.vanWeelden,         =*
*=  and J.C.van der Leun, Wavelength dependence of skin cancer induction by  =*
*=  ultraviolet irradiation of albino hairless mice, Cancer Research, vol 53,=*
*=  pp. 53-60, 1993                                                          =*
*=  (Action spectrum for carcinomas)                                         =*
*-----------------------------------------------------------------------------*
*=  PARAMETERS:                                                              =*
*=  W  - REAL, wavelength (nm)                                            (I)=*
*-----------------------------------------------------------------------------*

      IMPLICIT NONE

* input:
      REAL w

* function value:
      REAL futr

* local:
      REAL a1, a2, a3, a4, a5,
     >     x1, x2, x3, x4, x5,
     >     t1, t2, t3, t4, t5,
     >     b1, b2, b3, b4, b5,
     >     p

      a1 = -10.91
      a2 = - 0.86
      a3 = - 8.60
      a4 = - 9.36
      a5 = -13.15

      x1 = 270.
      x2 = 302.
      x3 = 334.
      x4 = 367.
      x5 = 400.

      t1 = (w-x2)*(w-x3)*(w-x4)*(w-x5)
      t2 = (w-x1)*(w-x3)*(w-x4)*(w-x5)
      t3 = (w-x1)*(w-x2)*(w-x4)*(w-x5)
      t4 = (w-x1)*(w-x2)*(w-x3)*(w-x5)
      t5 = (w-x1)*(w-x2)*(w-x3)*(w-x4)

      b1 = (x1-x2)*(x1-x3)*(x1-x4)*(x1-x5)
      b2 = (x2-x1)*(x2-x3)*(x2-x4)*(x2-x5)
      b3 = (x3-x1)*(x3-x2)*(x3-x4)*(x3-x5)
      b4 = (x4-x1)*(x4-x2)*(x4-x3)*(x4-x5)
      b5 = (x5-x1)*(x5-x2)*(x5-x3)*(x5-x4)

      p = a1*t1/b1 + a2*t2/b2 + a3*t3/b3 + a4*t4/b4 + a5*t5/b5

      futr  = EXP(p)

      RETURN
      END


program path_trace
    use pnm
    use scene_path

    implicit none

    real, parameter, dimension(3,3) :: identity = reshape( &
                (/ 1,0,0,0,1,0,0,0,1 /), shape(identity) )

    integer, parameter :: height=512, width=512
    real, dimension(width,height,3) :: image
    integer, dimension(width,height,3) :: int_image
    real, parameter :: aspect_ratio = width/height
    ! View_plane properties
    real, parameter :: view_len = width / tan(fov/2)/2
    real, dimension(3) :: hor,top_pixel
    ! ray tracing variables
    real, dimension(3) :: ray, pixel
    real :: colour(3)

    ! Set up the ray tracer geometry
    call cross(hor, cam_direction, ver)
    call normalize( ver )
    call normalize( hor )

    ! Establish view-plane location
    top_pixel = cam_position + cam_direction*view_len + ver*height/2 -hor*width/2;

    ! Seed random variable
    rand(0)
    ! Now, to do the tracing
    call trace_loop(img, hor, ver, top_pixel)

    int_image = nint(image*255)
    int_image = min(int_image, 255)
    call write_ppm('/scratch/jladan/traced.ppm', int_image)

contains
    subroutine trace_loop(img, hor, ver, top_pixel)
        real, intent(out) :: img(:,:)
        real, intent(in) :: hor(3), ver(3), top_pixel(3)

        integer :: i, j

        do i = 1,ubound(image,2)
            do j = 1,ubound(image,1)
                colour = 0
                pixel = top_pixel + hor*aspect_ratio*j - ver*i
                ray = pixel - cam_position
                call trace(colour, ray, cam_position)
            end do
        end do
    end subroutine

    subroutine trace(colour, ray, origin)
        real, intent(in) :: ray(3), origin(3)
        real, intent(out) :: colour(3)

        call trace_workhorse(colour, ray, origin, max_bounces)
    end subroutine

    subroutine trace_workhorse(colour, ray, origin)
        real, intent(in) :: ray(3), origin(3)
        real, intent(out) :: colour(3)
        real, dimension(3) :: normal, intersection, new_ray, tmp_colour
        real, dimension(3) :: material_colour
        real :: raylen
        integer :: i, sphere
        logical flag

        call intersect_nodes(ray, origin, raylen, normal, node, flag)

        colour=0
        if (flag) then              ! intersection
            if (node_type(node) ==  light_type) then
                colour = node_colour(node)
            else
                intersection = ray*raylen + origin
                do i = 1,max_casts
                    call scatter_ray(normal, new_ray)
                    call trace_workhorse(tmp_colour, new_ray, intersection)
                    colour = colour + tmp_colour * node_colour(node)
                end do
                colour = colour/max_casts(3)
            end if
        end if
    end subroutine

    subroutine scatter_ray(ray, normal, new_ray)
        real, intent(in) :: normal(3), ray(3)
        real, intent(out) :: new_ray(3)

        real :: binormal(3), phi, theta
        real :: tilt_matrix, rot_matrix

        ! determine our other axis for rotation
        call cross(binormal, ray, normal)
        ! just reflect anywhere in a hemisphere for now.
        phi = (rand(0)-0.5) * pi
        theta = rand(0) * 2*pi
        tilt_matrix = rotation_matrix(binormal,phi)
        rot_matrix = rotation_matrix(normal, theta)

        new_ray = matmul(rot_matrix, matmul(tilt_matrix))

    end subroutine

    subroutine intersect_spheres(ray, origin, raylen, normal, sphere)
        real, intent(in) :: ray(3), origin(3)
        real, intent(out) :: raylen, normal(3)
        integer, intent(out) :: sphere
        integer :: k
        real :: m = 10000,tmp, tmp_normal(3)

        raylen = 0

        do k = 1,ubound(spheres,2)
            call intersect_sphere(ray, origin, spheres(:,k), tmp, tmp_normal)
            if (tmp > 0.0000001) then
                if (tmp < raylen .or. raylen==0) then
                    raylen = tmp
                    sphere = k
                    normal = tmp_normal
                end if
            end if
        end do
    end subroutine

    subroutine intersect_sphere(ray, origin, sphere, raylen, normal)
        real, intent(in) :: ray(3), origin(3), sphere(4)
        real, intent(out) :: normal(3), raylen

        real :: line(3), a, b, c, roots(2)
        integer :: numroots
        line = sphere(1:3) - origin;
        a = dot_product(ray,ray)
        b = dot_product(ray,line)
        c = dot_product(line, line)

        call quadroots(a,-2*b, c - sphere(4)**2, numroots, roots)
        select case (numroots)
            case (0)
                raylen = 0
                normal = 0
            case (1)
                call ray_epsilon_check(roots(1), ray, line, raylen, normal)
            case (2)
                if (roots(1)<roots(2)) then
                    call ray_epsilon_check(roots(1), ray, line, raylen, normal)
                else
                    call ray_epsilon_check(roots(2), ray, line, raylen, normal)
                end if
        end select
    end subroutine

    subroutine quadroots(a, b, c, numroots, roots)
        real, intent(in) :: a,b,c
        real, intent(out) :: roots(2)
        integer, intent(out) :: numroots

        real :: t

        if (a==0) then
            roots(1) = -c/b
            roots(2) = 0
            numroots = 1
        else
            t = b**2 - 4*a*c
            if (t>0) then
                roots(1) = (-b+sqrt(t)) / (2*a)
                roots(2) = (-b-sqrt(t)) / (2*a)
                numroots = 2
            else
                roots = 0
                numroots = 0
            end if
        end if
    end subroutine

    subroutine ray_epsilon_check(root, ray, line, raylen, normal)
        real, intent(in) :: root, ray(3), line(3)
        real, intent(out) :: raylen, normal(3)

        if (root > 0.0000001) then
            raylen = root
            normal = ray*root-line
        else
            raylen=0
            normal=0
        end if
    end subroutine

    subroutine cross(tmp, x,y)
        real, dimension(3), intent(in) :: x,y
        real, dimension(3), intent(out) :: tmp

        tmp(1) = x(2)*y(3)-x(3)*y(2)
        tmp(2) = x(3)*y(1)-x(1)*y(3)
        tmp(3) = x(1)*y(2)-x(2)*y(1)
    end subroutine

    subroutine normalize(x)
        real, intent(inout) :: x(:)

        x = x / sqrt(dot_product(x,x))
    end subroutine

    function rotation_matrix(axis, theta)
        real, intent(in) :: axis(3), theta
        real :: norm(3)

        norm = axis
        call normalize(axis)
        rotation_matrix = identity*cos(theta) + sin(theta)*cross_matrix(nnorm) + (1-cos(theta)*tensor_product(nnorm)
    end function

    function cross_matrix(u)
        real, intent(in) :: u(3)
        real, intent(out) :: cross_matrix(3,3)
        real :: m(3,3)=0

        m(2,1) = u(3)
        m(1,2) = -u(3)
        m(3,1) = -u(2)
        m(1,3) = u(3)
        m(3,2) = u(1)
        m(2,3) = -u(1)

        cross_matrix = m
    end function

    function tensor_matrix(u)
        real, intent(in) :: u(3)
        real, intent(out) :: tensor_matrix(3,3)
        real :: m(3,3)
        integer :: i, j

        do i = 1,3
            do j = 1,3
                m(i,j) = u(i)*u(j)
            end do
        end do

        tensor_matrix = m
    end function

end program ray_trace


program test_sigma

use constants
use sigma
use aorsaNameList, &
only: nPhi, damping, delta0, lMax, nzfun, upshift, &
    read_nameList, xkPerp_cutOff
use netcdf
use check_mod

implicit none

integer :: nPts, i, j, nK, s
real :: rLeft, rRigh, dr, b0
real(kind=dbl) :: mSpec(2), qSpec(2)
real(kind=dbl), allocatable :: omgc(:)
real, allocatable :: r(:), b(:)
real :: kx, ky, kVec(3)
real :: k_cutOff, freq
real(kind=dbl) :: omgrf, k0, density, omgp2
real(kind=dbl) :: ktSpec
complex(kind=dbl) :: sigma_tmp(3,3)
real :: U_cyl(3,3), U_xyz(3,3)
integer :: zSpec(2)
character(len=100) :: fileName, outFName
complex(kind=dbl), allocatable, dimension(:,:) :: &
    sig11, sig12, sig13, &
    sig21, sig22, sig23, &
    sig31, sig32, sig33
integer :: nc_id, n_id, nK_id, &
    r_id, k_id, &
    sig11_re_id, sig11_im_id,&
    sig12_re_id, sig12_im_id,&
    sig13_re_id, sig13_im_id,&
    sig21_re_id, sig21_im_id,&
    sig22_re_id, sig22_im_id,&
    sig23_re_id, sig23_im_id,&
    sig31_re_id, sig31_im_id,&
    sig32_re_id, sig32_im_id,&
    sig33_re_id, sig33_im_id

real, allocatable :: kArr(:)
real :: kPhi
real :: xNuOmg = 0.00

fileName = 'test_sigma.in'

call read_nameList ( fileName = fileName )

nPts    = 2
rLeft   = 1.0
rRigh   = 1.000001
dr      = (rRigh-rLeft)/(nPts-1)

allocate ( r(nPts),b(nPts),omgc(nPts) )

r       = [ (i*dr,i=1,nPts) ] + rLeft

b0  = 1.0
b   = b0 / r
mSpec   = (/ xme, 2*xmh /)
ktSpec  = 1e3 * q
zSpec   = (/-1, 1/)
qSpec   = zSpec * q
density = 1.0e20
kx  = 1.0
ky  = 0.0
k_cutOff =  1e9
freq   = 80.0e6
omgrf = 2.0 * pi * freq
k0 = omgrf / clight
U_xyz   = real( reshape ( (/1,0,0,0,1,0,0,0,1/) , (/3,3/) ) )
U_cyl   = real( reshape ( (/1,0,0,0,1,0,0,0,1/) , (/3,3/) ) )

nK = 256

allocate (  sig11(nPts,nK),sig21(nPts,nK),sig31(nPts,nK), &
            sig12(nPts,nK),sig22(nPts,nK),sig32(nPts,nK), &
            sig13(nPts,nK),sig23(nPts,nK),sig33(nPts,nK), &
            kArr(nK) )

sig11 = 0
sig12 = 0
sig13 = 0

sig21 = 0
sig22 = 0
sig23 = 0

sig31 = 0
sig32 = 0
sig33 = 0

kArr    = 0

do s=1,2

omgc    = qSpec(s) * b / mSpec(s)
omgp2   = density * qSpec(s)**2 / ( eps0 * mSpec(s) )
write(*,*) omgrf
!write(*,*) omgp2

do i=1,nPts

    do j=1,nK

    nPhi = j-1
    kPhi = nPhi/r(i)

    kArr(j) = j
    kVec = (/ kx, ky, kPhi /)

    sigma_tmp = sigmaHot_maxwellian&
        ( real(mSpec(s),kind=dbl), &
        ktSpec, omgc(i), omgp2, &
        kVec, r(i), &
        omgrf, k0, &
        k_cutoff, s, &
        0.0, 0.0, b(i), 0.0, &
        xnuOmg )

    !sigma_tmp = sigmaCold_stix &
    !    ( omgc(i), omgp2, omgrf, xnuOmg )

        sig11(i,j) = sig11(i,j) + sigma_tmp(1,1)
        sig12(i,j) = sig12(i,j) + sigma_tmp(1,2)
        sig13(i,j) = sig13(i,j) + sigma_tmp(1,3)

        sig21(i,j) = sig21(i,j) + sigma_tmp(2,1)
        sig22(i,j) = sig22(i,j) + sigma_tmp(2,2)
        sig23(i,j) = sig23(i,j) + sigma_tmp(2,3)

        sig31(i,j) = sig31(i,j) + sigma_tmp(3,1)
        sig32(i,j) = sig32(i,j) + sigma_tmp(3,2)
        sig33(i,j) = sig33(i,j) + sigma_tmp(3,3)

    enddo
enddo

!write(*,*) sig11(1,1),sig12(1,1),sig13(1,1)
!write(*,*) sig21(1,1),sig22(1,1),sig23(1,1)
!write(*,*) sig31(1,1),sig32(1,1),sig33(1,1)

enddo

! write value to file for plotting in IDL
! ---------------------------------------

    outFName = 'test_sigma.nc'
    call check ( nf90_create ( outFName, nf90_clobber, nc_id ) )
    call check ( nf90_def_dim ( nc_id, "nPts", nPts, n_id ) )
    call check ( nf90_def_dim ( nc_id, "nK", nK, nK_id ) )

    call check ( nf90_def_var ( nc_id, "sig31_re", nf90_double, &
        (/n_id,nK_id/), sig31_re_id ) )
    call check ( nf90_def_var ( nc_id, "sig31_im", nf90_double, &
        (/n_id,nK_id/), sig31_im_id ) )

    call check ( nf90_def_var ( nc_id, "sig32_re", nf90_double, &
        (/n_id,nK_id/), sig32_re_id ) )
    call check ( nf90_def_var ( nc_id, "sig32_im", nf90_double, &
        (/n_id,nK_id/), sig32_im_id ) )

    call check ( nf90_def_var ( nc_id, "sig33_re", nf90_double, &
        (/n_id,nK_id/), sig33_re_id ) )
    call check ( nf90_def_var ( nc_id, "sig33_im", nf90_double, &
        (/n_id,nK_id/), sig33_im_id ) )

    call check ( nf90_def_var ( nc_id, "sig21_re", nf90_double, &
        (/n_id,nK_id/), sig21_re_id ) )
    call check ( nf90_def_var ( nc_id, "sig21_im", nf90_double, &
        (/n_id,nK_id/), sig21_im_id ) )

    call check ( nf90_def_var ( nc_id, "sig22_re", nf90_double, &
        (/n_id,nK_id/), sig22_re_id ) )
    call check ( nf90_def_var ( nc_id, "sig22_im", nf90_double, &
        (/n_id,nK_id/), sig22_im_id ) )

    call check ( nf90_def_var ( nc_id, "sig23_re", nf90_double, &
        (/n_id,nK_id/), sig23_re_id ) )
    call check ( nf90_def_var ( nc_id, "sig23_im", nf90_double, &
        (/n_id,nK_id/), sig23_im_id ) )

    call check ( nf90_def_var ( nc_id, "sig11_re", nf90_double, &
        (/n_id,nK_id/), sig11_re_id ) )
    call check ( nf90_def_var ( nc_id, "sig11_im", nf90_double, &
        (/n_id,nK_id/), sig11_im_id ) )

    call check ( nf90_def_var ( nc_id, "sig12_re", nf90_double, &
        (/n_id,nK_id/), sig12_re_id ) )
    call check ( nf90_def_var ( nc_id, "sig12_im", nf90_double, &
        (/n_id,nK_id/), sig12_im_id ) )

    call check ( nf90_def_var ( nc_id, "sig13_re", nf90_double, &
        (/n_id,nK_id/), sig13_re_id ) )
    call check ( nf90_def_var ( nc_id, "sig13_im", nf90_double, &
        (/n_id,nK_id/), sig13_im_id ) )

    call check ( nf90_def_var ( nc_id, "r", nf90_real, &
        (/n_id/), r_id ) )
    call check ( nf90_def_var ( nc_id, "k", nf90_real, &
        (/nk_id/), k_id ) )

    call check ( nf90_enddef ( nc_id ) )

    call check ( nf90_put_var ( nc_id, sig11_re_id, realPart ( sig11 ) ) )
    call check ( nf90_put_var ( nc_id, sig11_im_id, imagPart ( sig11 ) ) )
    call check ( nf90_put_var ( nc_id, sig12_re_id, realPart ( sig12 ) ) )
    call check ( nf90_put_var ( nc_id, sig12_im_id, imagPart ( sig12 ) ) )
    call check ( nf90_put_var ( nc_id, sig13_re_id, realPart ( sig13 ) ) )
    call check ( nf90_put_var ( nc_id, sig13_im_id, imagPart ( sig13 ) ) )

    call check ( nf90_put_var ( nc_id, sig21_re_id, realPart ( sig21 ) ) )
    call check ( nf90_put_var ( nc_id, sig21_im_id, imagPart ( sig21 ) ) )
    call check ( nf90_put_var ( nc_id, sig22_re_id, realPart ( sig22 ) ) )
    call check ( nf90_put_var ( nc_id, sig22_im_id, imagPart ( sig22 ) ) )
    call check ( nf90_put_var ( nc_id, sig23_re_id, realPart ( sig23 ) ) )
    call check ( nf90_put_var ( nc_id, sig23_im_id, imagPart ( sig23 ) ) )

    call check ( nf90_put_var ( nc_id, sig31_re_id, realPart ( sig31 ) ) )
    call check ( nf90_put_var ( nc_id, sig31_im_id, imagPart ( sig31 ) ) )
    call check ( nf90_put_var ( nc_id, sig32_re_id, realPart ( sig32 ) ) )
    call check ( nf90_put_var ( nc_id, sig32_im_id, imagPart ( sig32 ) ) )
    call check ( nf90_put_var ( nc_id, sig33_re_id, realPart ( sig33 ) ) )
    call check ( nf90_put_var ( nc_id, sig33_im_id, imagPart ( sig33 ) ) )

    call check ( nf90_put_var ( nc_id, r_id, r ) )
    call check ( nf90_put_var ( nc_id, k_id, kArr ) )

    call check ( nf90_close ( nc_id ) )

end program test_sigma


C         TEST PROGRAM FOR IPPCOV SUBPROGRAM
      INCLUDE 'VICMAIN_FOR'
      SUBROUTINE MAIN44
      DOUBLE PRECISION OM(3,3),RS(3),EMA(9)
      REAL PTS(3),LINE
      DATA EMA/1.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,1.0/

      CHARACTER*560 BUFFER

      RLAT =0.
      RLON =0.

C  DEFAULT VARIABLES FOR IO

      RS(1) = -730950.0
      RS(2) = -339690.0
      RS(3) = -1209.3

      PTS(1) = 1815.0
      PTS(2) = 1500.19 * 84.821
      PTS(3) = SQRT(RS(1)**2+RS(2)**2+RS(3)**2)

      OM(1,1) = 0.407057464D0
      OM(2,1) = 0.112318814D0
      OM(3,1) = 0.906470418D0
      OM(1,2) = -0.874813914D0
      OM(2,2) = -0.237469494D0
      OM(3,2) = 0.422266245D0
      OM(1,3) = 0.262687564D0
      OM(2,3) = -0.964879572D0
      OM(3,3) = 0.0015943704D0
      LINE = 614.10
      SAMP = 614.38
      OAL = 500.0
      OAS = 500.0
      FLAG = 99.99

      CALL XVMESSAGE(' ',' ')
      CALL XVMESSAGE('BEFORE CONVERSION FROM LINE/SAMPLE TO LAT/LONG:',
     .               ' ')
      WRITE(BUFFER,100)RLAT,RLON,LINE,SAMP,FLAG,RS,OM,PTS,OAL,OAS
      CALL XVMESSAGE(BUFFER(  2: 80),' ')
      CALL XVMESSAGE(BUFFER( 82:160),' ')
      CALL XVMESSAGE(BUFFER(162:240),' ')
      CALL XVMESSAGE(BUFFER(242:320),' ')
      CALL XVMESSAGE(BUFFER(322:400),' ')
      CALL XVMESSAGE(BUFFER(402:480),' ')
      CALL XVMESSAGE(BUFFER(482:560),' ')
      CALL XVMESSAGE(' ',' ')

      CALL IPPCOV(RLAT,RLON,LINE,SAMP,PTS,RS,OM,EMA,OAL,OAS,FLAG)

      CALL XVMESSAGE('AFTER CONVERSION TO LAT/LONG:',' ')
      WRITE(BUFFER,100)RLAT*57.0,RLON*57.0,LINE,SAMP,FLAG,RS,OM,PTS,
     1      OAL,OAS
      CALL XVMESSAGE(BUFFER(  2: 80),' ')
      CALL XVMESSAGE(BUFFER( 82:160),' ')
      CALL XVMESSAGE(BUFFER(162:240),' ')
      CALL XVMESSAGE(BUFFER(242:320),' ')
      CALL XVMESSAGE(BUFFER(322:400),' ')
      CALL XVMESSAGE(BUFFER(402:480),' ')
      CALL XVMESSAGE(BUFFER(482:560),' ')
      CALL XVMESSAGE(' ',' ')
      CALL XVMESSAGE(
     . 'Repeat test case in C to test C interface: zippcov', ' ')

      call tzippcov( OM, RS, EMA, PTS)

      RETURN
  100 FORMAT(' LAT: ',F8.2,'  LONG: ',F8.2,4X,'LINE: ',F8.2,'  SAMP: ',
     1       F8.2,' FLAG: ',F5.1,4X,' RS: ',3(E11.5,4X),30X,' OM:',2(
     3       3(E11.5,4X),35X),3(E11.5,4X),31X,' PTS: ',3(F10.2,2X),
     4       'OAL: ',F8.2,2X,'OAS: ',F8.2,30X)
      END