module map_non_coincident_grids_test_mod
use fruit
use map_non_coincident_grids_mod
implicit none

contains

subroutine setup
end subroutine setup

subroutine teardown
end subroutine teardown

subroutine testLatLonToIconGrids
  type(icon_icosohedral_grid), pointer :: coarse_grid
  type(icon_icosohedral_cell_latlon_pixel_ncg_mapper) :: ncg_mapper
  integer, dimension(:,:), pointer :: cell_neighbors
  integer, dimension(:,:), pointer :: secondary_neighbors
  real(kind=double_precision), dimension(:,:), allocatable :: cell_vertices_lats
  real(kind=double_precision), dimension(:,:), allocatable :: cell_vertices_lons
  real(kind=double_precision), dimension(:), allocatable :: pixel_center_lats
  real(kind=double_precision), dimension(:), allocatable :: pixel_center_lons
  class(*), dimension(:,:), pointer :: pixel_center_lats_ptr_2d
  class(*), dimension(:,:), pointer :: pixel_center_lons_ptr_2d
  class(latlon_field_section), pointer :: pixel_center_lats_field
  class(latlon_field_section), pointer :: pixel_center_lons_field
  class(*), dimension(:),pointer :: cell_vertex_coords_data
  class(icon_single_index_field_section), pointer :: cell_vertex_coords
  type(generic_1d_section_coords),pointer :: coarse_grid_shape
  class(latlon_section_coords),pointer :: fine_grid_shape
  class(field_section), pointer :: cell_numbers
  integer, dimension(:,:), pointer :: cell_numbers_data
  class(*), dimension(:,:), pointer :: cell_numbers_data_ptr
  integer :: i,j
  character(len=250) :: debug, debug2
    allocate(fine_grid_shape,source=latlon_section_coords(1,1,12,40))
    allocate(cell_vertices_lats(80,3))
    allocate(cell_vertices_lons(80,3))
    allocate(pixel_center_lats(12))
    allocate(pixel_center_lons(40))
    allocate(real(kind=double_precision)::pixel_center_lats_ptr_2d(12,40))
    allocate(real(kind=double_precision)::pixel_center_lons_ptr_2d(12,40))
    allocate(cell_neighbors(80,3))
    cell_neighbors = transpose( reshape((/ 5,7,2, &
                                           1,10,3, &
                                           2,13,4, &
                                           3,16,5, &
                                           4,19,1, &
                                           20,21,7, &
                                           1,6,8, &
                                           7,23,9, &
                                           8,25,10, &
                                           2,9,11, &
                                           10,27,12, &
                                           11,29,13, &
                                           3,12,14, &
                                           13,31,15, &
                                           14,33,16, &
                                           4,15,17, &
                                           16,35,18, &
                                           17,37,19, &
                                           5,18,20, &
                                           19,39,6, &
                                           6,40,22, &
                                           21,41,23, &
                                           8,22,24, &
                                           23,43,25, &
                                           24,26,9, &
                                           25,45,27, &
                                           11,26,28, &
                                           27,47,29, &
                                           12,28,30, &
                                           29,49,31, &
                                           14,30,32, &
                                           31,51,33, &
                                           15,32,34, &
                                           33,53,35, &
                                           17,34,36, &
                                           35,55,37, &
                                           18,36,38, &
                                           37,57,39, &
                                           20,38,40, &
                                           39,59,21, &
                                           22,60,42, &
                                           41,61,43, &
                                           24,42,44, &
                                           43,63,45, &
                                           26,44,46, &
                                           45,64,47, &
                                           28,46,48, &
                                           47,66,49, &
                                           30,48,50, &
                                           49,67,51, &
                                           32,50,52, &
                                           51,69,53, &
                                           34,52,54, &
                                           53,70,55, &
                                           36,54,56, &
                                           55,72,57, &
                                           38,56,58, &
                                           57,73,59, &
                                           40,58,60, &
                                           59,75,41, &
                                           42,75,62, &
                                           61,76,63, &
                                           44,62,64, &
                                           46,63,65, &
                                           64,77,66, &
                                           48,65,67, &
                                           50,66,68, &
                                           67,78,69, &
                                           52,68,70, &
                                           54,69,71, &
                                           70,79,72, &
                                           56,71,73, &
                                           58,72,74, &
                                           73,80,75, &
                                           60,74,61, &
                                           62,80,77, &
                                           65,76,78, &
                                           68,77,79, &
                                           71,78,80, &
                                           74,79,76 /), (/3,80/)))
    cell_vertices_lats = transpose(reshape((/  90.0,  60.0,  60.0, &
                                               90.0,  60.0,  60.0, &
                                               90.0,  60.0,  60.0, &
                                               90.0,  60.0,  60.0, &
                                               90.0,  60.0,  60.0, &
                                               60.0,  30.0,  30.0, &
                                               60.0,  30.0,  60.0, &
                                               60.0,  30.0,  30.0, &
                                               60.0,  30.0,  30.0, &
                                               60.0,  30.0,  60.0, &
                                               60.0,  30.0,  30.0, &
                                               60.0,  30.0,  30.0, &
                                               60.0,  30.0,  60.0, &
                                               60.0,  30.0,  30.0, &
                                               60.0,  30.0,  30.0, &
                                               60.0,  30.0,  60.0, &
                                               60.0,  30.0,  30.0, &
                                               60.0,  30.0,  30.0, &
                                               60.0,  30.0,  60.0, &
                                               60.0,  30.0,  30.0, &
                                               30.0,   0.0,  30.0, &
                                               30.0,   0.0,   0.0, &
                                               30.0,   0.0,  30.0, &
                                               30.0,   0.0,   0.0, &
                                               30.0,   0.0,  30.0, &
                                               30.0,   0.0,   0.0, &
                                               30.0,   0.0,  30.0, &
                                               30.0,   0.0,   0.0, &
                                               30.0,   0.0,  30.0, &
                                               30.0,   0.0,   0.0, &
                                               30.0,   0.0,  30.0, &
                                               30.0,   0.0,   0.0, &
                                               30.0,   0.0,  30.0, &
                                               30.0,   0.0,   0.0, &
                                               30.0,   0.0,  30.0, &
                                               30.0,   0.0,   0.0, &
                                               30.0,   0.0,  30.0, &
                                               30.0,   0.0,   0.0, &
                                               30.0,   0.0,  30.0, &
                                               30.0,   0.0,   0.0, &
                                                0.0, -30.0,   0.0, &
                                                0.0, -30.0, -30.0, &
                                                0.0, -30.0,   0.0, &
                                                0.0, -30.0, -30.0, &
                                                0.0, -30.0,   0.0, &
                                                0.0, -30.0, -30.0, &
                                                0.0, -30.0,   0.0, &
                                                0.0, -30.0, -30.0, &
                                                0.0, -30.0,   0.0, &
                                                0.0, -30.0, -30.0, &
                                                0.0, -30.0,   0.0, &
                                                0.0, -30.0, -30.0, &
                                                0.0, -30.0,   0.0, &
                                                0.0, -30.0, -30.0, &
                                                0.0, -30.0,   0.0, &
                                                0.0, -30.0, -30.0, &
                                                0.0, -30.0,   0.0, &
                                                0.0, -30.0, -30.0, &
                                                0.0, -30.0,   0.0, &
                                                0.0, -30.0, -30.0, &
                                              -30.0, -60.0, -30.0, &
                                              -30.0, -60.0, -60.0, &
                                              -30.0, -60.0, -30.0, &
                                              -30.0, -60.0, -30.0, &
                                              -30.0, -60.0, -60.0, &
                                              -30.0, -60.0, -30.0, &
                                              -30.0, -60.0, -30.0, &
                                              -30.0, -60.0, -60.0, &
                                              -30.0, -60.0, -30.0, &
                                              -30.0, -60.0, -30.0, &
                                              -30.0, -60.0, -60.0, &
                                              -30.0, -60.0, -30.0, &
                                              -30.0, -60.0, -30.0, &
                                              -30.0, -60.0, -60.0, &
                                              -30.0, -60.0, -30.0, &
                                              -60.0, -90.0, -60.0, &
                                              -60.0, -90.0, -60.0, &
                                              -60.0, -90.0, -60.0, &
                                              -60.0, -90.0, -60.0, &
                                              -60.0, -90.0, -60.0 /), (/3,80/)))

    cell_vertices_lons = transpose(reshape((/ 0.0, 324.0,  36.0, &
                                              0.0,  36.0, 108.0, &
                                              0.0, 108.0, 180.0, &
                                              0.0, 180.0, 252.0, &
                                              0.0, 252.0, 324.0, &
                                            324.0, 324.0,   0.0, &
                                            324.0,   0.0,  36.0, &
                                             36.0,   0.0,  36.0, &
                                             36.0,  36.0,  72.0, &
                                             36.0,  72.0, 108.0, &
                                            108.0,  72.0, 108.0, &
                                            108.0, 108.0, 144.0, &
                                            108.0, 144.0, 180.0, &
                                            180.0, 144.0, 180.0, &
                                            180.0, 180.0, 216.0, &
                                            180.0, 216.0, 252.0, &
                                            252.0, 216.0, 252.0, &
                                            252.0, 252.0, 288.0, &
                                            252.0, 288.0, 324.0, &
                                            324.0, 288.0, 324.0, &
                                            324.0, 342.0,   0.0, &
                                              0.0, 342.0,  18.0, &
                                              0.0,  18.0,  36.0, &
                                             36.0,  18.0,  54.0, &
                                             36.0,  54.0,  72.0, &
                                             72.0,  54.0,  90.0, &
                                             72.0,  90.0, 108.0, &
                                            108.0,  90.0, 126.0, &
                                            108.0, 126.0, 144.0, &
                                            144.0, 126.0, 162.0, &
                                            144.0, 162.0, 180.0, &
                                            180.0, 162.0, 198.0, &
                                            180.0, 198.0, 216.0, &
                                            216.0, 198.0, 234.0, &
                                            216.0, 234.0, 252.0, &
                                            252.0, 234.0, 270.0, &
                                            252.0, 270.0, 288.0, &
                                            288.0, 270.0, 306.0, &
                                            288.0, 306.0, 324.0, &
                                            324.0, 306.0, 342.0, &
                                            342.0,   0.0,  18.0, &
                                             18.0,   0.0,  36.0, &
                                             18.0,  36.0,  54.0, &
                                             54.0,  36.0,  72.0, &
                                             54.0,  72.0,  90.0, &
                                             90.0,  72.0, 108.0, &
                                             90.0, 108.0, 126.0, &
                                            126.0, 108.0, 144.0, &
                                            126.0, 144.0, 162.0, &
                                            162.0, 144.0, 180.0, &
                                            162.0, 180.0, 198.0, &
                                            198.0, 180.0, 216.0, &
                                            198.0, 216.0, 234.0, &
                                            234.0, 216.0, 252.0, &
                                            234.0, 252.0, 270.0, &
                                            270.0, 252.0, 288.0, &
                                            270.0, 288.0, 306.0, &
                                            306.0, 288.0, 324.0, &
                                            306.0, 324.0, 342.0, &
                                            342.0, 324.0,   0.0, &
                                              0.0,   0.0,  36.0, &
                                             36.0,   0.0,  72.0, &
                                             36.0,  72.0,  72.0, &
                                             72.0,  72.0, 108.0, &
                                            108.0,  72.0, 144.0, &
                                            108.0, 144.0, 144.0, &
                                            144.0, 144.0, 180.0, &
                                            180.0, 144.0, 216.0, &
                                            180.0, 216.0, 216.0, &
                                            216.0, 216.0, 252.0, &
                                            252.0, 216.0, 288.0, &
                                            252.0, 288.0, 288.0, &
                                            288.0, 288.0, 324.0, &
                                            324.0, 288.0,   0.0, &
                                            324.0,   0.0,   0.0, &
                                              0.0,   0.0,  72.0, &
                                             72.0,   0.0, 144.0, &
                                            144.0,   0.0, 216.0, &
                                            216.0,   0.0, 288.0, &
                                            288.0,   0.0,   0.0 /), (/3,80/)))
    pixel_center_lats = (/ 82.5, 67.5, 52.5, 37.5, 22.5, 7.5, &
                           -7.5,-22.5,-37.5,-52.5,-67.5,-82.5 /)
    pixel_center_lons = (/ 4.5, 13.5, 22.5, 31.5, 40.5, 49.5, 58.5, 67.5, 76.5, 85.5, &
                          94.5,103.5,112.5,121.5,130.5,139.5,148.5,157.5,166.5,175.5, &
                         184.5,193.5,202.5,211.5,220.5,229.5,238.5,247.5,256.5,265.5, &
                         274.5,283.5,292.5,301.5,310.5,319.5,328.5,337.5,346.5,355.5 /)
    do i = 1,size(pixel_center_lons)
        select type (pixel_center_lats_ptr_2d)
        type is (real(kind=double_precision))
            pixel_center_lats_ptr_2d(:,i) = pixel_center_lats(:)
        end select
    end do
    do i = 1,size(pixel_center_lats)
        select type (pixel_center_lons_ptr_2d)
        type is (real(kind=double_precision))
            pixel_center_lons_ptr_2d(i,:) = pixel_center_lons(:)
        end select
    end do
    pixel_center_lats_field => latlon_field_section(pixel_center_lats_ptr_2d,fine_grid_shape)
    pixel_center_lons_field => latlon_field_section(pixel_center_lons_ptr_2d,fine_grid_shape)
    coarse_grid => icon_icosohedral_grid(cell_neighbors)
    call coarse_grid%calculate_secondary_neighbors()
    secondary_neighbors => coarse_grid%get_cell_secondary_neighbors()
    allocate(unstructured_grid_vertex_coords::cell_vertex_coords_data(size(cell_vertices_lats,1)))
    select type (cell_vertex_coords_data)
    type is (unstructured_grid_vertex_coords)
      do i = 1,size(cell_vertices_lats,1)
        cell_vertex_coords_data(i) = &
            unstructured_grid_vertex_coords(cell_vertices_lats(i,:),cell_vertices_lons(i,:))
      end do
    end select
    allocate(coarse_grid_shape,source=generic_1d_section_coords(cell_neighbors,&
                                                                secondary_neighbors))
    cell_vertex_coords => icon_single_index_field_section(cell_vertex_coords_data,coarse_grid_shape)
    ncg_mapper = &
        icon_icosohedral_cell_latlon_pixel_ncg_mapper(pixel_center_lats_field,&
                                                      pixel_center_lons_field,&
                                                      cell_vertex_coords,&
                                                      fine_grid_shape)
    cell_numbers => ncg_mapper%generate_cell_numbers()
    select type(cell_numbers)
    class is (latlon_field_section)
        cell_numbers_data_ptr => cell_numbers%data
        select type (cell_numbers_data_ptr)
        type is (integer)
            cell_numbers_data => cell_numbers_data_ptr
        end select
    end select
    do i = 1,12
      write(debug,'(20(I3))') (cell_numbers_data(i,j),j=1,20)
      write(*,*) trim(debug)
    end do
    do i = 1,12
      write(debug2,'(13X,20(I3))') (cell_numbers_data(i,j),j=21,40)
      write(*,*) trim(debug2)
    end do
    call ncg_mapper%generate_limits()
    call ncg_mapper%icon_icosohedral_cell_latlon_pixel_ncg_mapper_destructor()
    call coarse_grid_shape%generic_1d_section_coords_destructor()
    deallocate(coarse_grid)
    deallocate(fine_grid_shape)
    deallocate(coarse_grid_shape)
    deallocate(cell_vertices_lats)
    deallocate(cell_vertices_lons)
    deallocate(pixel_center_lats)
    deallocate(pixel_center_lons)
    deallocate(pixel_center_lats_field)
    deallocate(pixel_center_lons_field)
    deallocate(pixel_center_lats_ptr_2d)
    deallocate(pixel_center_lons_ptr_2d)
    deallocate(cell_neighbors)
    deallocate(secondary_neighbors)
    deallocate(cell_vertex_coords_data)
    deallocate(cell_vertex_coords)
end subroutine testLatLonToIconGrids

end module map_non_coincident_grids_test_mod


C<8, 4, 7>(n, k, l) = A<8, 16, 23>(n, c, l*3+r*2) * W<4, 16, 3>(k, c, r);


subroutine tara2dMHDOMP(arg)

use omp_lib
use cfgio_mod, only: cfg_t, parse_cfg

implicit none

type(cfg_t):: cfg

real ( kind = 8 ), parameter :: pi=3.14159265358979323846d0

include "fftw3.f"

integer (kind=4) Np,Nx,Ny,Nh

integer ( kind = 4 ) i,j,t
real ( kind = 8 ) Lx,Ly,dx,dy,kx,ky,time,time_min,time_max,dt,G1,G2,G3
real ( kind = 8 ) spheat,rho0,ms,U0,mu,k,kf,A,sigma,uy0,M,CS,Re,P0,eta,mu_0,MA,VA,B0,ba
real ( kind = 8 ) Pressure,Energy,Energy0,y_Energy,y_Energy0,B_Field,C0,C1,C2,C3,div_B_tot

real (kind = 8), dimension (:), allocatable :: x,y
real (kind=8), dimension(:, :), allocatable :: rho,ux,uy,omega,j_B,rho_ux,rho_uy
real (kind=8), dimension(:, :), allocatable :: P,E,Bx,By,B2,div_B
real (kind=8), dimension(:, :), allocatable :: rho_dum,ux_dum,uy_dum,rho_ux_dum,rho_uy_dum
real (kind=8), dimension(:, :), allocatable :: P_dum,E_dum,Bx_dum,By_dum

complex (kind=8), dimension(:, :), allocatable :: rho_k,ux_k,uy_k,omega_k,j_k,rho_ux_k,rho_uy_k
complex (kind=8), dimension(:, :), allocatable :: P_k,E_k,Bx_k,By_k,div_B_k,Ek
complex (kind=8), dimension(:, :), allocatable :: rho_k_dum,ux_k_dum,uy_k_dum,omega_k_dum,j_k_dum
complex (kind=8), dimension(:, :), allocatable :: rho_ux_k_dum,rho_uy_k_dum,E_k_dum,Bx_k_dum,By_k_dum
complex (kind=8), dimension(:, :), allocatable :: rho_k_new,rho_ux_k_new,rho_uy_k_new,E_k_new,Bx_k_new,By_k_new

complex (kind=8), dimension(:, :), allocatable :: d_rho_k_dt_old,d_rho_ux_k_dt_old,d_rho_uy_k_dt_old
complex (kind=8), dimension(:, :), allocatable :: d_E_k_dt_old,d_Bx_k_dt_old,d_By_k_dt_old
complex (kind=8), dimension(:, :), allocatable :: d_rho_k_dt_new,d_rho_ux_k_dt_new,d_rho_uy_k_dt_new
complex (kind=8), dimension(:, :), allocatable :: d_E_k_dt_new,d_Bx_k_dt_new,d_By_k_dt_new

integer ( kind = 8 ) plan_forward,plan_backward ! FFTW

integer ( kind = 4 ) thread_num,num_thread,proc_num ! OMP
real ( kind = 8 ) t1,t2

common/comm/Lx,Ly,spheat,mu,ms,CS,mu_0,eta,dt,kf,A

integer,parameter :: seed = 99999999

character (len=90) :: filename
character (len=32) :: arg

cfg = parse_cfg(arg)

call cfg%get("grid","Nx",Nx)
call cfg%get("grid","Ny",Ny)

Nh = (Nx/2) + 1

call srand(seed)

allocate(x(Nx))
allocate(y(Ny))

allocate(rho(Nx,Ny))
allocate(ux(Nx,Ny))
allocate(uy(Nx,Ny))
allocate(omega(Nx,Ny))
allocate(j_B(Nx,Ny))
allocate(rho_ux(Nx,Ny))
allocate(rho_uy(Nx,Ny))
allocate(P(Nx,Ny))
allocate(E(Nx,Ny))
allocate(Bx(Nx,Ny))
allocate(By(Nx,Ny))
allocate(B2(Nx,Ny))
allocate(div_B(Nx,Ny))
allocate(rho_dum(Nx,Ny))
allocate(ux_dum(Nx,Ny))
allocate(uy_dum(Nx,Ny))
allocate(rho_ux_dum(Nx,Ny))
allocate(rho_uy_dum(Nx,Ny))
allocate(P_dum(Nx,Ny))
allocate(E_dum(Nx,Ny))
allocate(Bx_dum(Nx,Ny))
allocate(By_dum(Nx,Ny))

allocate(rho_k(Nh,Ny))
allocate(ux_k(Nh,Ny))
allocate(uy_k(Nh,Ny))
allocate(omega_k(Nh,Ny))
allocate(j_k(Nh,Ny))
allocate(rho_ux_k(Nh,Ny))
allocate(rho_uy_k(Nh,Ny))
allocate(P_k(Nh,Ny))
allocate(E_k(Nh,Ny))
allocate(Bx_k(Nh,Ny))
allocate(By_k(Nh,Ny))
allocate(div_B_k(Nh,Ny))
allocate(Ek(Nh,Ny))
allocate(rho_k_dum(Nh,Ny))
allocate(ux_k_dum(Nh,Ny))
allocate(uy_k_dum(Nh,Ny))
allocate(omega_k_dum(Nh,Ny))
allocate(j_k_dum(Nh,Ny))
allocate(rho_ux_k_dum(Nh,Ny))
allocate(rho_uy_k_dum(Nh,Ny))
allocate(E_k_dum(Nh,Ny))
allocate(Bx_k_dum(Nh,Ny))
allocate(By_k_dum(Nh,Ny))
allocate(rho_k_new(Nh,Ny))
allocate(rho_ux_k_new(Nh,Ny))
allocate(rho_uy_k_new(Nh,Ny))
allocate(E_k_new(Nh,Ny))
allocate(Bx_k_new(Nh,Ny))
allocate(By_k_new(Nh,Ny))
allocate(d_rho_k_dt_old(Nh,Ny))
allocate(d_rho_ux_k_dt_old(Nh,Ny))
allocate(d_rho_uy_k_dt_old(Nh,Ny))
allocate(d_E_k_dt_old(Nh,Ny))
allocate(d_Bx_k_dt_old(Nh,Ny))
allocate(d_By_k_dt_old(Nh,Ny))
allocate(d_rho_k_dt_new(Nh,Ny))
allocate(d_rho_ux_k_dt_new(Nh,Ny))
allocate(d_rho_uy_k_dt_new(Nh,Ny))
allocate(d_E_k_dt_new(Nh,Ny))
allocate(d_Bx_k_dt_new(Nh,Ny))
allocate(d_By_k_dt_new(Nh,Ny))

!===================== FILENAMES ==============================================

open(unit=5,file='output/System_information.dat',status='unknown')
open(unit=15,file='output/Initial_Grid_Data.dat',status='unknown')
!open(unit=20,file='INPUT.dat',status='old')  ! This input file is the file generated from Vorticity code.
!open(unit=25,file='Initial_Grid_Data_Reproduced.dat',status='unknown')
!open(unit=30,file='Initial_Energy_Spectra.dat',status='unknown')
!open(unit=35,file='Energy_Spectra.dat',status='unknown')
open(unit=40,file='output/Energy.dat',status='unknown')

!===================== USER INPUTS ============================================

! Define Number of Threads.
proc_num = omp_get_num_procs()
thread_num = 40
call omp_set_num_threads (thread_num)

write(5,*) "Number of Processors=", proc_num, "Number of Threads=", thread_num

! System Size.
call cfg%get("length","Lx",Lx)
call cfg%get("length","Ly",Ly)

Lx = Lx*pi; Ly = Ly*pi

! Grid Resolution.
dx = Lx/dfloat(Nx); dy = Ly/dfloat(Ny)

! Runtime Details and Time Step Width.
call cfg%get("time","time_min",time_min)
call cfg%get("time","time_max",time_max)
call cfg%get("time","dt",dt)

! Ratio of Specific Heats/ Adiabetic Index/ Heat Capacity Ratio/ Poisson Constant.
spheat = 5.0d0/3.0d0

! Co-efficient of Viscosity.
call cfg%get("resistivity","nu",mu)

! Co-efficient of Resistivity.
eta = 0.000100d0 !0.00010d0; 0.000030d0; 0.000010d0

! Magnetic Permiability.
mu_0 = 1.0d0

! Mass of the Fluid Element.
ms = 1.0d0

! Background Density.
rho0 = 1.0d0

! Initial Pressure.
P0 = 1.0d0

! Mach Number.
!M = 0.050d0
M = 0.010d0

! Alfven Mach Number.
MA = 1.0d0

! Maximum Velocity.
!U0 = 0.14732247502913884d0
!U0 = 0.6450d0

! Sound Speed.
 CS = 1.0d0/M!dsqrt(spheat*P0/rho0)
 U0 = M * CS

! Sound Speed.
! CS = U0/M

! Alfven Speed.
VA = U0/MA

! Initial Magnetic Field.
B0 = VA*dsqrt(mu_0*rho0)

write(5,*) "Sound Speed=", CS, "Initial Velocity=", U0
write(5,*) "Alfven Speed=", VA, "Initial Magnetic Field=", B0

! Forcing Scale.
kf = 1.0d0

! Mode Number of Perturbation.
!k = 2.0d0*pi

! Amplitude of Forcing
A = 1.0d0

! Magnetic Shear Width.
!ba = 0.010d0

! Perturbation Width.
!sigma = 4.0d0*a

! Perturbation Amplitude.
!uy0 = 0.00010d0

! Raynold's Number.
Re = ms*rho0*U0*Lx/mu; write(5,*) "Re =", Re

! Grid Generation.
do i = 1, Nx
  x(i)=0.0d0+real(i-1)*dx
  do j = 1, Ny
    y(j)=0.0d0+real(j-1)*dy
    ! Initial Density Distribution.
    rho(i,j) = rho0
    ! Initial Velocity Distribution.
    ux(i,j) = -dsin(kf*y(j))!U0 * (dtanh((y(j)-Ly/3.0d0)/a) - dtanh((y(j)-2.0d0*Ly/3.0d0)/a) - 1.0d0)
    !ux(i,j) = U0*tanh((y(j)-Ly/2.0d0)/a)
    uy(i,j) = dsin(kf*x(i))!0.0d0
    ! Initial Velocity Perturbation.
    !uy(i,j) = uy(i,j) + uy0*dsin(k*x(i))*dexp(-((y(j)-Ly/3.0d0)**2)/(sigma**2))
    !uy(i,j) = uy(i,j) + uy0*dsin(k*x(i))*dexp(-((y(j)-2.0d0*Ly/3.0d0)**2)/(sigma**2))
    !uy(i,j) = uy(i,j) + uy0*dsin(k*x(i))*exp(-((y(j)-Ly/2.0d0)**2)/(sigma**2))
    ! Initial Velocity Distribution.
    !read(20,*) G1,G2,G3,ux(i,j),uy(i,j)  ! You may define your own function here.
    ! Initial Pressure Distribution.
    P(i,j) = CS*CS*rho(i,j)!P0 !* (1.0d0 + 0.10d0 * (dtanh((y(j)-Ly/3.0d0)/ba) - dtanh((y(j)-2.0d0*Ly/3.0d0)/ba) - 1.0d0) )
    ! Initial Magnetic Field Profile.
    Bx(i,j) = B0!-dsin(y(j))!B0 * (dtanh((y(j)-Ly/3.0d0)/ba) - dtanh((y(j)-2.0d0*Ly/3.0d0)/ba) - 1.0d0)
    By(i,j) = B0!dsin(2.0d0*x(i))!0.0d0
    ! Initial Energy Distribution.
    E(i,j) = P(i,j)/(spheat -1.0d0) + 0.50d0*rho(i,j) * (ux(i,j)**2 + uy(i,j)**2) + 0.50d0*(Bx(i,j)**2 + By(i,j)**2)
    ! Initial Combined Variables.
    rho_ux(i,j) = rho(i,j) * ux(i,j)
    rho_uy(i,j) = rho(i,j) * uy(i,j)
    ! Keep Backup of the Arrays for FFTW.
    rho_dum(i,j) = rho(i,j)
    ux_dum(i,j) = ux(i,j)
    uy_dum(i,j) = uy(i,j)
    rho_ux_dum(i,j) = rho_ux(i,j)
    rho_uy_dum(i,j) = rho_uy(i,j)
    P_dum(i,j) = P(i,j)
    E_dum(i,j) = E(i,j)
    Bx_dum(i,j) = Bx(i,j)
    By_dum(i,j) = By(i,j)
    ! Write Initial Density and Velocity Distribution in File.
    write(15,*) x(i),y(j),rho(i,j),ux(i,j),uy(i,j),P(i,j),E(i,j),Bx(i,j),By(i,j)
  end do
end do

 close(15)

!===================== INITIAL TIME DATA ===============================================

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, rho_dum, rho_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, ux_dum, ux_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, uy_dum, uy_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, rho_ux_dum, rho_ux_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, rho_uy_dum, rho_uy_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, P_dum, P_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, E_dum, E_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, Bx_dum, Bx_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, By_dum, By_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

! Evaluate Initial Vorticity Spectra.
do i = 1, Nx/2+1
  do j = 1, Ny/2
  kx = 2.0d0*pi*dfloat(i-1)/Lx
  ky = 2.0d0*pi*dfloat(j-1)/Ly
  omega_k(i,j) = (0.0d0,1.0d0)*kx*uy_k(i,j) - (0.0d0,1.0d0)*ky*ux_k(i,j)
  omega_k_dum(i,j) = omega_k(i,j)
  enddo
  do j = Ny/2+1,Ny
  kx = 2.0d0*pi*dfloat(i-1)/Lx
  ky = 2.0d0*pi*dfloat((j-1)-Ny)/Ly
  omega_k(i,j) = (0.0d0,1.0d0)*kx*uy_k(i,j) - (0.0d0,1.0d0)*ky*ux_k(i,j)
  omega_k_dum(i,j) = omega_k(i,j)
  enddo
enddo

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, omega_k_dum, omega, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_destroy_plan_ (plan_forward)
  call dfftw_destroy_plan_ (plan_backward)

! Evaluate Initial Energy Spectra.
!do i = 1, Nx/2+1
  !do j = 1, Ny
  !write(30,*) i-1,j-1,abs(nk(i,j)),abs(ukx(i,j)),abs(uky(i,j))
  !end do
!end do

!Energy0 = 0.0d0; y_Energy0 = 0.0d0

do i = 1, Nx
  do j = 1, Ny
  ! FFTW Normalisation.
   omega(i,j) = omega(i,j)/(dfloat(Nx)*dfloat(Ny))
  ! Evaluate Initial Kinetic Energy.
  !Energy0 = Energy0 + (ux(i,j)**2 + uy(i,j)**2)
  !y_Energy0 = y_Energy0 + (uy(i,j)**2)
  ! Store Grid Data Reproduced from FFTW.
  !write(25,*) x(i),y(j),omega(i,j),n(i,j),ux(i,j),uy(i,j)
  end do
end do

! Write the Initial Energy in File.
!write(40,*) 0.0d0, Energy0,y_Energy0

!======================= MAIN PROGRAM =====================================================
t1 = omp_get_wtime()

! Time Loop Starts.
do time = time_min,time_max,dt

t = nint(time/dt) - dint(time_min/dt)

! Online Check of the Progress.
!if (mod(t,int(1.0/dt)) == 0) then
!print*, t/int(1.0/dt)
!endif

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

! Non-Linear Term Evaluator.
  call derive2com (Nx,Ny,Nh,pi,time,rho_k,rho_ux_k,rho_uy_k,E_k,Bx_k,By_k, &
                   d_rho_k_dt_old,d_rho_k_dt_new,d_rho_ux_k_dt_old,d_rho_ux_k_dt_new,d_rho_uy_k_dt_old,d_rho_uy_k_dt_new, &
                   d_E_k_dt_old,d_E_k_dt_new,d_Bx_k_dt_old,d_Bx_k_dt_new,d_By_k_dt_old,d_By_k_dt_new)

! Time Solvers.
! Adams-Bashforth
  call ab2com (Nx,Ny,Nh,pi,time,rho_k,rho_ux_k,rho_uy_k,E_k,Bx_k,By_k, &
               rho_k_new,rho_ux_k_new,rho_uy_k_new,E_k_new,Bx_k_new,By_k_new, &
               d_rho_k_dt_old,d_rho_k_dt_new,d_rho_ux_k_dt_old,d_rho_ux_k_dt_new,d_rho_uy_k_dt_old,d_rho_uy_k_dt_new, &
               d_E_k_dt_old,d_E_k_dt_new,d_Bx_k_dt_old,d_Bx_k_dt_new,d_By_k_dt_old,d_By_k_dt_new)

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

!$OMP PARALLEL SHARED(d_rho_k_dt_old,d_rho_ux_k_dt_old,d_rho_uy_k_dt_old),&
!$OMP & SHARED(d_E_k_dt_old,d_Bx_k_dt_old,d_By_k_dt_old),&
!$OMP & SHARED(d_rho_k_dt_new,d_rho_ux_k_dt_new,d_rho_uy_k_dt_new),&
!$OMP & SHARED(d_E_k_dt_new,d_Bx_k_dt_new,d_By_k_dt_new),&
!$OMP & SHARED(rho_k,rho_ux_k,rho_uy_k,E_k,Bx_k,By_k),&
!$OMP & SHARED(rho_k_new,rho_ux_k_new,rho_uy_k_new,E_k_new,Bx_k_new,By_k_new),&
!$OMP & SHARED(rho_k_dum,rho_ux_k_dum,rho_uy_k_dum,E_k_dum,Bx_k_dum,By_k_dum) PRIVATE(i,j)
!$OMP DO

do i = 1,Nx/2+1
  do j = 1,Ny
    ! Set the Variables in Proper Format for Next Time Iteration.
    d_rho_k_dt_old(i,j) = d_rho_k_dt_new(i,j)

    d_rho_ux_k_dt_old(i,j) = d_rho_ux_k_dt_new(i,j)
    d_rho_uy_k_dt_old(i,j) = d_rho_uy_k_dt_new(i,j)

    d_E_k_dt_old(i,j) = d_E_k_dt_new(i,j)

    d_Bx_k_dt_old(i,j) = d_Bx_k_dt_new(i,j)
    d_By_k_dt_old(i,j) = d_By_k_dt_new(i,j)

    rho_k(i,j) = rho_k_new(i,j)

    rho_ux_k(i,j) = rho_ux_k_new(i,j)
    rho_uy_k(i,j) = rho_uy_k_new(i,j)

    E_k(i,j) = E_k_new(i,j)

    Bx_k(i,j) = Bx_k_new(i,j)
    By_k(i,j) = By_k_new(i,j)

    ! Keep Backup of the Arrays for FFTW.
    rho_k_dum(i,j) = rho_k(i,j)

    rho_ux_k_dum(i,j) = rho_ux_k(i,j)
    rho_uy_k_dum(i,j) = rho_uy_k(i,j)

    E_k_dum(i,j) = E_k(i,j)

    Bx_k_dum(i,j) = Bx_k(i,j)
    By_k_dum(i,j) = By_k(i,j)
  enddo
enddo

!$OMP END DO
!$OMP END PARALLEL

! Evaluate Divergence of B in Spectral Space.

!$OMP PARALLEL SHARED(Lx,Ly,Bx_k,By_k,div_B_k) PRIVATE(i,j,kx,ky)
!$OMP DO

do i = 1,Nx/2+1
  do j = 1,Ny/2
  kx = 2.0d0*pi*dfloat(i-1)/Lx
  ky = 2.0d0*pi*dfloat(j-1)/Ly
  div_B_k(i,j) = (0.0d0,1.0d0)*kx*Bx_k(i,j) + (0.0d0,1.0d0)*ky*By_k(i,j)
  enddo
  do j = Ny/2+1,Ny
  kx = 2.0d0*pi*dfloat(i-1)/Lx
  ky = 2.0d0*pi*dfloat((j-1)-Ny)/Ly
  div_B_k(i,j) = (0.0d0,1.0d0)*kx*Bx_k(i,j) + (0.0d0,1.0d0)*ky*By_k(i,j)
  enddo
enddo

!$OMP END DO
!$OMP END PARALLEL

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, rho_k_dum, rho, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, rho_ux_k_dum, rho_ux, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, rho_uy_k_dum, rho_uy, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, E_k_dum, E, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, Bx_k_dum, Bx, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, By_k_dum, By, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, div_B_k, div_B, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

!$OMP PARALLEL SHARED(spheat,rho,rho_ux,rho_uy,E,Bx,By,div_B,ux,uy,ux_dum,uy_dum,P) PRIVATE(i,j)
!$OMP DO

do i = 1,Nx
  do j = 1,Ny
  ! FFTW Normalisation.
  rho(i,j) = rho(i,j)/(dfloat(Nx)*dfloat(Ny))

  rho_ux(i,j) = rho_ux(i,j)/(dfloat(Nx)*dfloat(Ny))
  rho_uy(i,j) = rho_uy(i,j)/(dfloat(Nx)*dfloat(Ny))

  E(i,j) = E(i,j)/(dfloat(Nx)*dfloat(Ny))

  Bx(i,j) = Bx(i,j)/(dfloat(Nx)*dfloat(Ny))
  By(i,j) = By(i,j)/(dfloat(Nx)*dfloat(Ny))

  ! Evaluate Divergence of B.
  div_B(i,j) = div_B(i,j)/(dfloat(Nx)*dfloat(Ny))

  ! Evaluate Velocity in Real Space.
  ux(i,j) = rho_ux(i,j)/rho(i,j)
  uy(i,j) = rho_uy(i,j)/rho(i,j)

  ! Evaluate Square of Magnetic Field.
  B2(i,j) = Bx(i,j)*Bx(i,j) + By(i,j)*By(i,j)

  ! Keep Backup of the Arrays for FFTW.
  ux_dum(i,j) = ux(i,j)
  uy_dum(i,j) = uy(i,j)

  ! Evaluate Pressure
  P(i,j) = CS*CS*rho(i,j)!( spheat - 1.0d0 ) * ( E(i,j) - 0.50d0 * ( rho_ux(i,j)*ux(i,j)+rho_uy(i,j)*uy(i,j) - B2(i,j) ) )
  enddo
enddo

!$OMP END DO
!$OMP END PARALLEL

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, ux_dum, ux_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, uy_dum, uy_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

! Evaluate Vorticity in Spectral Space.

!$OMP PARALLEL SHARED(Lx,Ly,ux_k,uy_k,omega_k,omega_k_dum,j_k,j_k_dum) PRIVATE(i,j,kx,ky)
!$OMP DO

do i = 1, Nx/2+1
  do j = 1, Ny/2
  kx = 2.0d0*pi*dfloat(i-1)/Lx
  ky = 2.0d0*pi*dfloat(j-1)/Ly
  omega_k(i,j) = (0.0d0,1.0d0)*kx*uy_k(i,j) - (0.0d0,1.0d0)*ky*ux_k(i,j)
  j_k(i,j) = (0.0d0,1.0d0)*kx*By_k(i,j) - (0.0d0,1.0d0)*ky*Bx_k(i,j)
  omega_k_dum(i,j) = omega_k(i,j)
  j_k_dum(i,j) = j_k(i,j)
  enddo
  do j = Ny/2+1,Ny
  kx = 2.0d0*pi*dfloat(i-1)/Lx
  ky = 2.0d0*pi*dfloat((j-1)-Ny)/Ly
  omega_k(i,j) = (0.0d0,1.0d0)*kx*uy_k(i,j) - (0.0d0,1.0d0)*ky*ux_k(i,j)
  j_k(i,j) = (0.0d0,1.0d0)*kx*By_k(i,j) - (0.0d0,1.0d0)*ky*Bx_k(i,j)
  omega_k_dum(i,j) = omega_k(i,j)
  j_k_dum(i,j) = j_k(i,j)
  enddo
enddo

!$OMP END DO
!$OMP END PARALLEL

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, omega_k_dum, omega, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, j_k_dum, j_B, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_destroy_plan_ (plan_forward)
  call dfftw_destroy_plan_ (plan_backward)

! FFTW Normalisation

!$OMP PARALLEL SHARED(omega,j_B) PRIVATE(i,j)
!$OMP DO

do i = 1,Nx
  do j = 1,Ny
  omega(i,j) = omega(i,j)/(dfloat(Nx)*dfloat(Ny))
  j_B(i,j) = j_B(i,j)/(dfloat(Nx)*dfloat(Ny))
  enddo
enddo

!$OMP END DO
!$OMP END PARALLEL

! Evaluate Energy Spectra at a Specified Time.
!if (t == 10000) then

!!! Try to avoid this OMP loop since it alters the sequence of i and j in Outout file. !!!
! !!$OMP PARALLEL SHARED(ukx,uky) PRIVATE(i,j)
! !!$OMP DO REDUCTION (+:Ek)

  !do i = 1,Nx/2+1
  !  do j = 1,Ny
  !  Ek(i,j) = Ek(i,j) + sqrt(abs(ukx(i,j))**2 + abs(uky(i,j))**2)
  !  write(35,*) i,j,sqrt(float((i-1)**2)+float((j-1)**2)),abs(Ek(i,j))
  !  enddo
  !enddo

! !!$OMP END PARALLEL

!endif

Pressure = 0.0d0; Energy = 0.0d0; y_Energy = 0.0d0; B_Field = 0.0d0
 C0 = 0.0d0; C1 = 0.0d0; C2 = 0.0d0; C3 = 0.0d0; div_B_Tot = 0.0d0

! Try to avoid this OMP loop since it alters the sequence of i and j in Outout file.
! !$OMP PARALLEL SHARED(t,dt,x,y,omega,j,n,ux,uy) PRIVATE(i,j)
! !$OMP DO REDUCTION (+:Energy,y_Energy)

do i = 1,Nx
  do j = 1,Ny
  ! Evaluate Pressure
  !Pressure = Pressure + P(i,j)/(dfloat(Nx)*dfloat(Ny))
  ! Evaluate Energy
  Energy = Energy + (ux(i,j)**2+uy(i,j)**2)/(dfloat(Nx)*dfloat(Ny))!rho(i,j)*(ux(i,j)**2 + uy(i,j)**2)
  ! Evaluate Growth Rate.
  !y_Energy = y_Energy + rho(i,j)*(uy(i,j)**2)/(2.0d0*dfloat(Nx)*dfloat(Ny))
  ! Evaluate Magnetic Field.
  B_Field = B_Field + (Bx(i,j)**2+By(i,j)**2)/(dfloat(Nx)*dfloat(Ny))
  ! Evaluate Casimirs.
  !C0 = C0 + omega(i,j)**0.0d0/(dfloat(Nx)*dfloat(Ny))
  !C1 = C1 + omega(i,j)**1.0d0/(dfloat(Nx)*dfloat(Ny))
  C2 = C2 + (omega(i,j)**2.0d0)/(dfloat(Nx)*dfloat(Ny))
  C3 = C3 + (j_B(i,j)**2.0d0)/(dfloat(Nx)*dfloat(Ny))
  ! Check for Div B = 0
  div_B_Tot = div_B_Tot + div_B(i,j)/(dfloat(Nx)*dfloat(Ny))
    ! Write Grid Data in State Files.
    if (mod(float(t),100000.0) == 0.0) then
      write(filename, '("output/fort.",I8.8)') t+100000
      open(unit=t+100000,file=filename,status='unknown')
      write(t+100000,*) x(i),y(j),rho(i,j),ux(i,j),uy(i,j),P(i,j),E(i,j),Bx(i,j),By(i,j)
    endif
  enddo
enddo

! !$OMP END PARALLEL

if (mod(float(t),100.0) == 0.0) then
write(40,*) time,Energy,B_Field,C2,C3,div_B_Tot
endif
  call flush (40)

if (mod(float(t),100000.0) == 0.0) then
  close(t+100000)
endif
enddo ! time

t2 = omp_get_wtime()

write(5,*) "Time taken for the run = ",t2 - t1

 close(5)
 close(40)

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

end subroutine tara2dMHDOMP


      function rcirc(am)

      include 'commonblocks'

      real om

      dimension rtab(nmax),amtab(nmax),rtab2(nmax)
     +     ,rtab2zero(nmax)
      data ifirst /0/

      save ifirst,rtab,amtab,rtab2,rtab2zero

c make a spline fit to [Rcirc/sqrt(Lcirc)] vs. Lcirc.
c this is ~ constant at the origin, and goes like Lcirc**1.5
c at large radii (where the potential is Kepler).

      if (ifirst.eq.0) then

         do i=1,nr
            r=(i-1)*dr
            call omekap(r,om,t)
            amtab(i)=om*r*r
            rtab(i)=1./sqrt(om)
         enddo
         slopeinf=1.5*rtab(nrdisk)/amtab(nr)
         call splined(amtab,rtab,nr,1.e32,slopeinf,rtab2)
         do i=1,nr
            rtab2zero(i) = 0.
         enddo
         ifirst=1
      endif
      aam=abs(am)
      if (aam.gt.amtab(nr)) then
         rcirc=rtab(nr)*(aam/amtab(nr))**2
      else
         call splintd(amtab,rtab,rtab2zero,nr,aam,rc)
         rcirc=rc*sqrt(aam)
         if(rc.lt.0.) then
            write(0,*) rc
            stop
         endif
      endif

      return
      end


      SUBROUTINE PSVOIGT(DX,SIG,GAM,FUNC,DFDX,DFDS,DFDG)

!PURPOSE: Compute function & derivatives pseudovoigt
!pseudo Voigt P.Tompson, D.E. Cox & J.B. Hastings (1987). J. Appl. Cryst.,20,79-83

      INCLUDE       '../INCLDS/COPYRIGT.FOR'

!PSEUDOCODE:

!CALLING ARGUMENTS:

      REAL*4        DX                  !Delta-x from center
      REAL*4        SIG                 !Gaussian variance
      REAL*4        GAM                 !Lorentzian FWHM
      REAL*4        FUNC                !Value of pseudo-Voigt at DX
      REAL*4        DFDX                !dF/dx
      REAL*4        DFDS                !dF/ds
      REAL*4        DFDG                !dF/dg

!INCLUDE STATEMENTS:

!LOCAL VARIABLES:

      REAL*4        COFG(6),COFL(6)     !Linear combination coeffs
      REAL*4        ACOFG(7),ACOFL(7)
      REAL*4        GNORM               !Gaussian Normalization constant
      REAL*4        COFT(6),COFN(3)

!SUBROUTINES CALLED:

!FUNCTION DEFINITIONS:

!DATA STATEMENTS:

      DATA STOFW/2.35482005/            !2*SQRT(2LN2)
      DATA SQ2PI/2.506628275/            !SQRT(2PI)
      DATA COFT/1.0,2.69269,2.42843,4.47163,0.07842,1.0/
      DATA COFN/1.36603,-0.47719,0.11116/

!CODE:

      SQSG = MAX(SQRT(SIG),0.001)
      FWHG = STOFW*SQSG
      PGL = FWHG**5
      SUMHM = PGL
      DSDL = 0.0
      DSDG = 0.0
      DO ITRM=1,5
        PGL = PGL/FWHG
        DSDL = DSDL+FLOAT(ITRM)*COFT(ITRM+1)*PGL
        DSDG = DSDG+FLOAT(6-ITRM)*COFT(ITRM)*PGL
        PGL = PGL*GAM
        SUMHM = SUMHM+COFT(ITRM+1)*PGL
      END DO
      FWHM = EXP(0.2*LOG(SUMHM))
      FRAC = GAM/FWHM
      DEDF = 0.0
      PF = 1.0
      ETA = 0.0
      DO ITRM=1,3
        DEDF = DEDF+FLOAT(ITRM)*COFN(ITRM)*PF
        PF = PF*FRAC
        ETA = ETA+COFN(ITRM)*PF
      END DO
      CALL LORENTZ(DX,FWHM,TL,DTLDT,DTLDFW)
      SIGP = (FWHM/STOFW)**2
      EX = MAX(-20.0,-0.5*DX**2/SIGP)
      TG = STOFW*EXP(EX)/(SQ2PI*FWHM)
      FUNC = ETA*TL+(1.0-ETA)*TG

      TS = -2.0*(1.0-ETA)*TG*(EX+0.5)/FWHM
      DFDX = ETA*DTLDT-(1.0-ETA)*TG*DX/SIGP

      DFWDG = 0.2*DSDG*FWHM/SUMHM
      DFRDG = -FRAC*DFWDG/FWHM
      DFDS = DEDF*DFRDG*(TL-TG)+(ETA*DTLDFW+TS)*DFWDG
      DFDS = 0.5*DFDS*STOFW/SQSG

      DFWDL = 0.2*DSDL*FWHM/SUMHM
      DFRDL = (1.0-FRAC*DFWDL)/FWHM
      DFDG = DEDF*DFRDL*(TL-TG)+(ETA*DTLDFW+TS)*DFWDL

      RETURN
      END

      SUBROUTINE PSVOIGT2(DX,SIG,GAM,FUNC,DFDX,DFDS,DFDG)

!PURPOSE: Compute function & derivatives pseudovoigt - unfinished;
!   no derivatives
!pseudo Voigt W.I.F. David, J. Appl. Cryst. 19, 63-64 (1986)

      INCLUDE       '../INCLDS/COPYRIGT.FOR'

!PSEUDOCODE:

!CALLING ARGUMENTS:

      REAL*4        DX                  !Delta-x from center
      REAL*4        SIG                 !Gaussian variance
      REAL*4        GAM                 !Lorentzian FWHM
      REAL*4        FUNC                !Value of pseudo-Voigt at DX
      REAL*4        DFDX                !dF/dx
      REAL*4        DFDS                !dF/ds
      REAL*4        DFDG                !dF/dg

!INCLUDE STATEMENTS:

!LOCAL VARIABLES:

      REAL*4        GNORM               !Gaussian Normalization constant
      REAL*4        COFEG(7),COFEL(7),COFGG(6),COFGL(6)

!SUBROUTINES CALLED:

!FUNCTION DEFINITIONS:

!DATA STATEMENTS:

      DATA STOFW/2.35482005/            !2*SQRT(2LN2)
      DATA SQ2PI/2.506628275/            !SQRT(2PI)
      DATA ITYPE/1/
      DATA COFEG/0.00268,0.75458,2.88898,-3.85144,-.55765,3.03824,
     1  -1.27539/
      DATA COFEL/1.35248,0.41168,-2.18731,6.42452,-10.29036,6.88093,
     1  -1.59194/
      DATA COFGG/-.50734,-.22744,1.63804,-2.28532,1.31943,0.0/
      DATA COFGL/-.99725,1.14594,2.56150,-6.52088,5.82647,-1.91086/

!CODE:

      SQSG = MAX(SQRT(SIG),0.001)
      FWHG = STOFW*SQSG
      FW = FWHG+GAM
      R1 = FWHG/FW
      R17 = R1
      R2 = GAM/FWHG
      R27 = R2
      DSDL = 0.0
      DSDG = 0.0
      ETAG = 0.0
      ETAL = 0.0
      DO ITRM=1,7
        ETAG = ETAG+R17*COFEG(ITRM)
        ETAL = ETAL+R27*COFEL(ITRM)
        R17 = R17*R1
        R27 = R27*R2
      END DO
      WG = 1.0
      WL = 1.0
      R16 = R1
      R26 = R2
      DO ITRM=1,6
        WG = WG+R26*COFGG(ITRM)
        WL = WL+R16*COFGL(ITRM)
        R16 = R16*R1
        R26 = R26*R2
      END DO
      CALL LORENTZ(DX,WL,TL,DTLDT,DTLDFW)
      SIGP = (WG/STOFW)**2
      EX = MAX(-20.0,-0.5*DX**2/SIGP)
      TG = STOFW*EXP(EX)/(SQ2PI*FWHM)
      FUNC = ETAL*TL+ETAG*TG

! Unfinished - no derivatives

      RETURN
      END


      subroutine runY_i1i2i3i4(i,j,i1,i2,i3,i4,f,Xtwiddle,Gtt,Gtwiddle,
     . Shat5,Czero4,N0)
      implicit none
C---  Expression for Eq. 5.61
      include 'TRconstants.f'
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,i,j,i1,i2,i3,i4,n,m,np
      parameter(np=3)
      double precision
     . Xtwiddle(0:np,0:np),Gtwiddle(np,np),f(np),Gtt(np,np,np,np)
      double complex Shat5(np,z4max,-2:0),Czero4(z4max,-2:0),
     . bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gtt(i,n,j,m)*f(n)
     . *(Shat5(m,z4(i1,i2,i3,i4),ep)
     . -2d0*delta(m,i1)*Dv(dzziii(z3(i2,i3,i4))+N0,ep)
     . -2d0*delta(m,i2)*Dv(dzziii(z3(i1,i3,i4))+N0,ep)
     . -2d0*delta(m,i3)*Dv(dzziii(z3(i1,i2,i4))+N0,ep)
     . -2d0*delta(m,i4)*Dv(dzziii(z3(i1,i2,i3))+N0,ep))
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=-4d0*Dv(dzziiii(z4(i1,i2,i3,i4))+N0,ep-1)
      Dv(diiii(z4(i1,i2,i3,i4))+N0,ep)=
     .  (Gtwiddle(i,j)
     . *(10d0*Dv(dzziiii(z4(i1,i2,i3,i4))+N0,ep)
     .  +pole-Czero4(z4(i1,i2,i3,i4),ep))
     .  +bit+Xtwiddle(0,j)*Dv(diiiii(z5(i,i1,i2,i3,i4))+N0,ep)
     .   )/Xtwiddle(i,j)

      enddo
      return
      end


! Copyright (C) 2017-2019 Matthieu Ancellin
! See LICENSE file at <https://github.com/mancellin/libDelhommeau>
MODULE GREEN_RANKINE

  USE CONSTANTS

  IMPLICIT NONE

  ! The index of the following node when going around a face.
  INTEGER, PRIVATE, DIMENSION(4), PARAMETER :: NEXT_NODE = (/ 2, 3, 4, 1 /)

CONTAINS

  SUBROUTINE COMPUTE_INTEGRAL_OF_RANKINE_SOURCE                     &
      (M,                                                           &
      Face_nodes, Face_center, Face_normal, Face_area, Face_radius, &
      S0, VS0)
    ! Estimate the integral S0 = ∫∫ 1/MM' dS(M') over a face
    ! and its derivative VS0 with respect to M.

    ! Based on formulas A6.1 and A6.3 (p. 381 to 383)
    ! in G. Delhommeau thesis (referenced below as [Del]).

    ! Inputs
    REAL(KIND=PRE), DIMENSION(3),    INTENT(IN) :: M
    REAL(KIND=PRE), DIMENSION(4, 3), INTENT(IN) :: Face_nodes
    REAL(KIND=PRE), DIMENSION(3),    INTENT(IN) :: Face_center, Face_normal
    REAL(KIND=PRE),                  INTENT(IN) :: Face_area, Face_radius

    ! Outputs
    REAL(KIND=PRE),               INTENT(OUT) :: S0
    REAL(KIND=PRE), DIMENSION(3), INTENT(OUT) :: VS0

    ! Local variables
    INTEGER                         :: L
    REAL(KIND=PRE)                  :: RO, GZ, DK, GY
    REAL(KIND=PRE), DIMENSION(4)    :: RR
    REAL(KIND=PRE), DIMENSION(3, 4) :: DRX
    REAL(KIND=PRE)                  :: ANT, DNT, ANL, DNL, ALDEN, AT
    REAL(KIND=PRE), DIMENSION(3)    :: PJ, GYX, ANTX, ANLX, DNTX

    RO = NORM2(M(1:3) - Face_center(1:3)) ! Distance from center of mass of the face to M.

    IF (RO > 7*Face_radius) THEN
      ! Asymptotic value if face far away from M
      S0       = Face_area/RO
      VS0(1:3) = (Face_center(1:3) - M)*S0/RO**2

    ELSE

      GZ = DOT_PRODUCT(M(1:3) - Face_center(1:3), Face_normal(1:3)) ! Called Z in [Del]

      DO L = 1, 4
        RR(L) = NORM2(M(1:3) - Face_nodes(L, 1:3))       ! Distance from vertices of Face to M.
        DRX(:, L) = (M(1:3) - Face_nodes(L, 1:3))/RR(L)  ! Normed vector from vertices of Face to M.
      END DO

      S0 = ZERO
      VS0(:) = ZERO

      DO L = 1, 4
        DK = NORM2(Face_nodes(NEXT_NODE(L), :) - Face_nodes(L, :))    ! Distance between two consecutive points, called d_k in [Del]
        IF (DK >= REAL(1e-3, PRE)*Face_radius) THEN
          PJ(:) = (Face_nodes(NEXT_NODE(L), :) - Face_nodes(L, :))/DK ! Normed vector from one corner to the next
          ! The following GYX(1:3) are called (a,b,c) in [Del]
          GYX(1) = Face_normal(2)*PJ(3) - Face_normal(3)*PJ(2)
          GYX(2) = Face_normal(3)*PJ(1) - Face_normal(1)*PJ(3)
          GYX(3) = Face_normal(1)*PJ(2) - Face_normal(2)*PJ(1)
          GY = DOT_PRODUCT(M - Face_nodes(L, :), GYX)                                    ! Called Y_k in  [Del]

          ANT = 2*GY*DK                                                                  ! Called N^t_k in [Del]
          DNT = (RR(NEXT_NODE(L))+RR(L))**2 - DK*DK + 2*ABS(GZ)*(RR(NEXT_NODE(L))+RR(L)) ! Called D^t_k in [Del]
          ANL = RR(NEXT_NODE(L)) + RR(L) + DK                                            ! Called N^l_k in [Del]
          DNL = RR(NEXT_NODE(L)) + RR(L) - DK                                            ! Called D^l_k in [Del]
          ALDEN = LOG(ANL/DNL)

          IF (ABS(GZ) >= REAL(1e-4, PRE)*Face_radius) THEN
            AT = ATAN(ANT/DNT)
          ELSE
            AT = 0.
          ENDIF

          ANLX(:) = DRX(:, NEXT_NODE(L)) + DRX(:, L)                    ! Called N^l_k_{x,y,z} in [Del]

          ANTX(:) = 2*DK*GYX(:)                                         ! Called N^t_k_{x,y,z} in [Del]
          DNTX(:) = 2*(RR(NEXT_NODE(L)) + RR(L) + ABS(GZ))*ANLX(:) &
            + 2*SIGN(ONE, GZ)*(RR(NEXT_NODE(L)) + RR(L))*Face_normal(:) ! Called D^t_k_{x,y,z} in [Del]

          IF (ABS(GY) < 1e-5) THEN
            ! Edge case where the singularity is on the boundary of the face (GY = 0, ALDEN = infty).
            ! This case seems to only occur when computating the free surface elevation,
            ! so no fix has been implemented for VS0, which is not needed then.
            S0 = S0 - 2*AT*ABS(GZ)
          ELSE
            ! General case
            S0 = S0 + GY*ALDEN - 2*AT*ABS(GZ)
          END IF

          VS0(:) = VS0(:) + ALDEN*GYX(:)     &
            - 2*SIGN(ONE, GZ)*AT*Face_normal(:)   &
            + GY*(DNL-ANL)/(ANL*DNL)*ANLX(:) &
            - 2*ABS(GZ)*(ANTX(:)*DNT - DNTX(:)*ANT)/(ANT*ANT+DNT*DNT)
        END IF
      END DO
    END IF

  END SUBROUTINE COMPUTE_INTEGRAL_OF_RANKINE_SOURCE

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

  SUBROUTINE COMPUTE_ASYMPTOTIC_RANKINE_SOURCE &
      (M,                                      &
      Face_center, Face_area,                  &
      S0, VS0)
    ! Same as above, but always use the approximate aymptotic value.

    ! Inputs
    REAL(KIND=PRE), DIMENSION(3), INTENT(IN) :: M
    REAL(KIND=PRE), DIMENSION(3), INTENT(IN) :: Face_center
    REAL(KIND=PRE),               INTENT(IN) :: Face_area

    ! Outputs
    REAL(KIND=PRE),               INTENT(OUT) :: S0
    REAL(KIND=PRE), DIMENSION(3), INTENT(OUT) :: VS0

    ! Local variables
    REAL(KIND=PRE) :: RO

    RO = NORM2(M(1:3) - Face_center(1:3)) ! Distance from center of mass of the face to M.

    IF (RO > REAL(1e-7, KIND=PRE)) THEN
      ! Asymptotic value if face far away from M
      S0       = Face_area/RO
      VS0(1:3) = (Face_center(1:3) - M)*S0/RO**2
    ELSE
      ! Singularity...
      S0 = ZERO
      VS0(1:3) = ZERO
    END IF

  END SUBROUTINE COMPUTE_ASYMPTOTIC_RANKINE_SOURCE

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

END MODULE GREEN_RANKINE