module subroutines
use rm
implicit none
integer, parameter :: dp2 = selected_real_kind(15, 307) !For doble precision
contains
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1
subroutine SetToZeroVariables(MagnetizationAver,MagnetizationAver2, &
								MagnetizationAver4,EnergyAver,EnergyAver2,average)

	integer,intent(in)::average
	real(dp2),intent(out)::MagnetizationAver(average),MagnetizationAver2(average),MagnetizationAver4(average)
	real(dp2),intent(out)::EnergyAver(average),EnergyAver2(average)

		MagnetizationAver(:) = 0.0
		MagnetizationAver2(:) = 0.0
		MagnetizationAver4(:) = 0.0
		EnergyAver(:) = 0.0
		EnergyAver2(:) = 0.0

end subroutine SetToZeroVariables
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1
subroutine Inicializacion_DeltaE(DeltaE,Temp)

	real,intent(in)::Temp
	real,intent(out)::DeltaE(2)

	DeltaE(1) = exp(-4/Temp)
	DeltaE(2) = exp(-8/Temp)

end subroutine Inicializacion_DeltaE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1
subroutine ini_matriz(matriz,nrows,ncols)

	!Initialize a square matrix of dimention nrowsXncols
	!with ones
	!that means all spin-ups
	integer,intent(in)::nrows,ncols
	integer,intent(out)::matriz(nrows,ncols)

	!Index to loop the matrix
	integer::i,j
	real::rvec(1)

	do i=1,nrows
		do j = 1,ncols
			matriz (i,j) = 1
		end do
	end do

end subroutine ini_matriz
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine elegir_sitio(nrows,ncols,posx,posy)

	!This subroutine gives a random point in the square matrix of LxL
	integer,intent(in)::nrows,ncols
	integer,intent(out)::posx,posy

	real::rvec(2)
	call ranmar(rvec,2)

	!Given values between 0-1 for rvec we want values between 1-nrows/ncols for each coordinate
	!So this lines map one values to others 0-1 -> 1-nrows/ncols
	posx = floor( nrows * rvec(1) ) +1
	posy = floor( ncols * rvec(2) ) +1

end subroutine elegir_sitio
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine CalcEnergy(nrows,ncols,posx,posy,matriz,Delta_E,ip,im)
	!Calculate Delta for a given point (posx,posy)
	!with periodic boundary conditions
	integer,intent(in)::nrows,ncols
	integer,intent(in)::posx,posy,matriz(nrows,ncols),ip(nrows),im(nrows)
	integer,intent(out)::Delta_E
	integer::J = 1

	Delta_E =2*J*matriz(posx,posy) * ( matriz(ip(posx),posy) + matriz(im(posx),posy) + matriz(posx,ip(posy)) + matriz(posx,im(posy)))

end subroutine CalcEnergy
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine CalculationsINequilibrium(nrows,ncols,matriz,Delta_E,EnergyAver,EnergyAver2, &
									MagnetizationAver,MagnetizationAver2,MagnetizationAver4,k,average,ip,im)

	integer,intent(in)::nrows,ncols,matriz(nrows,ncols),k,average
	integer,intent(out)::Delta_E
	integer,intent(in)::ip(nrows),im(nrows)
	real(dp2),intent(inout)::EnergyAver(average),EnergyAver2(average)
	real(dp2),intent(inout)::MagnetizationAver(average),MagnetizationAver2(average),MagnetizationAver4(average)
	integer::i,j
	integer::dim
	real(dp2)::Energy,Magnetization

	dim = nrows*ncols
	Energy = 0.0
	do i = 1, nrows
		do j = 1, ncols
			call CalcEnergy(nrows,ncols,i,j,matriz,Delta_E,ip,im)
			Energy = Energy - Delta_E/2
			!Divido por (-2) para que me devuelva la energía del spin i,j
		end do
	end do
	! E
	Energy = Energy/(dim*2.0)
	!Se divide por dos nuevamente para no contar dos veces interacciones entre spines

	!<E>
	EnergyAver(k) = EnergyAver(k) + Energy
	!<E2>
	EnergyAver2(k) = EnergyAver2(k) + Energy**2

	!write(*,*) "Energy: ",Energy," EnergyAv: ", EnergyAver, " EnergyAver2: ", EnergyAver2

	Magnetization = sum(matriz(1:nrows,1:ncols))/(dim*1.0)
	!<m>
	MagnetizationAver(k) = MagnetizationAver(k) + Magnetization
	!<m2>
	MagnetizationAver2(k) = MagnetizationAver2(k) + Magnetization**2
	!<m4>
	MagnetizationAver4(k) = MagnetizationAver4(k) + Magnetization**4

end subroutine CalculationsINequilibrium
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine Write2File ( promediateCounter, beta,currentTemp, MagnetizationAver,MagnetizationAver2, &
						MagnetizationAver4,EnergyAver,EnergyAver2,average )
	!Write the important values in a file
	integer,intent(in)::promediateCounter,average
	real,intent(in)::beta, currentTemp
	real(dp2),intent(in)::MagnetizationAver(average), MagnetizationAver2(average),MagnetizationAver4(average)
	real(dp2),intent(in)::EnergyAver(average),EnergyAver2(average)

	real(dp2):: Cumulant,Suceptibility,C_v
	real(dp2):: AverEnergy,AverEnergy2,AverMagnet,AverMagnet2,AverMagnet4

	!Promediate the values
	call prom1d(EnergyAver,average,AverEnergy)
	call prom1d(EnergyAver2,average,AverEnergy2)
	call prom1d(MagnetizationAver,average,AverMagnet)
	call prom1d(MagnetizationAver2,average,AverMagnet2)
	call prom1d(MagnetizationAver4,average,AverMagnet4)

	Suceptibility = beta*(AverMagnet2/promediateCounter - (AverMagnet/promediateCounter)**2 )
	Cumulant = 1 - ( AverMagnet4/promediateCounter / ( 3*( (AverMagnet2/promediateCounter)**2) ) )
	C_v = (beta**2)*( AverEnergy2/promediateCounter - (AverEnergy/promediateCounter)**2)

		write(1,*) currentTemp, abs(AverMagnet/promediateCounter), AverMagnet2/promediateCounter, Suceptibility , Cumulant
		write(33,*) currentTemp, AverEnergy/promediateCounter, AverEnergy2/promediateCounter, C_v

end subroutine Write2File
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine prom1d(array,dim_array,prome)

integer,intent(in)::dim_array		!dimension de la variable a promediar,cant de veces que se "tira" la particula
real(dp2),intent(in)::array(dim_array)				!variable a promediar
real(dp2), intent(out)::prome		!resultado del promedio
real(dp2)::s
integer::i
!veamos primero la sumatoria
s=0
do i=1,dim_array
	s=s+array(i)
end do

prome=(s/dim_array)

end subroutine prom1d
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine New_Temp(indexTemp,currentTemp,Tmax,Tmin,TempInterval)

	integer,intent(in)::indexTemp
	real,intent(in)::TempInterval,Tmax,Tmin
	real,intent(out)::currentTemp

	!From Tmax to Tmin in TempInterval steps
	!IndexTemp goes from 1 to NumofTempPoints...
	!.. at IndexTemp = 1 currentTemp = Tmax
	!.. at IndexTemp = NumofTempPoints currentTemp = Tmin
	currentTemp = Tmax - TempInterval*( indexTemp - 1 )

end subroutine New_Temp
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1
subroutine WriteSpinConf(matriz,nrows,ncols)

	integer,intent(in)::ncols,nrows
	integer, intent(in)::matriz(nrows,ncols)

	integer::index1,index2

	do index1=1,nrows
		do index2=1,ncols
			write(*,*) index1,index2,matriz(index1,index2)
		end do
	end do
end subroutine WriteSpinConf
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
end module subroutines


MODULE m_pd_pulses

! ----------------------------------------------------------------------
! MODULE: m_pd_pulses
! ----------------------------------------------------------------------
! Purpose:
!  Module for calling the pd_pulses subroutine
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou at Geoscience Australia
! Created:	17 August 2020
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE pd_pulses (rsat, vsat, mjd_t, t_sec, delta_v, mjd_ti, ti_sec, dir, integr_stage, Fpulse, PDr, PDv, PD_param)

! ----------------------------------------------------------------------
! SUBROUTINE: pd_pulses.f03
! ----------------------------------------------------------------------
! Purpose:
!  Acceleration vector and Partial derivatives of pseudo-stochastic pulses (Velocity changes)
! ----------------------------------------------------------------------
! Input arguments:
! - rsat:			Satellite Position vector (m)   in inertial frame (ICRF)
! - vsat:			Satellite Velocity vector (m/s) in inertial frame (ICRF)
! - mjd_t:			MJD of current Epoch
! - t_sec:			Seconds since start of day of current Epoch
! - delta_v:		        Pulse value
! - mjd_ti:			MJD of pulse epoch
! - ti_sec:			Seconds since start of the day of pulse' epoch
! - dir:			Pulse' direction e.g. Radial, Tangential, Normal directions, XYZ directions
! - integr_stage:		Numerical integration method intermediate stage of computations
!
! Output arguments:
! - Fpulse:		Acceleration vector cartesian components in inertial frame (ICRF)
! - PDr: 			Partial derivatives matrix of the acceleration w.r.t. the position vector in ICRF
! - PDv: 			Partial derivatives matrix of the acceleration w.r.t. the velocity vector in ICRF
! - PD_param: 		Partial derivatives matrix of the acceleration w.r.t. the (force-related) unknown parameters in ICRF
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou at Geoscience Australia
! Created:	17 August 2020
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE mdl_param
      use pod_yaml
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN), DIMENSION(3) :: rsat, vsat
      INTEGER (KIND = prec_int2), INTENT(IN) :: dir
      INTEGER (KIND = prec_int4), INTENT(IN) :: integr_stage
      REAL (KIND = prec_d), INTENT(IN) :: delta_v(3)
      REAL (KIND = prec_d), INTENT(IN) :: mjd_t, mjd_ti, t_sec, ti_sec
! ----------------------------------------------------------------------
! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: Fpulse (3)
      REAL (KIND = prec_d), INTENT(OUT) :: PDr(3,3), PDv(3,3)
      !REAL (KIND = prec_d), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: PD_param
      REAL (KIND = prec_d), INTENT(OUT), DIMENSION(3,1) :: PD_param
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_d), DIMENSION(3) :: rsat_icrf, vsat_icrf
      REAL (KIND = prec_q) :: er(3), et(3), en(3), e_unit_dir(3)
      REAL (KIND = prec_q) :: Rrtn(3,3), Rrtn_inv(3,3)
      REAL (KIND = prec_d) :: delta_dirac
      REAL (KIND = prec_d) :: delta_v_ti
      INTEGER (KIND = prec_int2) :: N_param_pulses
      INTEGER (KIND = prec_int2) :: AllocateStatus, DeAllocateStatus
      INTEGER (KIND = prec_int2) :: frame_pulse
!      REAL (KIND = prec_q) :: Rrtn(3,3), Rrtn_inv(3,3)
!      REAL (KIND = prec_d) :: Rcrf_bff(3,3), Rrtn_bff(3,3)
      INTEGER (KIND = prec_int2) :: delta_t
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
!N_param_pulses = N_PULSE_param_glb
!ALLOCATE (PD_param(3,N_param_pulses), STAT = AllocateStatus)
!ALLOCATE (PD_param(3,1), STAT = AllocateStatus)
PD_param = 0.0D0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! State Vector in ICRF
rsat_icrf = rsat
vsat_icrf = vsat
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Reference frame of pulse direction
! ----------------------------------------------------------------------
! 0. Intertial frame ICRF (XYZ directions)
! 1. Orbital Frame
!frame_pulse = 1
frame_pulse = yml_pulse_ref_frame
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Unit vector of the direction of the pulse:
! ----------------------------------------------------------------------
! 1. Radial direction
! 2. Along-track
! 3. Cross-track
! ----------------------------------------------------------------------
CALL orb_frame2_unit(rsat_icrf, vsat_icrf, Rrtn, er, et, en)
! Orbital frame to Inertial frame (GCRF) : Inverse matrix
CALL matrix_inv3 (Rrtn, Rrtn_inv)

! remove warning
e_unit_dir = 0.d0
delta_v_ti = 0.d0

if (dir == 1) then
! Radial direction
!e_unit_dir = er
delta_v_ti = delta_v(1)
e_unit_dir(1) = er(1)
e_unit_dir(2) = 0.0D0
e_unit_dir(3) = 0.0D0
if (frame_pulse == ICRF) then
! X direction
e_unit_dir(1) = 1.0D0
e_unit_dir(2) = 0.0D0
e_unit_dir(3) = 0.0D0
end if

elseif (dir == 2) then
! Tangential direction
!e_unit_dir = et
delta_v_ti = delta_v(2)
e_unit_dir(1) = 0.0D0
e_unit_dir(2) = et(2)
e_unit_dir(3) = 0.0D0
if (frame_pulse == ICRF) then
! Y direction
e_unit_dir(1) = 0.0D0
e_unit_dir(2) = 1.0D0
e_unit_dir(3) = 0.0D0
end if

elseif (dir == 3) then
! Normal direction
!e_unit_dir = en
delta_v_ti = delta_v(3)
e_unit_dir(1) = 0.0D0
e_unit_dir(2) = 0.0D0
e_unit_dir(3) = en(3)
if (frame_pulse == ICRF) then
! Z direction
e_unit_dir(1) = 0.0D0
e_unit_dir(2) = 0.0D0
e_unit_dir(3) = 1.0D0
end if

end if
! ----------------------------------------------------------------------

!IF ( abs(mjd_t - mjd_ti) < 1.0D-06 ) THEN
IF ( 1 < 0 ) THEN
print *,""
print *,"pd_pulses delta"
print *,"Direction", dir
print *,"delta_t", delta_t
print *,"(mjd_t),( mjd_ti)", (mjd_t), (mjd_ti)
print *,"t_sec, ti_sec", t_sec, ti_sec
print *,"t_sec-ti_sec", t_sec - ti_sec
print *,""
print *,"pd_pulses integr_stage", integr_stage
print *,""
END IF

! ----------------------------------------------------------------------
! Dirac's "delta" function at the current epoch t (mjd_t)
! ----------------------------------------------------------------------
delta_dirac = 0.0D0

! Pulse epoch control based on input time arguments
delta_t = 2

! ----------------------------------------------------------------------
! Instant velocity pulses approach (applied only at the start of the integration step)
! ----------------------------------------------------------------------
IF (delta_t == 1) THEN
! Integration step' stage control: Allow pulse only at the initial stage (0)
IF (integr_stage == 0) THEN
! Time difference comparison
IF ( abs(mjd_t - mjd_ti) < 1.0D-06 ) THEN
	delta_dirac = 1.0D0
END IF
END IF

ELSE IF (delta_t == 2) THEN
! Integration step' stage control: Allow pulse only at the initial stage (0)
IF (integr_stage == 0) THEN
!IF ( INT(mjd_t) == INT( mjd_ti) ) THEN
!IF ( abs(t_sec - ti_sec) < 1.0D-05 ) THEN
! Time difference comparison
!IF ( INT(mjd_t)==INT( mjd_ti) .AND. abs(t_sec-ti_sec)<1.0D-05 ) THEN
IF ( INT(mjd_t)==INT(mjd_ti).AND.abs(t_sec-(mjd_ti-INT( mjd_ti))*86400.d0) <1.0D-05 )THEN
	delta_dirac = 1.0D0
END IF
END IF

! ----------------------------------------------------------------------
! Constant piece-wise acceleration approach (applied during the overall integration step)
! ----------------------------------------------------------------------
ELSE IF (delta_t == 3) THEN

IF (integr_stage == 0) THEN
IF ( INT(mjd_t)==INT( mjd_ti) .AND. abs(t_sec-ti_sec)<1.0D-05 ) THEN
	delta_dirac = 1.0D0
END IF
END IF

IF (integr_stage > 0) THEN
IF ( INT(mjd_t)==INT( mjd_ti) .AND. (t_sec>ti_sec) .AND. (t_sec<=ti_sec+integstep) ) THEN
	delta_dirac = 1.0D0
END IF
END IF

END IF
! ----------------------------------------------------------------------
!IF (delta_dirac==1.0D0) THEN
!print *,"delta_t, delta_dirac, integr_stage, t_sec, ti_sec", &
!        delta_t,delta_dirac,integr_stage,t_sec,ti_sec
!END IF
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Summary of Pseudo-stochastic pulses
! ----------------------------------------------------------------------
!Fpulse = delta_v_ti * delta_dirac * e_unit_dir
Fpulse(1) = delta_v_ti * delta_dirac * e_unit_dir(1)
Fpulse(2) = delta_v_ti * delta_dirac * e_unit_dir(2)
Fpulse(3) = delta_v_ti * delta_dirac * e_unit_dir(3)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Partial derivatives w.r.t state vector
PDr = 0.0D0
PDv = 0.0D0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Partial derivatives w.r.t unknown parameters to be estimated
! ----------------------------------------------------------------------
!PD_param = delta_dirac * e_unit_dir
PD_param(1,1) = delta_dirac * e_unit_dir(1)
PD_param(2,1) = delta_dirac * e_unit_dir(2)
PD_param(3,1) = delta_dirac * e_unit_dir(3)
! ----------------------------------------------------------------------

IF (1 > 10) THEN
print *," "
print *,"m_pd_pulses "
print *,"delta_dirac ", delta_dirac
print *,"delta_v_ti ", delta_v_ti
print *,"dir ", dir
print *,"e_unit_dir ", e_unit_dir
print *,"Fpulse ", Fpulse
print *,"PD_param ", PD_param
print *," "
END IF

END SUBROUTINE

END Module


   PROGRAM chi_calcul
   IMPLICIT NONE

   INTEGER (KIND=8),PARAMETER::n=41

   INTEGER (KIND=8) :: i

   REAL (KIND=8),DIMENSION(n) :: eps,E,Cv,M1,M2,M3,chi1,chi2,chi3,slop_chi

!!!=======================================================================================
!!!=======================================================================================
!!!=======================================================================================
!!!=======================================================================================
   OPEN(unit=11,file='E_av_40_1.dat')
   OPEN(unit=12,file='chi_slop_40_1.txt')

   DO i=1,n
      READ(11,*)eps(i),E(i),Cv(i),M1(i),M2(i),M3(i),chi1(i),chi2(i),chi3(i)
   END DO

   slop_chi(:)=0.

   DO i=1,n-1
      WRITE(*,*)chi1(i),chi1(i+1),eps(i),eps(i+1)
      slop_chi(i+1)=(log(chi1(i+1))-log(chi1(i)))/(log(abs(eps(i+1)))-log(abs(eps(i))))

      WRITE(12,*)abs(eps(i+1)),slop_chi(i+1)
   END DO

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

   CLOSE(11)
   CLOSE(12)

   END PROGRAM chi_calcul


!> Orchid -- 2D/3D Euler/MagnetoHydroDynamics solver.
!> Copyright (C) Butakov Oleg 2019.

Module orchid_solver_hydro_flux_viscous
Use orchid_solver_params
Use orchid_solver_grid
Implicit None
Type, Abstract :: MhdHydroViscousFlux
    Contains
    Procedure, Public, Non_Overridable :: calc => mhd_hydro_calc_viscous_flux
    Procedure(mhd_hydro_calc_viscous_flux1D_t), Public, Deferred :: calc1D
    Procedure(mhd_hydro_calc_viscous_flux2D_t), Public, Deferred :: calc2D
    Procedure(mhd_hydro_calc_viscous_flux3D_t), Public, Deferred :: calc3D
    Procedure(mhd_hydro_calc_viscous_flux3D_mhd_t), Public, Deferred :: calc3D_mhd
End Type MhdHydroViscousFlux
Private :: mhd_hydro_calc_viscous_flux, &
           mhd_hydro_calc_viscous_flux1D_t, &
           mhd_hydro_calc_viscous_flux2D_t, &
           mhd_hydro_calc_viscous_flux3D_t, &
           mhd_hydro_calc_viscous_flux3D_mhd_t
Interface
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_viscous_flux1D_t(This, &
                                           rho, nrg, u, &
                                           grad_rho, grad_nrg, grad_u, &
                                           flux_rho, flux_nrg, flux_u)
    !> Calculate the Viscous Fluxes in 1D.
    !> {{{
    Import :: MhdHydroViscousFlux
    Class(MhdHydroViscousFlux), Intent(In) :: This
    Real(8), Intent(In) :: rho, nrg, u
    Real(8), Intent(In) :: grad_rho, grad_nrg, grad_u
    Real(8), Intent(Out) :: flux_rho, flux_nrg, flux_u
    !> }}}
End Subroutine mhd_hydro_calc_viscous_flux1D_t
Pure &
Subroutine mhd_hydro_calc_viscous_flux2D_t(This, &
                                           rho, nrg, u, v, &
                                           grad_rho, grad_nrg, grad_u, grad_v, &
                                           flux_rho, flux_nrg, flux_u, flux_v)
    !> Calculate the Viscous Fluxes in 2D.
    !> {{{
    Import :: MhdHydroViscousFlux
    Class(MhdHydroViscousFlux), Intent(In) :: This
    Real(8), Intent(In) :: rho, nrg, u, v
    Real(8), Intent(In) :: grad_rho, grad_nrg, grad_u, grad_v
    Real(8), Intent(Out) :: flux_rho, flux_nrg, flux_u, flux_v
    !> }}}
End Subroutine mhd_hydro_calc_viscous_flux2D_t
Pure &
Subroutine mhd_hydro_calc_viscous_flux3D_t(This, &
                                           rho, nrg, u, v, w, &
                                           grad_rho, grad_nrg, grad_u, grad_v, grad_w, &
                                           flux_rho, flux_nrg, flux_u, flux_v, flux_w)
    !> Calculate the Viscous Fluxes in 3D.
    !> {{{
    Import :: MhdHydroViscousFlux
    Class(MhdHydroViscousFlux), Intent(In) :: This
    Real(8), Intent(In) :: rho, nrg, u, v, w
    Real(8), Intent(In) :: grad_rho, grad_nrg, grad_u, grad_v, grad_w
    Real(8), Intent(Out) :: flux_rho, flux_nrg, flux_u, flux_v, flux_w
    !> }}}
End Subroutine mhd_hydro_calc_viscous_flux3D_t
Pure &
Subroutine mhd_hydro_calc_viscous_flux3D_mhd_t(This, &
                                               rho, nrg, u, v, w, bx, by, bz, &
                                               grad_rho, grad_nrg, grad_u, grad_v, grad_w, grad_bx, grad_by, grad_bz, &
                                               flux_rho, flux_nrg, flux_u, flux_v, flux_w, flux_bx, flux_by, flux_bz)
    !> Calculate the Viscous Fluxes in 3D for the MHD Equations.
    !> {{{
    Import :: MhdHydroViscousFlux
    Class(MhdHydroViscousFlux), Intent(In) :: This
    Real(8), Intent(In) :: rho, nrg, u, v, w, bx, by, bz
    Real(8), Intent(In) :: grad_rho, grad_nrg, grad_u, grad_v, grad_w, grad_bx, grad_by, grad_bz
    Real(8), Intent(Out) :: flux_rho, flux_nrg, flux_u, flux_v, flux_w, flux_bx, flux_by, flux_bz
    !> }}}
End Subroutine mhd_hydro_calc_viscous_flux3D_mhd_t
!########################################################################################################
!########################################################################################################
!########################################################################################################
End Interface
Contains
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_viscous_flux(This, &
                                       fields, fields_grad, flux)
    !> Calculate the Viscous Fluxes in 1D/2D/3D.
    !> {{{
    Class(MhdHydroViscousFlux), Intent(In) :: This
    Real(8), Dimension(1:), Intent(In) :: fields, fields_grad
    Real(8), Dimension(1:), Intent(Out) :: flux
    !> }}}
    Real(8) :: rho, nrg, u, v, w, bx, by, bz, &
               grad_rho, grad_nrg, grad_u, grad_v, grad_w, grad_bx, grad_by, grad_bz
    rho = fields(1)
    nrg = fields(2)/rho
    u   = fields(3)/rho
    grad_rho = fields_grad(1)
    grad_nrg = ( fields_grad(2) - nrg*grad_rho )/rho
    grad_u   = ( fields_grad(3) - u*grad_rho )/rho
    If ( dim >= 2 .OR. mhd ) Then
        v = fields(4)/rho
        grad_v = ( fields_grad(4) - v*grad_rho )/rho
        If ( dim >= 3 .OR. mhd ) Then
            w = fields(5)/rho
            grad_w = ( fields_grad(5) - w*grad_rho )/rho
       End If
    End If
    If ( mhd ) Then
        !> MHD case.
        bx = fields(6)
        by = fields(7)
        bz = fields(8)
        grad_bx = fields_grad(6)
        grad_by = fields_grad(7)
        grad_bz = fields_grad(8)
        Call This%calc3D_mhd(rho, nrg, u, v, w, bx, by, bz, &
                             grad_rho, grad_nrg, grad_u, grad_v, grad_w, grad_bx, grad_by, grad_bz, &
                             flux(1), flux(2), flux(3), flux(4), flux(5), flux(6), flux(7), flux(8))
    Else
        !> Navier-Stokes case.
        If ( dim == 1 ) Then
            !> 1D Case.
            Call This%calc1D(rho, nrg, u, &
                             grad_rho, grad_nrg, grad_u, &
                             flux(1), flux(2), flux(3))
        Else If ( dim == 2 ) Then
            !> 2D Case.
            Call This%calc2D(rho, nrg, u, v, &
                             grad_rho, grad_nrg, grad_u, grad_v, &
                             flux(1), flux(2), flux(3), flux(4))
        Else If ( dim == 3 ) Then
            !> 3D Case.
            Call This%calc3D(rho, nrg, u, v, w, &
                             grad_rho, grad_nrg, grad_u, grad_v, grad_w, &
                             flux(1), flux(2), flux(3), flux(4), flux(5))
        End If
    End If
End Subroutine mhd_hydro_calc_viscous_flux
!########################################################################################################
!########################################################################################################
!########################################################################################################
End Module orchid_solver_hydro_flux_viscous

Module orchid_solver_hydro_flux_viscous_gas
Use orchid_solver_params
Use orchid_solver_hydro_flux_viscous
Implicit None
Type, Extends(MhdHydroViscousFlux) :: MhdHydroViscousFluxGas
    Contains
    Procedure, Public, Non_Overridable :: calc1D => mhd_hydro_calc_viscous_flux_gas1D
    Procedure, Public, Non_Overridable :: calc2D => mhd_hydro_calc_viscous_flux_gas2D
    Procedure, Public, Non_Overridable :: calc3D => mhd_hydro_calc_viscous_flux_gas3D
    Procedure, Public, Non_Overridable :: calc3D_mhd => mhd_hydro_calc_viscous_flux_gas3D_mhd
End Type MhdHydroViscousFluxGas
Private :: mhd_hydro_calc_viscous_flux_gas1D, &
           mhd_hydro_calc_viscous_flux_gas2D, &
           mhd_hydro_calc_viscous_flux_gas3D, &
           mhd_hydro_calc_viscous_flux_gas3D_mhd
Contains
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_viscous_flux_gas1D(This, &
                                           rho, nrg, u, &
                                           grad_rho, grad_nrg, grad_u, &
                                           flux_rho, flux_nrg, flux_u)
    !> Calculate the Viscous Fluxes in 1D.
    !> {{{
    Class(MhdHydroViscousFluxGas), Intent(In) :: This
    Real(8), Intent(In) :: rho, nrg, u
    Real(8), Intent(In) :: grad_rho, grad_nrg, grad_u
    Real(8), Intent(Out) :: flux_rho, flux_nrg, flux_u
    !> }}}
    Real(8) :: grad_temp
    grad_temp = Gamma1/Rgas*( grad_nrg - u*grad_u )
    flux_rho = 0.0D0
    flux_nrg = Kappa*grad_temp
    flux_u   = Mu_hydro*grad_u
End Subroutine mhd_hydro_calc_viscous_flux_gas1D
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_viscous_flux_gas2D(This, &
                                           rho, nrg, u, v, &
                                           grad_rho, grad_nrg, grad_u, grad_v, &
                                           flux_rho, flux_nrg, flux_u, flux_v)
    !> Calculate the Viscous Fluxes in 2D.
    !> {{{
    Class(MhdHydroViscousFluxGas), Intent(In) :: This
    Real(8), Intent(In) :: rho, nrg, u, v
    Real(8), Intent(In) :: grad_rho, grad_nrg, grad_u, grad_v
    Real(8), Intent(Out) :: flux_rho, flux_nrg, flux_u, flux_v
    !> }}}
    Real(8) :: grad_temp
    grad_temp = Gamma1/Rgas*( grad_nrg - u*grad_u - v*grad_v )
    flux_rho = 0.0D0
    flux_nrg = Kappa*grad_temp
    flux_u   = Mu_hydro*grad_u
    flux_v   = Mu_hydro*grad_v
End Subroutine mhd_hydro_calc_viscous_flux_gas2D
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_viscous_flux_gas3D(This, &
                                             rho, nrg, u, v, w, &
                                             grad_rho, grad_nrg, grad_u, grad_v, grad_w, &
                                             flux_rho, flux_nrg, flux_u, flux_v, flux_w)
    !> Calculate the Viscous Fluxes in 3D.
    !> {{{
    Class(MhdHydroViscousFluxGas), Intent(In) :: This
    Real(8), Intent(In) :: rho, nrg, u, v, w
    Real(8), Intent(In) :: grad_rho, grad_nrg, grad_u, grad_v, grad_w
    Real(8), Intent(Out) :: flux_rho, flux_nrg, flux_u, flux_v, flux_w
    !> }}}
    Real(8) :: grad_temp
    grad_temp = Gamma1/Rgas*( grad_nrg - u*grad_u - v*grad_v - w*grad_w )
    flux_rho = 0.0D0
    flux_nrg = Kappa*grad_temp
    flux_u   = Mu_hydro*grad_u
    flux_v   = Mu_hydro*grad_v
    flux_w   = Mu_hydro*grad_w
End Subroutine mhd_hydro_calc_viscous_flux_gas3D
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_viscous_flux_gas3D_mhd(This, &
                                                 rho, nrg, u, v, w, bx, by, bz, &
                                                 grad_rho, grad_nrg, grad_u, grad_v, grad_w, grad_bx, grad_by, grad_bz, &
                                                 flux_rho, flux_nrg, flux_u, flux_v, flux_w, flux_bx, flux_by, flux_bz)
    !> Calculate the Viscous Fluxes in 3D for the MHD Equations.
    !> {{{
    Class(MhdHydroViscousFluxGas), Intent(In) :: This
    Real(8), Intent(In) :: rho, nrg, u, v, w, bx, by, bz
    Real(8), Intent(In) :: grad_rho, grad_nrg, grad_u, grad_v, grad_w, grad_bx, grad_by, grad_bz
    Real(8), Intent(Out) :: flux_rho, flux_nrg, flux_u, flux_v, flux_w, flux_bx, flux_by, flux_bz
    !> }}}
    Real(8) :: grad_temp
    grad_temp = Gamma1/Rgas*( grad_nrg - u*grad_u - v*grad_v - w*grad_w )
    flux_rho = 0.0D0
    flux_nrg = Kappa*grad_temp
    flux_u   = Mu_hydro*grad_u
    flux_v   = Mu_hydro*grad_v
    flux_w   = Mu_hydro*grad_w
    flux_bx  = Mu_magneto*grad_bx
    flux_by  = Mu_magneto*grad_by
    flux_bz  = Mu_magneto*grad_bz
End Subroutine mhd_hydro_calc_viscous_flux_gas3D_mhd
!########################################################################################################
!########################################################################################################
!########################################################################################################
End Module orchid_solver_hydro_flux_viscous_gas


      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      !!
      !!      Author:  Pawel Gniewek
      !!      Email:   pawel.gniewek@berkeley.edu
      !!      License: BSD-3
      !!      Reference: "Jamming by growth"; Gniewek, P. and Schreck, C.S. and Hallatschek, O.; 2018
      !!
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      PROGRAM shear_packing

      IMPLICIT NONE
      INTEGER Ntot
      PARAMETER(Ntot=4096)
      DOUBLE PRECISION pi
      PARAMETER(pi=3.1415926535897932d0)
      DOUBLE PRECISION x(Ntot),y(Ntot),th(Ntot),D(Ntot),D1,exp
      DOUBLE PRECISION ftol,ftol1,fret,width,Lx,Ly
      DOUBLE PRECISION alpha(Ntot),scale(Ntot)
      DOUBLE PRECISION phi,flow,D0(Ntot)
      DOUBLE PRECISION xa(2),ya(2)
      DOUBLE PRECISION cc,ss,dr(2),dd,att
      INTEGER N,Nr,iter,i,kk
      INTEGER Nf,Nu,Nmm,Nbb,Nmb

      CHARACTER file_conf*150
      CHARACTER file_traj*150
      CHARACTER file_G_data*150

      INTEGER F(Ntot), Nc, Ziso
      DOUBLE PRECISION calc_phi, wide
      DOUBLE PRECISION phi_init,ddelrx,delrx

      INTEGER shear_steps, step_index
      DOUBLE PRECISION shear_stress, cory, shear_stress_0

      COMMON /f2com/ width
      COMMON /f3com/ alpha
      COMMON /f4com/ exp,att
      COMMON /f5com/ Lx,Ly
      COMMON /f9com/ scale
      COMMON /f11com/ delrx
      COMMON /f12com/ shear_stress

      ! READ geometric PARAMETERs
      READ(*,*) Lx
      READ(*,*) Ly

      ! READ cell PARAMETERs
      READ(*,*) att

      ! READ output files
      READ(*,*) file_conf
      READ(*,*) ddelrx
      READ(*,*) shear_steps

      ! PARAMETERs
      D1=1d0         ! Minor axis of particle; D1=1.0 - circle
      exp=2d0        ! 2 =  LS, 2.5 = Hertzian, >2.9 = RLJ
      width=0.1d0    ! width of neighborlist
      ftol=0.5d-16   ! Condition 1 for frprmn: V/N < ftol
      ftol1=0.5d-16  ! Condition 2 for frprmn: dV/N < ftol1

      wide = 2.0d0

      shear_stress = 0d0
      shear_stress_0= 0d0

      ! FILES
 123  OPEN(unit=1,file=TRIM(file_conf)) ! CONFIGURATION FILE

      file_traj='SHEAR_TRAJ_' // TRIM(file_conf)
      OPEN(unit=11,file=TRIM(file_traj), status='replace')

      file_G_data ='G_data_' // TRIM(file_conf)
      OPEN(unit=12,file=TRIM(file_G_data), status='replace')

!     READ PACKING FROM FILE
      READ(1, *) N, phi_init
      DO i=1,N
          READ(1, *) x(i),y(i),D(i),alpha(i),th(i)
      ENDDO

      DO step_index=1,shear_steps

         delrx = dble(step_index-1)*ddelrx

         ! convert from angle to length scale = sqrt(I/m) * angle
         DO i=1,N
            dd=alpha(i)-1d0
            scale(i)=dsqrt(2d0*(1d0+dd**4)/(1+dd**2)+
     +              4d0*(dd*(1d0+dd)/(1+dd**2))**2)/4d0*d(i)

            th(i)=th(i)*scale(i)
         ENDDO

         ! minimize energy
         CALL frprmn(N,x,y,th,D,D1,ftol,ftol1,iter,fret)

         IF(delrx.EQ.0d0)THEN
             shear_stress_0 = shear_stress
         ENDIF

         WRITE(*,*) N,fret/dble(N),
     +     delrx,ddelrx,step_index,shear_stress,
     +     shear_stress-shear_stress_0

         ! convert back to angles
         DO i=1,N
            th(i)=th(i)/scale(i)
         ENDDO

         CALL contacts_yeast(x,y,th,D1,D,N,Nc,F,Nf,Nu,Nmm,Nbb,Nmb)
         CALL out_numbers(N, Nf, Nu, Ziso)
         WRITE(12,'(3E26.18,5I12)')delrx,shear_stress,
     +         shear_stress-shear_stress_0,N,Nc,Nf,Nu,Ziso

         phi = calc_phi(D, alpha, D1, N)
         WRITE(11,*) 2*N, phi
         DO i=1,N
              cc=dcos(th(i))
              ss=dsin(th(i))
              dd=alpha(i)-1d0
              dr(1)=(1d0+dd)/(1d0+dd**2)*dd**2*D(i)/2d0
              dr(2)=-(1d0+dd)/(1d0+dd**2)*D(i)/2d0
              DO kk=1,2
                 xa(kk)=x(i)+dr(kk)*cc
                 ya(kk)=y(i)+dr(kk)*ss
              ENDDO
              WRITE(11,'(3E26.18,I12)')xa(1),ya(1),d(i),0
              WRITE(11,'(3E26.18,I12)')xa(2),ya(2),d(i)*dd,1
         ENDDO

      ENDDO

      END PROGRAM

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE CG_check(N,x,y,xp,yp,maxdis)
      IMPLICIT NONE
      INTEGER Ntot,N,i
      PARAMETER(Ntot = 4096)
      DOUBLE PRECISION maxdis,x(Ntot),y(Ntot),xp(Ntot),yp(Ntot)

      maxdis=0d0
      DO i=1,N
         maxdis=max(dabs(x(i)-xp(i)),maxdis)
         maxdis=max(dabs(y(i)-yp(i)),maxdis)
      ENDDO
      maxdis=2d0*dsqrt(2d0*maxdis*maxdis)

      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE makelist(N,x,y,D,D1,xp,yp,countn,nl)
      IMPLICIT NONE
      INTEGER Ntot
      PARAMETER(Ntot = 4096)
      DOUBLE PRECISION x(Ntot),y(Ntot),xp(Ntot),yp(Ntot),D(Ntot)
      DOUBLE PRECISION D1,xij,yij,rij,dij,rijsq,alpha(Ntot),width
      DOUBLE PRECISION dd,dr1,dr2,dk2,di_up(Ntot),exp,att
      DOUBLE PRECISION Lx,Ly,delrx,cory
      INTEGER countn(Ntot),nl(800,Ntot),N,i,j
      COMMON /f2com/ width
      COMMON /f3com/ alpha ! aspect ratio
      COMMON /f4com/ exp,att
      COMMON /f5com/ Lx,Ly
      COMMON /f11com/ delrx

      DO i=1,N
         countn(i)=0
      ENDDO

      DO i=1,N
         dd=alpha(i)-1d0
         dr1=(1d0+dd)/(1d0+dd**2)*dd**2*D(i)/2d0
         dr2=-(1d0+dd)/(1d0+dd**2)*D(i)/2d0
         dk2=dd*D(i)
         di_up(i)=(dk2/2d0-dr2)*2d0
      ENDDO

      DO i=1,N-1
         DO j=i+1,N
            xij=x(i)-x(j)
            yij=y(i)-y(j)
            cory=idnint(yij/Ly)
            xij=xij-cory*delrx*Lx
            xij=xij-idnint(xij/Lx)*Lx  !! PBC
            yij=yij-cory*Ly  !! PBC

            rijsq=xij*xij+yij*yij
            dij=(di_up(i)+di_up(j))/2d0
            dij=D1*( D(i) + D(j) )/2d0
            IF(rijsq.LT.(2.D0*dij)**2) THEN
               countn(i)=countn(i)+1
               nl(countn(i),i)=j
            ENDIF
         ENDDO
      ENDDO

      DO i=1,N
         xp(i)=x(i)
         yp(i)=y(i)
      ENDDO

      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE func(N,x,y,th,D,D1,V,countn,nl)
      IMPLICIT NONE
      INTEGER Ntot
      PARAMETER(Ntot = 4096)
      DOUBLE PRECISION pi
      PARAMETER(pi=3.1415926535897932d0)
      DOUBLE PRECISION x(Ntot),y(Ntot),th(Ntot),D(Ntot),alpha(Ntot)
      DOUBLE PRECISION rij,xij,yij,dij,exp,dij_up,sigma,LJ,D1,V
      DOUBLE PRECISION Lx,Ly,rijsq,scale(Ntot),c(Ntot),att
      DOUBLE PRECISION s(Ntot),dd,dr(Ntot,2),xa(Ntot,2),ya(Ntot,2)
      DOUBLE PRECISION dk(Ntot,2),di_up(Ntot),di1j1,Vij
      DOUBLE PRECISION delrx,cory
      INTEGER countn(Ntot),nl(800,Ntot),N,i,j,k,jj,ki,kj

      COMMON /f3com/ alpha ! aspect ratio
      COMMON /f4com/ exp,att
      COMMON /f5com/ Lx,Ly
      COMMON /f9com/ scale
      COMMON /f11com/ delrx

      ! convert from molecules to atoms
      DO i=1,N
         c(i)=dcos(th(i)/scale(i))
         s(i)=dsin(th(i)/scale(i))
         dd=alpha(i)-1d0
         dr(i,1)=(1d0+dd)/(1d0+dd**2)*dd**2*D(i)*D1/2d0
         dr(i,2)=-(1d0+dd)/(1d0+dd**2)*D(i)*D1/2d0
         DO k=1,2
            xa(i,k)=x(i)+dr(i,k)*c(i)
            ya(i,k)=y(i)+dr(i,k)*s(i)
         ENDDO
         dk(i,1)=D(i)*D1
         dk(i,2)=dd*D(i)*D1
         IF(alpha(i).LT.2d0) THEN
            di_up(i)=(dk(i,2)/2d0-dr(i,2))*2d0*D1
         ELSE
            di_up(i)=(dk(i,1)/2d0+dr(i,1))*2d0*D1
         ENDIF
      ENDDO

      ! inter-particle interactions
      V=0d0
      DO i=1,N-1
         IF(countn(i).GE.1) THEN
            DO jj=1,countn(i)
               j=nl(jj,i)
               dij_up=(di_up(i)+di_up(j))/2d0

               xij=x(i)-x(j)
               yij=y(i)-y(j)
               cory=idnint(yij/Ly)
               xij=xij-cory*delrx*Lx
               xij=xij-idnint(xij/Lx)*Lx  !! PBC
               yij=yij-cory*Ly  !! PBC

               IF(dabs(xij).LT.dij_up+att) THEN
                  rijsq=xij**2+yij**2
                  IF(rijsq.LT.(dij_up+att)**2) THEN
                     di1j1=(dk(i,1)+dk(j,1))/2d0
                     DO ki=1,2
                        DO kj=1,2
                           dij=(dk(i,ki)+dk(j,kj))/2d0
                           xij=xa(i,ki)-xa(j,kj)
                           yij=ya(i,ki)-ya(j,kj)
                           cory = idnint(yij/Ly)
                           xij=xij-cory*delrx*Lx
                           xij=xij-idnint(xij/Lx)*Lx  !! PBC
                           yij=yij-cory*Ly  !! PBC
                           rijsq=xij**2+yij**2
                           IF(rijsq.LT.(dij+att)**2) THEN
                              rij=dsqrt(rijsq)
                              IF(exp .GT. 2.9) THEN
                                 LJ=(dij/rij)*(dij/rij)
                                 LJ=LJ*LJ*LJ
                                 Vij=(LJ-1d0)*(LJ-1d0)
                              ELSE
                                 Vij=(1d0-rij/dij)**exp/exp-
     +                                (att/dij)**exp/exp
                              ENDIF
                              V=V+Vij*dij**2/di1j1**2
                           ENDIF
                        ENDDO
                     ENDDO
                  ENDIF
               ENDIF
            ENDDO
         ENDIF
      ENDDO

      IF(exp.GT.2.9) THEN
         V=V/72d0
      ENDIF

      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE dfunc(N,x,y,th,D,D1,fx,fy,fth,countn,nl)
      IMPLICIT NONE
      INTEGER Ntot
      PARAMETER(Ntot = 4096)
      DOUBLE PRECISION pi
      PARAMETER(pi=3.1415926535897932d0)
      DOUBLE PRECISION x(Ntot),y(Ntot),th(Ntot),sigma,D(Ntot),D1,dij
      DOUBLE PRECISION fx(Ntot),fy(Ntot),fth(Ntot),rij,xij,yij,fr,exp
      DOUBLE PRECISION dij_up,alpha(Ntot),LJ,fc,ft,f_x,f_y
      DOUBLE PRECISION scale(Ntot)
      DOUBLE PRECISION fthi,fthj,fth_c,Lx,Ly,rijsq
      DOUBLE PRECISION s(Ntot),dd,dr(Ntot,2),xa(Ntot,2),ya(Ntot,2)
      DOUBLE PRECISION dk(Ntot,2),di_up(Ntot),di1j1
      DOUBLE PRECISION c(Ntot),Vij, delrx,cory,att
      DOUBLE PRECISION shear_stress
      INTEGER countn(Ntot),nl(800,Ntot),N,i,j,k,jj,ki,kj
      COMMON /f3com/ alpha ! aspect ratio
      COMMON /f4com/ exp,att
      COMMON /f5com/ Lx,Ly
      COMMON /f9com/ scale
      COMMON /f11com/ delrx
      COMMON /f12com/ shear_stress

      DO i=1,N
         fx(i)=0d0
         fy(i)=0d0
         fth(i)=0d0
      ENDDO
      shear_stress=0d0

      ! convert to from molecules to atoms
      DO i=1,N
         c(i)=dcos(th(i)/scale(i))
         s(i)=dsin(th(i)/scale(i))
         dd=alpha(i)-1d0
         dr(i,1)=(1d0+dd)/(1d0+dd**2)*dd**2*D(i)*D1/2d0
         dr(i,2)=-(1d0+dd)/(1d0+dd**2)*D(i)*D1/2d0
         DO k=1,2
            xa(i,k)=x(i)+dr(i,k)*c(i)
            ya(i,k)=y(i)+dr(i,k)*s(i)
         ENDDO
         dk(i,1)=D(i)*D1
         dk(i,2)=dd*D(i)*D1
         IF(alpha(i).LT.2d0) THEN
            di_up(i)=(dk(i,2)/2d0-dr(i,2))*2d0*D1
         ELSE
            di_up(i)=(dk(i,1)/2d0+dr(i,1))*2d0*D1
         ENDIF
      ENDDO

      ! inter-particle interactions
      DO i=1,N-1
         IF(countn(i).GE.1) THEN
            DO jj=1,countn(i)
               j=nl(jj,i)
               dij_up=(di_up(i)+di_up(j))/2d0
               xij=x(i)-x(j)
               yij=y(i)-y(j)
               cory=idnint(yij/Ly)
               xij=xij-cory*delrx*Lx
               xij=xij-idnint(xij/Lx)*Lx  !! PBC
               yij=yij-cory*Ly  !! PBC
               IF(dabs(xij).LT.dij_up+att) THEN
                  rijsq=xij**2+yij**2
                  IF(rijsq.LT.(dij_up+att)**2) THEN
                     di1j1=(dk(i,1)+dk(j,1))/2d0
                     DO ki=1,2
                        DO kj=1,2
                           dij=(dk(i,ki)+dk(j,kj))/2d0
                           xij=xa(i,ki)-xa(j,kj)
                           yij=ya(i,ki)-ya(j,kj)
                           cory = idnint(yij/Ly)
                           xij=xij-cory*delrx*Lx
                           xij=xij-idnint(xij/Lx)*Lx  !! PBC
                           yij=yij-cory*Ly  !! PBC
                           rijsq=xij**2+yij**2
                           IF(rijsq.LT.(dij+att)**2) THEN
                              rij=dsqrt(rijsq)
                              IF(exp .GT. 2.9) THEN
                                 LJ=(dij/rij)*(dij/rij)
                                 LJ=LJ*LJ*LJ
                                 fc=1d0/rij*LJ*(LJ-1d0)
                              ELSE
                                 fc=(1d0-rij/dij)**(exp-1d0)/dij
                              ENDIF

                              fr=-fc/rij*dij**2/di1j1**2

                              f_x = fr*xij
                              f_y = fr*yij
                              fx(i)=fx(i)+f_x
                              fx(j)=fx(j)-f_x
                              fy(i)=fy(i)+f_y
                              fy(j)=fy(j)-f_y
                           fth(i)=fth(i)+dr(i,ki)*(c(i)*f_y-s(i)*f_x)
                           fth(j)=fth(j)-dr(j,kj)*(c(j)*f_y-s(j)*f_x)

                             shear_stress=shear_stress-xij*yij/rij*fc

                           ENDIF
                        ENDDO
                     ENDDO
                  ENDIF
               ENDIF
            ENDDO
         ENDIF
      ENDDO

      IF(exp .GT. 2.9) THEN
         DO i=1,N
            fx(i)=fx(i)/6d0
            fy(i)=fy(i)/6d0
            fth(i)=fth(i)/6d0
         ENDDO
      ENDIF

      DO i=1,N
         fth(i)=fth(i)/scale(i)
      ENDDO

      shear_stress=shear_stress/Lx/Ly

      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      DOUBLE PRECISION FUNCTION calc_phi(D, alpha, D1, N)
      IMPLICIT NONE
      INTEGER Ntot
      PARAMETER(Ntot = 4096)
      DOUBLE PRECISION pi
      PARAMETER(pi=3.1415926535897932d0)
      DOUBLE PRECISION D(Ntot),alpha(Ntot)
      DOUBLE PRECISION Lx,Ly,phis,D1,phit
      INTEGER N,i
      COMMON /f5com/ Lx,Ly

      phit=0d0
      DO i=1,N
         phit=phit+(1d0+(alpha(i)-1d0)**2)*D(i)**2
      ENDDO

      calc_phi=pi*D1*D1*phit/Lx/Ly/4d0
      END FUNCTION

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE contacts_yeast(x,y,th,D1,D,N,Z,F,Nf,Nu,Nmm,Nbb,Nmb)
      IMPLICIT NONE
      INTEGER Ntot, N
      PARAMETER(Ntot = 4096)
      INTEGER i,j,F(Ntot),Z,nc_bud(Ntot,2),Nf,Nu,Nmm,Nbb,Nmb
      INTEGER ki,kj,k
      DOUBLE PRECISION overlap,aspect_ratio
      DOUBLE PRECISION x(Ntot),y(Ntot),th(Ntot),alpha(Ntot)
      DOUBLE PRECISION xij,yij,D(Ntot),D1
      DOUBLE PRECISION exp,dij_up,dij
      DOUBLE PRECISION Lx,Ly,rijsq,c(Ntot),att
      DOUBLE PRECISION s(Ntot),dd,dr(Ntot,2),xa(Ntot,2),ya(Ntot,2)
      DOUBLE PRECISION dk(Ntot,2)
      DOUBLE PRECISION delrx,cory
      INTEGER flag
      COMMON /f3com/ alpha ! aspect ratio
      COMMON /f4com/ exp,att
      COMMON /f5com/ Lx,Ly
      COMMON /f11com/ delrx

      Z = 0
      Nf= 0
      Nu= 0

      Nmm = 0
      Nbb = 0
      Nmb = 0

      flag = 0

      ! convert to from molecules to atoms
      DO i=1,N
         c(i)=dcos( th(i) )
         s(i)=dsin( th(i) )
         dd=alpha(i)-1d0
         dr(i,1)=(1d0+dd)/(1d0+dd**2)*dd**2*D(i)*D1/2d0
         dr(i,2)=-(1d0+dd)/(1d0+dd**2)*D(i)*D1/2d0
         DO k=1,2
            xa(i,k)=x(i)+dr(i,k)*c(i)
            ya(i,k)=y(i)+dr(i,k)*s(i)
         ENDDO
         dk(i,1)=D(i)*D1
         dk(i,2)=dd*D(i)*D1
      ENDDO

      DO i=1,N
         nc_bud(i,1)=0
         nc_bud(i,2)=0
      ENDDO

      DO i=1,N-1
          DO j=i+1, N
              DO ki=1,2
                  DO kj=1,2
                      dij=(dk(i,ki)+dk(j,kj))/2d0
                      xij=xa(i,ki)-xa(j,kj)
                      yij=ya(i,ki)-ya(j,kj)
                      cory=idnint(yij/Ly)
                      xij=xij-cory*delrx*Lx
                      xij=xij-idnint(xij/Lx)*Lx  !! PBC
                      yij=yij-cory*Ly  !! PBC

                      rijsq=xij**2+yij**2
                      IF(rijsq.LT.(dij**2)) THEN
                          Z = Z+2
                          nc_bud(i,ki)=nc_bud(i,ki)+1
                          nc_bud(j,kj)=nc_bud(j,kj)+1
                          IF(ki.EQ.1 .AND. kj.EQ.1) THEN
                              Nmm = Nmm + 2
                          ELSEIF(ki.EQ.2 .AND. kj.EQ.2) THEN
                              Nbb = Nbb + 2
                          ELSE
                              Nmb = Nmb + 2
                          ENDIF
                      ENDIF
                  ENDDO
              ENDDO
          ENDDO
      ENDDO

      DO i=1,N
          flag = 0
          IF( (nc_bud(i,1)+nc_bud(i,2)).LT.3 ) THEN
              nf = nf + 1
              flag = 1
          ENDIF

          IF( (nc_bud(i,1)+nc_bud(i,2)).EQ.3 ) THEN
              IF( nc_bud(i,1).EQ.2 .OR. nc_bud(i,2).EQ.2 ) THEN
                  nf = nf + 1
                  flag = 1
              ENDIF
          ENDIF

          IF(flag.EQ.0) THEN
              IF( nc_bud(i,1).EQ.0 ) THEN
                  nu = nu + 1
              ENDIF
              IF( nc_bud(i,2).EQ.0 ) THEN
                  nu = nu + 1
              ENDIF
          ENDIF

      ENDDO

      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE out_numbers(N, Nf, Nu, Ziso)
      IMPLICIT NONE
      INTEGER N, Nf, Nu, Ziso

      Ziso = 6*(N-Nf) - 2*Nu - 2

      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!    STANDARD NUMERICAL CODE   !!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE frprmn(N,x,y,th,D,D1,ftol,ftol1,iter,fret)
      PARAMETER(Ntot = 4096)
      INTEGER its,iter,ITMAX
      DOUBLE PRECISION fret,ftol,EPS,ftol1
      PARAMETER (EPS=1d-10,ITMAX=1000000000)
      DOUBLE PRECISION dgg,fp,gam,gg,width
      DOUBLE PRECISION gx(Ntot),gy(Ntot),hx(Ntot),hy(Ntot)
      DOUBLE PRECISION D(Ntot),D1,xix(Ntot),xiy(Ntot),xith(Ntot)
      DOUBLE PRECISION x(Ntot),y(Ntot),maxdis,xp(Ntot),yp(Ntot)
      DOUBLE PRECISION th(Ntot),hth(Ntot),gth(Ntot),exp,att,V
      INTEGER N,countn(Ntot),nl(800,Ntot)

      ! not needed
      DOUBLE PRECISION f1,f2,f3,fxe,fye,fthe
      DOUBLE PRECISION xi,yi,thi,max1,max2,max3,del
      DOUBLE PRECISION alpha(Ntot),Lx,Ly

      ! not needed
      COMMON /f3com/ alpha ! aspect ratio
      COMMON /f5com/ Lx,Ly

      COMMON /f2com/ width
      COMMON /f4com/ exp,att

      iter=0

      CALL makelist(N,x,y,D,D1,xp,yp,countn,nl)
      CALL func(N,x,y,th,D,D1,fp,countn,nl)
      IF(fp.LT.ftol*dble(N).AND.att.EQ.0d0) THEN
         fret=fp
         RETURN
      ENDIF

      CALL dfunc(N,x,y,th,D,D1,xix,xiy,xith,countn,nl)

      DO i=1,N
        gx(i)=-xix(i)
	gy(i)=-xiy(i)
        gth(i)=-xith(i)
        hx(i)=gx(i)
	hy(i)=gy(i)
        hth(i)=gth(i)
        xix(i)=hx(i)
	xiy(i)=hy(i)
        xith(i)=hth(i)
      ENDDO

      DO its=1,ITMAX
         iter=its

         CALL linmin(N,x,y,th,D,D1,xix,xiy,xith,fret,xp,yp,countn,nl)

c         WRITE(*,*) its, fret/dble(N), fret, fp

         IF(att.EQ.0d0) THEN
            IF(dabs(fret-fp).LT.ftol1*fp.OR.fret.LT.ftol*dble(N))THEN
                CALL func(N,x,y,th,D,D1,fp,countn,nl)
               RETURN
            ENDIF
         ELSE
            IF(dabs(fret-fp).LT.ftol1) THEN
                CALL func(N,x,y,th,D,D1,fp,countn,nl)
               RETURN
            ENDIF
         ENDIF

         CALL CG_check(N,x,y,xp,yp,maxdis)
         IF(maxdis.GT.width*D1) THEN
            CALL makelist(N,x,y,D,D1,xp,yp,countn,nl)
         ENDIF

         fp=fret
         CALL dfunc(N,x,y,th,D,D1,xix,xiy,xith,countn,nl)

         gg=0d0
         dgg=0d0

         DO i=1,N
            gg=gg+gx(i)*gx(i)+gy(i)*gy(i)+gth(i)*gth(i)
            dgg=dgg+(xix(i)+gx(i))*xix(i)+(xiy(i)+gy(i))*xiy(i)
     +           +(xith(i)+gth(i))*xith(i)
         ENDDO

         IF(gg.EQ.0d0) THEN
            RETURN
         ENDIF
         gam=dgg/gg
         DO i=1,N
            gx(i)=-xix(i)
            gy(i)=-xiy(i)
            gth(i)=-xith(i)
            hx(i)=gx(i)+gam*hx(i)
            hy(i)=gy(i)+gam*hy(i)
            hth(i)=gth(i)+gam*hth(i)
            xix(i)=hx(i)
            xiy(i)=hy(i)
            xith(i)=hth(i)
         ENDDO
      ENDDO

c     pause 'frprmn maximum iterations exceeded'
      RETURN
      END
C (C) Copr. 1986-92 Numerical Recipes Software Dt+;39.

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE linmin(N,x,y,th,D,D1,xix,xiy,xith,fret,
     +     xpr,ypr,countnr,nlr)
      DOUBLE PRECISION fret,TOL
      PARAMETER (Ntot=4096,TOL=1d-8)
C     USES dbrent,df1dim,mnbrak
      DOUBLE PRECISION ax,bx,fa,fb,fx,xmin,xx
      DOUBLE PRECISION xp(Ntot),yp(Ntot),dbrent
      DOUBLE PRECISION pxcom(Ntot),pycom(Ntot)
      DOUBLE PRECISION xixcom(Ntot),xiycom(Ntot)
      DOUBLE PRECISION x(Ntot),y(Ntot),th(Ntot),xix(Ntot),xiy(Ntot)
      DOUBLE PRECISION xith(Ntot),Dcom(Ntot),D1com,D(Ntot),D1,width
      DOUBLE PRECISION pthcom(Ntot),xithcom(Ntot),f1dim,df1dim
      DOUBLE PRECISION xpr(Ntot),ypr(Ntot)
      INTEGER countn(Ntot),nl(800,Ntot),countnr(Ntot),nlr(800,Ntot)
      INTEGER N,ncom

      COMMON /f1com/ pxcom,pycom,pthcom,xixcom,xiycom,xithcom,
     +     Dcom,D1com,xp,yp,thp,countn,nl,ncom
      COMMON /f2com/ width

      EXTERNAL df1dim
      EXTERNAL f1dim

      DO i=1,N
        pxcom(i)=x(i)
        pycom(i)=y(i)
        pthcom(i)=th(i)
        xixcom(i)=xix(i)
	xiycom(i)=xiy(i)
        xithcom(i)=xith(i)
        Dcom(i)=D(i)
      ENDDO
      D1com=D1
      ncom=N

      DO i=1,N
         xp(i)=xpr(i)
         yp(i)=ypr(i)
         countn(i)=countnr(i)
         DO j=1,countn(i)
            nl(j,i)=nlr(j,i)
         ENDDO
      ENDDO

      ax=0d0
      xx=1d0
      CALL mnbrak(ax,xx,bx,fa,fx,fb,f1dim)
      fret=dbrent(ax,xx,bx,f1dim,df1dim,TOL,xmin)
      DO i=1,N
        xix(i)=xmin*xix(i)
        xiy(i)=xmin*xiy(i)
        xith(i)=xmin*xith(i)
        x(i)=x(i)+xix(i)
	y(i)=y(i)+xiy(i)
        th(i)=th(i)+xith(i)
      ENDDO

      RETURN
      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE mnbrak(ax,bx,cx,fa,fb,fc,func)
      DOUBLE PRECISION ax,bx,cx,fa,fb,fc,func,GOLD,GLIMIT,TINY
c      EXTERNAL func
      PARAMETER (GOLD=1.618034d0, GLIMIT=100., TINY=1.d-20)
      DOUBLE PRECISION dum,fu,q,r,u,ulim
      fa=func(ax)
      fb=func(bx)
      IF(fb.GT.fa)THEN ! was gt
        dum=ax
        ax=bx
        bx=dum
        dum=fb
        fb=fa
        fa=dum
      ENDIF
      cx=bx+GOLD*(bx-ax)
      fc=func(cx)
1     IF(fb.GT.fc)THEN ! was ge
        r=(bx-ax)*(fb-fc)
        q=(bx-cx)*(fb-fa)
        u=bx-((bx-cx)*q-(bx-ax)*r)/(2d0*dsign(max(dabs(q-r),TINY),q-r))
        ulim=bx+GLIMIT*(cx-bx)
        IF((bx-u)*(u-cx).GT.0d0)THEN
          fu=func(u)
          IF(fu.LT.fc)THEN
            ax=bx
            fa=fb
            bx=u
            fb=fu
            RETURN
          ELSE IF(fu.GT.fb)THEN
            cx=u
            fc=fu
            RETURN
          ENDIF
          u=cx+GOLD*(cx-bx)
          fu=func(u)
        ELSE IF((cx-u)*(u-ulim).GT.0d0)THEN
          fu=func(u)
          IF(fu.LT.fc)THEN
            bx=cx
            cx=u
            u=cx+GOLD*(cx-bx)
            fb=fc
            fc=fu
            fu=func(u)
          ENDIF
        ELSE IF((u-ulim)*(ulim-cx).GE.0d0)THEN ! was ge
          u=ulim
          fu=func(u)
        ELSE
          u=cx+GOLD*(cx-bx)
          fu=func(u)
        ENDIF
        ax=bx
        bx=cx
        cx=u
        fa=fb
        fb=fc
        fc=fu
        goto 1
      ENDIF
      RETURN
      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      FUNCTION df1dim(x)
      PARAMETER (Ntot=4096)
      DOUBLE PRECISION df1dim,x,maxdis
      DOUBLE PRECISION fx(Ntot),fy(Ntot),fth(Ntot)
      DOUBLE PRECISION pxcom(Ntot),pycom(Ntot),pthcom(Ntot)
      DOUBLE PRECISION xixcom(Ntot),xiycom(Ntot),xithcom(Ntot)
      DOUBLE PRECISION xt(Ntot),yt(Ntot),tht(Ntot)
      DOUBLE PRECISION xp(Ntot),yp(Ntot)
      DOUBLE PRECISION Dcom(Ntot),D1com
      DOUBLE PRECISION alpha(Ntot),width
      INTEGER ncom,countn(Ntot),nl(800,Ntot)
      COMMON /f1com/ pxcom,pycom,pthcom,xixcom,xiycom,xithcom,
     +     Dcom,D1com,xp,yp,thp,countn,nl,ncom
      COMMON /f2com/ width
      COMMON /f3com/ alpha ! aspect ratio

      DO i=1,ncom
        xt(i)=pxcom(i)+x*xixcom(i)
        yt(i)=pycom(i)+x*xiycom(i)
        tht(i)=pthcom(i)+x*xithcom(i)
      ENDDO

      CALL CG_check(ncom,xt,yt,xp,yp,maxdis)
      IF(maxdis.GT.width*D1com) THEN
	CALL makelist(ncom,xt,yt,Dcom,D1com,xp,yp,countn,nl)
      ENDIF
      CALL dfunc(ncom,xt,yt,tht,Dcom,D1com,fx,fy,fth,countn,nl)

      df1dim=0.D0
      DO i=1,ncom
        df1dim=df1dim+fx(i)*xixcom(i)+fy(i)*xiycom(i)+fth(i)*xithcom(i)
      ENDDO

      RETURN
      END
C  (C) Copr. 1986-92 Numerical Recipes Software Dt+;39.

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      FUNCTION dbrent(ax,bx,cx,f,df,tol,xmin)
      INTEGER ITMAX
      DOUBLE PRECISION dbrent,ax,bx,cx,tol,xmin,df,f,ZEPS
      EXTERNAL df,f
      PARAMETER (ITMAX=10000,ZEPS=1.0e-12)
      INTEGER iter
      DOUBLE PRECISION a,b,d,d1,d2,du,dv,dw,dx,e,fu,fv,fw
      DOUBLE PRECISION fx,olde,tol1,tol2,u,u1,u2,v,w,x,xm
      LOGICAL ok1,ok2
      a=min(ax,cx)
      b=max(ax,cx)
      v=bx
      w=v
      x=v
      e=0.
      fx=f(x)
      fv=fx
      fw=fx
      dx=df(x)
      dv=dx
      dw=dx
      DO 11 iter=1,ITMAX
        xm=0.5*(a+b)
        tol1=tol*dabs(x)+ZEPS
        tol2=2.*tol1
        IF(dabs(x-xm).LE.(tol2-0.5d0*(b-a))) goto 3
        IF(dabs(e).GT.tol1) THEN
          d1=2.*(b-a)
          d2=d1
          IF(dw.NE.dx) d1=(w-x)*dx/(dx-dw)
          IF(dv.NE.dx) d2=(v-x)*dx/(dx-dv)
          u1=x+d1
          u2=x+d2
          ok1=((a-u1)*(u1-b).GT.0d0).AND.(dx*d1.LE.0d0)
          ok2=((a-u2)*(u2-b).GT.0d0).AND.(dx*d2.LE.0d0)
          olde=e
          e=d
          IF(.NOT.(ok1.OR.ok2))THEN
            goto 1
          ELSE IF(ok1.AND.ok2)THEN
            IF(dabs(d1).LT.dabs(d2))THEN
              d=d1
            ELSE
              d=d2
            ENDIF
          ELSE IF(ok1)THEN
            d=d1
          ELSE
            d=d2
          ENDIF
          IF(dabs(d).GT.dabs(0.5d0*olde))goto 1
          u=x+d
          IF(u-a.LT.tol2 .OR. b-u.LT.tol2) d=dsign(tol1,xm-x)
          goto 2
        ENDIF
1       IF(dx.GE.0d0) THEN
          e=a-x
        ELSE
          e=b-x
        ENDIF
        d=0.5d0*e
2        IF(dabs(d).GE.tol1) THEN
          u=x+d
           fu=f(u)
        ELSE
          u=x+dsign(tol1,d)
          fu=f(u)
          IF(fu.GT.fx)goto 3
        ENDIF
        du=df(u)
        IF(fu.LE.fx) THEN
          IF(u.GE.x) THEN
            a=x
          ELSE
            b=x
          ENDIF
          v=w
          fv=fw
          dv=dw
          w=x
          fw=fx
          dw=dx
          x=u
          fx=fu
          dx=du
        ELSE
          IF(u.LT.x) THEN
            a=u
          ELSE
            b=u
          ENDIF
          IF(fu.LE.fw .OR. w.EQ.x) THEN
            v=w
            fv=fw
            dv=dw
            w=u
            fw=fu
            dw=du
          ELSE IF(fu.LE.fv .OR. v.EQ.x .OR. v.EQ.w) THEN
            v=u
            fv=fu
            dv=du
          ENDIF
        ENDIF
11    continue
c      pause 'dbrent exceeded maximum iterations'
3     xmin=x
      dbrent=fx
      RETURN
      END
c  (C) Copr. 1986-92 Numerical Recipes Software Dt+;39.

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      FUNCTION f1dim(x)
      PARAMETER (Ntot=4096)
      DOUBLE PRECISION f1dim,x
      DOUBLE PRECISION pxcom(Ntot),pycom(Ntot),pthcom(Ntot)
      DOUBLE PRECISION xixcom(Ntot),xiycom(Ntot),xithcom(Ntot)
      DOUBLE PRECISION xt(Ntot),yt(Ntot),tht(Ntot),width
      DOUBLE PRECISION Dcom(Ntot),maxdis,D1com
      DOUBLE PRECISION xp(Ntot),yp(Ntot),alpha(Ntot)
      INTEGER nl(800,Ntot),countn(Ntot),ncom
      COMMON /f1com/ pxcom,pycom,pthcom,xixcom,xiycom,xithcom,
     +     Dcom,D1com,xp,yp,thp,countn,nl,ncom

      COMMON /f2com/ width
      COMMON /f3com/ alpha ! aspect ratio

      DO i=1,ncom
        xt(i)=pxcom(i)+x*xixcom(i)
        yt(i)=pycom(i)+x*xiycom(i)
        tht(i)=pthcom(i)+x*xithcom(i)
      ENDDO

      CALL CG_check(ncom,xt,yt,xp,yp,maxdis)
      IF(maxdis.GT.width*D1com) THEN
	CALL makelist(ncom,xt,yt,Dcom,D1com,xp,yp,countn,nl)
      ENDIF
      CALL func(ncom,xt,yt,tht,Dcom,D1com,f1dim,countn,nl)

      RETURN
      END
C  (C) Copr. 1986-92 Numerical Recipes Software Dt+;39.


      SUBROUTINE SBDCLO( DIST, XCLOS, POINT,
     &                   AXIS, BOXRAD, BOXDIM, CENTRE)
      IMPLICIT NONE
      SAVE
C ********************************************************************
C *                                                                  *
C * This software is an unpublished work containing confidential and *
C * proprietary information of Birkbeck College. Use, disclosure,    *
C * reproduction and transfer of this work without the express       *
C * written consent of Birkbeck College are prohibited. This notice  *
C * must be attached to all copies or extracts of the software.      *
C *                                                                  *
C * (c) 1996 Oliver Smart & Birkbeck College, All rights reserved    *
C *                                                                  *
C ********************************************************************

C This s/r finds the closest approach of a "sphere-box" (oss i005)
C to point "POINT".  Returns distance (DIST) and co-ordinates of
C the closest point.

C distance and closest point to be worked out
      DOUBLE PRECISION			DIST, XCLOS(3)

C point to which closest distance to is to be found
      DOUBLE PRECISION			POINT(3)

C centre of sphere box
      DOUBLE PRECISION			CENTRE(3)

C unit vector giving directions of axes which define sphere box
C first axis is vector (axis(1,1),axis(2,1),axis(3,1)
C N.B. no check is made in this s/r that axes are unit
C and orthogonal - This must be made certain in calling routine.
      DOUBLE PRECISION			AXIS(3,3)

C radius of sphere box, its additional dimensions along the three axis
      DOUBLE PRECISION			BOXRAD, BOXDIM(3)

C internal vbles ***********************

C the vector from centre to point (cartesian)
      DOUBLE PRECISION			DISP(3)

C components of DISP along axis(*,1), axis(*,2) and axis(*,3)
      DOUBLE PRECISION			COMP(3)

C closest point in "axis" units
      DOUBLE PRECISION			AXISCL(3)

C x,y,z loop count
       INTEGER				XCOUNT

C end of decs **************************

C the vector from centre to point
      DISP(1) = POINT(1) - CENTRE(1)
      DISP(2) = POINT(2) - CENTRE(2)
      DISP(3) = POINT(3) - CENTRE(3)

C work out components along the various axes
      CALL DDOT( DISP, AXIS(1,1), COMP(1))
      CALL DDOT( DISP, AXIS(1,2), COMP(2))
      CALL DDOT( DISP, AXIS(1,3), COMP(3))
C*      write(*,*) 'comp''s', comp

C closest point on (or inside) box in axis units
      DO 10 XCOUNT = 1, 3
        IF (COMP(XCOUNT).GT.0.) THEN
          AXISCL(XCOUNT) = MIN(COMP(XCOUNT), BOXDIM(XCOUNT))
        ELSE
          AXISCL(XCOUNT) = MAX(COMP(XCOUNT),-BOXDIM(XCOUNT))
        ENDIF
10    CONTINUE
C*      write(*,*) 'axiscl ', axiscl

C make comp's vector from axiscl to point
      COMP(1) = COMP(1) - AXISCL(1)
      COMP(2) = COMP(2) - AXISCL(2)
      COMP(3) = COMP(3) - AXISCL(3)
C*      write(*,*) 'comp''s vector ', comp

C work out length of this
      DIST = SQRT(COMP(1)**2+ COMP(2)**2 + COMP(3)**2)

C unit the comp vector
      IF (DIST.GT.0.) THEN
        COMP(1) = COMP(1)/DIST
        COMP(2) = COMP(2)/DIST
        COMP(3) = COMP(3)/DIST
      ENDIF
C*      write(*,*) 'comp''s after unit', comp

C the closest distance is this minus the radius (n.b. negative if inside)
      DIST = DIST - BOXRAD

C the closest point is BOXRAD along the comp vector
      AXISCL(1) = AXISCL(1) + BOXRAD*COMP(1)
      AXISCL(2) = AXISCL(2) + BOXRAD*COMP(2)
      AXISCL(3) = AXISCL(3) + BOXRAD*COMP(3)

C have co-ord's of closest point in axis units convert back to cartesian
C using s/r sbcart (at bottom of file sbgen.f)
      CALL SBCART( AXISCL, XCLOS, CENTRE, AXIS)

      RETURN
      END


include 'fftlib.for'
program errori
        implicit none
        integer :: N, i
        double precision,allocatable ,dimension(:):: un ,ue, error, ufft
        double precision :: time, minerr, maxerr, norm, dummy
        character(50) :: fname

        print*, 'N?'
        read*, N

        allocate(un(0:N),ue(0:N),error(0:N), ufft(1:N/2))

        call system('ls sol* > fileread')
        call system('mkdir error')
        open(1,file='error/fileread')
        open(2,file='error/error_history.dat')
        !write(2,*) 'Variables = time, min_error, max_error, L2norm_error'
        write(2,*) 'Variables = time, disp_error, phase_error, max_error'
        do
          read(1,*) fname
          open(3, file=trim(fname), status='old')
          print*, fname
          read(3,*)
          read(3,*)
          read(3,*)
          do i=0,N
              read(3,*) dummy, un(i), ue(i)
          enddo
          close(3)
          error = un - ue

         call FFT1d(error(1:N), N, ufft)
         call writefft1d(ufft,N,100d0/N,'error/fft_'//trim(fname))

          print*,  fname(5:13)
        ! minerr = minval(error)
        ! maxerr = maxval(error)
        ! norm = dsqrt(dot_product(error,error))/N

          minerr = maxval(n/4:n/2)
          maxerr = maxval(1:n/4)
          norm   = maxval(error)
          write(2,*)  fname(5:13),minerr,maxerr,norm
        enddo
endprogram errori


C    @(#)newvec.f	20.3 2/13/96
      subroutine newvec

      include 'ipfinc/parametr.inc'

      include 'ipfinc/smallp.inc'

      double precision aij, geta

      xkpos = 1.0
      if (newx.gt.n) go to 40
      do 10 k = 1,size
   10 gr(k) = 0.0
      do 30 l = 1,size
         i = ybasis(l)
         aij = geta(i,newx)
         if (aij.eq.0.0) go to 30
         do 20 k = 1,size
            gr(k) = gr(k) + aij * inv(k,l)
   20    continue
   30 continue

      if (inbase(newx).eq.-1) xkpos = -1.0
      go to 60

   40 i = newx - n
      l = iseff(i)
      do 50 k = 1,size
   50 gr(k) = inv(k,l)
      if (s(i).eq.-1.0) xkpos = -1.0
   60 return
      end


      subroutine beyond(ivtype,nccut,ccut,ccdf,ncut,cut,cdf,zmin,zmax,
     +           ltail,ltpar,middle,mpar,utail,utpar,zval,cdfval,ierr)
c-----------------------------------------------------------------------
c
c                     Go Beyond a Discrete CDF
c                     ************************
c
c This subroutine is a general purpose subroutine to interpolate within
c and extrapolate beyond discrete points on a conditional CDF.  If the
c Z value "zval" is specified then the corresponding CDF value "cdfval"
c will be computed, if the CDF value "cdfval" is specified the
c corresponding Z value "zval" will be computed.
c
c
c
c INPUT/OUTPUT VARIABLES:
c
c   ivtype           variable type (1=continuous, 0=categorical)
c   nccut            number of cutoffs defining the conditional CDF
c   ccut()           real array of the nccut cutoffs
c   ccdf()           real array of the conditional cdf values
c   ncut             number of cutoffs defining the global CDF
c   cut()            real array of the ncut cutoffs
c   cdf()            real array of the global cdf values
c
c   zmin,zmax        minimum and maximum allowable data values
c   ltail            option to handle values in lower tail
c   ltpar            parameter required for option ltail
c   middle           option to handle values in the middle
c   mpar             parameter required for option middle
c   utail            option to handle values in upper tail
c   utpar            parameter required for option utail
c
c   zval             interesting cutoff (if -1 then it is calculated)
c   cdfval           interesting CDF (if -1 then it is calculated)
c
c
c-----------------------------------------------------------------------

      implicit integer (i-n)
      implicit double precision (a-h,o-z)

      parameter(EPSLON=1.0e-20,UNEST=-1.0)
      dimension ccut(nccut),ccdf(nccut),cut(1),cdf(1)
      real*8      utpar,mpar,ltpar,lambda
      integer   ltail,utail,middle,cclow,cchigh
c
c Check for both "zval" and "cdfval" defined or undefined:
c
      ierr  = 1
      if(zval.gt.UNEST.and.cdfval.gt.UNEST) return
      if(zval.le.UNEST.and.cdfval.le.UNEST) return
c
c Handle the case of a categorical variable:
c
      if(ivtype.eq.0) then
            cum = 0
            do i=1,nccut
                  cum = cum + ccdf(i)
                  if(cdfval.le.cum) then
                         zval = ccut(i)
                         return
                  endif
            end do
            return
      end if
c
c Figure out what part of distribution: ipart = 0 - lower tail
c                                       ipart = 1 - middle
c                                       ipart = 2 - upper tail
      ierr  = 0
      ipart = 1
      if(zval.gt.UNEST) then
            if(zval.le.ccut(1))       ipart = 0
            if(zval.ge.ccut(nccut))   ipart = 2
      else
            if(cdfval.le.ccdf(1))     ipart = 0
            if(cdfval.ge.ccdf(nccut)) ipart = 2
      endif
c
c ARE WE IN THE LOWER TAIL?
c
      if(ipart.eq.0) then
            if(ltail.eq.1) then
c
c Straight Linear Interpolation:
c
                  powr = 1.0
                  if(zval.gt.UNEST) then
                        cdfval = powint(zmin,ccut(1),0.d0,ccdf(1),
     +                                  zval,powr)
                  else
                        zval = powint(0.d0,ccdf(1),zmin,ccut(1),
     +                                cdfval,powr)
                  endif
            else if(ltail.eq.2) then
c
c Power Model interpolation to lower limit "zmin"?
c
                  if(zval.gt.UNEST) then
                        cdfval = powint(zmin,ccut(1),0.d0,ccdf(1),
     +                                  zval,ltpar)
                  else
                        powr = 1.0 / ltpar
                        zval = powint(0.d0,ccdf(1),zmin,ccut(1),
     +                                cdfval,powr)
                  endif
c
c Linear interpolation between the rescaled global cdf?
c
            else if(ltail.eq.3) then
                  if(zval.gt.UNEST) then
c
c Computing the cdf value. Locate the point and the class bound:
c
                        call locate(cut,ncut,1,ncut,zval,idat)
                        call locate(cut,ncut,1,ncut,ccut(1),iupp)
c
c Straight linear interpolation if no data; otherwise, linear:
c
                        if(idat.le.0.or.idat.ge.ncut.or.
     +                     iupp.le.0.or.iupp.ge.ncut) then
                               cdfval = powint(zmin,cut(1),0.d0,cdf(1),
     +                                         zval,1.)
                         else
                               temp   = powint(cut(idat),cut(idat+1),
     +                                    cdf(idat),cdf(idat+1),zval,1.)
                               cdfval = temp*ccdf(1)/cdf(iupp)
                         endif
                   else
c
c Computing Z value: Are there any data out in the tail?
c
                         call locate(cut,ncut,1,ncut,ccut(1),iupp)
c
c Straight linear interpolation if no data; otherwise, local linear
c interpolation:
c
                        if(iupp.le.0.or.iupp.ge.ncut) then
                              zval = powint(0.d0,cdf(1),zmin,cut(1),
     +                                      cdfval,1.)
                        else
                              temp = cdfval*cdf(iupp)/ccdf(1)
                              call locate(cdf,ncut,1,ncut,temp,idat)
                              if(idat.le.0.or.idat.ge.ncut) then
                                    zval = powint(0.d0,cdf(1),zmin,
     +                                            cut(1),cdfval,1.)
                              else
                                    zval = powint(cdf(idat),cdf(idat+1),
     +                                   cut(idat),cut(idat+1),temp,1.)
                              end if
                        endif
                  endif
            else
c
c Error situation - unacceptable option:
c
                  ierr = 2
                  return
            endif
      endif
c
c FINISHED THE LOWER TAIL,  ARE WE IN THE MIDDLE?
c
      if(ipart.eq.1) then
c
c Establish the lower and upper limits:
c
            if(zval.gt.UNEST) then
                  call locate(ccut,nccut,1,nccut,zval,cclow)
            else
                  call locate(ccdf,nccut,1,nccut,cdfval,cclow)
            endif
            cchigh = cclow + 1
            if(middle.eq.1) then
c
c Straight Linear Interpolation:
c
                  powr = 1.0
                  if(zval.gt.UNEST) then
                        cdfval = powint(ccut(cclow),ccut(cchigh),
     +                           ccdf(cclow),ccdf(cchigh),zval,powr)
                  else
                        zval = powint(ccdf(cclow),ccdf(cchigh),
     +                         ccut(cclow),ccut(cchigh),cdfval,powr)
                  endif
c
c Power interpolation between class bounds?
c
            else if(middle.eq.2) then
                  if(zval.gt.UNEST) then
                        cdfval = powint(ccut(cclow),ccut(cchigh),
     +                           ccdf(cclow),ccdf(cchigh),zval,mpar)
                  else
                        powr = 1.0 / mpar
                        zval = powint(ccdf(cclow),ccdf(cchigh),
     +                         ccut(cclow),ccut(cchigh),cdfval,powr)
                  endif
c
c Linear interpolation between the rescaled global cdf?
c
            else if(middle.eq.3) then
                  call locate(cut,ncut,1,ncut,ccut(cclow),ilow)
                  call locate(cut,ncut,1,ncut,ccut(cchigh),iupp)
                  if(cut(ilow).lt.ccut(cclow))  ilow = ilow + 1
                  if(cut(iupp).gt.ccut(cchigh)) iupp = iupp - 1
                  if(zval.gt.UNEST) then
                        call locate(cut,ncut,1,ncut,zval,idat)
c
c Straight linear interpolation if no data; otherwise, local linear
c interpolation:
c
                        if(idat.le.0.or.idat.ge.ncut.or.
     +                     ilow.le.0.or.ilow.ge.ncut.or.
     +                     iupp.le.0.or.iupp.ge.ncut.or.
     +                     iupp.le.ilow) then
                              cdfval=powint(ccut(cclow),ccut(cchigh),
     +                                ccdf(cclow),ccdf(cchigh),zval,1.)
                        else
                              temp = powint(cut(idat),cut(idat+1),
     +                                cdf(idat),cdf(idat+1),zval,1.)
                              cdfval=powint(cdf(ilow),cdf(iupp),
     +                                ccdf(cclow),ccdf(cchigh),temp,1.)
                        endif
                  else
c
c Straight linear interpolation if no data; otherwise, local linear
c interpolation:
c
                        if(ilow.le.0.or.ilow.ge.ncut.or.
     +                     iupp.le.0.or.iupp.ge.ncut.or.
     +                     iupp.le.ilow) then
                              zval=powint(ccdf(cclow),ccdf(cchigh),
     +                              ccut(cclow),ccut(cchigh),cdfval,1.)
                        else
                              temp=powint(ccdf(cclow),ccdf(cchigh),
     +                              cdf(ilow),cdf(iupp),cdfval,1.)
                              call locate(cdf,ncut,1,ncut,temp,idat)
                              if(cut(idat).lt.ccut(cclow)) idat=idat+1
                              if(idat.le.0.or.idat.ge.ncut.or.
     +                           cut(idat+1).gt.ccut(cchigh)) then
                                    zval = powint(ccdf(cclow),
     +                                     ccdf(cchigh),ccut(cclow),
     +                                     ccut(cchigh),cdfval,1.)
                              else
                                    zval = powint(cdf(idat),cdf(idat+1),
     +                                   cut(idat),cut(idat+1),temp,1.)
                              end if
                              zval = powint(cdf(idat),cdf(idat+1),
     +                                cut(idat),cut(idat+1),temp,1.)
                        endif
                  endif
            else
c
c Error situation - unacceptable option:
c
                  ierr = 2
                  return
            endif
      endif
c
c FINISHED THE MIDDLE,  ARE WE IN THE UPPER TAIL?
c
      if(ipart.eq.2) then
            if(utail.eq.1) then
                  powr = 1.0
                  if(zval.gt.UNEST) then
                        cdfval = powint(ccut(nccut),zmax,ccdf(nccut),
     +                                  1.0,zval,powr)
                  else
                        zval   = powint(ccdf(nccut),1.0,ccut(nccut),
     +                                  zmax,cdfval,powr)
                  endif

            else if(utail.eq.2) then
c
c Power interpolation to upper limit "utpar"?
c
                  if(zval.gt.UNEST) then
                        cdfval = powint(ccut(nccut),zmax,ccdf(nccut),
     +                                  1.0,zval,utpar)
                  else
                        powr = 1.0 / utpar
                        zval   = powint(ccdf(nccut),1.0,ccut(nccut),
     +                                  zmax,cdfval,powr)
                  endif
c
c Linear interpolation between the rescaled global cdf?
c
            else if(utail.eq.3) then
                  if(zval.gt.UNEST) then
c
c Approximately Locate the point and the class bound:
c
                        call locate(cut,ncut,1,ncut,zval,idat)
                        call locate(cut,ncut,1,ncut,ccut(nccut),ilow)
                        if(cut(idat).lt.zval)        idat = idat + 1
                        if(cut(ilow).lt.ccut(nccut)) ilow = ilow + 1
c
c Straight linear interpolation if no data; otherwise, local linear
c interpolation:
c
                        if(idat.le.0.or.idat.ge.ncut.or.
     +                     ilow.le.0.or.ilow.ge.ncut) then
                              cdfval = powint(ccut(nccut),zmax,
     +                                  ccdf(nccut),1.0,zval,1.)
                        else
                              temp   = powint(cut(idat),cut(idat+1),
     +                                  cdf(idat),cdf(idat+1),zval,1.)
                              cdfval = powint(cdf(ilow),1.0,
     +                                  ccdf(nccut),1.0,temp,1.)
                        endif
                  else
c
c Computing Z value: Are there any data out in the tail?
c
                        call locate(cut,ncut,1,ncut,ccut(nccut),ilow)
                        if(cut(ilow).lt.ccut(nccut)) ilow = ilow + 1
c
c Straight linear interpolation if no data; otherwise, local linear
c interpolation:
c
                        if(ilow.le.0.or.ilow.ge.ncut) then
                              zval   = powint(ccdf(nccut),1.0,
     +                                  ccut(nccut),zmax,cdfval,1.)
                        else
                              temp = powint(ccdf(nccut),1.0,
     +                                cdf(ilow),1.0,cdfval,1.)
                              call locate(cdf,ncut,1,ncut,temp,idat)
                              if(cut(idat).lt.ccut(nccut)) idat=idat+1
                              if(idat.ge.ncut) then
                                    zval   = powint(ccdf(nccut),1.0,
     +                                       ccut(nccut),zmax,cdfval,1.)
                              else
                                    zval = powint(cdf(idat),cdf(idat+1),
     +                                   cut(idat),cut(idat+1),temp,1.)
                              endif
                        endif
                  endif
c
c Fit a Hyperbolic Distribution?
c
            else if(utail.eq.4) then
c
c Figure out "lambda" and required info:
c
                  lambda = (ccut(nccut)**utpar)*(1.0-ccdf(nccut))
                  if(zval.gt.UNEST) then
                        cdfval = 1.0 - (lambda/(zval**utpar))
                  else
                        zval = (lambda/(1.0-cdfval))**(1.0/utpar)
                  endif
            else
c
c Error situation - unacceptable option:
c
                  ierr = 2
                  return
            endif
      endif
      if(zval.lt.zmin) zval = zmin
      if(zval.gt.zmax) zval = zmax
c
c All finished - return:
c
      return
      end


module mod_poisson_green
  implicit none

contains

  subroutine poisson_solver_Green ( f, dx, dy, hgttend )
    !
    !   New version of "height_tendency", using precalculated response kernel
    !   (JR 10.12.2015)

    implicit none
    real, dimension ( :, :, : ), allocatable, save  :: response
    real, dimension ( :, : ), intent ( in ) :: f
    real,                     intent ( in ) :: dx, dy
    real, dimension ( :, : ), intent ( out ) :: hgttend
    integer :: i,j
    integer :: ind, ii, jj, nlon, nlat

    nlon=size(f,1)
    nlat=size(f,2)

    if(.not. allocated (response))then
       allocate(response(nlon/2+1,nlat,(nlat+1)/2))
       call responsekernel(response,nlon,nlat,dx,dy)
    end if

    hgttend=0.0e0

    do i=1,nlon
       do j=2,nlat-1
          do ii=1,nlon

             ind = 1 + min ( abs(i-ii), abs(i-ii+nlon), abs(i-ii-nlon) )

             do jj=1,nlat/2
                hgttend(i,j) = hgttend(i,j) + f(ii,jj) &
                     * response(ind,j,jj)
             enddo

             do jj=nlat/2+1,nlat
                hgttend(i,j) = hgttend(i,j) + f(ii,jj) &
                     *response(ind,nlat+1-j,nlat+1-jj)
             enddo

          enddo
       enddo
    enddo

  end subroutine poisson_solver_Green

  subroutine responsekernel(response,nlon,nlat,dx,dy)

    implicit none
    real,dimension(:,:,:),intent(inout) :: response
    integer,intent(in) :: nlon,nlat
    real,intent(in) :: dx,dy

    real :: forcing(nlon,nlat,1),res1(nlon,nlat,1)
    integer :: i,j,j0

    do j0=1,(nlat+1)/2
       forcing=0.
       forcing(1,j0,1)=1.
       call invert_lapl(forcing,nlon,nlat,1,dx,dy,res1)
       do i=1,nlon/2+1
          do j=1,nlat
             response(i,j,j0)=res1(i,j,1)
          enddo
       enddo
       write(*,*)'Calculated response, j0=',j0
    enddo

  end subroutine responsekernel

  subroutine invert_lapl(forcing,nlon,nlat,nlev,dx,dy,phi)
    !
    !   Former "height_tendency". Only name of subroutine changed (JR 10.12.15)
    !
    !   Calculation of inverse of laplacian with iteration and by using function laplace2_cart.
    !   Southern and northern boundaries are left as zero.
    !
    implicit none
    real,dimension(:,:,:),intent(in) :: forcing
    real,intent(in) :: dx,dy
    integer,intent(in) :: nlev
    real,dimension(:,:,:),intent(inout) :: phi

    integer :: nlon,nlat,l,i,j,k,itermax
    real :: coeff(nlon,nlat,nlev),lapl2(nlon,nlat,nlev)

    phi=0.
    itermax=1000

    do l=1,itermax
       call laplace2_cart(phi,lapl2,coeff,dx,dy)
       do k=1,nlev
          do j=2,nlat-1
             do i=1,nlon
                phi(i,j,k)=(forcing(i,j,k)-lapl2(i,j,k))/coeff(i,j,k)
             enddo
          enddo
       enddo
    enddo

  end subroutine invert_lapl

  subroutine laplace2_cart(f,lapl2,coeff,dx,dy)
    !
    !     As laplace_cart
    !       - jätetään kussakin pisteessä paikallisen arvon osuus pois
    !       - lasketaan paikallisen arvon kerroin coeff
    !
    real,dimension(:,:,:),intent(in) :: f
    real,    intent ( in )  :: dx, dy
    real,dimension(:,:,:), intent ( out ) :: lapl2, coeff
    integer :: nlon, nlat, nlev

    nlon=size(f,1)
    nlat=size(f,2)
    nlev=size(f,3)

    ! x-direction
    lapl2 ( 2 : nlon - 1, :, : ) = f( 1: nlon - 2, :, : ) + f ( 3: nlon, :, : )
    lapl2 ( 1, :, : )    = f( nlon,     :, : ) + f ( 2, :, : )
    lapl2 ( nlon, :, : ) = f( nlon - 1, :, : ) + f ( 1, :, : )
    lapl2 = lapl2 / ( dx * dx )

    ! y-directon
    lapl2 ( :, 2 : nlat -1, : ) = lapl2 ( :, 2 : nlat -1, : ) &
         + ( f ( :, 1 : nlat -2, : ) + f ( :, 3 : nlat, :) ) / ( dy * dy )

    coeff ( :, 2 : nlat -1, : ) = -2.0 / (dx * dx ) -2.0 / (dy * dy )
    coeff ( :, 1,    : ) = -2.0 / (dx * dx )
    coeff ( :, nlat, : ) = -2.0 / (dx * dx )

  end subroutine laplace2_cart

end module mod_poisson_green


      SUBROUTINE PELNOR(XMOM,PARA)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  PARAMETER ESTIMATION VIA L-MOMENTS FOR THE NORMAL DISTRIBUTION
C
C  PARAMETERS OF ROUTINE:
C  XMOM   * INPUT* ARRAY OF LENGTH 2. CONTAINS THE L-MOMENTS LAMBDA-1,
C                  LAMBDA-2.
C  PARA   *OUTPUT* ARRAY OF LENGTH 2. ON EXIT, CONTAINS THE PARAMETERS
C                  IN THE ORDER MU, SIGMA (LOCATION, SCALE).
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION XMOM(2),PARA(2)
      DATA ZERO/0D0/
      DATA ROOTPI/1.7724 53850 90551 603D0/
C
      IF(XMOM(2).LE.ZERO)GOTO 1000
      PARA(2)=XMOM(2)*ROOTPI
      PARA(1)=XMOM(1)
      RETURN
C
 1000 WRITE(6,7000)
      RETURN
C
 7000 FORMAT(' *** ERROR *** ROUTINE PELNOR : L-MOMENTS INVALID')
      END