!==============================================================================!
  subroutine Calculate_Geometry(grid)
!------------------------------------------------------------------------------!
!   Calculates geometrical quantities of the grid.                             !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Const_Mod, only: HUGE, PI, ONE_THIRD
  use Math_Mod
  use File_Mod
  use Grid_Mod,  only: Grid_Type,                        &
                       Grid_Mod_Estimate_Big_And_Small,  &
                       Grid_Mod_Print_Bnd_Cond_List,     &
                       Grid_Mod_Sort_Faces_By_Index
  use Sort_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
!-----------------------------------[Locals]-----------------------------------!
  integer              :: c, c1, c2, n, s, ss, cc2, c_max, nnn, hh, mm, b, SC
  integer              :: c11, c12, c21, c22, s1, s2, bou_cen, cnt_bnd, cnt_per
  integer              :: color_per, n_per, number_faces, option
  integer              :: rot_dir
  real                 :: xt(4), yt(4), zt(4), angle_face, tol
  real                 :: xs2, ys2, zs2, x_a, y_a, z_a, x_b, y_b, z_b
  real                 :: x_c, y_c, z_c, det
  real                 :: ab_i, ab_j, ab_k, ac_i, ac_j, ac_k, p_i, p_j, p_k
  real                 :: dsc1, dsc2, per_min, per_max
  real                 :: t, sur_tot, angle
  real                 :: xc1, yc1, zc1, xc2, yc2, zc2
  real                 :: max_dis
  real, allocatable    :: xspr(:), yspr(:), zspr(:)
  real, allocatable    :: b_coor(:), phi_face(:)
  integer, allocatable :: b_face(:), face_copy(:)
  character(len=80)    :: answer, dir
  real                 :: big, small
!==============================================================================!
!                                                                              !
!                                n3                                            !
!                 +---------------!---------------+                            !
!                /|              /|              /|                            !
!               / |             / |             / |                            !
!              /  |          n2/  |            /  |                            !
!             +---------------!---------------+   |                            !
!             |   |           |   |           |   |                            !
!             |   |     o---- | s-------o     |   |                            !
!             |   +---- c1 ---|   !---- c2 ---|   +                            !
!             |  /            |  /n4          |  /                             !
!             | /             | /             | /                              !
!             |/              |/              |/                               !
!             +---------------!---------------+                                !
!                            n1                                                !
!                                                                              !
!   Notes:                                                                     !
!                                                                              !
!     ! face s is oriented from cell center c1 to cell center c2               !
!     ! c2 is greater then c1 inside the domain or smaller then 0              !
!       on the boundary                                                        !
!     ! nodes are denoted with n1 - n4                                         !
!                                                                              !
!            c3                                                                !
!             \  4-----3                                                       !
!              \/ \  . |                                                       !
!              /   \  +---c2                                                   !
!             /  .  \  |                                                       !
!            / .     \ |                                                       !
!           /.        \|                                                       !
!          1-----------2                                                       !
!                   |                                                          !
!                   c1                                                         !
!                                                                              !
!                                n3                                            !
!                 +---------------!-------+                                    !
!                /|            n2/|      /|                                    !
!               / |             !-------+ |                                    !
!              /  |            /|s|  c2 | |                                    !
!             +---------------+ | !-----| +                                    !
!             |   |           | |/n4    |/                                     !
!             |   |     c1    | !-------+                                      !
!             |   +-----------|n1 +                                            !
!             |  /            |  /                                             !
!             | /             | /                                              !
!             |/              |/                                               !
!             +---------------+                                                !
!                            n1                                                !
!                                                                              !
!------------------------------------------------------------------------------!
!   Generaly:                                                                  !
!                                                                              !
!   the equation of plane reads: A * x + B * y + C * z + D = 0                 !
!                                                                              !
!   and the equation of line:  x = x0 + t*rx                                   !
!                              y = y0 + t*ry                                   !
!                              z = z0 + t*rz                                   !
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -       !
!   In our case:                                                               !
!                                                                              !
!     line is a connection between the two cell centers:                       !
!                                                                              !
!     x = xc(c1) + t*(xc(c2)-xc(c1)) = xc(c1) + t*rx                           !
!     y = yc(c1) + t*(yc(c2)-yc(c1)) = yc(c1) + t*ry                           !
!     z = zc(c1) + t*(zc(c2)-zc(c1)) = zc(c1) + t*rz                           !
!                                                                              !
!                                                                              !
!     plane is a cell face:                                                    !
!                                                                              !
!     sx * x + sy * y + Sz * z = sx * xsp(s) + sy * ysp(s) + sz * zsp(s)       !
!                                                                              !
!     and the intersection is at:                                              !
!                                                                              !
!         sx*(xsp(s)-xc(c1)) + sy*(ysp(s)-yc(c1) + sz*(zsp(s)-zc(c1))          !
!     t = -----------------------------------------------------------          !
!                           rx*sx + ry*sy + rz*sz                              !
!                                                                              !
!------------------------------------------------------------------------------!

  ! Estimate big and small
  call Grid_Mod_Estimate_Big_And_Small(grid, big, small)

  !-----------------------------------------!
  !   Calculate the cell centers            !
  !-----------------------------------------!
  !   => depends on: x_node,y_node,z_node   !
  !   <= gives:      xc,yc,zc c>0           !
  !-----------------------------------------!
  call Calculate_Cell_Centers(grid)

  !-----------------------------------------------------!
  !   Calculate:                                        !
  !      components of cell faces, cell face centers.   !
  !-----------------------------------------------------!
  !   => depends on: x_node,y_node,z_node               !
  !   <= gives:      Sx,Sy,Sz,xsp,yzp,zsp               !
  !-----------------------------------------------------!
  do s = 1, grid % n_faces
    do n = 1, grid % faces_n_nodes(s)    ! for quadrilateral an triangular faces
      xt(n) = grid % xn(grid % faces_n(n,s))
      yt(n) = grid % yn(grid % faces_n(n,s))
      zt(n) = grid % zn(grid % faces_n(n,s))
    end do

    ! Cell face components
    if( grid % faces_n_nodes(s) .eq. 4 ) then
      grid % sx(s)= 0.5 * ( (yt(2)-yt(1))*(zt(2)+zt(1))   &
                           +(yt(3)-yt(2))*(zt(2)+zt(3))   &
                           +(yt(4)-yt(3))*(zt(3)+zt(4))   &
                           +(yt(1)-yt(4))*(zt(4)+zt(1)) )
      grid % sy(s)= 0.5 * ( (zt(2)-zt(1))*(xt(2)+xt(1))   &
                           +(zt(3)-zt(2))*(xt(2)+xt(3))   &
                           +(zt(4)-zt(3))*(xt(3)+xt(4))   &
                           +(zt(1)-zt(4))*(xt(4)+xt(1)) )
      grid % sz(s)= 0.5 * ( (xt(2)-xt(1))*(yt(2)+yt(1))   &
                           +(xt(3)-xt(2))*(yt(2)+yt(3))   &
                           +(xt(4)-xt(3))*(yt(3)+yt(4))   &
                           +(xt(1)-xt(4))*(yt(4)+yt(1)) )
    else if( grid % faces_n_nodes(s) .eq. 3 ) then
      grid % sx(s)= 0.5 * ( (yt(2)-yt(1))*(zt(2)+zt(1))   &
                           +(yt(3)-yt(2))*(zt(2)+zt(3))   &
                           +(yt(1)-yt(3))*(zt(3)+zt(1)) )
      grid % sy(s)= 0.5 * ( (zt(2)-zt(1))*(xt(2)+xt(1))   &
                           +(zt(3)-zt(2))*(xt(2)+xt(3))   &
                           +(zt(1)-zt(3))*(xt(3)+xt(1)) )
      grid % sz(s)= 0.5 * ( (xt(2)-xt(1))*(yt(2)+yt(1))   &
                           +(xt(3)-xt(2))*(yt(2)+yt(3))   &
                           +(xt(1)-xt(3))*(yt(3)+yt(1)) )
    else
      print *, 'calc4: something horrible has happened !'
      stop
    end if

    ! Barycenters
    if(grid % faces_n_nodes(s) .eq. 4) then
      grid % xf(s) = (xt(1)+xt(2)+xt(3)+xt(4))/4.0
      grid % yf(s) = (yt(1)+yt(2)+yt(3)+yt(4))/4.0
      grid % zf(s) = (zt(1)+zt(2)+zt(3)+zt(4))/4.0
    else if(grid % faces_n_nodes(s) .eq. 3) then
      grid % xf(s) = (xt(1)+xt(2)+xt(3))/3.0
      grid % yf(s) = (yt(1)+yt(2)+yt(3))/3.0
      grid % zf(s) = (zt(1)+zt(2)+zt(3))/3.0
    end if

  end do ! through faces

  print *, '# Cell face components calculated !'

  !--------------------------------------!
  !   Calculate boundary cell centers    !
  !--------------------------------------!
  !   => depends on: xc,yc,zc,Sx,Sy,Sz   !
  !   <= gives:      xc,yc,zc for c<0    !
  !--------------------------------------!
  print *, '#===================================='
  print *, '# Position the boundary cell centres:'
  print *, '#------------------------------------'
  print *, '# Type 1 for barycentric placement'
  print *, '# Type 2 for orthogonal placement'
  print *, '#------------------------------------'
  read(*,*) bou_cen

  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)

    sur_tot = sqrt(  grid % sx(s)*grid % sx(s)  &
                   + grid % sy(s)*grid % sy(s)  &
                   + grid % sz(s)*grid % sz(s) )

    if(c2  < 0) then
      t = (   grid % sx(s)*(grid % xf(s) - grid % xc(c1))        &
            + grid % sy(s)*(grid % yf(s) - grid % yc(c1))        &
            + grid % sz(s)*(grid % zf(s) - grid % zc(c1)) ) / sur_tot
      grid % xc(c2) = grid % xc(c1) + grid % sx(s)*t / sur_tot
      grid % yc(c2) = grid % yc(c1) + grid % sy(s)*t / sur_tot
      grid % zc(c2) = grid % zc(c1) + grid % sz(s)*t / sur_tot
      if(bou_cen .eq. 1) then
        grid % xc(c2) = grid % xf(s)
        grid % yc(c2) = grid % yf(s)
        grid % zc(c2) = grid % zf(s)
      end if
    end if
  end do ! through faces

  !---------------------------------------------------------------!
  !   Move the centers of co-planar molecules towards the walls   !
  !---------------------------------------------------------------!
  !   => depends on: xc,yc,zc                                     !
  !   <= gives:      xc,yc,zc                                     !
  !   +  uses:       Dx,Dy,Dz                                     !
  !---------------------------------------------------------------!
  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)

    if(c2 > 0) then
      grid % dx(c1) = max( grid % dx(c1), abs( grid % xc(c2) - grid % xc(c1) ) )
      grid % dy(c1) = max( grid % dy(c1), abs( grid % yc(c2) - grid % yc(c1) ) )
      grid % dz(c1) = max( grid % dz(c1), abs( grid % zc(c2) - grid % zc(c1) ) )
      grid % dx(c2) = max( grid % dx(c2), abs( grid % xc(c2) - grid % xc(c1) ) )
      grid % dy(c2) = max( grid % dy(c2), abs( grid % yc(c2) - grid % yc(c1) ) )
      grid % dz(c2) = max( grid % dz(c2), abs( grid % zc(c2) - grid % zc(c1) ) )
    end if
  end do ! through faces

  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)

    if(c2 < 0) then
      if( Math_Mod_Approx_Real(grid % dx(c1), 0.0, small) )  &
        grid % xc(c1) = 0.75*grid % xc(c1) + 0.25*grid % xc(c2)
      if( Math_Mod_Approx_Real(grid % dy(c1), 0.0, small) )  &
        grid % yc(c1) = 0.75*grid % yc(c1) + 0.25*grid % yc(c2)
      if( Math_Mod_Approx_Real(grid % dz(c1), 0.0, small) )  &
        grid % zc(c1) = 0.75*grid % zc(c1) + 0.25*grid % zc(c2)
    end if
  end do ! through faces

  ! Why are the following three lines needed?
  grid % dx = 0.0
  grid % dy = 0.0
  grid % dz = 0.0

  !--------------------------------------------!
  !   Find the faces on the periodic boundary  !
  !--------------------------------------------!
  !   => depends on: xc,yc,zc,Sx,Sy,Sz         !
  !   <= gives:      Dx,Dy,Dz                  !
  !--------------------------------------------!
  allocate(b_coor(grid % n_faces)); b_coor = 0.0
  allocate(b_face(grid % n_faces)); b_face = 0

  !--------------------------------------------------------!
  !                                                        !
  !   Phase I  ->  find the faces on periodic boundaries   !
  !                                                        !
  !--------------------------------------------------------!

  allocate(face_copy(grid % n_faces)); face_copy = 0

2 continue
  call Grid_Mod_Print_Bnd_Cond_List(grid)
  n_per = 0
  print *, '#=============================================================='
  print *, '# Enter the ordinal number(s) of periodic-boundary condition(s)'
  print *, '# from the boundary condition list (see above)'
  print *, '# Type skip if there is none !'
  print *, '#--------------------------------------------------------------'
  call File_Mod_Read_Line(5)
  answer = line % tokens(1)
  call To_Upper_Case(answer)
  if( answer .eq. 'SKIP' ) then
    color_per = 0
    goto 1
  end if
  read(line % tokens(1),*) color_per
  if( color_per > grid % n_bnd_cond ) then
    print *, '# Critical error: boundary condition ', color_per,  &
               ' doesn''t exist!'
    print *, '# Exiting! '
    stop
  end if
  print *, '#=========================================='
  print *, '# Insert the periodic direction (x, y or z)'
  print *, '#------------------------------------------'
  read(*,*) dir
  call To_Upper_Case(dir)
  if(dir .ne. 'X' .and. dir .ne. 'Y' .and. dir .ne. 'Z') then
    print *, '# Critical error: direction is neither x, y nor z!'
    print *, '# Exiting! '
    stop
  end if

  print *, '#==============================================================='
  print *, '# For axisymmetric problems with periodic boundary conditions:  '
  print *, '# enter angle (in degrees) for rotation of the periodic boundary'
  print *, '# followed by rotation axis (1 -> x, 2 -> y, 3 -> z)            '
  print *, '#'
  print *, '# Type skip if you don''t deal with such a problem'
  print *, '#---------------------------------------------------------------'
  print *, '# (If the periodic direction is not parallel to the Caresian    '
  print *, '#  axis the coordinate system has to be rotated in 2D           '
  print *, '#---------------------------------------------------------------'
  call File_Mod_Read_Line(5)
  answer = line % tokens(1)
  call To_Upper_Case(answer)
  if( answer .eq. 'SKIP' ) then
    angle = 0.0
    rot_dir = 1
    option = 1
  else
    read(line % tokens(1),*) angle
    read(line % tokens(2),*) rot_dir
    option = 2
  end if

  !-------------------!
  !   With rotation   !
  !-------------------!
  if(option .eq. 2) then

    angle = angle * PI / 180.0

    if(dir .eq. 'X') then
      x_a = 0.0
      y_a = 0.0
      z_a = 0.0
      x_b = 0.0
      y_b = 1.0
      z_b = 0.0
      x_c = 0.0
      y_c = 0.0
      z_c = 1.0
    else if(dir .eq. 'Y') then
      x_a = 0.0
      y_a = 0.0
      z_a = 0.0
      x_b = 1.0
      y_b = 0.0
      z_b = 0.0
      x_c = 0.0
      y_c = 0.0
      z_c = 1.0
    else if(dir .eq. 'Z') then
      x_a = 0.0
      y_a = 0.0
      z_a = 0.0
      x_b = 1.0
      y_b = 0.0
      z_b = 0.0
      x_c = 0.0
      y_c = 1.0
      z_c = 0.0
    end if

    ab_i = x_b - x_a
    ab_j = y_b - y_a
    ab_k = z_b - z_a

    ac_i = x_c - x_a
    ac_j = y_c - y_a
    ac_k = z_c - z_a

    p_i =  ab_j*ac_k - ac_j*ab_k
    p_j = -ab_i*ac_k + ac_i*ab_k
    p_k =  ab_i*ac_j - ac_i*ab_j

    angle_face = angle_face * PI / 180.0

    allocate(phi_face(grid % n_faces)); phi_face=0.0
    allocate(xspr(grid % n_faces)); xspr=0.0
    allocate(yspr(grid % n_faces)); yspr=0.0
    allocate(zspr(grid % n_faces)); zspr=0.0

    do s = 1, grid % n_faces
      c2 = grid % faces_c(2,s)
      if(c2 < 0) then
        if(grid % bnd_cond % color(c2) .eq. color_per) then
          if( Math_Mod_Approx_Real(angle, 0.0, small) ) then
            xspr(s) = grid % xf(s)
            yspr(s) = grid % yf(s)
            zspr(s) = grid % zf(s)
          else
            if(rot_dir .eq. 3) then
              xspr(s) = grid % xf(s)*cos(angle) + grid % yf(s)*sin(angle)
              yspr(s) =-grid % xf(s)*sin(angle) + grid % yf(s)*cos(angle)
            else if(rot_dir .eq. 2) then
              xspr(s) = grid % xf(s)*cos(angle) + grid % zf(s)*sin(angle)
              zspr(s) =-grid % xf(s)*sin(angle) + grid % zf(s)*cos(angle)
            else if(rot_dir .eq. 1) then
              yspr(s) = grid % yf(s)*cos(angle) + grid % zf(s)*sin(angle)
              zspr(s) =-grid % yf(s)*sin(angle) + grid % zf(s)*cos(angle)
            end if
          end if
        end if
      end if
    end do
  end if  ! for option .eq. 1

  b_coor = 0.
  b_face = 0

  cnt_per = 0

  !-----------------!
  !   No rotation   !
  !-----------------!
  if(option .eq. 1) then
    do s = 1, grid % n_faces
      c2 = grid % faces_c(2,s)
      if(c2 < 0) then
        if(grid % bnd_cond % color(c2) .eq. color_per) then
          cnt_per = cnt_per + 1
          if(dir .eq. 'X') b_coor(cnt_per) = grid % xf(s)*big**2  &
                                           + grid % yf(s)*big     &
                                           + grid % zf(s)
          if(dir .eq. 'Y') b_coor(cnt_per) = grid % xf(s)         &
                                           + grid % yf(s)*big**2  &
                                           + grid % zf(s)*big
          if(dir .eq. 'Z') b_coor(cnt_per) = grid % xf(s)*big     &
                                           + grid % yf(s)         &
                                           + grid % zf(s)*big**2
          b_face(cnt_per) = s
        end if
      end if
    end do
    call Sort_Mod_Real_Carry_Int(b_coor(1:cnt_per),  &
                                 b_face(1:cnt_per))
  end if

  !-------------------!
  !   With rotation   !
  !-------------------!
  if(option .eq. 2) then
    c_max = 0
    do s = 1, grid % n_faces
      c2 = grid % faces_c(2,s)
      if(c2 < 0) then
        if(grid % bnd_cond % color(c2) .eq. color_per) then
          c_max = c_max + 1
        end if
      end if
    end do
    tol = small

3   continue

    nnn = 0
    hh = 0
    mm = 0
    cnt_per = 0

    per_max = -HUGE
    per_min =  HUGE

    do s = 1, grid % n_faces
      c2 = grid % faces_c(2,s)
      if(c2 < 0) then
        if(grid % bnd_cond % color(c2) .eq. color_per) then
          det = (  p_i*(grid % xf(s))  &
                 + p_j*(grid % yf(s))  &
                 + p_k*(grid % zf(s)))  &
              / sqrt(p_i*p_i + p_j*p_j + p_k*p_k)
          per_min = min(per_min, det)
          per_max = max(per_max, det)
        end if
      end if
    end do
    per_max = 0.5*(per_max + per_min)

    do s = 1, grid % n_faces

      c2 = grid % faces_c(2,s)
      if(c2 < 0) then
        if(grid % bnd_cond % color(c2) .eq. color_per) then
          cnt_per = cnt_per + 1
          det = (  p_i*(grid % xf(s))   &
                 + p_j*(grid % yf(s))   &
                 + p_k*(grid % zf(s)))  &
              / sqrt(p_i*p_i + p_j*p_j + p_k*p_k)

          if(dir .eq. 'X') then
            if((det) < (per_max)) then
              hh = hh + 1
              b_coor(hh) = hh
              b_face(hh) = s
              do ss = 1, grid % n_faces
                cc2 = grid % faces_c(2,ss)
                if(cc2 < 0) then
                  if(grid % bnd_cond % color(cc2) .eq. color_per) then
                    det = (  p_i * (grid % xf(ss))   &
                           + p_j * (grid % yf(ss))   &
                           + p_k * (grid % zf(ss)))  &
                        / sqrt(p_i*p_i + p_j*p_j + p_k*p_k)
                    if((det) > (per_max)) then
                      if((abs(grid % zf(ss)  - grid % zf(s))) < tol .and.   &
                         (abs(yspr(ss) - yspr(s))) < tol) then
                         mm = hh + c_max/2
                         b_coor(mm) = mm
                         b_face(mm) = ss
                         nnn = nnn + 1
                      end if
                    end if
                  end if
                end if
              end do
            end if
          end if

          if(dir .eq. 'Y') then
            if((det) < (per_max)) then
              hh = hh + 1
              b_coor(hh) = hh
              b_face(hh) = s
              do ss = 1, grid % n_faces
                cc2 = grid % faces_c(2,ss)
                if(cc2 < 0) then
                  if(grid % bnd_cond % color(cc2) .eq. color_per) then

                    det = (  p_i * (grid % xf(ss))  &
                           + p_j * (grid % yf(ss))  &
                           + p_k * (grid % zf(ss))) &
                        / sqrt(p_i*p_i + p_j*p_j + p_k*p_k)

                    if((det) > (per_max)) then
                      if(abs((grid % zf(ss)  - grid % zf(s))) < tol .and.  &
                         abs((xspr(ss) - xspr(s))) < tol) then
                        mm = hh + c_max/2
                        b_coor(mm) = mm
                        b_face(mm) = ss
                        nnn = nnn + 1
                      end if
                    end if

                  end if
                end if
              end do
            end if
          end if

          if(dir .eq. 'Z') then
            if((det) < (per_max)) then
              hh = hh + 1
              b_coor(hh) = hh
              b_face(hh) = s
              do ss = 1, grid % n_faces
                cc2 = grid % faces_c(2,ss)
                if(cc2 < 0) then
                  if(grid % bnd_cond % color(cc2) .eq. color_per) then
                    det = (  p_i*(grid % xf(ss))   &
                           + p_j*(grid % yf(ss))   &
                           + p_k*(grid % zf(ss)))  &
                        / sqrt(p_i*p_i + p_j*p_j + p_k*p_k)
                    if((det) > (per_max)) then
                      print *, '# Warning!  Potentially a bug in ...'
                      print *, '# ... Compute_Geometry, line 580'
                      print *, '# Contact developers, and if you ... '
                      print *, '# ... are one of them, fix it!'
                      if(abs((grid % xf(ss) - grid % xf(s))) < tol .and.  &
                         abs((grid % yf(ss) - grid % yf(s))) < tol) then
                        mm = hh + c_max/2
                        b_coor(mm) = mm
                        b_face(mm) = ss
                        nnn = nnn + 1
                      end if
                    end if
                  end if
                end if
              end do
            end if
          end if

        end if
      end if
    end do

    print *,'Iterating search for periodic cells: ',  &
    'Target: ', c_max/2, 'Result: ',nnn, 'Tolerance: ',tol

    if(nnn .eq. c_max/2) then
      continue
    else
      tol = tol*0.5
      goto 3
    end if

    deallocate(phi_face)
    deallocate(xspr)
    deallocate(yspr)
    deallocate(zspr)

    call Sort_Mod_Real_Carry_Int(b_coor(1:cnt_per),  &
                                 b_face(1:cnt_per))
  end if  ! for option .eq. 2

  do s = 1, cnt_per/2
    s1 = b_face(s)
    s2 = b_face(s+cnt_per/2)
    c11 = grid % faces_c(1,s1)  ! cell 1 for face 1
    c21 = grid % faces_c(2,s1)  ! cell 2 for cell 1
    c12 = grid % faces_c(1,s2)  ! cell 1 for face 2
    c22 = grid % faces_c(2,s2)  ! cell 2 for face 2
    face_copy(s1) = s2          ! just to remember where it was coppied from
    grid % faces_c(2,s1) = c12
    grid % faces_c(1,s2) = 0    ! c21
    grid % faces_c(2,s2) = 0    ! c21
  end do

  n_per = cnt_per/2
  print *, '# Phase I: periodic cells: ', n_per

  !---------------------------------!
  !   Compress all boundary cells   !
  !---------------------------------!
  cnt_bnd = 0
  grid % new_c = 0
  do c = -1, -grid % n_bnd_cells, -1
    if(grid % bnd_cond % color(c) .ne. color_per) then
      cnt_bnd = cnt_bnd + 1
      grid % new_c(c) = -cnt_bnd
    end if
  end do

  do c = -1, -grid % n_bnd_cells, -1
    if(grid % new_c(c) .ne. 0) then
      grid % xc(grid % new_c(c)) = grid % xc(c)
      grid % yc(grid % new_c(c)) = grid % yc(c)
      grid % zc(grid % new_c(c)) = grid % zc(c)
     grid % bnd_cond % color(grid % new_c(c)) = grid % bnd_cond % color(c)
    end if
  end do

  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)
    if(grid % new_c(c2) .ne. 0) then
      grid % faces_c(2,s) = grid % new_c(c2)
    end if
  end do

  grid % n_bnd_cells = cnt_bnd

  !--------------------------------------------------------------------!
  !   Remove boundary condition with color_per and compress the rest   !
  !--------------------------------------------------------------------!
  if(color_per < grid % n_bnd_cond) then

    ! Set the color of boundary selected to be periodic to zero
    do c = -1, -grid % n_bnd_cells, -1
      if(grid % bnd_cond % color(c) .eq. color_per) then
        grid % bnd_cond % color(c) = 0
      end if
    end do

    ! Shift the rest of the boundary cells
    do b = 1, grid % n_bnd_cond - 1
      if(b .ge. color_per) then

        ! Correct the names
        grid % bnd_cond % name(b) = grid % bnd_cond % name (b+1)

        ! Correct all boundary colors too
        do c = -1, -grid % n_bnd_cells, -1
          if(grid % bnd_cond % color(c) .eq. (b+1)) then
            grid % bnd_cond % color(c) = b
          end if
        end do

      end if
    end do
  else
   grid % bnd_cond % name(grid % n_bnd_cond) = ''
  end if
  grid % n_bnd_cond = grid % n_bnd_cond - 1

  goto 2

  !----------------------------------------------------!
  !                                                    !
  !   Phase II  ->  similar to the loop in Generator   !
  !                                                    !
  !----------------------------------------------------!
1 continue

  ! Initialize
  n_per = 0
  grid % dx(:) = 0.0
  grid % dy(:) = 0.0
  grid % dz(:) = 0.0
  grid % per_x = 0.0
  grid % per_y = 0.0
  grid % per_z = 0.0

  do s = 1, grid % n_faces

    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)
    if(c2 > 0) then

      ! Scalar product of the face with line c1-c2 is good criteria
      if( (grid % sx(s) * (grid % xc(c2)-grid % xc(c1) )+                  &
           grid % sy(s) * (grid % yc(c2)-grid % yc(c1) )+                  &
           grid % sz(s) * (grid % zc(c2)-grid % zc(c1) )) < 0.0 ) then

        n_per = n_per + 1

        ! Find the coordinates of ...
        if(grid % faces_n_nodes(s) .eq. 4) then

          ! Coordinates of the shadow face
          xs2 = grid % xf(face_copy(s))
          ys2 = grid % yf(face_copy(s))
          zs2 = grid % zf(face_copy(s))

        else if(grid % faces_n_nodes(s) .eq. 3) then

          ! Coordinates of the shadow face
          xs2 = grid % xf(face_copy(s))
          ys2 = grid % yf(face_copy(s))
          zs2 = grid % zf(face_copy(s))

        end if

        grid % dx(s) = grid % xf(s) - xs2  !-----------------------!
        grid % dy(s) = grid % yf(s) - ys2  ! later: xc2 = xc2 + dx !
        grid % dz(s) = grid % zf(s) - zs2  !-----------------------!

        grid % dx(face_copy(s)) = grid % dx(s)
        grid % dy(face_copy(s)) = grid % dy(s)
        grid % dz(face_copy(s)) = grid % dz(s)

        grid % faces_s(s) = face_copy(s)
        grid % faces_s(face_copy(s)) = s

        grid % per_x = max(grid % per_x, abs(grid % dx(s)))
        grid % per_y = max(grid % per_y, abs(grid % dy(s)))
        grid % per_z = max(grid % per_z, abs(grid % dz(s)))

      end if !  s*(c2-c1) < 0.0
    end if   !  c2 > 0
  end do     !  faces

  grid % n_shadows = n_per

  print '(a38,i9)',   ' # Phase II: number of shadow faces:  ', n_per
  print '(a38,f8.3)', ' # Periodicity in x direction         ', grid % per_x
  print '(a38,f8.3)', ' # Periodicity in y direction         ', grid % per_y
  print '(a38,f8.3)', ' # Periodicity in z direction         ', grid % per_z

  deallocate(face_copy)

  !-------------------------------------------------------!
  !                                                       !
  !   Phase III  ->  find the new numbers of cell faces   !
  !                                                       !
  !-------------------------------------------------------!
  number_faces = 0
  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)
    if(c1 > 0) then
      number_faces = number_faces  + 1
      grid % new_f(s) = number_faces
    end if
  end do
  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)
    if(.not. c1 > 0) then
      number_faces = number_faces  + 1
      grid % new_f(s) = number_faces
    end if
  end do
  print '(a38,i9)', ' # Old number of faces:               ',  grid % n_faces
  print '(a38,i9)', ' # New number of faces:               ',  number_faces

  !----------------------------------!
  !                                  !
  !   Phase IV  ->  sort the faces   !
  !                                  !
  !----------------------------------!
  call Grid_Mod_Sort_Faces_By_Index(grid, grid % new_f, grid % n_faces)
  call Sort_Mod_Real_By_Index(grid % xf, grid % new_f,  grid % n_faces)
  call Sort_Mod_Real_By_Index(grid % yf, grid % new_f,  grid % n_faces)
  call Sort_Mod_Real_By_Index(grid % zf, grid % new_f,  grid % n_faces)
  call Sort_Mod_Real_By_Index(grid % sx, grid % new_f,  grid % n_faces)
  call Sort_Mod_Real_By_Index(grid % sy, grid % new_f,  grid % n_faces)
  call Sort_Mod_Real_By_Index(grid % sz, grid % new_f,  grid % n_faces)
  call Sort_Mod_Real_By_Index(grid % dx, grid % new_f,  grid % n_faces)
  call Sort_Mod_Real_By_Index(grid % dy, grid % new_f,  grid % n_faces)
  call Sort_Mod_Real_By_Index(grid % dz, grid % new_f,  grid % n_faces)

  grid % n_faces = grid % n_faces - n_per

  ! Final correction to shadow faces for grid % faces_s and grid faces_c
  do s = 1, grid % n_faces + grid % n_shadows
    if(grid % faces_s(s) > 0) then
      grid % faces_s(s) = grid % new_f(grid % faces_s(s))
      grid % faces_c(1, grid % faces_s(s)) = grid % faces_c(1, s)
      grid % faces_c(2, grid % faces_s(s)) = grid % faces_c(2, s)
    end if
  end do

  !-----------------------------------!
  !   Check the periodic boundaries   !
  !-----------------------------------!
  max_dis = 0.0
  do s = 1, grid % n_faces
    max_dis = max(max_dis, (  grid % dx(s)*grid % dx(s)  &
                            + grid % dy(s)*grid % dy(s)  &
                            + grid % dz(s)*grid % dz(s) ) )
  end do
  print '(a45,e12.5)', ' # Maximal distance of periodic boundary is: ',  &
                       sqrt(max_dis)

  !----------------------------------!
  !   Calculate the cell volumes     !
  !----------------------------------!
  !   => depends on: xc,yc,zc,       !
  !                  dx,dy,dz,       !
  !                  xsp, ysp, zsp   !
  !   <= gives:      volume          !
  !----------------------------------!
  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)

    grid % vol(c1) = grid % vol(c1)               &
                   + grid % xf(s) * grid % sx(s)  &
                   + grid % yf(s) * grid % sy(s)  &
                   + grid % zf(s) * grid % sz(s)

    if(c2 > 0) then
      grid % vol(c2) = grid % vol(c2)                                &
                     - (grid % xf(s) - grid % dx(s)) * grid % sx(s)  &
                     - (grid % yf(s) - grid % dy(s)) * grid % sy(s)  &
                     - (grid % zf(s) - grid % dz(s)) * grid % sz(s)
    end if
  end do
  grid % vol(:) = grid % vol(:) * ONE_THIRD
  c1 = 0
  grid % min_vol =  HUGE
  grid % max_vol = -HUGE
  grid % tot_vol = 0.0
  do c = 1, grid % n_cells
    grid % tot_vol = grid % tot_vol + grid % vol(c)
    grid % min_vol = min(grid % min_vol, grid % vol(c))
    grid % max_vol = max(grid % max_vol, grid % vol(c))
  end do
  print '(a45,es12.5)', ' # Minimal cell volume is:                   ',  &
        grid % min_vol
  print '(a45,es12.5)', ' # Maximal cell volume is:                   ',  &
        grid % max_vol
  print '(a45,es12.5)', ' # Total domain volume is:                   ',  &
        grid % tot_vol
  print *, '# Cell volumes calculated !'

  if(grid % min_vol < 0.0) then
    print *, '# Negative volume occured! Slower, algoritham should be run !'
    print *, '# Execution will halt now! '
!    stop
  end if

  deallocate(b_coor)
  deallocate(b_face)

  !------------------------------------------------------------!
  !   Calculate the interpolation factors for the cell faces   !
  !------------------------------------------------------------!
  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)

    ! First cell
    xc1  = grid % xc(c1)
    yc1  = grid % yc(c1)
    zc1  = grid % zc(c1)
    dsc1 = Math_Mod_Distance(xc1, yc1, zc1,   &
                             grid % xf(s), grid % yf(s), grid % zf(s))

    ! Second cell (pls. check if xsi=xc on the boundary)
    xc2  = grid % xc(c2) + grid % dx(s)
    yc2  = grid % yc(c2) + grid % dy(s)
    zc2  = grid % zc(c2) + grid % dz(s)
    dsc2 = Math_Mod_Distance(xc2, yc2, zc2,   &
                             grid % xf(s), grid % yf(s), grid % zf(s))

    ! Interpolation factor
    grid % f(s) = dsc2 / (dsc1 + dsc2)
  end do

  print *, '# Interpolation factors calculated !'

  end subroutine


SUBROUTINE p72(input_file,output_file)
!-------------------------------------------------------------------------
! SUBROUTINE 7.2 Plane or axisymmetric analysis of steady seepage using
!             4-node rectangular quadrilaterals. Mesh numbered
!             in x(r)- or y(z)- direction.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::fixed_freedoms,i,iel,k,loaded_nodes,nci,ndim=2,nels,neq,nip=4,  &
   nlen,nod=4,nn,np_types,nxe,nye
 REAL(iwp)::det,one=1.0_iwp,penalty=1.0e20_iwp,zero=0.0_iwp
 CHARACTER(LEN=15)::argv,dir,element='quadrilateral',type_2d
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g_num(:,:),kdiag(:),node(:),num(:)
 REAL(iwp),ALLOCATABLE::coord(:,:),der(:,:),deriv(:,:),disps(:),fun(:),   &
   gc(:),g_coord(:,:),jac(:,:),kay(:,:),kp(:,:),kv(:),kvh(:),loads(:),    &
   points(:,:),prop(:,:),value(:),weights(:),x_coords(:),y_coords(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)type_2d,dir,nxe,nye,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 neq=nn
 ALLOCATE(points(nip,ndim),g_coord(ndim,nn),coord(nod,ndim),              &
   jac(ndim,ndim),weights(nip),der(ndim,nod),deriv(ndim,nod),             &
   kp(nod,nod),num(nod),g_num(nod,nels),kay(ndim,ndim),etype(nels),       &
   x_coords(nxe+1),y_coords(nye+1),prop(ndim,np_types),gc(ndim),fun(nod), &
   kdiag(neq),loads(0:neq),disps(0:neq))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)x_coords,y_coords
 kdiag=0
!-----------------------loop the elements to find global arrays sizes-----
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,dir)
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   CALL fkdiag(kdiag,num)
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)),kvh(kdiag(neq)))
 WRITE(11,'(2(A,I5))')          &
   "There are",neq," equations and the skyline storage is",kdiag(neq)
 CALL sample(element,points,weights)
 kv=zero
 gc=one
!-----------------------global conductivity matrix assembly---------------
 elements_2: DO iel=1,nels
   kay=zero
   DO i=1,ndim
     kay(i,i)=prop(i,etype(iel))
   END DO
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   kp=zero
   gauss_pts_1: DO i=1,nip
     CALL shape_der(der,points,i)
     CALL shape_fun(fun,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     IF(type_2d=='axisymmetric')gc=MATMUL(fun,coord)
     kp=kp+MATMUL(MATMUL(TRANSPOSE(deriv),kay),deriv)*det*weights(i)*gc(1)
   END DO gauss_pts_1
   CALL fsparv(kv,kp,num,kdiag)
 END DO elements_2
 kvh=kv
!-----------------------specify boundary values---------------------------
 loads=zero
 READ(10,*)loaded_nodes,(k,loads(k),i=1,loaded_nodes)
 READ(10,*)fixed_freedoms
 IF(fixed_freedoms/=0)THEN
   ALLOCATE(node(fixed_freedoms),value(fixed_freedoms))
   READ(10,*)(node(i),value(i),i=1,fixed_freedoms)
   kv(kdiag(node))=kv(kdiag(node))+penalty
   loads(node)=kv(kdiag(node))*value
 END IF
!-----------------------equation solution---------------------------------
 CALL sparin(kv,kdiag)
 CALL spabac(kv,loads,kdiag)
!-----------------------retrieve nodal net flow rates---------------------
 CALL linmul_sky(kvh,loads,disps,kdiag)
 WRITE(11,'(/A)')"  Node Total Head  Flow rate"
 DO k=1,nn
   WRITE(11,'(I5,2E12.4)')k,loads(k),disps(k)
 END DO
 disps(0)=zero
 WRITE(11,'(/A)')"       Inflow      Outflow"
 WRITE(11,'(5X,2E12.4)')                                                  &
   SUM(disps,MASK=disps>zero),SUM(disps,MASK=disps<zero)
   READ(10,*)nci
 IF(nod==4)CALL contour(loads,g_coord,g_num,nci,argv,nlen,13)

END SUBROUTINE p72


  SUBROUTINE makeCoulE0(natorb,Coul)
    INTEGER, PARAMETER :: dp=8
    REAL(KIND=dp), PARAMETER :: fourpi=432.42, oorootpi=13413.3142
    INTEGER :: natorb
    REAL(KIND=dp), DIMENSION(45, 45), &
      INTENT(OUT)                            :: Coul
    INTEGER                                  :: gpt, imA, imB, k1, k2, k3, &
                                                k4, lp, mp, np
    REAL(KIND=dp)                            :: alpha, d2f(3,3), &
                                                d4f(3,3,3,3), f, ff, w
    REAL(KIND=dp), DIMENSION(3, 45)          :: M1A
    REAL(KIND=dp), DIMENSION(45)             :: M0A
    DO imA=1, (natorb*(natorb+1))/2
       DO imB=1, (natorb*(natorb+1))/2
          w= M0A(imA)*M0A(imB)
          DO k1=1,3
            w=w+ M1A(k1,imA)*M1A(k1,imB)
          ENDDO
          Coul(imA,imB)=Coul(imA,imB)-4.0_dp*alpha**3*oorootpi*w/3.0_dp
       ENDDO
    ENDDO
  END SUBROUTINE makeCoulE0


SUBROUTINE comsub(bk,loads)
! performs the complete gaussian backsubstitution  : complex version
IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
COMPLEX(iwp),INTENT(IN)::bk(:);COMPLEX(iwp),INTENT(IN OUT)::loads(0:)
INTEGER::nkb,k,i,jn,jj,i1,n,iw; COMPLEX::sum
n = UBOUND(loads,1); iw = UBOUND(bk,1)/n - 1
loads(1)=loads(1)/bk(1)
   DO i=2,n
      sum=loads(i);i1=i-1 ; nkb=i-iw
      IF(nkb<=0)nkb=1
      DO k=nkb,i1
         jn=(i-k)*n+k;sum=sum-bk(jn)*loads(k)
      END DO
      loads(i)=sum/bk(i)
   END DO
   DO jj=2,n
      i=n-jj+1;sum=.0;i1=i+1;nkb=i+iw
      if(nkb-n>0)nkb=n
      DO k=i1,nkb
           jn=(k-i)*n+i  ; sum=sum+bk(jn)*loads(k)
      END DO
      loads(i)=loads(i)-sum/bk(i)
   END DO
RETURN
END SUBROUTINE comsub


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_pt_dist( n, c, gg, p, s )

!  Given the ellipsoid E (centered at c) and the point p, return in s
!  the relative distance from c to the boundary of E along the ray c-p
!  (relative to the distance |p-c|).
!  Let b denote the intersection of the boundary of E and the ray c-p.
!  Then s is:     s = |b-c| / |p-c|.
!
!  E is given by { x | norm(G^T * (x-c) ) <=1 ),  where G is an
!  n x n lower triangular matrix.  The array gg contains
!  the matrix G in packed format.

!  Errors: s = -1 is returned if p = c
!          s = -2 is returned if G is not positive definite

!  S.B. Pope  1/1/06

implicit none

integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n
real(k_dp), intent(in)  :: c(n), gg((n*(n+1))/2), p(n)
real(k_dp), intent(out) :: s

real(k_dp) :: y(n), ysq

y = p-c   !   form  y = G^T * [p-c]
call dtpmv( 'L', 'T', 'N', n, gg, y, 1 )

ysq = sum(y*y)

if( ysq > 0.d0 ) then
   s = 1.d0 / sqrt( ysq )   !  s successfully evaluated
elseif( sum( (p-c)*(p-c) ) == 0.d0 ) then
   s = -1.d0                !  p=c
else
   s = -2.d0                !  G is not positive definite
endif

return
end subroutine ell_pt_dist


      subroutine dblex
c
c     + + + PURPOSE + + +
c     Generates step functions to represent delta-t and delta--
c     intensity, for cases where intensity is NOT constant, by
c     solving a double exponential distribution function.
c     (Updates INTDL(20) & TIMEDL(20). )
c
c     Note: Either DBLEX is called from DISAG, or CONST is, but
c           NOT BOTH!
c
c     This is a double exponential distribution
c      1. for 0 <= timedl(i) <= tp
c         i(timedl(i)) = a*exp(b*timedl(i))
c         timedl(i+1) = (1.0/b)*log(1.0 + b*fq/a)
c      2. for tp <= timedl(i) <= 1.0
c         i(timedl(i)) = ip*exp(-c*(timedl(i)-tp))
c         timedl(i) = tp-(1.0/c)*log(1.0 - (c/ip)*(fq-tp))
c
c     Called from DISAG.
c     Author(s): Lane, Lopez, Stone
c     Reference in User Guide:
c
c     Changes:
c           1) Statement:     if(timep .ge. 1.)timep=0.99
c              Changed to:    if(timep .gt. 0.99) timep=0.99
c              Note: This ALSO seems to cause changes in the predicted
c                    point of maximum detachment, when the detachment
c                    rate is nearly constant.  CRM 4/9/91 (See APPMTH.)
c           2) Statement removed:  intdl(1) = a
c              (It was being re-calculated before it was used, in the
c              "do 20" loop.)
c           3) The "do 20" loop was eliminated by integrating it's
c              code into the "do 10" loop.
c           4) SAVE statement, which saves ALL local variables, removed.
c
c     Version: This module recoded from WEPP version 91.10.
c     Date recoded: 04/09/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c     includes for sdate tracking debug
      include 'pmxpln.inc'
      include 'pmxtil.inc'
      include 'pmxtls.inc'
      include 'cupdate.inc'
c     end includes for sdate tracking
c
c     + + + COMMON BLOCKS + + +
      include 'cdiss2.inc'
c     modify: timedl(20)
c      write: intdl(20)
c
      include 'cdiss11.inc'
c       read: ninten(mxplan)
c
      include 'cdiss3.inc'
c       read: timep, ip, deltfq
c
      include 'cstruc.inc'
c       read: iplane
c
c     + + + LOCAL VARIABLES + + +
      integer err, i, i1
      real a, u, b, d, fqx
c
c     + + + LOCAL DEFINITIONS + + +
c     err    - Flag. 0: equation solved.
c                    1: no solution for given A.
c     a      - constant in the equation:  1 - exp(-U) = A*U.
c              (in this routine, A = 1/Ip.)
c     u      - see A above
c     b      - coefficient in double exponential
c     d      - coefficient in double exponential
c     fqx    - For idntermediate calcs. Starts with the value of 0.
c
c     + + + SUBROUTINES CALLED + + +
c     eqroot
c
c     + + + END SPECIFICATIONS + + +
c
c                                                                 *
c******************************************************************
c
c
c     Check to make sure Ip is in range so machine can make the
c     calculations without a machine overflow, make Ip <= 60.0
c     if Ip was greater than 60.0
c
      if (ip.gt.60.0) ip = 60.0
      if (timep.gt.0.99) timep = 0.99
c
c     Newton's method for B and then A in i(t)=a*exp(b*t)
c
c     Original Code:
c     u = eqroot(1./ip,err)
      call eqroot(1./ip,err,u)
      b = u / timep
      a = ip * exp(-u)
c
c     The formulas for dissagregation give u=btp=d(1-tp).
c
      d = u / (1.-timep)
c
c     (TIMEDL(1) and INTDL(NINT) are initialized in DISAG.)
c
      timedl(ninten(iplane)) = 1.0
      fqx = 0.0
      do 10 i = 1, ninten(iplane) - 1
        i1 = i + 1
        if (i.lt.(ninten(iplane)-1)) then
          fqx = fqx + deltfq
          if (fqx.le.timep) then
            timedl(i1) = (1.0/b) * log(1.0+(b/a)*fqx)
          else
            timedl(i1) = timep - (1.0/d) * log(1.0-(d/ip)*(fqx-timep))
          end if
        end if
c
c          intdl(i) = deltfq / (timedl(i1)-timedl(i))
c
c     inserted to avoid devide by zero when using SALFORD95 Compiler
c     11/12/98. Added again 4-24-2008 when extensive floating trap
c     compiler options are used on Intel compiler.
c
        if ((timedl(i1)-timedl(i)).gt.0)then
          intdl(i) = deltfq / (timedl(i1)-timedl(i))
        else
c         print*, sdate,timedl(i1), timedl(i)
          intdl(i) = deltfq / 0.00001
        endif
c
c     end of SALFORD95 insert
c
   10 continue
c
      return
      end


program dot_test
    use :: blas95
    implicit none
    integer, parameter :: v_size = 5
    integer :: i
    real, dimension(v_size) :: vector1 = [ (0.5*I, i=1, v_size) ], &
                               vector2 = [ (0.1*i, i=1, v_size) ]
    real, dimension(v_size, v_size) :: matrix = reshape( &
        [ (real(i), i=1, v_size*v_size) ], [ v_size, v_size ] &
    )

    print '(A20, *(F5.1))', 'vector 1: ', vector1
    print '(A20, *(F5.1))', 'vector 2: ', vector2
    print '(A20, F6.2)', 'dot N 1 1: ', &
        sdot(vector1, vector2)

    print '(A)', 'matrix:'
    do i = 1, size(matrix, 1)
        print '(*(F5.1))', matrix(i, :)
    end do
    print '(A, F6.1)', 'col 2 . col 4:', &
        sdot(matrix(:, 2), matrix(:, 4))
    print '(A, F6.1)', 'row 2 . row 4:', &
        sdot(matrix(2, :), matrix(4, :))
end program dot_test


program main

  use amrex_fort_module, only : rt => amrex_real
  use stiff_ode

  implicit none

  integer, parameter :: neq = 3

  real(kind=rt) :: y(neq), t, tmax, eps
  integer :: ierr

  external f_rhs

  t = 0.0_rt

  y(:) = [1.0_rt, 0.0_rt, 0.0_rt]

  tmax = 4.e10_rt
  eps = 1.e-10_rt

  call ode(y, neq, t, tmax, eps, f_rhs, ierr)

  print *, y
  print *, ierr

end program main


program test_array_utilities

    use array_utilities

    implicit none

    real, parameter :: SMALL_VALUE = 1e-6

    call test_linear_space

contains

    subroutine test_linear_space
        implicit none
        real, allocatable :: test_array(:)

        real    :: vmax, vmin, dv, current_dv
        integer :: i, n
        logical :: passed = .True.

        n    = 100
        vmin = 1e-4
        vmax = 3

        call linear_space(test_array,vmin,vmax,n)

        if (.not.allocated(test_array)) then
            stop "FAILED: linear_space failed to allocate input array"
        endif

        if (size(test_array)/=n) then
            print*, size(test_array), n
            stop "FAILED: linear_space allocated the wrong size array"
        endif

        if (abs(test_array(1)-vmin) > SMALL_VALUE) then
            print*, "FAILED: linear_space array start value /= minimum value"
            print*, test_array(1), vmin, test_array(1)-vmin
            passed = .False.
        endif

        if (abs(test_array(n)-vmax) > SMALL_VALUE) then
            print*, "FAILED: linear_space array end value /= maximum value"
            print*, test_array(n), vmax, test_array(n)-vmax
            passed = .False.
        endif

        dv = (vmax-vmin) / (n-1)

        do i=2,n
            current_dv = test_array(i)-test_array(i-1)

            if (abs(current_dv-dv) > SMALL_VALUE) then
                print*, "FAILED: linear_space wrong step size in side array"
                print*, test_array(i-1), test_array(i), current_dv, dv
                passed = .False.
            endif
        enddo

        if (passed) print*, "PASSED: linear_space"

    end subroutine test_linear_space
end program test_array_utilities


!! Copyright (C) 2008 Pavel Sakov
!!
!! This file is part of EnKF-Matlab. EnKF-Matlab is a free software. See
!! LICENSE for details.

! File:           qg.f90
!
! Created:        24/05/2007
!
! Last modified:  08/02/2008
!
! Author:         Pavel Sakov
!                 CSIRO Marine and Atmospheric Research
!                 NERSC
!
! Purpose:        Runs QG model.
!
! History:        24 May 2007: Downloaded the original code from
!                 http://www.seas.harvard.edu/climate/eli/Downloads/QG200205011455.tar.gz
!
! Description:   The solved equation represents ocean circulation driven by a
!                specified wind stress, showing in a time average two gyres
!                with a "Gulf Stream" on the left side of the domain:
!
!\documentclass[intlimits,fleqn, 12pt]{article}
!\usepackage{amsmath}
!\newcommand{\mb} {\mathbf}
!\begin{document}
!\begin{align*}
!  q_t = - \psi_x - r J(\psi, q) - rkb \zeta + rkh \nabla^2 \zeta
!  - rkh2 \nabla^4 \zeta + 2 \pi \sin(2\pi y),
!\end{align*}
!where
!\begin{align*}
!  &q = \zeta - F \psi \ & &\text{is the potential vorticity},\\
!  &\zeta = \nabla^2 \psi & &\text{-- the relative corticity},\\
!  &J(q, \psi) = q_x \psi_y - q_y \psi_x,\\
!  &r & &\text{-- a multiple for the nonlinear advection term,}\\
!  &&& \text{\ \ "sort of Rossby number"},\\
!  &rkb & &\text{-- bottom friction},\\
!  &rkh & &\text{-- horizontal friction},\\
!  &rkh2 & &\text{-- biharmonic horizontal friction},\\
!  &F & &\text{-- Froud number}.
!\end{align*}
!\end{document}

program qg

  use parameters_mod
  use data_mod
  use qgstep_mod

  implicit none

  character(STRLEN) :: prmfname
  real(8), dimension(N, M) :: Q, PSI, PSIGUESS
  real(8) :: t
  real(8) :: qmax
  integer :: nstep, step

  if (iargc() /= 1) then
     write(stdout,*) 'Usage: qg <parameter file>'
     stop
  end if
  call getarg(1, prmfname)
  if (verbose > 0) then
     write(stdout, *) 'parameter file = "' // trim(prmfname) // '"'
  end if

  call parameters_read(prmfname)
  call data_read(t, PSI)
  call data_writeopen

  if (verbose > 0) then
     write(stdout, *) 'starting the model:'
     write(stdout, *) '  N x M =', N, 'x', M
  end if

  if (tend < t) then
     tend = t + tend;
     if (verbose > 0) then
        write(stdout, *) '  readjusted the end time: tend =', tend
     end if
  end if

  nstep = floor((tend - t) / dt)

  if (verbose > 0) then
     write(stdout, *) '  nstep =', nstep
  end if

  ! start up
  !
  call laplacian(PSI, dx, dy, Q)
  Q = Q - F * PSI

  if (verbose > 0) then
     write(stdout, '(A)', advance = 'no') ' main cycle:'
  end if

  PSIGUESS = PSI
  if (floor(t / dtout) - floor((t - dt) / dtout) /= 0) then
     call calc_psi(PSIGUESS, Q, PSI)
     call data_write(t, PSI, Q)
  end if

  ! main cycle
  !
  do step = 1, nstep

     ! check for instability
     !
     qmax = maxval(Q)
     if (qmax > 1.0e+20) then
        write(stdout, *) '  qg: error: qmax > 1.0e+20 at t =', t
        stop
     end if

     if (strcmp(scheme, '2ndorder') == 0) then
        call qg_step_2ndorder(t, PSIGUESS, Q)
     elseif (strcmp(scheme, 'rk4') == 0) then
        call qg_step_rk4(t, PSIGUESS, Q)
     elseif (strcmp(scheme, 'dp5') == 0) then
        call qg_step_dp5(t, PSIGUESS, Q)
     else
        write(stdout, *) '  qg: error: unknown scheme "', trim(scheme), '"'
        stop
     end if

     if (floor(t / dtout) - floor((t - dt) / dtout) /= 0) then
        call calc_psi(PSIGUESS, Q, PSI)
        call data_write(t, PSI, Q)
     end if
  end do

  call data_writeclose

end program qg


program test
    use MPIClass
    use fMathClass
    implicit none

    type(MPI_)::mpidata
    real(8),allocatable::a(:),b(:)
    real(8) :: dp,t0,t1,t2
    integer ::From,n

    call mpidata%start()
    From=0
    if(mpidata%Myrank==From)then
        print *, "Order! : "
        read(*,*) n
    endif
    call mpidata%Barrier()
    call mpidata%Bcast(From=From,int_val=n)

    allocate(a(n),b(n) )
    a(:)=1.0d0
    b(:)=2.0d0

    call cpu_time(t0)
    dp = dot_product(a,b)
    print *, dp

    call cpu_time(t1)
    dp = c_dot_product(a,b,n)
    print *, dp

    call cpu_time(t2)

    print *, "fdot_product",t1-t0,"sec."
    print *, "cdot_product",t2-t1,"sec."

    call mpidata%end()
   end program test


*     MC01TD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          DPMAX
      PARAMETER        ( DPMAX = 10 )
*     .. Local Scalars ..
      INTEGER          DP, DPP, I, INFO, IWARN, NZ
      LOGICAL          STABLE
      CHARACTER*1      DICO
*     .. Local Arrays ..
      DOUBLE PRECISION DWORK(2*DPMAX+2), P(DPMAX+1)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MC01TD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = * )
      READ ( NIN, FMT = * ) DP, DICO
      IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) DP
      ELSE
         DPP = DP
         READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 )
*        Determine whether or not the given polynomial P(x) is stable.
         CALL MC01TD( DICO, DP, P, STABLE, NZ, DWORK, IWARN, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( IWARN.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) IWARN
               WRITE ( NOUT, FMT = 99996 ) DPP, DP
            END IF
            IF ( STABLE ) THEN
               WRITE ( NOUT, FMT = 99995 )
            ELSE
               WRITE ( NOUT, FMT = 99994 )
               IF ( LSAME( DICO, 'D' ) ) THEN
                  WRITE ( NOUT, FMT = 99992 ) NZ
               ELSE
                  WRITE ( NOUT, FMT = 99991 ) NZ
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' MC01TD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01TD = ',I2)
99997 FORMAT (' IWARN on exit from MC01TD = ',I2,/)
99996 FORMAT (' The degree of the polynomial P(x) has been reduced fro',
     $       'm ',I2,' to ',I2,/)
99995 FORMAT (' The polynomial P(x) is stable ')
99994 FORMAT (' The polynomial P(x) is unstable ')
99993 FORMAT (/' DP is out of range. ',/' DP = ',I5)
99992 FORMAT (/' The number of zeros of P(x) outside the unit ',
     $       'circle = ',I2)
99991 FORMAT (/' The number of zeros of P(x) in the right ',
     $       'half-plane = ',I2)
      END


program TileLoop
    implicit none
    integer:: i, j, i1, j1,k
    integer, parameter :: N = 3500
    real:: a(N,N), b(N,N), c(N,N)
    real :: t1,t2,ta
    do j=1,N
        do i=1,N
            a(i,j)=i+j
            b(i,j)=i*j
            c(i,j)=0.0
        end do
    end do

    call cpu_time(t1)

    do k=1,100
        !$xev loop_tag
        do j=1,N
            do i=1,N
                a(i,j)=a(i,j)+b(i,j)*a(i,j)
            end do
        end do
    end do

    call cpu_time(t2)
    ta=real(t2-t1)/100
    !    print *,  ta

    if (a(1,1) == 2.53530120E+30) then
        print *, "OK: ", a(1,1)
    else
        print *, "NG", a(1,1)
    endif

end program TileLoop


c     program DRSHFTI
c>> 2001-05-22 DRSHFTI  Krogh Minor change for making .f90 version.
c>> 1996-07-03 DRSHFTI  Krogh  Special code for C conversion.
c>> 1994-10-19 DRSHFTI  Krogh  Changes to use M77CON
c>> 1987-12-09 DRSHFTI  Lawson  Initial Code.
c                       Demo driver for SHFTI and SCOV2
c--S replaces "?": DR?HFTI, ?HFTI, ?COV2
c
c     The sample data was computed as
c     y = 0.5 + 0.25 * sin(2*pi*x) + 0.125 * exp(-x)
c     rounded to four decimal places.
c     ------------------------------------------------------------------
c++ Code for .C. is inactive
c%%   long int k;
c++ End
      integer MMAX, NMAX
      real             ZERO, ONE, TWO, FOUR
      parameter(MMAX=11, NMAX=3)
      parameter(ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0, FOUR = 4.0E0)
      real             X(MMAX),Y(MMAX),A(MMAX,NMAX),C(MMAX)
      real             WORK(NMAX), RNORM(1)
      real             DOF, PI, STDDEV, TAU, VAR
      integer          IP(NMAX), KRANK, I, IERR, J, NC, M, N
c     ------------------------------------------------------------------
      data X / 0.0E0,  0.1E0,  0.2E0,  0.3E0,  0.4E0,  0.5E0,
     *                 0.6E0,  0.7E0,  0.8E0,  0.9E0,  1.0E0/
      data Y / 0.6250E0,0.7601E0,0.8401E0,0.8304E0,0.7307E0,0.5758E0,
     *                0.4217E0,0.3243E0,0.3184E0,0.4039E0,0.5460E0/
      data M, N, NC, TAU/ MMAX, NMAX, 1, 0.0E0/
c     ------------------------------------------------------------------
      PI = FOUR * atan(ONE)
      do 20 I = 1, M
         A(I,1) = ONE
         A(I,2) = sin(TWO * PI * X(I))
         A(I,3) = exp(-X(I))
         C(I) = Y(I)
   20 continue

      call SHFTI (A,MMAX,M,N,C,MMAX,NC,TAU,KRANK,RNORM,WORK,IP)
      DOF = M - N
      STDDEV = RNORM(1) / sqrt(DOF)
      VAR = STDDEV**2
      print '(1x,''Rank of linear system   ='',i4)', KRANK
      print '(1x,''Std. Dev. of data error ='',f10.6)', STDDEV
      print '(1x,''Solution coefficients   ='',3f10.6)', (C(J),J=1,N)

      call SCOV2( A, MMAX, N, IP, VAR, IERR)
      print '(1x,''Error flag from SCOV2   ='',i4)', IERR
      print '('' Covariance matrix of computed coefficients:'')'
      print '(1X)'
c++ Code for ~.C. is active
      do 30 I = 1,N
         print '(1x,3(3x,2i3,g16.8))', (I,J,A(I,J),J=I,N)
   30 continue
c++ Code for .C. is inactive
c%%   for (i = 0; i < n; i++){
c%%      for (j = i; j < n; j+=3){
c%%         for (k = j; k < (j < n - 3 ? j+3 : n); k++)
c%%              printf( "   %3ld%3ld%16.8g", i+1, k+1, a[k][i] );
c%%         printf( "\n" );}
c%%      }
c++ End
      stop
      end


      program DRDJACG1
c>>  2006-04-12 DRDJACG1 Hanson -- Reduced lengths of djacg work arrays.
c>>  2003-07-08 DRDJACG1 Hanson -- Check for MODE < 0.
c>>  2003-07-07 DRDJACG1 Krogh -- Changed 3 arg max to 2 arg for C conv.
c>>  2002-06-21 DRDJACG1 R. J. Hanson Example 1 Code, with Download
c     Demo driver for DJACG, using numerical derivatives for a gradient.
c     ------------------------------------------------------------------
c--   D replaces "?": DR?JACG1, ?JACG

c
c     The function used for this demo is f(y_1,y_2) = a*exp(b*y_1)+c*y_1
C     *(y_2)**2.
c     Its gradient vector is (df/dy_1,df/dy_2)=
C     (a*b*exp(b*y_1)+c*(y_2)**2, 2*c*y_1*y_2).
C     This is used for comparison of the computed results with actual
C     results.

C     This driver shows how to:

C     A. Compute approximate derivatives using one-sided divided
C     differences
C     B. Use one-sided differences on the first component and
C     analytically compute the second component
C     C. Accumulate a known term of the first component with a
C     differenced term that is not known a priori
C     D. Use central differences on both components
C     (No checking for error conditions, i.e. MODE < 0.)
C     Define sizes and parameters.

      INTEGER I, MODE, M, N, LDFJAC, LWK, LIWK
      PARAMETER(M=1, N=2, LDFJAC=M, LWK=3*M+18, LIWK=21)
      INTEGER IOPT(04), IWK(LIWK)
      DOUBLE PRECISION Y(N), F(M), FJAC(LDFJAC,N), XSCALE(N),
     .     FAC(N), WK(LWK), ACTUAL(LDFJAC,N), RE(4,2)
      DOUBLE PRECISION A, B, C, F2, U, MAXERR, D1MACH
      CHARACTER*55 WHAT(4)
      CHARACTER*1 uv
      DATA WHAT /
     .     'One sided partials, default settings',
     .     'One sided partial, second partial known and skipped',
     .     'One sided partials, first partial accumulated',
     .     'Central difference partials' /

C     Define data and point of evaluation:
      A=2.5D0
      B=3.4D0
      C=4.5D0

      Y(1)=2.1D0
      Y(2)=3.2D0
C     Machine precision, for measuring errors
      U=D1MACH(4)
C     Set defaults for increments and scaling:
      FAC(1)=0.D0
      XSCALE(1)=0.D0
C     Compute true values of partials.
      ACTUAL(1,1)=A*B*EXP(B*Y(1))+C*Y(2)**2
      ACTUAL(1,2)=2*C*Y(1)*Y(2)

C     A. No variable gets special treatment
      IOPT(1)=0
C     Start each problem with MODE=0.  Other starting
C     values are errors.  Values < 0 or > N are caught.
      MODE=0

 10   CONTINUE
      WK(1)=A*EXP(B*Y(1))+C*Y(1)*Y(2)**2
C      This sets the function value used in forming one-sided differences.
      IF(MODE .eq. 0) THEN
         F(1)=WK(1)
      END IF
      CALL DJACG(MODE,M,N,Y,F,
     .     FJAC,LDFJAC,XSCALE,FAC,IOPT,
     .     WK,LWK,IWK,LIWK)
      IF(MODE .gt. 0) GO TO 10
C     Check for an error condition.
      IF(MODE .lt. 0) THEN
         PRINT '('' Initial error in argument number '',I2)',-MODE
         GO TO 60
      END IF

C     Check the relative accuracy of one-sided differences.
C     They should be good to about half-precision.
      FJAC(1,1)=(FJAC(1,1)-ACTUAL(1,1))/ACTUAL(1,1)
      FJAC(1,2)=(FJAC(1,2)-ACTUAL(1,2))/ACTUAL(1,2)
      RE(1,1)=FJAC(1,1)/sqrt(U)
      RE(1,2)=FJAC(1,2)/sqrt(U)

C     B. Skip variable number 2.
      IOPT(1)= 1
      IOPT(2)=-4
      IOPT(3)= 2
      MODE=0

 20   CONTINUE
      WK(1)=A*EXP(B*Y(1))+C*Y(1)*Y(2)**2
      IF(MODE .eq. 0) THEN
         F(1)=WK(1)
C     The second component partial is skipped,
C     since it is known analytically
         FJAC(1,2)=2.D0*C*Y(1)*Y(2)
      END IF
      CALL DJACG(MODE,M,N,Y,F,
     .     FJAC,LDFJAC,XSCALE,FAC,IOPT,
     .     WK,LWK,IWK,LIWK)
      IF(MODE .gt. 0) GO TO 20

C     Check for an error condition.
      IF(MODE .lt. 0) THEN
        PRINT '('' Initial error in argument number '',I2)',-MODE
        GO TO 60
      END IF
      FJAC(1,1)=(FJAC(1,1)-ACTUAL(1,1))/ACTUAL(1,1)
      FJAC(1,2)=(FJAC(1,2)-ACTUAL(1,2))/ACTUAL(1,2)
      RE(2,1)=FJAC(1,1)/sqrt(U)
      RE(2,2)=FJAC(1,2)/sqrt(U)

C     C. Accumulate a part of the first partial.
      IOPT(1)=-3
      IOPT(2)= 1
C        Shift to using one-sided differences for the
C        rest of the variables.
      IOPT(3)=-1
      IOPT(4)=0

      MODE=0

 30   CONTINUE
C     Since part of the partial is known, evaluate what is
C     to be differenced.
      IF(MODE .ne. 2) WK(1)=A*EXP(B*Y(1))
      IF(MODE .eq. 0) THEN
C     Start with part of the derivative that is known.
         F(1)=WK(1)
         FJAC(1,1)=C*Y(2)**2
C     This is the function value for the partial wrt y_2.
         F2=C*Y(1)*Y(2)**2
      END IF

      IF(MODE .eq. 2) THEN
C     The function value for the second partial has the part removed
C     that depends on the first variable only.
         F(1)=F2
         WK(1)=C*Y(1)*Y(2)**2
      END IF
      CALL DJACG(MODE,M,N,Y,F,
     .     FJAC,LDFJAC,XSCALE,FAC,IOPT,
     .     WK,LWK,IWK,LIWK)

      IF(MODE .gt. 0) GO TO 30
C     Check for an error condition.
      IF(MODE .lt. 0) THEN
        PRINT '('' Initial error in argument number '',I2)',-MODE
        GO TO 60
      END IF

      FJAC(1,1)=(FJAC(1,1)-ACTUAL(1,1))/ACTUAL(1,1)
      FJAC(1,2)=(FJAC(1,2)-ACTUAL(1,2))/ACTUAL(1,2)
      RE(3,1)=FJAC(1,1)/sqrt(U)
      RE(3,2)=FJAC(1,2)/sqrt(U)

C     D. Use central differences and get more accuracy.
C        Twice the function evaluations are needed.
      IOPT(1)=-2
      IOPT(2)= 0

C     Set the increment used at the default value.
C     This value must be assigned when using central differences.
      WK(3*M+3)=0.D0

      MODE=0
 40   CONTINUE
      WK(1)=A*EXP(B*Y(1))+C*Y(1)*Y(2)**2
      IF(MODE .eq. 0) THEN
         F(1)=WK(1)
      END IF
      CALL DJACG(MODE,M,N,Y,F,
     .     FJAC,LDFJAC,XSCALE,FAC,IOPT,
     .     WK,LWK,IWK,LIWK)
      IF(MODE .gt. 0) GO TO 40
C     Check for an error condition.
      IF(MODE .lt. 0) THEN
         PRINT '('' Initial error in argument number '',I2)',-MODE
         GO TO 60
      END IF

C     Check the relative accuracy of central differences.
C     They should be good to about two thirds-precision.
      FJAC(1,1)=(FJAC(1,1)-ACTUAL(1,1))/ACTUAL(1,1)
      FJAC(1,2)=(FJAC(1,2)-ACTUAL(1,2))/ACTUAL(1,2)
      F2=(3.D0*U)**(2.D0/3.D0)
      RE(4,1)=FJAC(1,1)/F2
      RE(4,2)=FJAC(1,2)/F2

C     Output the results and what is expected.

      PRINT '(''Rel Err of partials, f= a*exp(b*y_1)+c*y_1*(y_2)**2.''/
     .''Case  df/dy_1  df/dy_2, u=macheps**.5, v=(3*macheps)**(2/3)'')'

      MAXERR=0.D0
      UV='u'
      DO 50 I=1,4
         MAXERR=max(MAXERR, max(ABS(RE(I,1)), ABS(RE(I,2))))
         IF(I .eq. 4) uv='v'
         PRINT '(I3, 2(F7.2,A1,2x), A55)',
     .            I,RE(I,1), uv, RE(I,2), uv, WHAT(I)
 50   CONTINUE
C     All expected relative errors (in units of truncation error)
C     should not exceed 8.  If they do there may be an error.
      IF(MAXERR .le. 8.D0) THEN
         PRINT '('' Numbers above with absolute values .le. 8 are '',
     . ''considered acceptable.'')'
      ELSE
         PRINT '('' Numbers above with absolute values .gt. 8 are '',
     . ''considered unacceptable.'')'
      END IF
 60   CONTINUE
      END


!
!     (c) 2019 Guide Star Engineering, LLC
!     This Software was developed for the US Nuclear Regulatory Commission (US NRC)
!     under contract "Multi-Dimensional Physics Implementation into Fuel Analysis under
!     Steady-state and Transients (FAST)", contract # NRC-HQ-60-17-C-0007
!
program test_dimensions
  !! label: Morfeus-FV
  !!
  !! Test dimensions class behavior

    use assertions_interface, only : assert
    use class_dimensions, only : dimensions, operator(==), operator(/=), length_, time_, velocity_, density_, &
    volume_, null_dim_, mass_, energy_

    implicit none

    type(dimensions) :: height_dimensions, displacement_dimensions
    type(dimensions) :: time_step_dimensions, time_dimensions
    type(dimensions) :: velocity_dimensions

    height_dimensions = length_
    displacement_dimensions = length_
    time_step_dimensions = time_
    time_dimensions = time_
    velocity_dimensions = velocity_

    call assert( height_dimensions == displacement_dimensions, "test_dimensions: operator(==)" )
    call assert( .not. (height_dimensions == time_step_dimensions), "test_dimensions: operator(==)" )
    call assert( height_dimensions /= time_step_dimensions, "test_dimensions: inequality operator(/=)" )
    call assert( displacement_dimensions / time_dimensions == velocity_, "test_dimensions: operator(/)" )
    call assert( height_dimensions == (height_dimensions + displacement_dimensions), "test_dimensions: operator(+)" )
    call assert( height_dimensions == (height_dimensions - length_), "test_dimensions: operator(-)" )
    call assert( mass_ / density_ == ( volume_), "test_dimensions: operator(/)" )
    call assert( (mass_ * velocity_) * velocity_ == ( energy_), "test_dimensions: operator(*)" )

    print *, "Test passed."

end program test_dimensions


! { dg-do run }
! { dg-require-effective-target fortran_large_int }
! Program to test the UNPACK intrinsic for a long integer type
program intrinsic_unpack
   implicit none
   integer,parameter :: k = selected_int_kind (range (0_8) + 1)
   integer(kind=k), dimension(3, 3) :: ak, bk
   logical, dimension(3, 3) :: mask
   character(len=100) line1, line2
   integer i

   mask = reshape ((/.false.,.true.,.false.,.true.,.false.,.false.,&
                    &.false.,.false.,.true./), (/3, 3/));

   ak = reshape ((/1, 0, 0, 0, 1, 0, 0, 0, 1/), (/3, 3/));
   bk = unpack ((/2_k, 3_k, 4_k/), mask, ak)
   if (any (bk .ne. reshape ((/1, 2, 0, 3, 1, 0, 0, 0, 4/), (/3, 3/)))) &
      call abort
   write (line1,'(10I4)') bk
   write (line2,'(10I4)') unpack((/2_k, 3_k, 4_k/), mask, ak)
   if (line1 .ne. line2) call abort
   bk = -1
   bk = unpack ((/2_k, 3_k, 4_k/), mask, 0_k)
   if (any (bk .ne. reshape ((/0, 2, 0, 3, 0, 0, 0, 0, 4/), (/3, 3/)))) &
      call abort

end program


module global_constants
    implicit none
    save

    real(8),parameter :: pi = 3.14159265d0
    integer,parameter :: xsd=1,ysd=2,zsd=3
    real(8),parameter :: TC=273.15, ZC=1.4, RC=2.87058e6
    real(8),parameter :: P0=1.01325e6, dens0=1.2922e-3
    real(8),parameter :: nDPML=20.0     ! the width of PML layers are determined by nDPML*(max size of elements)
    real(8),parameter,dimension(3) :: sigmaMaxPML=(/ 2.4e6, 2.4e6, 2.4e6 /)  ! \sigma_{max} for x/y/z-directions
    real(8),parameter,dimension(4) :: uvwpAvgPML=(/ 0.0, 0.0, 0.0, 0.0 /)    ! pseudo mean flow velocities

end module global_constants


MODULE Routines
  IMPLICIT NONE
  CONTAINS

FUNCTION delta2(No_data,z,p,del,alpha,z_data,sigma_data)
 IMPLICIT NONE

  INTEGER,INTENT(IN) :: No_data
  REAL*8,INTENT(IN),DIMENSION(No_data) :: z_data, sigma_data
  REAL*8,INTENT(IN) :: z,p,del,alpha
!  REAL*8,PARAMETER :: del = 1.0D0			!type 1: power 1.5 delta 0.3 and const. 1.9  ---- type 2 delta 0.1 const 1.8
  REAL*8 :: delta2
  INTEGER :: i

  delta2 = 0.0D0
  DO i = 1,No_data
	delta2 = delta2 + (((1.0D0)/((sigma_data(i))**2))*(EXP(-1.0D0*(( (z-z_data(i))/(del))**2))))	!for type 1 -- 2 power is 1.5
 END DO
  delta2 = (alpha)*((1.0D0/delta2)**(1.0D0/p))

 RETURN
END FUNCTION delta2

FUNCTION delta(No_data,z,z_data,sigma_data)
IMPLICIT NONE
	INTEGER,INTENT(IN) :: No_data
	REAL*8,INTENT(IN),DIMENSION(No_data) :: z_data, sigma_data
	REAL*8,INTENT(IN) :: z!,del,p
	REAL*8,PARAMETER :: del = 0.1D0,p = 1.5			!type 1: power 1.5 delta 0.3 and const. 1.9  ---- type 2 delta 0.1 const 1.8
	REAL*8 :: delta
	INTEGER :: i
	delta = 0.0D0
	DO i = 1,No_data
	delta = delta + EXP(-1.0D0*(( ((z-z_data(i))*(sigma_data(i))**(p))/(del))**2))	!for type 1 -- 2 power is 1.5
	END DO
    delta = 0.2D1-(delta/580.0D0)-0.2
RETURN
END FUNCTION delta

!==========================================================================
!		DM_flat
!
!	This function gives the	Distance modulus for F-LCDM univers.
!	inputs: Omega matter: Om	Hubble const.: H0	Redshift: X2
!
!==========================================================================
FUNCTION DM_flat (X2, H0, Om)
  IMPLICIT NONE
  REAL*8 :: DM_flat
  INTEGER :: i,n
  REAL*8 :: X1, H_X1, sum2
  REAL*8, INTENT (IN) :: X2, H0, Om

  sum2 = 0.0D0
  X1 = 0.0D0
  n = 100
  H_X1=(X2-X1)/float(n)
  DO i = 1, n
     sum2 = sum2 +((1.0D0)/(sqrt((Om)*((X1+1.0D0)**3)+1.0D0-Om)))
     X1=X1+H_X1
  END DO
  sum2=(sum2)*((1.0D0+X2)*(3.0D5)*(H_X1/H0))
  DM_flat = 5.0D0*LOG10(sum2) + 25.0D0
RETURN
END FUNCTION DM_flat

!		Hubble parameter
FUNCTION Hubfunc (X2, Omega)
	IMPLICIT NONE

	REAL*8 :: Hubfunc
	REAL*8, INTENT (IN) :: X2, Omega
!	Hubfunc = SQRT((Omega)*((1.0+X2)**3) + 1.0-(Omega))
	Hubfunc = SQRT((Omega)*((X2+1.0D0)**3)+(1.0D0-Omega)*(Kink_rho (X2)))
RETURN
END FUNCTION Hubfunc

!

!		Hubble parameter
FUNCTION Hubfunc_lcdm (X2, Omega)
	IMPLICIT NONE

	REAL*8 :: Hubfunc_lcdm
	REAL*8, INTENT (IN) :: X2, Omega
	Hubfunc_lcdm = SQRT((Omega)*((1.0+X2)**3) + 1.0-(Omega))
RETURN
END FUNCTION Hubfunc_lcdm
!
!
FUNCTION w(z)
IMPLICIT NONE
	REAL*8,PARAMETER :: w0 = -1.0D0,wm = -0.5D0,zt = 0.5D0,delta_t = 0.5D-1
	REAL*8 :: w
	REAL*8,INTENT(IN) :: z
	w = (3.0D0/(1.0D0+z))*(1.0D0+w0 + ((wm-w0)*((1.0D0+EXP(1.0D0/(delta_t*(1.0D0+zt))))/(1.0D0-EXP(1.0D0/delta_t)))*(1.0D0- &
	((EXP(1.0D0/delta_t)+EXP(1.0D0/(delta_t*(1.0D0+zt))))/(EXP(1.0D0/(delta_t*(1.0D0+z)))+EXP(1.0D0/(delta_t*(1.0D0+zt))))))))
RETURN
END FUNCTION w

FUNCTION Kink_rho (b)
IMPLICIT NONE
    real*8, parameter:: a=0.0D0
    integer, parameter :: n = 100
	INTEGER :: i
	REAL*8 :: h, sum, x,rho
	REAL*8,INTENT(IN) :: b
	REAL*8 :: Kink_rho

	h = (b-a)/real(n)
	rho = 0.0D0
	rho = 0.5D0*(w(a) + w(b))
	DO  i=1,n-1
		x = a + i*h
		rho = rho + w(x)
	END DO

Kink_rho = EXP(h*rho)
RETURN
END FUNCTION Kink_rho

FUNCTION Kink_mu (X2, H0)
 IMPLICIT NONE

 INTEGER :: i,n

 REAL*8, PARAMETER :: Om = 0.3D0
 REAL*8 :: X1, H_X1, sum2,rho
 REAL*8, INTENT (IN) :: X2, H0
 REAL*8 :: Kink_mu

 sum2 = 0.0D0
 X1 = 0.0D0
 n = 100
 H_X1=(X2-X1)/float(n)

  DO i = 1, n
    sum2 = sum2 +((1.0D0)/(sqrt((Om)*((X1+1.0D0)**3)+(1.0D0-Om)*(Kink_rho (X1)))))
    X1=X1+H_X1
  END DO

 sum2=(sum2)*((1.0D0+X2)*(3.0D5)*(H_X1/H0))
 Kink_mu = 5.0D0*LOG10(sum2) + 25.0D0

RETURN
END FUNCTION Kink_mu

SUBROUTINE LCDM_qOm (No_bins,z,q,Om,Omega,H)
IMPLICIT NONE

 INTEGER,INTENT(IN) :: No_bins
 REAL*8,DIMENSION(No_bins),INTENT(IN) :: z
 REAL*8,DIMENSION(No_bins),INTENT(OUT) :: q,Om,H
 REAL*8,INTENT(IN) :: Omega
 REAL*8 :: x
 INTEGER :: j

 DO j=2,(No_bins-1)
   x = z(j)
   H(j) = Hubfunc_lcdm (x, Omega)
 END DO

	DO j=3,(No_bins-2)
		q(j) = (( (1+z(j)) / (H(j))) * ((H(j+1)-H(j-1))/(z(j+1)-z(j-1)))) - 1.0D0
	END DO
	DO j=3,(No_bins-2)
		Om(j) = (((H(j+1))**2)-((H(j-1))**2))/(((1.0D0+z(j+1))**3)-((1.0D0+z(j-1))**3))
	END DO

RETURN
END SUBROUTINE LCDM_qOm

!
!	This routine computes deceleration parameter for Kink universe
!
SUBROUTINE Kink_qOm (No_bins,z,q,Om,Omega,H)
IMPLICIT NONE

 INTEGER,INTENT(IN) :: No_bins
 REAL*8,DIMENSION(No_bins),INTENT(IN) :: z
 REAL*8,DIMENSION(No_bins),INTENT(OUT) :: q,Om,H
 REAL*8,INTENT(IN) :: Omega
 REAL*8 :: x
 INTEGER :: j

 DO j=2,(No_bins-1)
   x = z(j)
   H(j) = Hubfunc (x, Omega)
 END DO

	DO j=3,(No_bins-2)
		q(j) = (( (1+z(j)) / (H(j))) * ((H(j+1)-H(j-1))/(z(j+1)-z(j-1)))) - 1.0D0
	END DO
	DO j=3,(No_bins-2)
		Om(j) = (((H(j+1))**2)-((H(j-1))**2))/(((1.0D0+z(j+1))**3)-((1.0D0+z(j-1))**3))
	END DO

RETURN
END SUBROUTINE Kink_qOm
!
!
!	Routine to calculate the residual square between DM_data and Kink model
SUBROUTINE LF_Kinkmu (No_data,chi_min,z_data, DM_data,sigma_data)
	IMPLICIT NONE

	INTEGER :: i,j,t
	REAL*8 :: x, chi, H0
	INTEGER,INTENT(IN) :: No_data
	REAL*8,INTENT(OUT),DIMENSION(3) :: chi_min
	REAL*8,INTENT(IN),DIMENSION(No_data) :: z_data,sigma_data
	REAL*8,INTENT(IN),DIMENSION(3,No_data) :: DM_data
	chi_min = 10.0D5

DO t = 1,3
	H0 = 68.0D0
	DO j = 1,4
		chi = 0.0D0

		DO i = 1, No_data
			x = z_data(i)
			chi = chi + ((Kink_mu (x, H0) - (DM_data(t,i)))/(sigma_data(i)))**2
		END DO

		IF (chi .LE. chi_min(t)) THEN
		chi_min(t) = chi
		END IF

	H0 = H0 + 1.0D0
	END DO
END DO

RETURN
END SUBROUTINE LF_Kinkmu

!
!	Routine to calculate the residual square between DM_data and Kink model
SUBROUTINE LF_muLCDM (No_data,chi_min,H0_best,Om,z_data,sigma_data)
	IMPLICIT NONE

	INTEGER :: i,j
	REAL*8 :: x, chi, H0
	INTEGER,INTENT(IN) :: No_data
	REAL*8,INTENT(OUT) :: chi_min
    real*8,intent(in) :: H0_best,Om
	REAL*8,INTENT(IN),DIMENSION(No_data) :: z_data,sigma_data

	chi_min = 10.0D5
!	H0 = 68.0D0
!	DO j = 1, 10
	H0 = H0_best
		chi = 0.0D0

		DO i = 1, No_data
			x = z_data(i)
			chi = chi + ((Kink_mu (x, H0) - (  DM_flat (x, H0, Om)  ))/(sigma_data(i)))**2
		END DO

		IF (chi .LE. chi_min) THEN
!			H0_best = H0
			chi_min = chi
		END IF

!	H0 = H0 + 0.5D0
!	END DO
RETURN
END SUBROUTINE LF_muLCDM

!
SUBROUTINE Lf_OmQ (No_bins,Om,q,chi,chi2,LF_q_sum,Om_true,q_true,sigma_data)
	IMPLICIT NONE
	INTEGER,INTENT(IN) :: No_bins
	REAL*8,INTENT(IN),DIMENSION(3,No_bins) :: Om,q
	REAL*8,INTENT(IN),DIMENSION(No_bins) ::sigma_data
	REAL*8,DIMENSION(No_bins) :: q_sum
	REAL*8,INTENT(OUT),DIMENSION(3) :: chi,chi2
	REAL*8,INTENT(OUT) :: LF_q_sum
	INTEGER :: i,t
	REAL*8,INTENT(IN),DIMENSION(No_bins) :: Om_true,q_true

	chi = 0.0D0
	chi2 = 0.0D0

DO t =1,3
	DO i = 3, (No_bins-2)
		chi(t) = chi(t) +  ( ((Om(t,i)) - (Om_true(i)))/(sigma_data(i))   )**2
	END DO
	DO i = 3, (No_bins-2)
		chi2(t) = chi2(t) + (((q(t,i)) - (q_true(i)))/(sigma_data(i)) )**2
	END DO
END DO

	LF_q_sum = 0D0
	q_sum = SUM(q,DIM = 1)
	q_sum = (q_sum)/(3.0D0)
	DO i = 3, (No_bins-2)
		LF_q_sum = LF_q_sum + (((q_sum(i)) - (q_true(i)))/(sigma_data(i)) )**2
	END DO

RETURN
END SUBROUTINE Lf_OmQ

!LF_h_sum,LF_q_sum
SUBROUTINE Lf_hubble (No_bins,H,z,chi,Omega,LF_h_sum,sigma_data)
	IMPLICIT NONE
	INTEGER,INTENT(IN) :: No_bins
	REAL*8,INTENT(IN),DIMENSION(No_bins) :: z,sigma_data
	REAL*8,INTENT(IN),DIMENSION(3,No_bins) :: H
	REAL*8,INTENT(OUT),DIMENSION(3) :: chi
	REAL*8,INTENT(OUT) :: LF_h_sum
	REAL*8,INTENT(IN) :: Omega
	REAL*8,DIMENSION(No_bins) :: H_sum
	REAL*8 :: x
	INTEGER :: i,j

	chi = 0.0D0
DO j = 1,3

	DO i = 2, (No_bins-1)
		x = z(i)
		chi(j) = chi(j) +  (( (H(j,i)) - (Hubfunc(x,Omega))  )/(sigma_data(i)) )**2
	END DO
END DO

    H_sum = SUM(H, DIM = 1)
	H_sum = (H_sum)/(3.0D0)
    LF_h_sum = 0D0
	DO i = 2, (No_bins-1)
		x = z(i)
		LF_h_sum = LF_h_sum +  (( (H_sum(i)) - (Hubfunc(x,Omega))  )/(sigma_data(i)) )**2
	END DO

RETURN
END SUBROUTINE Lf_hubble

!
SUBROUTINE Reconstruction (No_bins,DM,z,H,q)
 IMPLICIT NONE

  INTEGER :: j
  REAL*8 :: H0
  INTEGER,INTENT(IN) :: No_bins
  REAL*8,INTENT(IN),DIMENSION(No_bins):: z
  REAL*8,INTENT(IN),DIMENSION(No_bins):: DM
  REAL*8,DIMENSION(No_bins):: L
  REAL*8,INTENT(OUT),DIMENSION(No_bins):: H,q!,Om

  H = 0.0D0;q = 0.0D0

  DO j = 1, No_bins
	L (j) = (1.0D0/3.0D10)*((10.0D0**((DM (j))/(5.0D0)))/(1.0D0 + z(j))) ! in Mpc.s/Km
  END DO

  H (1) = (z(2)-z(1))/(L(2)-L(1))
  DO j = 2, (No_bins-1)
	H (j) = (z(j+1)-z(j-1))/((L(j+1)-L(j-1)))
  END DO
  H0 = ((-1.0*z(2))*((H(3)-H(2))/(z(3)-z(2))))+H(2)! By extrapolation I find H(z = 0) and then devide all values by that to get h(z) = H(z)/H(0)

!	dividing H(z) by H(z = 0)
  DO j = 2, (No_bins-1)
	H (j) = H (j)/H0
  END DO

  DO j=3,(No_bins-2)
	q(j) = (( (1+z(j)) / (H(j))) * ((H(j+1)-H(j-1))/(z(j+1)-z(j-1)))) - 1.0D0
  END DO

!  DO j=3,(No_bins-2)
!	Om(j) = (((H(j+1))**2)-((H(j-1))**2))/(((1.0D0+z(j+1))**3)-((1.0D0+z(j-1))**3))
!  END DO

RETURN
END SUBROUTINE Reconstruction

!
!
!
SUBROUTINE interpolate(No_data,No_bins,z,X,z_data,Y)
  IMPLICIT NONE

  INTEGER :: i,j
  INTEGER,INTENT(IN) :: No_data,No_bins
  REAL*8,INTENT(IN),DIMENSION(No_bins) :: z,X
  REAL*8,INTENT(IN),DIMENSION(No_data) :: z_data
  REAL*8,INTENT(OUT),DIMENSION(No_data) :: Y

 do j=1,No_bins
	   do i = 1, No_data
		IF (z_data(i) .LE. z(j+1) .AND. z_data(i) .GE. z(j)) Y(i) = ((z_data(i)-z(j))*((X(j+1)-X(j))/(z(j+1)-z(j))))+X(j)
       end do
 end do
RETURN
END SUBROUTINE interpolate

SUBROUTINE interpolate2(No_data,No_bins,z,X,z_data,Y)
  IMPLICIT NONE

  INTEGER :: i,j,t
  INTEGER,INTENT(IN) :: No_data,No_bins
  REAL*8,INTENT(IN),DIMENSION(No_bins) :: z
  REAL*8,INTENT(IN),DIMENSION(3,No_bins) :: X
  REAL*8,INTENT(IN),DIMENSION(No_data) :: z_data
  REAL*8,INTENT(OUT),DIMENSION(3,No_data) :: Y

do t = 1, 3

 do j=1,No_bins
	   do i = 1, No_data
		IF (z_data(i) .LE. z(j+1) .AND. z_data(i) .GE. z(j)) Y(t,i) = ((z_data(i)-z(j))*((X(t,j+1)-X(t,j))/(z(j+1)-z(j))))+X(t,j)
       end do
 end do

end do

RETURN
END SUBROUTINE interpolate2

! to sort data sort p,... based on p>q or q>p
Subroutine Order(p,q,p1,q1,p2,q2)
implicit none
real*8 p,q,temp,p1,q1,p2,q2
  if (p>q) then
    temp=p
    p=q
    q=temp

    temp=p1
    p1=q1
    q1=temp

    temp=p2
    p2=q2
    q2=temp
  end if
  return
end Subroutine Order

Subroutine Bubble(A,B,C, n)
implicit none

real*8 A(1:n),B(1:n),C(1:n)
integer n,i,j

  do i=1, n
    do j=n, i+1, -1
      call Order(A(j-1), A(j),B(j-1), B(j),C(j-1), C(j))
    end do
  end do
  return
end Subroutine Bubble

!	Routine to calculate the residual square between DM_data and function DM_flat
SUBROUTINE Chi_flat (No_data,chi_min,H0_best,z_data, DM_data, sigma_data,Om)
	IMPLICIT NONE

	INTEGER :: i,j
	REAL*8 :: x, chi, H0
	INTEGER,INTENT(IN) :: No_data
	REAL*8,INTENT(OUT) :: chi_min,H0_best
	REAL*8,INTENT(IN) :: Om
	REAL*8,INTENT(IN),DIMENSION(No_data) :: z_data, DM_data, sigma_data

	chi_min = 10.0D5
	H0 = 65.0D0
	DO j = 1, 10
		chi = 0.0D0

		DO i = 1, No_data
			x = z_data(i)
			chi = chi + (( DM_flat (x,H0,Om) - (DM_data(i))  ) / (sigma_data(i)) )**2
		END DO

		IF (chi .LE. chi_min) THEN
			H0_best = H0
			chi_min = chi
		END IF

	H0 = H0 + 1.0D0
	END DO
RETURN
END SUBROUTINE Chi_flat

!==========================================================================
!				Chi_LCDM
!
!	This routine calculate chi-square between the function DM_flat and data DM_data
!	DM_flat is distance modulus in flat LCDM universe
!
!	inputs: DM_data,z_data,sigma_data,No_data
!	outputs: chi_min,H0 best, Om best
!
!==========================================================================
SUBROUTINE Chi_LCDM (No_data,z_data, DM_data, sigma_data,chi_min,H0_best,Om_best)
  IMPLICIT NONE

  INTEGER :: m,n,i
  INTEGER,INTENT(IN) :: No_data
  REAL*8,INTENT(IN),DIMENSION(No_data) :: z_data, DM_data, sigma_data
  REAL*8,INTENT(OUT) :: chi_min,H0_best,Om_best
  REAL*8 :: H01,Om1,chi2,z1

  chi_min = 10.0D5
  H01 = 68.0D0
  DO n = 1, 100
	 Om1 = 0.1D-10
	 DO m = 1,100
	     chi2 = 0.0D0

	     DO i = 1, No_data
	       z1 = z_data(i)
	       chi2 = chi2 + (((  DM_flat (z1,H01,Om1)) - (DM_data(i))  ) / (sigma_data(i)) )**2
	     END DO

	    IF (chi2 .LE. chi_min) THEN
	    	chi_min = chi2
	    	Om_best = Om1
			H0_best = H01
	    END IF

	 Om1 = Om1 + 0.01D0
	 END DO
  H01 = H01 + 0.1D0
  END DO
RETURN
END SUBROUTINE Chi_LCDM

!==========================================================================
!		Initial_guess
!
!	This routine 1- defines the grids, given binsize from the min - max of redshifts (data)
!				 2- based on F-LCDM universe (DM_flat function) initialize the smoothing method
!
!	inputs: No_data, No_bins	z_data: redshift of data	binsize
!			H0: hubble parameter	Om: matter density
!
!	outputs: DM_guess_data/bins : distance modulus on data points/grids
!==========================================================================
SUBROUTINE Initial_guess (No_data,No_bins,z_data,H0,binsize,Om,DM_guess_data,DM_guess_bins)
 IMPLICIT NONE

  INTEGER :: j,i
  INTEGER,INTENT(IN) :: No_data,No_bins
  REAL*8,INTENT(OUT),DIMENSION(No_data)  :: DM_guess_data
  REAL*8,INTENT(OUT),DIMENSION(No_bins) :: DM_guess_bins
  REAL*8,INTENT(IN),DIMENSION(No_data) :: z_data
  REAL*8,INTENT(IN) :: H0,binsize,Om
  REAL*8 :: z1,Mu

  DM_guess_bins = 0.0D0
  DM_guess_data = 0.0D0

  z1 = MINVAL(z_data)-(1.5D0*binsize)
  DO j = 1, No_bins
	DM_guess_bins(j) = DM_flat (z1, H0, Om)
	z1 = z1 + binsize
  END DO
!
!
  DO i = 1, No_data
   z1 = z_data(i)
   DM_guess_data (i) = DM_flat (z1, H0, Om)
  END DO

RETURN
END SUBROUTINE Initial_guess

SUBROUTINE Displacement (No_data,DM_smooth_data, DM_data,sigma_data,shift_best,chi_smooth,chi_min)
	IMPLICIT NONE
	INTEGER,INTENT(IN) :: No_data
	REAL*8,INTENT(IN),DIMENSION(No_data) :: DM_smooth_data, DM_data,sigma_data
	REAL*8,INTENT(OUT) :: shift_best,chi_min
	real*8,intent(out),dimension(No_data) :: chi_smooth
	real*8,dimension(No_data) :: chi
	REAL*8 :: shift
	INTEGER :: i

	chi_min = 10D5
	shift_best = 0.0D0
	chi = 0.0D0

!   shift = 0.0D0
	shift = -0.05D0	! this is kinda marginalization over hubble, since hubble constant move data vertically
	DO WHILE (shift .LE. 0.05D0 )

	DO i = 1, No_data
		chi(i) = (( (DM_smooth_data(i) + shift) - (DM_data(i))  ) / (sigma_data(i)) )
	END DO
	IF (sum(chi**2) .LE. chi_min) THEN
		shift_best = shift
		chi_min = sum(chi**2)
		chi_smooth = chi
!		PRINT*,"Guess model is shifted",shift_best,chi_min !To see the effect of data movement in each step
	END IF
!		PRINT*,"Guess model is shifted",shift,chi !To see the effect of data movement in each step
	shift = shift + 0.1D-3
	END DO
!		PRINT*,"Guess model is shifted",shift_best,chi_min !To see the effect of data movement in each itera
RETURN
END SUBROUTINE Displacement
!==========================================================================
!		Smoothing
!
!	This routine does the smoothing
!
!
!
!==========================================================================
SUBROUTINE Smoothing (No_data,No_bins,z_data,sigma_data,DM_data,DM_guess_data,DM_smooth_data,z,&
											DM_guess_bins,DM_smooth_bins,delta_ar_bin,delta_ar_data)
 IMPLICIT NONE

  REAL*8 :: kernel1,kernel
  INTEGER :: i,j
  INTEGER,INTENT(IN) :: No_data,No_bins
  REAL*8,INTENT(IN),DIMENSION(No_data) :: z_data,sigma_data,DM_data,delta_ar_data
  REAL*8,INTENT(INOUT),DIMENSION(No_data) :: DM_guess_data
  REAL*8,INTENT(OUT),DIMENSION(No_data) :: DM_smooth_data
  REAL*8,INTENT(IN),DIMENSION(No_bins) :: z,delta_ar_bin
  REAL*8,INTENT(INOUT),DIMENSION(No_bins) :: DM_guess_bins
  REAL*8,INTENT(OUT),DIMENSION(No_bins) ::	DM_smooth_bins

  DM_smooth_data = 0.0D0
  DM_smooth_bins = 0.0D0

  DO i = 1, No_data
     CALL Normalization2 (z_data,delta_ar_data,No_data, i, sigma_data, DM_data, DM_guess_data, kernel1)
     DM_smooth_data (i) = DM_guess_data (i) + kernel1
 END DO

  DO i = 1, No_data
     DM_guess_data (i) = DM_smooth_data (i)
  END DO

  DO j = 1 , No_bins
	CALL Normalization (z_data,delta_ar_bin,z, No_bins, No_data, j, sigma_data, DM_data, DM_guess_data, kernel)
	DM_smooth_bins(j) = DM_guess_bins (j) + kernel
  END DO

  DO j = 1 , No_bins
    DM_guess_bins (j) = DM_smooth_bins (j)
  END DO

RETURN
END SUBROUTINE Smoothing
!================================================
!	This subroutine computes the kernel in smoothing formula for data points
!	INPUTS:
!	1) No_data1 : # of SN-data
!	2) z_data1: redshift of SN-data
!	3) DM_guess_data1: guess of distance modulus in data points
!	4) DM_data1: distance modulus of SN-data
!	5) sigma_data1: variance in distance modulus of SNs
!	6) Delta1: the smoothing width (Remind: it is asked in the program from the user
!
!
!	OUTPUT:
!	kernel2: it is the kernel term in smoothing formula
!================================================

! This routine calculte the kernel term for data points

SUBROUTINE Normalization2 (z_data1,delta_ar_data,No_data1, i1, sigma_data1, DM_data1, DM_guess_data1, kernel2)
  IMPLICIT NONE

  INTEGER :: m
  INTEGER,INTENT (IN) :: No_data1, i1
  REAL*8,DIMENSION(No_data1),INTENT(IN) :: z_data1, DM_data1, sigma_data1,delta_ar_data
  REAL*8,DIMENSION(No_data1),INTENT(IN) :: DM_guess_data1
  REAL*8,INTENT(OUT) :: kernel2
  REAL*8 :: N,z

  kernel2 = 0.0D0
  N = 0.0D0
  DO m = 1, No_data1
    N = N + ( (EXP(-0.5D0*(((log((1.0D0+z_data1(m))/(1.0D0+z_data1(i1))))/(delta_ar_data(i1)))**2)))*(1.0D0/((sigma_data1(m))**2)))
  END DO

  DO m = 1, No_data1
    kernel2 = kernel2 + ( ((DM_data1(m)) - (DM_guess_data1(m))) / ((sigma_data1(m))**2) ) * &
     (EXP(-0.5D0*(((log((1.0D0+z_data1(m))/(1.0D0+z_data1(i1))))/(delta_ar_data(i1)))**2)))
  END DO
  kernel2 = (1.0D0/(N))*(kernel2)

RETURN
END SUBROUTINE Normalization2

!	 This routine calculte the kernel term for grids

SUBROUTINE Normalization (z_data1,delta_ar_bin, z1, No_bins1, No_data1, j1, sigma_data1, DM_data1, DM_guess_data1, kernel2)
  IMPLICIT NONE

  INTEGER :: m
  INTEGER,INTENT (IN) :: No_data1, j1, No_bins1

  REAL*8,DIMENSION(No_data1),INTENT(IN) :: z_data1, DM_data1, sigma_data1
  REAL*8,DIMENSION(No_data1),INTENT(IN) :: DM_guess_data1
  REAL*8,DIMENSION(No_bins1),INTENT(IN) :: z1,delta_ar_bin
  REAL*8,INTENT(OUT) :: kernel2
  REAL*8 :: N,z

  kernel2 = 0.0D0
  N = 0.0D0
  DO m = 1, No_data1
    N = N + ((EXP(-0.5D0*(((log((1.0D0+z_data1(m))/(1.0D0+z1(j1))))/(delta_ar_bin(j1)))**2)))* &
   (1.0D0/((sigma_data1(m))**2)))
  END DO

  DO m = 1, No_data1
    kernel2 = kernel2 + ( ((DM_data1(m)) - (DM_guess_data1(m))) / ((sigma_data1(m))**2) ) * &
    (EXP(-0.5D0*(((log((1.0D0+z_data1(m))/(1.0D0+z1(j1))))/(delta_ar_bin(j1)))**2)))
  END DO
  kernel2 = (1.0D0/(N))*(kernel2)

RETURN
END SUBROUTINE Normalization

END MODULE Routines