!------------------------------------------------------------------
module rebin

  !rebin Power Spectrum variables
  double precision, allocatable :: reb_freq(:), reb_pds(:), &
       reb_err_pds(:)

  !rebin lag vs frequency variables
  double precision, allocatable :: rc_freq_reb(:), ic_freq_reb(:)
  double precision, allocatable :: reb_lag_freq(:), reb_err_cohe_lag(:), reb_err_prop_lag(:)
  double precision, allocatable :: std_rc_freq_reb(:), std_ic_freq_reb(:)

contains
  subroutine rebin_PDS(freq, pds_int, int_number, int_len_dim, reb_dim)
    implicit none

    integer         , intent(IN)  :: int_number, int_len_dim
    double precision, intent(IN)  :: freq(int_len_dim / 2), pds_int(int_number, int_len_dim / 2)

    integer              :: i, j, k, reb_dim, start, end_reb
    double precision     :: reb_fac
    integer, allocatable :: reb_array(:)
    double precision, allocatable :: reb_pds2(:)

    if(allocated(reb_array  )) deallocate(reb_array)
    if(allocated(reb_freq   )) deallocate(reb_freq)
    if(allocated(reb_pds    )) deallocate(reb_pds )
    if(allocated(reb_err_pds)) deallocate(reb_err_pds)
    if(allocated(reb_pds2   )) deallocate(reb_pds2 )

    write(*,*) '   Choose exponensial rebinning factor'
    read(*,*) reb_fac
    print *, ' '

    allocate(reb_freq (int_len_dim /2))
    allocate(reb_array(int_len_dim /2))

!Finds out the dimension of the rebinned array and the rebin indexes
    call rebin_log(freq, reb_freq, reb_array, int_len_dim / 2, reb_dim, reb_fac)

    allocate(reb_pds    (reb_dim))
    allocate(reb_pds2   (reb_dim))
    allocate(reb_err_pds(reb_dim))

    reb_pds  = 0.d0
    reb_pds2 = 0.d0

    do i = 1, int_number
       start   = 0
       end_reb = 0
       do j = 1, reb_dim
          start   = end_reb + 1
          end_reb = end_reb + reb_array(j)

          do k = start, end_reb
             reb_pds (j) = reb_pds (j) + pds_int(i, k)
             reb_pds2(j) = reb_pds2(j) + pds_int(i, k) * pds_int(i, k)
          enddo
       enddo
    enddo

    do j = 1, reb_dim - 1
       reb_pds (j) = reb_pds (j) / dble(int_number * reb_array(j))
       reb_pds2(j) = reb_pds2(j) / dble(int_number * reb_array(j))
       reb_err_pds(j) = sqrt((reb_pds2(j) - reb_pds(j)**2 ) / dble(int_number * reb_array(j)))

    enddo

    if (allocated(reb_array)) deallocate(reb_array)
    if (allocated(reb_pds2 )) deallocate(reb_pds2)

  end subroutine rebin_PDS

  subroutine rebin_lag_freq(freq, rc_freq, ic_freq, pw_freq1, pw_freq2, int_number, int_len_dim, reb_dim)
    implicit none

    integer         , intent(IN)  :: int_number, int_len_dim
    double precision, intent(IN)  :: freq(int_len_dim / 2), rc_freq(int_number, int_len_dim / 2), ic_freq(int_number, int_len_dim / 2), &
         pw_freq1(int_number, int_len_dim / 2), pw_freq2(int_number, int_len_dim / 2)

    integer              :: i, j, k, reb_dim, start, end_reb
    double precision     :: reb_fac, bias2
    integer, allocatable :: reb_array(:)

    double precision, parameter   :: pi = acos(-1.0)
    double precision, allocatable :: rc2_freq_reb(:), &
         ic2_freq_reb(:), rc_ic_freq_reb(:), pw_freq1_reb(:), &
         pw_freq2_reb(:), pw2_freq1_reb(:), pw2_freq2_reb(:)
    double precision, allocatable :: deriv_rc(:), deriv_ic(:), &
         reb_coher2_freq(:), reb_covariance(:)

    if(allocated(reb_freq        )) deallocate(reb_freq        )
    if(allocated(reb_array       )) deallocate(reb_array       )

    if(allocated(reb_lag_freq    )) deallocate(reb_lag_freq    )
    if(allocated(reb_lag_freq    )) deallocate(reb_lag_freq    )
    if(allocated(reb_err_cohe_lag)) deallocate(reb_err_cohe_lag)
    if(allocated(reb_err_prop_lag)) deallocate(reb_err_prop_lag)
    if(allocated(std_rc_freq_reb )) deallocate(std_rc_freq_reb )
    if(allocated(std_ic_freq_reb )) deallocate(std_ic_freq_reb )
    if(allocated(rc_freq_reb     )) deallocate(rc_freq_reb     )
    if(allocated(ic_freq_reb     )) deallocate(ic_freq_reb     )

    write(*,*) '   Choose exponensial rebinning factor'
    read(*,*) reb_fac
    print *, ' '

    allocate(reb_freq (int_len_dim /2))
    allocate(reb_array(int_len_dim /2))

!Finds out the dimension of the rebinned array and the rebin indexes
    call rebin_log(freq, reb_freq, reb_array, int_len_dim / 2, reb_dim, reb_fac)

    if(.not. allocated(rc_freq_reb)   ) allocate(rc_freq_reb   (reb_dim))
    if(.not. allocated(ic_freq_reb)   ) allocate(ic_freq_reb   (reb_dim))
    if(.not. allocated(rc2_freq_reb)  ) allocate(rc2_freq_reb  (reb_dim))
    if(.not. allocated(ic2_freq_reb)  ) allocate(ic2_freq_reb  (reb_dim))
    if(.not. allocated(rc_ic_freq_reb)) allocate(rc_ic_freq_reb(reb_dim))
    if(.not. allocated(pw_freq1_reb)  ) allocate(pw_freq1_reb  (reb_dim))
    if(.not. allocated(pw_freq2_reb)  ) allocate(pw_freq2_reb  (reb_dim))
    if(.not. allocated(pw2_freq1_reb) ) allocate(pw2_freq1_reb (reb_dim))
    if(.not. allocated(pw2_freq2_reb) ) allocate(pw2_freq2_reb (reb_dim))

    rc_freq_reb    = 0.d0
    ic_freq_reb    = 0.d0
    rc2_freq_reb   = 0.d0
    ic2_freq_reb   = 0.d0
    rc_ic_freq_reb = 0.d0
    pw_freq1_reb   = 0.d0
    pw_freq2_reb   = 0.d0
    pw2_freq1_reb  = 0.d0
    pw2_freq2_reb  = 0.d0

    do i = 1, int_number
       start   = 0
       end_reb = 0
       do j = 1, reb_dim
          start   = end_reb + 1
          end_reb = end_reb + reb_array(j)
          ! write(*,*) j, start, end_reb

          do k = start, end_reb
             rc_freq_reb   (j) = rc_freq_reb   (j) + rc_freq(i, k)
             ic_freq_reb   (j) = ic_freq_reb   (j) + ic_freq(i, k)
             rc2_freq_reb  (j) = rc2_freq_reb  (j) + (rc_freq(i, k) * rc_freq(i, k))
             ic2_freq_reb  (j) = ic2_freq_reb  (j) + (ic_freq(i, k) * ic_freq(i, k))
             rc_ic_freq_reb(j) = rc_ic_freq_reb(j) + (rc_freq(i, k) * ic_freq(i, k))
             pw_freq1_reb  (j) = pw_freq1_reb  (j) + pw_freq1(i, k)
             pw2_freq1_reb (j) = pw2_freq1_reb (j) + (pw_freq1(i, k) * pw_freq1(i, k))
             pw_freq2_reb  (j) = pw_freq2_reb  (j) + pw_freq2(i, k)
             pw2_freq2_reb (j) = pw2_freq2_reb (j) + (pw_freq2(i, k) * pw_freq2(i, k))
          enddo
       enddo
    enddo

    do j = 1, reb_dim - 1
       rc_freq_reb   (j) = rc_freq_reb   (j) / dble(int_number * reb_array(j))
       ic_freq_reb   (j) = ic_freq_reb   (j) / dble(int_number * reb_array(j))
       rc2_freq_reb  (j) = rc2_freq_reb  (j) / dble(int_number * reb_array(j))
       ic2_freq_reb  (j) = ic2_freq_reb  (j) / dble(int_number * reb_array(j))
       rc_ic_freq_reb(j) = rc_ic_freq_reb(j) / dble(int_number * reb_array(j))
       pw_freq1_reb  (j) = pw_freq1_reb  (j) / dble(int_number * reb_array(j))
       pw_freq2_reb  (j) = pw_freq2_reb  (j) / dble(int_number * reb_array(j))
       pw2_freq1_reb (j) = pw2_freq1_reb (j) / dble(int_number * reb_array(j))
       pw2_freq2_reb (j) = pw2_freq2_reb (j) / dble(int_number * reb_array(j))
    enddo

    allocate(std_rc_freq_reb (reb_dim))
    allocate(std_ic_freq_reb (reb_dim))
    allocate(reb_err_prop_lag(reb_dim))
    allocate(reb_err_cohe_lag(reb_dim))
    allocate(reb_coher2_freq (reb_dim))
    allocate(reb_lag_freq    (reb_dim))

    allocate(deriv_rc        (reb_dim))
    allocate(deriv_ic        (reb_dim))
    allocate(reb_covariance  (reb_dim))

!lag calculation and errors
   do j = 1, reb_dim - 1

!Errors through standard deviation on real and imaginary part
      !lag with propagation formula
      std_rc_freq_reb(j) = sqrt((rc2_freq_reb(j) - (rc_freq_reb(j) * rc_freq_reb(j)) ))  / (sqrt(dble(int_number * reb_array(j))))
      std_ic_freq_reb(j) = sqrt((ic2_freq_reb(j) - (ic_freq_reb(j) * ic_freq_reb(j)) ))  / (sqrt(dble(int_number * reb_array(j))))
      reb_covariance(j)  = (rc_ic_freq_reb(j) - ((rc_freq_reb(j) * ic_freq_reb(j) ) ) )  /       dble(int_number * reb_array(j))
      ! covariance(j) = 0.0
      deriv_rc(j) =  (-1.d0 *  ic_freq_reb(j) / rc_freq_reb(j)**2) / (1 + (ic_freq_reb(j) / rc_freq_reb(j))**2 )
      deriv_ic(j) =                      (1.d0 / rc_freq_reb(j))    / (1 + (ic_freq_reb(j) / rc_freq_reb(j))**2 )

      reb_err_prop_lag(j) = sqrt( (deriv_rc(j)**2 * std_rc_freq_reb(j)**2) + (deriv_ic(j)**2 * std_ic_freq_reb(j)**2) + (2.d0 * deriv_rc(j) * deriv_ic(j) * reb_covariance(j)) ) / (2.d0 * pi * reb_freq(j))

!bias term
      ! if ((obs_freq_bins(j) * int_number) .lt. 500 ) then
      !    bias2 = ((pw_fq_en(j, k) - P_noise_ext(k)) * P_noise_ext_ref(k) + (pw_fq_en_ref(j, k) - P_noise_ext_ref(k)) * P_noise_ext(k) + P_noise_ext(k) * P_noise_ext_ref(k) ) / (dble(int_number))
      ! else
      !    bias2 = 0.0
      ! endif

      bias2 = 0.0

!Coherence and error on the lag with the coherence formula
      reb_coher2_freq(j) = (rc_freq_reb(j)**2 + ic_freq_reb(j)**2 - bias2) / (pw_freq1_reb(j) * pw_freq2_reb(j))
      ! write(*,*) 'iiii', pw_freq1_reb(j), pw_freq2_reb(j), reb_coher2_freq(j)

      reb_err_cohe_lag(j) = sqrt( (1.d0 - reb_coher2_freq(j)) / (2.d0 * reb_coher2_freq(j) * dble(int_number * reb_array(j)))) / (2.d0 * pi * reb_freq(j))

      ! write(*,*) 'iiiii', reb_err_cohe_lag(j)
      ! write(*,*) j, freq(j), reb_coher2_freq(j), rc_freq_reb(j)**2, ic_freq_reb(j)**2, pw_freq1_reb(j),  pw_freq2_reb(j)

!Adam's formula real and imaginary part
         ! errA_rc_ic(j) = sqrt (pw_freq_reb2(j) * (pw_freq_reb1(j, k) - ( (rc_freq_reb(j)**2 + ic_freq_reb(j)**2 - bias2) / (pw_freq_reb2(j, k) - P_noise_ext_ref(k)) ) ) / (2 * dble( int_number * reb_dim) ) )

!Adam's formula lag
         ! errA_lag(j) = sqrt( pw_fq_en_ref(j, k) * ( (pw_fq_en(j, k) / (rc_fq_en(j, k)**2 + ic_fq_en(j, k)**2 - bias2) ) - ( 1 / (pw_fq_en_ref(j, k) - P_noise_ext_ref(k))  ) ) / (2 *  dble(int_number * reb_dim)) ) / (2 * pi * relevant_freq(j))

      reb_lag_freq(j) = atan2(ic_freq_reb(j), rc_freq_reb(j)) / (2.d0 * pi * reb_freq(j))

   enddo

   deallocate(reb_array     )
   deallocate(deriv_rc      )
   deallocate(deriv_ic      )
   deallocate(reb_covariance)
   deallocate(rc_freq_reb   )
   deallocate(ic_freq_reb   )
   deallocate(rc2_freq_reb  )
   deallocate(ic2_freq_reb  )
   deallocate(rc_ic_freq_reb)
   deallocate(pw_freq1_reb  )
   deallocate(pw_freq2_reb  )
   deallocate(pw2_freq1_reb )
   deallocate(pw2_freq2_reb )

  end subroutine rebin_lag_freq

  subroutine rebin_lag_freq_obs(freq, rc_freq_obs, ic_freq_obs, pw_freq1_obs, pw_freq2_obs, int_number_max, int_number_obs, int_len_dim, obs_num, reb_dim)
    implicit none

    integer         , intent(IN)  :: obs_num, int_number_max, int_len_dim, int_number_obs(obs_num)
    double precision, intent(IN)  :: freq(int_len_dim), rc_freq_obs(int_number_max, int_len_dim / 2, obs_num), ic_freq_obs(int_number_max, int_len_dim / 2, obs_num), &
         pw_freq1_obs(int_number_max, int_len_dim / 2, obs_num), pw_freq2_obs(int_number_max, int_len_dim / 2, obs_num)

    integer              :: i, j, k, o, reb_dim, start, end_reb, tot_interval_reb
    double precision     :: reb_fac, bias2
    integer, allocatable :: reb_array(:)

    double precision, parameter   :: pi = acos(-1.0)
    double precision, allocatable :: rc2_freq_reb(:), &
         ic2_freq_reb(:), rc_ic_freq_reb(:), pw_freq1_reb(:), &
         pw_freq2_reb(:), pw2_freq1_reb(:), pw2_freq2_reb(:)
    double precision, allocatable :: deriv_rc(:), deriv_ic(:), &
         reb_coher2_freq(:), reb_covariance(:)

    if(allocated(reb_freq        )) deallocate(reb_freq        )
    if(allocated(reb_array       )) deallocate(reb_array       )

    if(allocated(reb_lag_freq    )) deallocate(reb_lag_freq    )
    if(allocated(reb_lag_freq    )) deallocate(reb_lag_freq    )
    if(allocated(reb_err_cohe_lag)) deallocate(reb_err_cohe_lag)
    if(allocated(reb_err_prop_lag)) deallocate(reb_err_prop_lag)
    if(allocated(std_rc_freq_reb )) deallocate(std_rc_freq_reb )
    if(allocated(std_ic_freq_reb )) deallocate(std_ic_freq_reb )
    if(allocated(rc_freq_reb     )) deallocate(rc_freq_reb     )
    if(allocated(ic_freq_reb     )) deallocate(ic_freq_reb     )

    write(*,*) '   Choose exponensial rebinning factor'
    read(*,*) reb_fac
    print *, ' '

    allocate(reb_freq (int_len_dim /2))
    allocate(reb_array(int_len_dim /2))

!Finds out the dimension of the rebinned array and the rebin indexes
    call rebin_log(freq, reb_freq, reb_array, int_len_dim / 2, reb_dim, reb_fac)

    if(.not. allocated(rc_freq_reb)   ) allocate(rc_freq_reb   (reb_dim))
    if(.not. allocated(ic_freq_reb)   ) allocate(ic_freq_reb   (reb_dim))
    if(.not. allocated(rc2_freq_reb)  ) allocate(rc2_freq_reb  (reb_dim))
    if(.not. allocated(ic2_freq_reb)  ) allocate(ic2_freq_reb  (reb_dim))
    if(.not. allocated(rc_ic_freq_reb)) allocate(rc_ic_freq_reb(reb_dim))
    if(.not. allocated(pw_freq1_reb)  ) allocate(pw_freq1_reb  (reb_dim))
    if(.not. allocated(pw_freq2_reb)  ) allocate(pw_freq2_reb  (reb_dim))
    if(.not. allocated(pw2_freq1_reb) ) allocate(pw2_freq1_reb (reb_dim))
    if(.not. allocated(pw2_freq2_reb) ) allocate(pw2_freq2_reb (reb_dim))

    rc_freq_reb    = 0.d0
    ic_freq_reb    = 0.d0
    rc2_freq_reb   = 0.d0
    ic2_freq_reb   = 0.d0
    rc_ic_freq_reb = 0.d0
    pw_freq1_reb   = 0.d0
    pw_freq2_reb   = 0.d0
    pw2_freq1_reb  = 0.d0
    pw2_freq2_reb  = 0.d0

    tot_interval_reb = 0

    do o = 1, obs_num
       do i = 1, int_number_obs(o)
          start   = 0
          end_reb = 0
          do j = 1, reb_dim
             start   = end_reb + 1
             end_reb = end_reb + reb_array(j)
             ! write(*,*) j, start, end_reb

             do k = start, end_reb
                rc_freq_reb   (j) = rc_freq_reb   (j) + rc_freq_obs(i, k, o)
                ic_freq_reb   (j) = ic_freq_reb   (j) + ic_freq_obs(i, k, o)
                rc2_freq_reb  (j) = rc2_freq_reb  (j) + (rc_freq_obs(i, k, o) * rc_freq_obs(i, k, o))
                ic2_freq_reb  (j) = ic2_freq_reb  (j) + (ic_freq_obs(i, k, o) * ic_freq_obs(i, k, o))
                rc_ic_freq_reb(j) = rc_ic_freq_reb(j) + (rc_freq_obs(i, k, o) * ic_freq_obs(i, k, o))
                pw_freq1_reb  (j) = pw_freq1_reb  (j) + pw_freq1_obs(i, k, o)
                pw2_freq1_reb (j) = pw2_freq1_reb (j) + (pw_freq1_obs(i, k, o) * pw_freq1_obs(i, k, o))
                pw_freq2_reb  (j) = pw_freq2_reb  (j) +  pw_freq2_obs(i, k, o)
                pw2_freq2_reb (j) = pw2_freq2_reb (j) + (pw_freq2_obs(i, k, o) * pw_freq2_obs(i, k, o))
             enddo
          enddo
       enddo
       tot_interval_reb = tot_interval_reb + int_number_obs(o)
    enddo

    do j = 1, reb_dim - 1
       rc_freq_reb   (j) = rc_freq_reb   (j) / dble(tot_interval_reb * reb_array(j))
       ic_freq_reb   (j) = ic_freq_reb   (j) / dble(tot_interval_reb * reb_array(j))
       rc2_freq_reb  (j) = rc2_freq_reb  (j) / dble(tot_interval_reb * reb_array(j))
       ic2_freq_reb  (j) = ic2_freq_reb  (j) / dble(tot_interval_reb * reb_array(j))
       rc_ic_freq_reb(j) = rc_ic_freq_reb(j) / dble(tot_interval_reb * reb_array(j))
       pw_freq1_reb  (j) = pw_freq1_reb  (j) / dble(tot_interval_reb * reb_array(j))
       pw_freq2_reb  (j) = pw_freq2_reb  (j) / dble(tot_interval_reb * reb_array(j))
       pw2_freq1_reb (j) = pw2_freq1_reb (j) / dble(tot_interval_reb * reb_array(j))
       pw2_freq2_reb (j) = pw2_freq2_reb (j) / dble(tot_interval_reb * reb_array(j))
    enddo

    allocate(std_rc_freq_reb (reb_dim))
    allocate(std_ic_freq_reb (reb_dim))
    allocate(reb_err_prop_lag(reb_dim))
    allocate(reb_err_cohe_lag(reb_dim))
    allocate(reb_coher2_freq (reb_dim))
    allocate(reb_lag_freq    (reb_dim))

    allocate(deriv_rc        (reb_dim))
    allocate(deriv_ic        (reb_dim))
    allocate(reb_covariance  (reb_dim))

!lag calculation and errors
   do j = 1, reb_dim - 1

!Errors through standard deviation on real and imaginary part
      !lag with propagation formula
      std_rc_freq_reb(j) = sqrt((rc2_freq_reb(j) - (rc_freq_reb(j) * rc_freq_reb(j)) ))  / (sqrt(dble(tot_interval_reb * reb_array(j))))
      std_ic_freq_reb(j) = sqrt((ic2_freq_reb(j) - (ic_freq_reb(j) * ic_freq_reb(j)) ))  / (sqrt(dble(tot_interval_reb * reb_array(j))))
      reb_covariance(j)  = (rc_ic_freq_reb(j) - ((rc_freq_reb(j) * ic_freq_reb(j) ) ) )  /       dble(tot_interval_reb * reb_array(j))
      ! covariance(j) = 0.0
      deriv_rc(j) =  (-1.d0 *  ic_freq_reb(j) / rc_freq_reb(j)**2) / (1 + (ic_freq_reb(j) / rc_freq_reb(j))**2 )
      deriv_ic(j) =                      (1.d0 / rc_freq_reb(j))    / (1 + (ic_freq_reb(j) / rc_freq_reb(j))**2 )

      reb_err_prop_lag(j) = sqrt( (deriv_rc(j)**2 * std_rc_freq_reb(j)**2) + (deriv_ic(j)**2 * std_ic_freq_reb(j)**2) + (2.d0 * deriv_rc(j) * deriv_ic(j) * reb_covariance(j)) ) / (2.d0 * pi * reb_freq(j))

!bias term
      ! if ((obs_freq_bins(j) * int_number) .lt. 500 ) then
      !    bias2 = ((pw_fq_en(j, k) - P_noise_ext(k)) * P_noise_ext_ref(k) + (pw_fq_en_ref(j, k) - P_noise_ext_ref(k)) * P_noise_ext(k) + P_noise_ext(k) * P_noise_ext_ref(k) ) / (dble(int_number))
      ! else
      !    bias2 = 0.0
      ! endif

      bias2 = 0.0

!Coherence and error on the lag with the coherence formula
      reb_coher2_freq(j) = (rc_freq_reb(j)**2 + ic_freq_reb(j)**2 - bias2) / (pw_freq1_reb(j) * pw_freq2_reb(j))
      ! write(*,*) 'iiii', pw_freq1_reb(j), pw_freq2_reb(j), reb_coher2_freq(j)

      reb_err_cohe_lag(j) = sqrt( (1.d0 - reb_coher2_freq(j)) / (2.d0 * reb_coher2_freq(j) * dble(tot_interval_reb* reb_array(j)))) / (2.d0 * pi * reb_freq(j))

      ! write(*,*) 'iiiii', reb_err_cohe_lag(j)
      ! write(*,*) j, freq(j), reb_coher2_freq(j), rc_freq_reb(j)**2, ic_freq_reb(j)**2, pw_freq1_reb(j),  pw_freq2_reb(j)

!Adam's formula real and imaginary part
         ! errA_rc_ic(j) = sqrt (pw_freq_reb2(j) * (pw_freq_reb1(j, k) - ( (rc_freq_reb(j)**2 + ic_freq_reb(j)**2 - bias2) / (pw_freq_reb2(j, k) - P_noise_ext_ref(k)) ) ) / (2 * dble( int_number * reb_dim) ) )

!Adam's formula lag
         ! errA_lag(j) = sqrt( pw_fq_en_ref(j, k) * ( (pw_fq_en(j, k) / (rc_fq_en(j, k)**2 + ic_fq_en(j, k)**2 - bias2) ) - ( 1 / (pw_fq_en_ref(j, k) - P_noise_ext_ref(k))  ) ) / (2 *  dble(int_number * reb_dim)) ) / (2 * pi * relevant_freq(j))

      reb_lag_freq(j) = atan2(ic_freq_reb(j), rc_freq_reb(j)) / (2.d0 * pi * reb_freq(j))

   enddo

   deallocate(reb_array     )
   deallocate(deriv_rc      )
   deallocate(deriv_ic      )
   deallocate(reb_covariance)
   deallocate(rc_freq_reb   )
   deallocate(ic_freq_reb   )
   deallocate(rc2_freq_reb  )
   deallocate(ic2_freq_reb  )
   deallocate(rc_ic_freq_reb)
   deallocate(pw_freq1_reb  )
   deallocate(pw_freq2_reb  )
   deallocate(pw2_freq1_reb )
   deallocate(pw2_freq2_reb )

 end subroutine rebin_lag_freq_obs

  subroutine rebin_PDS_FPMA_B(freq, pds_intA, pds_intB, int_number, int_len_dim, reb_dim)
    implicit none

    integer         , intent(IN)  :: int_number, int_len_dim
    double precision, intent(IN)  :: freq(int_len_dim / 2), &
         pds_intA(int_number, int_len_dim / 2), &
         pds_intB(int_number, int_len_dim / 2)

    integer              :: i, j, k, reb_dim, start, end_reb
    double precision     :: reb_fac
    integer, allocatable :: reb_array(:)
    double precision, allocatable :: reb_pds2(:)

    if(allocated(reb_array  )) deallocate(reb_array)
    if(allocated(reb_freq   )) deallocate(reb_freq)
    if(allocated(reb_pds    )) deallocate(reb_pds )
    if(allocated(reb_err_pds)) deallocate(reb_err_pds)
    if(allocated(reb_pds2   )) deallocate(reb_pds2 )

    write(*,*) '   Choose exponensial rebinning factor'
    read(*,*) reb_fac
    print *, ' '

    allocate(reb_freq (int_len_dim /2))
    allocate(reb_array(int_len_dim /2))

!Finds out the dimension of the rebinned array and the rebin indexes
    call rebin_log(freq, reb_freq, reb_array, int_len_dim / 2, reb_dim, reb_fac)

    allocate(reb_pds    (reb_dim))
    allocate(reb_pds2   (reb_dim))
    allocate(reb_err_pds(reb_dim))

    reb_pds  = 0.d0
    reb_pds2 = 0.d0

    do i = 1, int_number
       start   = 0
       end_reb = 0
       do j = 1, reb_dim
          start   = end_reb + 1
          end_reb = end_reb + reb_array(j)

          do k = start, end_reb
             reb_pds (j) = reb_pds (j) + pds_intA(i, k)
             reb_pds (j) = reb_pds (j) + pds_intB(i, k)
             reb_pds2(j) = reb_pds2(j) + pds_intA(i, k) **2
             reb_pds2(j) = reb_pds2(j) + pds_intB(i, k) **2
          enddo
       enddo
    enddo

    do j = 1, reb_dim
       reb_pds (j) = reb_pds (j) / dble(2 * int_number * reb_array(j))
       reb_pds2(j) = reb_pds2(j) / dble(2 * int_number * reb_array(j))
       reb_err_pds(j) = sqrt((reb_pds2(j) - reb_pds(j)**2 ) / dble(2 * int_number * reb_array(j)))

    enddo

    if (allocated(reb_array)) deallocate(reb_array)
    if (allocated(reb_pds2 )) deallocate(reb_pds2)

  end subroutine rebin_PDS_FPMA_B

!-----------------------------------------------------------------------
!     PURPOUSE:  Logarithmic rebin of a vector. Find how many bins (nf)
!     the logarithmic rebinned vector has. c is the binning factor,
!     dim is the dimension of the lin vector. It takes the linear x_axis
!
!     INPUTS:  vector -- linear vector
!              dim -- # bin of the linear vector
!              c -- rebinning factor
!
!     OUTPUTS: rebin_vector -- logarithmic rebinned vector
!              rebin_array -- how many numbers for each rebin
!
!     ROUTINE CALLED: none
!     AUTHOR: Mastroserio
!     DATE WRITTEN: Feb 2019
!     LAST CHANGE:
!     NOTE:
!
!----------------------------------------------------------------
!----------------------------------------------------------------
      subroutine rebin_log(vector, rebin_vector, rebin_array, dim, nf, c)
        implicit none

        integer         , intent(IN)    :: dim
        integer         , intent(INOUT) :: nf
        integer         , intent(OUT)   :: rebin_array(dim)
        double precision, intent(IN)    :: vector(dim), c
        double precision, intent(OUT)   :: rebin_vector(dim)

        integer                :: i, j, nnp, remain, cont
        integer, allocatable   :: iar(:), np(:)

        i = 0
        j = 0
        cont = 0
        do while( i .lt. dim)
           j      = j + 1
           remain = dim - i
           if (floor( c**j ).eq.remain) cont = 1
           nnp  = min( floor( c**j ) , remain )
           nnp  = max( 1 , nnp )
           i   = i + nnp
        end do
        if (cont.eq.1) nf = j
        if (cont.ne.1) nf = j - 1

        allocate(iar(0:nf))
        allocate(np(nf))

        np = 0
! First calculate binning scheme
        i = 0
        j = 0
        iar(0) = 0

        do while( i .lt. dim)
           j      = j + 1
           remain = dim - i

           if (floor( c**j ).gt.remain) then
              np(nf)  = np(nf) + remain
              iar(nf) = dim
              i      = i + np(nf)
           else
              np(j)  = min( floor( c**j ) , remain )
              np(j)  = max( 1 , np(j) )
              i      = i + np(j)
              iar(j) = i
           endif

        end do

! Now do the binning
        do j = 0, nf - 1
           rebin_vector(j + 1)  = 0.d0
           cont = 0
           do i = iar(j) + 1,iar(j + 1)
              cont = cont + 1
              rebin_vector(j + 1)  = rebin_vector(j + 1) + vector(i)
           end do
           rebin_array (j + 1) = cont
           rebin_vector(j + 1) = rebin_vector(j + 1) / float( np(j + 1) )
        end do

        if(allocated(iar)) deallocate(iar)
        if(allocated(np)) deallocate(np)

        return
      end subroutine rebin_log

end module rebin
!------------------------------------------------------------------


      subroutine runCP_00i(i1,m0sq,Gr,Bzero1,N0)
      implicit none
      include 'TRconstants.f'
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,i1,m,n,np
      parameter(np=2)
      double precision m0sq,Gr(np,np)
      double complex Bzero1(z1max,-2:0),bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gr(n,m)*Cv(ciii(z3(n,m,i1))+N0,ep)
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=4d0*Cv(czzi(i1)+N0,ep-1)

      Cv(czzi(i1)+N0,ep)=
     . (pole
     . +2d0*Bzero1(i1,ep)
     . +2d0*m0sq*Cv(ci(i1)+N0,ep)
     . -bit)/12d0
      enddo

      return
      end


      module materialProperties
        ! Contains code relevant to importing material properties from props array

        ! Data structure for material properties
        ! FYI naming this type "properties" triggered an error, so its named mproperties
        type :: mproperties
          real(kind=kind(1.d0)) :: E1, E2, E3, nu12, nu13, nu23, G12, G13, G23
          real(kind=kind(1.d0)) :: nu21, nu31, nu32
        end type

        ! Machine precision
        integer, parameter, private :: dp = kind(1.d0)

      Contains
        subroutine materialProperties_load(nprops, props, properties)
          ! Loads the props array into a properties object
          ! Material symmetry is handled within this subroutine

#ifdef umat
          include 'aba_param.inc'
#else
          include 'vaba_param.inc'
#endif

          ! Arguments
          integer, intent(in) :: nprops
          dimension props(nprops)  ! Intent in
          type(mproperties), intent(out) :: properties

          ! Locals
          real(dp) :: E, G, nu

          ! Branch depending on nprops
          ! Isotropic
          if (nprops .EQ. 2) then
            properties%E1 = props(1)
            properties%E2 = props(1)
            properties%E3 = props(1)

            properties%nu12 = props(2)
            properties%nu13 = props(2)
            properties%nu23 = props(2)

            G = props(1)/(2*(1+props(2)))
            properties%G12 = G
            properties%G13 = G
            properties%G23 = G

          ! Transversely isotropic
          else if (nprops .EQ. 5) then
            properties%E1 = props(1)
            properties%E2 = props(2)
            properties%E3 = props(2)

            properties%nu12 = props(3)
            properties%nu13 = properties%E1/(2*properties%G13) - 1.d0
            properties%nu23 = properties%E2/(2*properties%G23) - 1.d0

            properties%G12 = props(4)
            properties%G13 = props(5)
            properties%G23 = props(5)

          ! Orthotropic
          else if (nprops .EQ. 9) then
            properties%E1 = props(1)
            properties%E2 = props(2)
            properties%E3 = props(3)

            properties%nu12 = props(4)
            properties%nu13 = props(5)
            properties%nu23 = props(6)

            properties%G12 = props(7)
            properties%G13 = props(8)
            properties%G23 = props(9)

          else
            Call ABQERR(-3,'BAD INPUT. Expecting that nprops is 2, 5, or 9. Received nprops=%I.',nprops,realv,charv)

          end if

          ! Calculate inverse Poisson's ratios
          properties%nu21 = properties%nu12 * (properties%E2/properties%E1)
          properties%nu31 = properties%nu13 * (properties%E3/properties%E1)
          properties%nu32 = properties%nu23 * (properties%E3/properties%E2)

          return
        end subroutine materialProperties_load

        subroutine materialProperties_elasticStiffness(elementType, properties, stiff)
          ! Computes the stiffness tensor

          ! Arguments
          character(len=80), intent(in) :: elementType           ! Stores type of element if it is recognized
          type(mproperties), intent(in) :: properties            ! Material properties
          real(dp), dimension(:,:) :: stiff                                   ! Stiffness matrix

          ! Locals
          real :: preFactor

          ! Define the stiffness matrix
          if ((elementType .EQ. 'CPS') .OR. (elementType .EQ. 'S') .OR. (elementType .EQ. 'SC')) then      ! Plane stress
            stiff = 0.d0
            stiff(1,1) = properties%E1/(1.d0-properties%nu12*properties%nu21)
            stiff(1,2) = (properties%nu12*properties%E2)/(1.d0-properties%nu12*properties%nu21)
            stiff(2,2) = properties%E2/(1.d0-properties%nu12*properties%nu21)
            stiff(2,1) = stiff(1,2)

            ! Handle vumat weirdness where for some reason I don't understand, ndir=3 for plane stress in explicit
            if (size(stiff) .EQ. 9) then
              ! Implicit
              stiff(3,3) = properties%G12
            else
              ! Explicit, where ndir=3
              stiff(4,4) = properties%G12
            end if

          else if ((elementType .EQ. 'CPE') .OR. (elementType .EQ. 'C3D')) then      ! Plane strain and 3D
            preFactor = (1-properties%nu12*properties%nu21-properties%nu23*properties%nu32-properties%nu13*properties%nu31 &
               -2*properties%nu21*properties%nu32*properties%nu13)/(properties%E1*properties%E2*properties%E3)

            stiff = 0.d0
            stiff(1,1) = (1-properties%nu23*properties%nu32)/(properties%E2*properties%E3*preFactor)
            stiff(2,2) = (1-properties%nu13*properties%nu31)/(properties%E1*properties%E3*preFactor)
            stiff(3,3) = (1-properties%nu12*properties%nu21)/(properties%E1*properties%E2*preFactor)
            stiff(1,2) = (properties%nu21+properties%nu31*properties%nu23)/(properties%E2*properties%E3*preFactor)
            stiff(1,3) = (properties%nu31+properties%nu21*properties%nu32)/(properties%E2*properties%E3*preFactor)
            stiff(2,1) = stiff(1,2)
            stiff(2,3) = (properties%nu32+properties%nu12*properties%nu31)/(properties%E1*properties%E3*preFactor)
            stiff(3,1) = stiff(1,3)
            stiff(3,2) = stiff(2,3)
            stiff(4,4) = properties%G12

            ! Additional components for 3D elements
            if (elementType .EQ. 'C3D') then
              stiff(4,4) = properties%G12
#ifdef umat
              stiff(5,5) = properties%G13
              stiff(6,6) = properties%G23
#else
              stiff(5,5) = properties%G23
              stiff(6,6) = properties%G13
#endif
            end if

          else
            Call ABQERR(-3,'Did not find a recognized element type in material name.',intv,realv,charv)

          end if

          return
        end subroutine materialProperties_elasticStiffness

      end module


c
c
c
      subroutine interp(r,f,nr,rs,ps,dps,deriv)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c----- this routine interpolates functn f on grid r
c      returns value ps and its derivative dps
c
      implicit real*8 (a-h,o-z)
      logical deriv
      real*8 r(nr),f(nr),c(4)
c
      ip1=2
      do i=ip1,nr-1
      if (rs.gt.r(i)) ip1=i+1
      enddo
      i=ip1-1
      call fit(r,f,nr,i,c)
c
      h1=rs-r(i)
      h2=r(ip1)-rs
      c2=1.d0+c(4)*h1*h2
      ps=((c(3)-c(2))*h1+c(1))/c2
      dps=c(2)+(c(3)-c(2)+ps*c(4)*(h1-h2))/c2
      ps=ps+f(i)-c(1)+c(2)*h1

      return
      end


      SUBROUTINE QFORCE(Q,F,QF)
*
*
*       KS transpose of Q times 2F.
*       ---------------------------
*
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 Q(4),F(3),QF(4)
*
*
      QF(1)=2.D0*(+Q(1)*F(1)+Q(2)*F(2)+Q(3)*F(3))
      QF(2)=2.D0*(-Q(2)*F(1)+Q(1)*F(2)+Q(4)*F(3))
      QF(3)=2.D0*(-Q(3)*F(1)-Q(4)*F(2)+Q(1)*F(3))
      QF(4)=2.D0*(+Q(4)*F(1)-Q(3)*F(2)+Q(2)*F(3))
*
      RETURN
      END


      SUBROUTINE LMRKAP(PARA,XMOM,NMOM)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  L-MOMENT RATIOS FOR THE KAPPA DISTRIBUTION
C
C  PARAMETERS OF ROUTINE:
C  PARA   * INPUT* ARRAY OF LENGTH 4. CONTAINS THE PARAMETERS OF THE
C                  DISTRIBUTION, IN THE ORDER XI, ALPHA, K, H.
C  XMOM   *OUTPUT* ARRAY OF LENGTH NMOM. ON EXIT, CONTAINS THE L-MOMENTS
C                  LAMBDA-1, LAMBDA-2, TAU-3, TAU-4, ... .
C  NMOM   * INPUT* NUMBER OF L-MOMENTS TO BE FOUND. AT MOST 20.
C
C  OTHER ROUTINES USED: DLGAMA,DIGAMD
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION PARA(4),XMOM(NMOM),BETA(20)
      DATA ZERO/0D0/,HALF/0.5D0/,ONE/1D0/,THREE/3D0/,FOUR/4D0/,SIX/6D0/
C
C         EU  IS EULER'S CONSTANT
C
      DATA EU/0.577215664901532861D0/
C
C         SMALL IS USED TO TEST WHETHER H IS EFFECTIVELY ZERO
C         OFL SHOULD BE CHOSEN SO THAT EXP(OFL) JUST DOES NOT CAUSE
C         OVERFLOW
C
      DATA SMALL/1D-8/,OFL/170D0/
C
      U=PARA(1)
      A=PARA(2)
      G=PARA(3)
      H=PARA(4)
C
C         TEST FOR FEASIBLE PARAMETERS
C
      IF(A.LE.ZERO)GOTO 1000
      IF(G.LE.-ONE)GOTO 1000
      IF(H.LT.ZERO.AND.G*H.LE.-ONE)GOTO 1000
      IF(NMOM.GT.20)GOTO 1010
C
C         CALCULATE FUNCTIONS OCCURRING IN THE PWM'S BETA-SUB-R
C
      DLGAM=DLGAMA(ONE+G)
      ICASE=1
      IF(H.GT.ZERO)ICASE=3
      IF(DABS(H).LT.SMALL)ICASE=2
      IF(G.EQ.ZERO)ICASE=ICASE+3
      GOTO(10,30,50,70,90,110),ICASE
C
C         - CASE H<0, G NONZERO
C
   10 DO 20 IR=1,NMOM
      R=IR
      ARG=DLGAM+DLGAMA(-R/H-G)-DLGAMA(-R/H)-G*DLOG(-H)
      IF(DABS(ARG).GT.OFL)GOTO 1020
   20 BETA(IR)=DEXP(ARG)
      GOTO 130
C
C         - CASE H SMALL, G NONZERO
C
   30 DO 40 IR=1,NMOM
      R=IR
   40 BETA(IR)=DEXP(DLGAM-G*DLOG(R))*(ONE-HALF*H*G*(ONE+G)/R)
      GOTO 130
C
C         - CASE H>0, G NONZERO
C
   50 DO 60 IR=1,NMOM
      R=IR
      ARG=DLGAM+DLGAMA(ONE+R/H)-DLGAMA(ONE+G+R/H)-G*DLOG(H)
      IF(DABS(ARG).GT.OFL)GOTO 1020
   60 BETA(IR)=DEXP(ARG)
      GOTO 130
C
C         - CASE H<0, G=0
C
   70 DO 80 IR=1,NMOM
      R=IR
   80 BETA(IR)=EU+DLOG(-H)+DIGAMD(-R/H)
      GOTO 130
C
C         - CASE H SMALL, G=0
C
   90 DO 100 IR=1,NMOM
      R=IR
  100 BETA(IR)=EU+DLOG(R)
      GOTO 130
C
C         - CASE H>0, G=0
C
  110 DO 120 IR=1,NMOM
      R=IR
  120 BETA(IR)=EU+DLOG(H)+DIGAMD(ONE+R/H)
      GOTO 130
C
C         LAMBDA-1
C
  130 CONTINUE
      IF(G.EQ.ZERO)XMOM(1)=U+A*BETA(1)
      IF(G.NE.ZERO)XMOM(1)=U+A*(ONE-BETA(1))/G
      IF(NMOM.EQ.1)RETURN
C
C         LAMBDA-2
C
      ALAM2=BETA(2)-BETA(1)
      IF(G.EQ.ZERO)XMOM(2)=A*ALAM2
      IF(G.NE.ZERO)XMOM(2)=A*ALAM2/(-G)
      IF(NMOM.EQ.2)RETURN
C
C         HIGHER MOMENTS
C
      Z0=ONE
      DO 170 J=3,NMOM
      DJ=J
      Z0=Z0*(FOUR*DJ-SIX)/DJ
      Z=Z0*THREE*(DJ-ONE)/(DJ+ONE)
      SUM=Z0*(BETA(J)-BETA(1))/ALAM2-Z
      IF(J.EQ.3)GOTO 160
      DO 150 I=2,J-2
      DI=I
      Z=Z*(DI+DI+ONE)*(DJ-DI)/((DI+DI-ONE)*(DJ+DI))
      SUM=SUM-Z*XMOM(I+1)
  150 CONTINUE
  160 XMOM(J)=SUM
  170 CONTINUE
      RETURN
C
 1000 WRITE(6,7000)
      RETURN
 1010 WRITE(6,7010)
      RETURN
 1020 WRITE(6,7020)
      RETURN
C
 7000 FORMAT(' *** ERROR *** ROUTINE LMRKAP : PARAMETERS INVALID')
 7010 FORMAT(' *** ERROR *** ROUTINE LMRKAP : PARAMETER NMOM TOO LARGE')
 7020 FORMAT(' *** ERROR *** ROUTINE LMRKAP :',
     *  ' CALCULATIONS OF L-MOMENTS HAVE BROKEN DOWN')
      END


SUBROUTINE p44(input_file,output_file)
!-------------------------------------------------------------------------
! Program 4.4 Analysis of elastic rigid-jointed frames using 2-node
!             beam/rod elements in 2- or 3-dimensions.
!-------------------------------------------------------------------------
 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,ndim,ndof,nels,neq,nod=2,   &
   nodof,nn,nprops,np_types,nr,nlen
 REAL(iwp)::penalty=1.0e20_iwp,zero=0.0_iwp
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),kdiag(:),nf(:,:), &
   no(:),node(:),num(:),sense(:)
 REAL(iwp),ALLOCATABLE::action(:),coord(:,:),eld(:),gamma(:),g_coord(:,:),&
   km(:,:),kv(:),loads(:),prop(:,:),value(:)
 CHARACTER(LEN=15)::argv
!-----------------------input and initialisation--------------------------
 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nels,nn,ndim,nprops,np_types
 IF(ndim==2)nodof=3
 IF(ndim==3)nodof=6
 ndof=nod*nodof
 ALLOCATE(nf(nodof,nn),km(ndof,ndof),coord(nod,ndim),g_coord(ndim,nn),    &
   eld(ndof),action(ndof),g_num(nod,nels),num(nod),g(ndof),gamma(nels),   &
   g_g(ndof,nels),prop(nprops,np_types),etype(nels))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 IF(ndim==3)READ(10,*)gamma
 READ(10,*)g_coord
 READ(10,*)g_num
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(kdiag(neq),loads(0:neq))
!-----------------------loop the elements to find global array sizes------
 kdiag=0
 elements_1: DO iel=1,nels
   num=g_num(:,iel)
   CALL num_to_g(num,nf,g)
   g_g(:,iel)=g
   CALL fkdiag(kdiag,g)
 END DO elements_1
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)))
 WRITE(11,'(2(A,I10))')                                                   &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
!-----------------------global stiffness matrix assembly------------------
 kv=zero
 elements_2: DO iel=1,nels
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   CALL rigid_jointed(km,prop,gamma,etype,iel,coord)
   g=g_g(:,iel)
   CALL fsparv(kv,km,g,kdiag)
 END DO elements_2
!-----------------------read loads and/or displacements-------------------
 loads=zero
 READ(10,*)loaded_nodes,(k,loads(nf(:,k)),i=1,loaded_nodes)
 READ(10,*)fixed_freedoms
 IF(fixed_freedoms/=0)THEN
   ALLOCATE(node(fixed_freedoms),no(fixed_freedoms),                      &
     sense(fixed_freedoms),value(fixed_freedoms))
   READ(10,*)(node(i),sense(i),value(i),i=1,fixed_freedoms)
   DO i=1,fixed_freedoms
     no(i)=nf(sense(i),node(i))
   END DO
   kv(kdiag(no))=kv(kdiag(no))+penalty
   loads(no)=kv(kdiag(no))*value
 END IF
!-----------------------equation solution --------------------------------
 CALL sparin(kv,kdiag)
 CALL spabac(kv,loads,kdiag)
 loads(0)=zero
 WRITE(11,'(/A)')  "  Node   Displacements and Rotation(s)"
 DO k=1,nn
   WRITE(11,'(I5,6E12.4)')k,loads(nf(:,k))
 END DO
!-----------------------retrieve element end actions----------------------
 WRITE(11,'(/A)')" Element Actions"
 elements_3: DO iel=1,nels
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   eld=loads(g)
   CALL rigid_jointed(km,prop,gamma,etype,iel,coord)
   action=MATMUL(km,eld)
   IF(ndim<3)THEN
     WRITE(11,'(I5,6E12.4)')iel,action
   ELSE
     WRITE(11,'(I5,6E12.4)')iel,   action(1: 6)
     WRITE(11,'(A,6E12.4)')"     ",action(7:12)
   END IF
 END DO elements_3
END SUBROUTINE p44


module test_advect_module

  use bl_types
  use bl_constants_module
  implicit none

  private
  public :: init_density_2d, init_density_3d

  ! width of the gaussian
  real (kind=dp_t), parameter :: W = 0.05

contains

  subroutine init_density_2d(rho, rhoX, trac, ng_s, lo, hi, dx)

    ! initialize the density field to a Gaussian centered on the domain.
    ! set the first composition variable to the density and the rest to 0.

    use probin_module, only: prob_lo, prob_hi, base_cutoff_density

    integer         , intent(in   ) :: lo(:), hi(:), ng_s
    real (kind=dp_t), intent(inout) ::  rho(lo(1)-ng_s:,lo(2)-ng_s:)
    real (kind=dp_t), intent(inout) :: rhoX(lo(1)-ng_s:,lo(2)-ng_s:,:)
    real (kind=dp_t), intent(inout) :: trac(lo(1)-ng_s:,lo(2)-ng_s:,:)
    real (kind=dp_t), intent(in   ) :: dx(:)

    ! Local variables
    integer :: i, j
    real (kind=dp_t) :: x, y
    real (kind=dp_t) :: xc, yc
    real (kind=dp_t) :: dist

    xc = HALF*(prob_hi(1) - prob_lo(1))
    yc = HALF*(prob_hi(2) - prob_lo(2))

    do j = lo(2), hi(2)
       y = (dble(j)+0.5d0)*dx(2) + prob_lo(2)

       do i = lo(1), hi(1)
          x = (dble(i)+0.5d0)*dx(1) + prob_lo(1)

          dist = sqrt((x - xc)**2 + (y - yc)**2)

          rho(i,j) = max(exp(-dist**2/W**2),base_cutoff_density)

          rhoX(i,j,:) = ZERO
          rhoX(i,j,1) = rho(i,j)

          trac(i,j,1) = ZERO
       enddo
    enddo

  end subroutine init_density_2d

  subroutine init_density_3d(rho, rhoX, trac, ng_s, lo, hi, dx)

    ! initialize the density field to a Gaussian centered on the domain.
    ! set the first composition variable to the density and the rest to 0.

    use probin_module, only: prob_lo, prob_hi, base_cutoff_density

    integer         , intent(in   ) :: lo(:), hi(:), ng_s
    real (kind=dp_t), intent(inout) ::  rho(lo(1)-ng_s:,lo(2)-ng_s:,lo(3)-ng_s:)
    real (kind=dp_t), intent(inout) :: rhoX(lo(1)-ng_s:,lo(2)-ng_s:,lo(3)-ng_s:,:)
    real (kind=dp_t), intent(inout) :: trac(lo(1)-ng_s:,lo(2)-ng_s:,lo(3)-ng_s:,:)
    real (kind=dp_t), intent(in   ) :: dx(:)

    ! Local variables
    integer :: i, j, k
    real (kind=dp_t) :: x, y, z
    real (kind=dp_t) :: xc, yc, zc
    real (kind=dp_t) :: dist

    xc = HALF*(prob_hi(1) - prob_lo(1))
    yc = HALF*(prob_hi(2) - prob_lo(2))
    zc = HALF*(prob_hi(3) - prob_lo(3))

    do k = lo(3), hi(3)
       z = (dble(k)+0.5d0)*dx(3) + prob_lo(3)

       do j = lo(2), hi(2)
          y = (dble(j)+0.5d0)*dx(2) + prob_lo(2)

          do i = lo(1), hi(1)
             x = (dble(i)+0.5d0)*dx(1) + prob_lo(1)

             dist = sqrt((x - xc)**2 + (y - yc)**2 + (z - zc)**2)

             rho(i,j,k) = max(exp(-dist**2/W**2),base_cutoff_density)

             rhoX(i,j,k,:) = ZERO
             rhoX(i,j,k,1) = rho(i,j,k)

             trac(i,j,k,1) = ZERO
          enddo
       enddo
    enddo

  end subroutine init_density_3d

end module test_advect_module


subroutine invert_basic(observed, nspec, modcode, &
            inits, npars, ipars, cons, ncons, icons, &
            pmu, psd, plog, pmin, ngibbs, results, seed)
    use mod_types
    use mod_statistics
    use mod_selectmodel
    use mod_dataspec_wavelength
    implicit none

    ! Inputs
    integer(kind=i2), intent(in) :: nspec, npars, ncons, modcode, seed(100)
    integer(kind=i2), intent(in) :: ipars(npars), icons(ncons)
    real(kind=r2), intent(in) :: observed(nw,nspec), inits(npars), cons(ncons)
    real(kind=r2), intent(in), dimension(npars) :: pmin, pmu, psd
    logical, intent(in) :: plog(npars)
    integer(kind=i2), intent(in) :: ngibbs

    ! Internals
    integer(kind=i1) :: i, ng, adapt
    integer(kind=i2) :: nseed
    real(kind=r2) :: rp1, rp2, rinv, rsd
    real(kind=r2) :: PrevError(nw,nspec), PrevSpec(nw)
    real(kind=r2) :: Jump(npars)
    real(kind=r1) :: adj_min
    real(kind=r1), dimension(npars) :: adj, ar
    procedure(), pointer :: model

    ! Outputs
    real(kind=r2), intent(out) :: results(ngibbs, npars+1)

    nseed = 100
    call random_seed(size=nseed)
    call random_seed(put=seed)      !! Initialize random number generator
    call model_select(modcode, model)

    rp1 = 0.001 + nspec*nw/2
    rsd = 0.5
    call model(inits, npars, ipars, cons, ncons, icons, PrevSpec)
    do i=1,nspec
        PrevError(:,i) = PrevSpec - observed(:,i)
    enddo
    Jump = inits * 0.05
    adapt = 20
    adj_min = 0.1
    ar = 0
    do ng=1,ngibbs
        if(mod(ng, adapt) < 1) then
            adj = ar / adapt / 0.75
            where(adj < adj_min)
                adj = adj_min
            end where
            Jump = Jump * adj
            ar = 0
        endif
        call mh_sample(observed, nspec, model, &
            inits, npars, ipars, cons, ncons, icons, rsd, &
            Jump, pmu, psd, plog, pmin, PrevError, ar)
        results(ng,1:npars) = inits
        rp2 = 0.001 + sum(PrevError * PrevError)/2
        rinv = rgamma(rp1, 1/rp2)
        rsd = 1/sqrt(rinv)
        results(ng,npars+1) = rsd
    enddo
end subroutine


!===================================================================
!         Finds the parcels nearest every "small" parcel

!         Initialise data first using ranpar.f90
!===================================================================

program nearest

 !Import parameters and constants:
use constants

implicit none

 !Total number of parcels:
integer:: n

 !Parcel positions (x,z) and area fractions:
double precision:: x(nm),z(nm),v(nm)

 !Used for searching for possible parcel merger:
integer:: nppc(ncell),kc1(ncell),kc2(ncell) !ncell = nx*nz
integer:: loc(nm),node(nm),isma(nm/8),ibig(nm/8),nmerge
logical:: merge(nm)

 !Other variables:
double precision:: vmin,vmax,delx,delz,dsq,dsqmin,xm,zm
integer:: i,ic,i0,imin,k,m
integer:: ix,iz,ix0,iz0

!---------------------------------------------------------------------
! Read parcel positions and volume fractions (of grid cell volume):
open(80,file='ini_parcels.asc',status='old')
read(80,*) n
do i=1,n
  read(80,*) x(i),z(i),v(i)
enddo
close(80)

!---------------------------------------------------------------------
! Ask for merger criterion:
vmin=minval(v(1:n))
vmax=maxval(v(1:n))
write(*,*)
write(*,'(a,f9.7)') ' Minimum area fraction of any parcel = ',vmin
write(*,'(a,f9.7)') ' Maximum area fraction of any parcel = ',vmax

write(*,*)
write(*,*) ' Area fraction below which a parcel should be merged?'
read(*,*) vmin

!POMP$ INST BEGIN(foo1)
! These parcels are marked for merger:
merge(1:n)=(v(1:n) < vmin)
nmerge=0
nppc=0 !nppc(ic) will contain the number of parcels in grid cell ic

! Form list of small parcels:
do i=1,n
  if (merge(i)) then
    nmerge=nmerge+1
    isma(nmerge)=i
  else
    ix=int(dxi*(x(i)-xmin))
    iz=int(dzi*(z(i)-zmin))

    ! Cell index of parcel:
    ic=1+ix+nx*iz !This runs from 1 to ncell

    ! Accumulate number of parcels in this grid cell:
    nppc(ic)=nppc(ic)+1

    ! Store grid cell that this parcel is in:
    loc(i)=ic
  endif
enddo

! Find arrays kc1(ic) & kc2(ic) which indicate the parcels in grid cell ic
! through i = node(k), for k = kc1(ic),kc2(ic):
kc1(1)=1
do ic=1,ncell-1
  kc1(ic+1)=kc1(ic)+nppc(ic)
enddo

kc2=kc1-1
do i=1,n
  if (.not. merge(i)) then
    ic=loc(i)
    k=kc2(ic)+1
    node(k)=i
    kc2(ic)=k
  endif
enddo
!POMP$ INST END(foo1)

!POMP$ INST BEGIN(foo2)
!---------------------------------------------------------------------
! Now find the nearest grid point to each small parcel (to be merged)
! and search over the surrounding 8 grid cells for the closest parcel:
do m=1,nmerge
  i0=isma(m)
  xm=x(i0) !SB: store value for reuse, compiler may be picking up on this anyway
  zm=z(i0) !SB: store value for reuse, compiler may be picking up on this anyway
  ! Parcel i0 is small and should be merged; find closest other:
  ix0=mod(nint(dxi*(xm-xmin)),nx) ! ranges from 0 to nx-1
  iz0=nint(dzi*(zm-zmin))         ! ranges from 0 to nz
  ! Grid point (ix0,iz0) is closest to parcel i0

  ! Initialise minimum squared distance between parcels and parcel index:
  dsqmin=ellx*ellx
  imin=0

  ! Loop over 8 cells surrounding (ix0,iz0):
  do iz=max(0,iz0-1),min(nz-1,iz0) !=> iz=0 for iz0=0 & iz=nz-1 for iz0=nz
    do ix=ix0-1,ix0
      ! Cell index (accounting for x periodicity):
      ic=1+mod(nx+ix,nx)+nx*iz
      ! Search parcels for closest:
      do k=kc1(ic),kc2(ic)
        i=node(k)
        delz=z(i)-zm
        dsq=delz*delz
        if(dsq<dsqmin) then !SB: perform initial test to reject parcel and avoid working out delx
           delx=x(i)-xm
           delx=delx-ellx*dble(int(delx*hlxi)) ! works across periodic edge
           dsq=dsq+delx*delx
           if (dsq < dsqmin) then
              dsqmin=dsq
              imin=i
           endif
        end if
      enddo
    enddo
  enddo
  ! Store the index of the parcel to be merged with:
  ibig(m)=imin !SB: only update here
enddo
!POMP$ INST END(foo2)

!---------------------------------------------------------------------
! Output data:
open(31,file='domain.asc',status='replace')
write(31,*) nx,nz
write(31,*) ellx,ellz
close(31)

open(31,file='merge.asc',status='replace')
do m=1,nmerge
  write(31,*) isma(m),ibig(m)
enddo
close(31)

write(*,*)
write(*,*) ' A list of the small & large parcels to be merged is in merge.asc'
write(*,*)

 !End main program
end program nearest


      module glats_stochy_mod

      implicit none

      contains

      subroutine glats_stochy(lgghaf,colrad,wgt,wgtcs,rcs2,iprint)
!
! Jan 2013   Henry Juang  increase precision by kind_qdt_prec=16
!                         to help wgt (Gaussian weighting)
      use machine
      implicit none
      integer                  iter,k,k1,l2,lgghaf,iprint
!
! increase precision for more significant digit to help wgt
      real(kind=kind_qdt_prec) drad,dradz,p1,p2,phi,pi,rad,rc
!     real(kind=kind_qdt_prec) drad,dradz,eps,p1,p2,phi,pi,rad,rc
      real(kind=kind_qdt_prec) rl2,scale,si,sn,w,x
!
      real(kind=kind_dbl_prec), dimension(lgghaf) ::  colrad, wgt,
     &                                                wgtcs,  rcs2
!
      real(kind=kind_dbl_prec), parameter :: cons0 = 0.d0, cons1 = 1.d0,
     &                                       cons2 = 2.d0, cons4 = 4.d0,
     &                                       cons180 = 180.d0,
     &                                       cons360 = 360.d0,
     &                                       cons0p25 = 0.25d0
      real(kind=kind_qdt_prec), parameter :: eps = 1.d-20
!
! for better accuracy to select smaller number
!     eps = 1.d-12
!     eps = 1.d-20
!
      if(iprint == 1) print 101
 101  format ('   i   colat   colrad     wgt', 12x, 'wgtcs',
     & 10x, 'iter  res')
      si    = cons1
      l2    = 2*lgghaf
      rl2   = l2
      scale = cons2/(rl2*rl2)
      k1    = l2-1
      pi    = atan(si)*cons4
!     dradz = pi / cons360 / 10.0
!  for better accuracy to start iteration
      dradz = pi / float(lgghaf) / 200.0
      rad   = cons0
      do k=1,lgghaf
        iter = 0
        drad = dradz
1       call poly(l2,rad,p2)
2       p1 = p2
        iter = iter + 1
        rad = rad + drad
        call poly(l2,rad,p2)
        if(sign(si,p1) == sign(si,p2)) go to 2
        if(drad < eps)go to 3
        rad  = rad-drad
        drad = drad * cons0p25
        go to 1
3       continue
        colrad(k) = rad
        phi = rad * cons180 / pi
        call poly(k1,rad,p1)
        x        = cos(rad)
        w        =  scale * (cons1 - x*x)/ (p1*p1)
        wgt(k)   = w
        sn       = sin(rad)
        w        = w/(sn*sn)
        wgtcs(k) = w
        rc       = cons1/(sn*sn)
        rcs2(k)  = rc
        call poly(l2,rad,p1)
        if(iprint == 1)
     &       print 102,k,phi,colrad(k),wgt(k),wgtcs(k),iter,p1
 102    format(1x,i3,2x,f6.2,2x,f10.7,2x,e14.7,2x,e14.7,2x,i4,2x,e14.7)
      enddo
      if(iprint == 1) print 100,lgghaf
100   format(1h ,'shalom from 0.0e0 glats for ',i3)
!
      return
      end

      subroutine poly(n,rad,p)
      use machine
!
      implicit none
!
      integer                  i,n
!
! increase precision for more significant digit to help wgt
      real(kind=kind_qdt_prec) floati,g,p,rad,x,y1,y2,y3
!
      real(kind=kind_dbl_prec), parameter ::  cons1 = 1.d0
!
      x  = cos(rad)
      y1 = cons1
      y2 = x
      do i=2,n
        g = x*y2
        floati = i
        y3 = g - y1 + g - (g-y1)/floati
        y1 = y2
        y2 = y3
      enddo
      p = y3
      return
      end

      end module glats_stochy_mod


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C       Written by: Anshuk Attri
C
C       Contact: contact@anshukattri.in
C       Website: www.anshukattri.in/research
C       GITHUB: github.com/aa-tree/
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

        SUBROUTINE XPP_NBODY_PERT(VTIME, VSTATE, VDIM, OSTATE)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
        IMPLICIT NONE

        INCLUDE 'common.dat'

        INTEGER VDIM
        REAL*8 VTIME
        REAL*8 VSTATE(VDIM), OSTATE(VDIM)

        INTEGER I,J
        REAL*8 MU_J
        REAL*8 RJI(VDIM), RJ(VDIM), RJ0(VDIM)
        REAL*8 RTEMP(3)
        REAL*8 T_OSTATE, LTIME, TEMP_MOD

C
C       X' is V, which is taken from the input state vector
C

        DO I=1,3
            OSTATE(I)=VSTATE(I+3)
        END DO

        DO I=1,3
            OSTATE(I+3)=0.0D0
        END DO

        IF(PERTURBATION) THEN
            DO I=1,6
                PERT_ARRAY(I)=0.0D0
            END DO

            DO I=1,3
                PERT_ARRAY(I)=OSTATE(I)
            END DO
        END IF

        IF(SYS_TYPE .EQ. 0) THEN
            WRITE(*,*) 'Error in XPP_NBODY_PERT.'
            WRITE(*,*) 'Two body system not defined.'
            WRITE(*,*) 'Call START_TWOBODYSYSTEM to define a system.'
            STOP
        END IF

C
C       For the primary body. Call START_TWOBODYSYSTEM before this
C       routine.
C

        CALL GET_MU(IPB, MU_J)

!        CALL SPKEZ(IPB, VTIME, 'J2000', 'NONE', 0,
!     &RJ, LTIME)

        CALL GET_POS_WRT_IBC(VTIME, IPB, RJ)

        !DO I=1,6
        !  RJ(I)=0.00D0
        !END DO

        !CALL TRANS_ORIGIN_FROMSSB(VTIME, IBC, RJ0, RJ)

        DO I=1,6
            RJI(I)= VSTATE(I)-RJ(I)
        END DO

        CALL GET_VEC_MOD(RJI, TEMP_MOD)

        IF(TEMP_MOD .NE. 0 ) THEN
            DO I=1,3

                T_OSTATE=(-1.0D0*MU_J)*RJI(I)
                OSTATE(I+3)=T_OSTATE/(TEMP_MOD)**3.0D0

            END DO
        END IF

C
C       For all bodies in the system.
C

        DO J=1,MMAX

        IF(LIST_I(J,1) .NE. IPB) THEN

            CALL GET_POS_WRT_IBC(VTIME, LIST_I(J,1), RJ)

            DO I=1,3
                RJI(I)= VSTATE(I)-RJ(I)
            END DO

            CALL GET_VEC_MOD(RJI, TEMP_MOD)

            IF(TEMP_MOD .NE. 0 ) THEN

                    MU_J=0.D0
                    CALL GET_MU(LIST_I(J,1), MU_J)

                DO I=1,3

                    T_OSTATE=(-1.0D0*MU_J)*RJI(I)
                    T_OSTATE=T_OSTATE/(TEMP_MOD**3.0D0)

                    IF(PERTURBATION) THEN
                        PERT_ARRAY(I+3)=PERT_ARRAY(I+3)+T_OSTATE
                    END IF

                    OSTATE(I+3)=OSTATE(I+3)+T_OSTATE

                END DO

            END IF

        END IF
        END DO

        IF(PERTURBATION) THEN
            DO I=1,3
                PERT_ARRAY(I+3)=OSTATE(I+3)-PERT_ARRAY(I+3)
               ! WRITE(*,*) PERT_ARRAY(I+3)
            END DO
           ! PAUSE
        END IF

        RETURN
        END


C
C $Id: idxchn.f,v 1.4 2008-07-27 00:17:30 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      FUNCTION IDXCHN (X,Y,I1,I2,I3,I4)
C
        DIMENSION X(*),Y(*)
C
C This function determines whether or not two adjacent triangles in
C the triangulation should be "exchanged".  It generates the Delaunay
C triangulation, used by the package "nngridr", by preferring triangles
C whose circumscribed circles have no data points in their interiors.
C
C The input arguments are the X and Y coordinate arrays of the data and
C the indices of four data points - P1, P2, P3, and P4 - forming a
C quadrilateral, with P3 and P4 connected diagonally.  The function
C returns a 1 when it decides that P1 and P2 should be connected
C instead (an "exchange") and a 0 otherwise.
C
        VPDT(U1,V1,U2,V2,U3,V3)=(U1-U3)*(V2-V3)-(V1-V3)*(U2-U3)
C
C Extract the required coordinates.
C
        X1=X(I1)
        Y1=Y(I1)
        X2=X(I2)
        Y2=Y(I2)
        X3=X(I3)
        Y3=Y(I3)
        X4=X(I4)
        Y4=Y(I4)
C
C Assume no exchange (value = 0) until we find out otherwise.
C
        IVAL=0
C
C If interior angles are less than 180 degrees, and either the point
C (X2,Y2) is inside the circle passing through the points (X1,Y1),
C (X3,Y3), and (X4,Y4) or the point (X1,Y1) is inside the circle
C passing through the points (X2,Y2), (X3,Y3), and (X4,Y4), return
C the value 1; this will cause the triangulation to be changed so
C as to use the diagonal from point 1 to point 2, rather than the
C diagonal from point 3 to point 4.  (Note that, mathematically, only
C one of the tests inside the IF-block should need to be made, because
C passing one of the tests implies passing the other, as well.)
C
        IF (VPDT(X1,Y1,X2,Y2,X3,Y3)*VPDT(X1,Y1,X2,Y2,X4,Y4).LT.0.) THEN
          CALL IDGTCP (X1,Y1,X3,Y3,X4,Y4,XC,YC)
          IF ((X2-XC)*(X2-XC)+(Y2-YC)*(Y2-YC).LT.
     +        (X1-XC)*(X1-XC)+(Y1-YC)*(Y1-YC)) IVAL=1
          CALL IDGTCP (X2,Y2,X3,Y3,X4,Y4,XC,YC)
          IF ((X1-XC)*(X1-XC)+(Y1-YC)*(Y1-YC).LT.
     +        (X2-XC)*(X2-XC)+(Y2-YC)*(Y2-YC)) IVAL=1
        END IF
C
C Set the value of the function for return to the caller.
C
        IDXCHN=IVAL
C
C Done.
C
        RETURN
C
      END


      SUBROUTINE vacuum_par (rmnc, rmns, zmns, zmnc, xm, xn,
     &                       plascur, rbtor, wint, ns, ivac_skip,
     &                       ivac, mnmax, ier_flag, lscreen)
      USE vacmod
      USE vparams, ONLY: nthreed, zero, one, mu0
      USE vmec_params, ONLY: norm_term_flag, phiedge_error_flag
      USE vmec_input, ONLY: lrfp         ! JDH Added 2013-11-25, to test for RFP
      USE vmec_main, ONLY: nznt, irst
      USE parallel_include_module
      USE timer_sub
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER :: ns, ivac_skip, ivac, mnmax, ier_flag
      REAL(dp) :: plascur, rbtor
      REAL(dp), DIMENSION(mnmax), INTENT(in) ::
     &   rmnc, rmns, zmns, zmnc, xm, xn
      REAL(dp), DIMENSION(nuv3), INTENT(in) :: wint
      LOGICAL :: lscreen
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: mn, n, n1, m, i, info=0, j
      REAL(dp), DIMENSION(:), POINTER :: potcos, potsin
      REAL(dp), ALLOCATABLE :: potu(:), potv(:)
      REAL(dp), ALLOCATABLE :: amatrix(:)
      REAL(dp):: dn2, dm2, cosmn, sinmn, huv, hvv,
     &           det, bsubuvac, fac, ton, toff
      REAL(dp) :: tmp1(2), tmp2(2)
C-----------------------------------------------
!
!     THIS ROUTINE COMPUTES .5 * B**2 ON THE VACUUM / PLASMA SURFACE
!     BASED ON THE PROGRAM BY P. MERKEL [J. Comp. Phys. 66, 83 (1986)]
!     AND MODIFIED BY W. I. VAN RIJ AND S. P. HIRSHMAN (1987)

!     THE USER MUST SUPPLY THE FILE << MGRID >> WHICH INCLUDES THE MAGNETIC
!     FIELD DATA TO BE READ BY THE SUBROUTINE BECOIL
!     THE "VACUUM.INC" FILE IS DEFINED IN VMEC.UNIX
!
!
      CALL second0(tvacon)
      IF (.NOT.ALLOCATED(potvac)) STOP 'POTVAC not ALLOCATED in VACCUM'

      ALLOCATE (amatrix(mnpd2*mnpd2), potu(nuv3), potv(nuv3), stat=i)
      IF (i .NE. 0) STOP 'Allocation error in vacuum'

      potsin => potvac(1:mnpd)
      potcos => potvac(1+mnpd:)

      ALLOCATE (bexu(nuv3), bexv(nuv3), bexn(nuv3),
     &     bexni(nuv3), r1b(nuv), rub(nuv3), rvb(nuv3),
     &     z1b(nuv), zub(nuv3), zvb(nuv3), auu(nuv3), auv(nuv3),
     &     avv(nuv3), snr(nuv3), snv(nuv3), snz(nuv3), drv(nuv3),
     &     guu_b(nuv3), guv_b(nuv3), gvv_b(nuv3), rzb2(nuv),
     &     rcosuv(nuv), rsinuv(nuv), stat=i)
      IF (i .NE. 0) STOP 'Allocation error in vacuum'

!
!       INDEX OF LOCAL VARIABLES
!
!       rmnc,rmns,zmns,zmnc:     Surface Fourier coefficients (m,n) of R,Z
!       xm,xn:     m, n values corresponding to rc,zs array
!       bsqvac:    B**2/2 at the vacuum INTERFACE
!       plascur:   net toroidal current
!       rbtor  :   net (effective) poloidal current (loop integrated R*Btor)
!       mnmax:     number of R, Z modes in Fourier series of R,Z
!       ivac_skip: regulates whether full (=0) or incremental (>0)
!                 update of matrix elements is necessary
!
!
!       compute and store mean magnetic fields (due to
!       toroidal plasma current and EXTERNAL tf-coils)
!       note: these are fixed for a constant current iteration
!
!       bfield = rbtor*grad(zeta) + plascur*grad("theta") - grad(potential)
!
!       where "theta" is computed using Biot-Savart law for filaments
!       Here, the potential term is needed to satisfy B dot dS = 0 and has the form:
!
!       potential = SUM potsin*SIN(mu - nv) + potcos*COS(mu - nv)
!
      CALL second0(ton)
      IF (.NOT. ALLOCATED(tanu)) CALL precal (wint)
      CALL surface (rmnc, rmns, zmns, zmnc, xm, xn, mnmax)
      CALL second0(toff)
      timer_vac(tsurf) = timer_vac(tsurf) + (toff-ton)

      ton = toff
      CALL bextern (plascur, wint, lscreen)
      CALL second0(toff)
      timer_vac(tbext) = timer_vac(tbext)+(toff-ton)
!
!     Determine scalar magnetic potential POTVAC
!
      CALL second0(ton)
      CALL scalpot (potvac, amatrix, ivac_skip)
      CALL second0(toff)
      timer_vac(tscal) = timer_vac(tscal) + (toff-ton)

      ton = toff
      CALL solver (amatrix, potvac, mnpd2, 1, info)
      CALL second0(toff)
      timer_vac(tsolver) = timer_vac(tsolver) + (toff-ton)
      solver_time = solver_time + (toff - ton)

      IF (info .NE. 0) STOP 'Error in solver in VACUUM'
!
!       compute tangential covariant (sub u,v) and contravariant
!       (super u,v) magnetic field components on the plasma surface
!
      potu(nuv3min:nuv3max) = 0;  potv(nuv3min:nuv3max) = 0

      mn = 0
      DO n = -nf, nf
         dn2 = -(n*nfper)
         n1 = ABS(n)
         DO m = 0, mf
            mn = mn + 1
            dm2 = m
            j = 0
            DO i = nuv3min, nuv3max
               j = j + 1
               cosmn = potsin(mn)*cosmni(j,mn)/(pi2*pi2*wint(i))
               potu(i) = potu(i) + dm2*cosmn
               potv(i) = potv(i) + dn2*cosmn
            END DO
            IF (.NOT.lasym) CYCLE
            j = 0
            DO i = nuv3min, nuv3max
               j = j + 1
               sinmn = potcos(mn)*sinmni(j,mn)/(pi2*pi2*wint(i))
               potu(i) = potu(i) - dm2*sinmn
               potv(i) = potv(i) - dn2*sinmn
            END DO
         END DO
      END DO

      DO i = nuv3min, nuv3max
         bsubu_sur(i) = potu(i) + bexu(i)                               !Covariant components
         bsubv_sur(i) = potv(i) + bexv(i)
         huv = p5*guv_b(i)*(nfper)
         hvv = gvv_b(i)*(nfper*nfper)
         det = one/(guu_b(i)*hvv-huv*huv)
         bsupu_sur(i) = (hvv*bsubu_sur(i)-huv*bsubv_sur(i))*det         !Contravariant components
         bsupv_sur(i) = ((-huv*bsubu_sur(i))+guu_b(i)*bsubv_sur(i))*det
         bsqvac(i) = p5*(bsubu_sur(i)*bsupu_sur(i)
     &             +     bsubv_sur(i)*bsupv_sur(i))                     !.5*|Bvac|**2
         brv(i) = rub(i)*bsupu_sur(i) + rvb(i)*bsupv_sur(i)
         bphiv(i) = r1b(i)*bsupv_sur(i)
         bzv(i) = zub(i)*bsupu_sur(i) + zvb(i)*bsupv_sur(i)
      END DO
!
!       PRINT OUT VACUUM PARAMETERS
!
      IF (ivac .EQ. 0) THEN
         ivac = ivac + 1
         IF (vrank .EQ. 0) THEN
            IF (lscreen) WRITE (*, 200) nfper, mf, nf, nu, nv
            WRITE (nthreed, 200) nfper, mf, nf, nu, nv
         END IF
  200 FORMAT(/,2x,'In VACUUM, np =',i3,2x,'mf =',i3,2x,'nf =',i3,
     &       ' nu =',i3,2x,'nv = ',i4)

         bsubuvac = 0
         bsubvvac = 0
         DO i = nuv3min, nuv3max
            bsubuvac = bsubuvac + bsubu_sur(i)*wint(i)
            bsubvvac = bsubvvac + bsubv_sur(i)*wint(i)
         END DO
         tmp1(1) = bsubuvac
         tmp1(2)=bsubvvac
         CALL second0(ton)

         IF (vlactive) THEN
            CALL MPI_Allreduce(tmp1, tmp2, 2, MPI_REAL8, MPI_SUM,
     &                         VAC_COMM, MPI_ERR)
         END IF

         CALL second0(toff)
         allreduce_time = allreduce_time + (toff - ton)
         bsubuvac = tmp2(1); bsubvvac = tmp2(2)
         bsubuvac = bsubuvac*signgs*pi2

         fac = 1.e-6_dp/mu0
         IF (vrank .EQ. 0) THEN
            IF (lscreen ) THEN
               WRITE (*,1000) bsubuvac*fac, plascur*fac, bsubvvac, rbtor
            END IF
            WRITE (nthreed, 1000) bsubuvac*fac, plascur*fac, bsubvvac,
     &                            rbtor
         END IF
 1000 FORMAT(2x,'2*pi * a * -BPOL(vac) = ',1p,e10.2,
     &       ' TOROIDAL CURRENT = ',e10.2,/,2x,'R * BTOR(vac) = ',
     &       e10.2,' R * BTOR(plasma) = ',e10.2)
!  JDH Add test for RFP. 2013-11-25
!         IF (rbtor*bsubvvac .lt. zero) ier_flag = phiedge_error_flag
!         IF (ABS((plascur - bsubuvac)/rbtor) .gt. 1.e-2_dp)
!     1      ier_flag = 10
         IF (rbtor*bsubvvac .LT. zero) THEN
            IF (lrfp) THEN
               IF (vrank .EQ. 0) THEN
                  IF (lscreen) WRITE(*,1100)
                  WRITE(nthreed,1100)
               END IF
            ELSE
               ier_flag = phiedge_error_flag
            ENDIF
         ENDIF
         IF (ABS((plascur - bsubuvac)/rbtor) .GT. 5.e-2_dp) THEN
            IF (lrfp) THEN
               IF (vrank .EQ. 0) THEN
                  IF (lscreen) WRITE(*,1200)
                  WRITE(nthreed,1200)
               END IF
            ELSE
               ier_flag = 10
            ENDIF
         ENDIF
!  END JDH Add test for RFP. 2013-11-25
      ENDIF
1100  FORMAT('lrfp is TRUE. Ignore phiedge sign problem')
1200  FORMAT('lrfp is TRUE. Proceed with convergence')

      IF (ALLOCATED(bexu))
     &    DEALLOCATE (bexu, bexv, bexn, bexni, r1b, rub, rvb, z1b, zub,
     &    zvb, auu, auv, avv, snr, snv, snz, drv, guu_b, guv_b, gvv_b,
     &    rzb2, rcosuv, rsinuv, stat=i)
      IF (i .NE. 0) STOP 'Deallocation error in vacuum'

      DEALLOCATE (amatrix, potu, potv, stat=i)
      IF (i .NE. 0) STOP 'Deallocation error in vacuum'

      CALL second0(ton)

      IF (vlactive) THEN
         CALL MPI_Allgatherv(MPI_IN_PLACE, numjs_vac, MPI_REAL8, bsqvac,
     &                       counts_vac, disps_vac, MPI_REAL8, VAC_COMM,
     &                       MPI_ERR)
      END IF

      CALL second0(toff)
      timer_vac(tallgv) = timer_vac(tallgv) + (toff-ton)

      tvacoff = toff
      vacuum_time = vacuum_time + (tvacoff - tvacon)

      END SUBROUTINE vacuum_par

      SUBROUTINE vacuum(rmnc, rmns, zmns, zmnc, xm, xn,
     &                  plascur, rbtor, wint, ns, ivac_skip, ivac,
     &                  mnmax, ier_flag, lscreen)
      USE vacmod
      USE vparams, ONLY: nthreed, zero, one, mu0
      USE vmec_params, ONLY: norm_term_flag, phiedge_error_flag
      USE vmec_input, ONLY: lrfp         ! JDH Added 2013-11-25, to test for RFP

      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER :: ns, ivac_skip, ivac, mnmax, ier_flag
      REAL(dp) :: plascur, rbtor
      REAL(dp), DIMENSION(mnmax), INTENT(in) ::
     &   rmnc, rmns, zmns, zmnc, xm, xn
      REAL(dp), DIMENSION(ns, nuv3), INTENT(in) :: wint
      LOGICAL :: lscreen
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: i
      REAL(dp), ALLOCATABLE :: tmpwint(:)
C-----------------------------------------------
      ALLOCATE (tmpwint(nuv3), stat=i)
      IF (i .NE. 0) STOP 'Allocation error in vacuum'

      tmpwint(:) = wint(ns, :)

      CALL vacuum_par (rmnc, rmns, zmns, zmnc, xm, xn,
     &                 plascur, rbtor, tmpwint, ns, ivac_skip,
     &                 ivac, mnmax, ier_flag, lscreen)

      DEALLOCATE (tmpwint, stat = i)

      END SUBROUTINE vacuum


      SUBROUTINE cumnbn(s,xn,pr,ompr,cum,ccum)
C**********************************************************************
C
C     SUBROUTINE CUMNNBN(S,XN,PR,OMPR,CUM,CCUM)
C                    CUmulative Negative BINomial distribution
C
C
C                              Function
C
C
C     Returns the probability that it there will be S or fewer failures
C     before there are XN successes, with each binomial trial having
C     a probability of success PR.
C
C     Prob(# failures = S | XN successes, PR)  =
C                        ( XN + S - 1 )
C                        (            ) * PR^XN * (1-PR)^S
C                        (      S     )
C
C
C                              Arguments
C
C
C     S --> The number of failures
C                                                  S is DOUBLE PRECISION
C
C     XN --> The number of successes
C                                                  XN is DOUBLE PRECISIO
C
C     PR --> The probability of success in each binomial trial.
C                                                  PR is DOUBLE PRECISIO
C
C     OMPR --> 1 - PR
C                                                  OMPR is DOUBLE PRECIS
C
C     CUM <-- Cumulative negative binomial distribution.
C                                                  CUM is DOUBLE PRECISI
C
C     CCUM <-- Compliment of Cumulative negative binomial distribution.
C                                                  CCUM is DOUBLE PRECIS
C
C
C                              Method
C
C
C     Formula  26.5.26    of   Abramowitz  and    Stegun,  Handbook   of
C     Mathematical   Functions (1966) is   used  to reduce the  negative
C     binomial distribution to the cumulative beta distribution.
C
C**********************************************************************
C     .. Scalar Arguments ..
      DOUBLE PRECISION pr,ompr,s,xn,cum,ccum
C     ..
C     .. External Subroutines ..
      EXTERNAL cumbet
C     ..
C     .. Executable Statements ..
      CALL cumbet(pr,ompr,xn,s+1.D0,cum,ccum)
      RETURN

      END


!   --------------------------------------------------------------------
!   DMET DELUX 2000	Subrutine	fase
!   --------------------------------------------------------------------
!   HENSIKT :
!   Beregner fasevinkler for hiv og stamp for begge lektere
!
!   METODE :
!   Tar inn frekvensvektor, konstantverdier fra lektergeometri og
!   alle beregnede koeffisienter for stamp. Beregner fasevinkel
!   mellom krefter og respons ut fra teorien om dempede svingesystemer
!   med periodisk kraft. ATAN2-funksjonen i Fortran er brukt.
!   Teorien er presentert i rapporten. På grunn av komplekse formler
!   er uttrykkene faktorisert i stor grad.
!
!   KALLESEKVENS:
!   CALL fasekalk(n,nl,omega,M,A33,B33,C33,A55,B55,C55,I55,delta3,delta5)
!
!   PARAMETERE:
!   Navn	I/O	Type			Innhold/Beskrivelse
!   ....................................................................
!   omega	I	flyttals vektor		bølgefrekvens
!   n		I	heltall			antall frekvensintervaller
!   nl		I/O	heltall			antall lektere
!   k		I	flyttallsvektor		bølgetall
!   zeta_an	I	flyttallsvektor		bølgeamplitude
!   hs		I	heltall	  		signifikant bølgehøyde
!   tp		I	heltall			midlere periode
!   gamma	I	heltall			toppethetsfaktor
!   pi		I	flyttall		pi
!   g		I/O	flyttall		tyngdelfeltsakselerasjon
!   sn		O	flyttallsvektor		spekterverdi
!   a		I/O	heltall			nedre frekvensverdi
!   b		I/O	heltall			øvre frekvensverdi
!   H3		I/O	flyttalls matrise	transferfunksjon hiv
!   H5		I/O	flyttalls matrise	transferfunksjon stamp
!   delta3	I/O	flyttalls matrise	fasevinkel hiv
!   delta5	I/O	flyttalls matrise	fasevinkel stamp
!   A33		I/O	flyttalls matrise	tilleggsmasse hiv
!   A55		I/O 	flyttalls matrise	tilleggsmasse stamp
!   B33		I/O	flyttalls matrise	demping hiv
!   B55		I/O	flyttalls matrise	demping stamp
!   C33		I/O	flyttalls vektor	fjørkoeffisient hiv
!   C55		I/O	flyttalls vektor	fjærkoeffisient stamp
!   L		I/O	heltalls vektor		lengde på lekter
!   Br		I/O 	heltalls vektor		bredde på lekter
!   D		I/O	flyttalls vektor	dypgang på lekter
!   H		I/O	flyttalls vektor	dybde i riss for lekter
!   M		I/O	flyttalls vektor	masse lekter
!   GML		I/O	flyttalls vektor	langskips metasenter
!   I33		I/O	flyttall vektor		andre arealmoment tverrskips
!   I55		I/O	flyttalls vektor	andre arealmoment langskips
!   pi		I/O	flyttall		pi
!   rho		I/O	flyttal			tetthet sjøvann
!   g		I/O	flyttall		tyngdeakselerasjonen
!
!
!   INTERNE VARIABLE:
!   Navn			Funksjon
!   .....................................................................
!   i				tellevariabler
!   t3,n3,t5,n5			faktorer i uttrykk!
!
!   SKRIVEFILER:
!   Navn			Eventuell beskrivelse
!   .....................................................................
!   fase3sjekk.txt		skriver resultat for visuell kontroll
!   fase5sjekk.txt		skriver resultat for visuell kontroll
!
!   --------------------------------------------------------------------
!
!   Programmert av:	     Tor Erik Larsen
!   Dato/Versjon  : 	     27.04.15 / 1.0
!
!   --------------------------------------------------------------------

SUBROUTINE fasekalk(n,nl,omega,M,A33,B33,C33,A55,B55,C55,I55,delta3,delta5)
IMPLICIT NONE
!Erklærer vektorer og parametere
INTEGER::i,j,n,nl
REAL::rho,g
DOUBLE PRECISION::t3,n3,t5,n5
REAL,DIMENSION(1:n,1:nl)::A33,B33,A55,B55
REAL,DIMENSION(1:nl)::C33,C55,M,I55
DOUBLE PRECISION,DIMENSION(1:n)::omega
DOUBLE PRECISION,DIMENSION(1:n,1:nl)::delta3,delta5

!Regner fasevinkel for hivbevegelse
DO i=1,n
   DO j=1,nl
      t3 = -omega(i)*B33(i,j)
      n3 = (C33(j) - (M(j) + A33(i,j))*omega(i)**2)
      delta3(i,j) = ATAN2(t3,n3)
   END DO
END DO

!Regner fasevinkel for stampebevegelse
DO i=1,n
   DO j=1,nl
      t5 = omega(i)*B55(i,j)
      n5 = (C55(j) - (I55(j) + A55(i,j))*omega(i)**2)
      delta5(i,j) = ATAN2(t5,n5)
   END DO
END DO

!Skriver hivfase til fil for visuell kontroll
OPEN(249,FILE="fase3sjekk.txt",ACTION="WRITE",STATUS="UNKNOWN")
DO i=1,n
   WRITE(249,*)omega(i), delta3(i,1), delta3(i,2)
END DO
CLOSE(249)

!Skriver stampefasevinkel til fil for kontroll
OPEN(251,FILE="fase5sjekk.txt",ACTION="WRITE",STATUS="UNKNOWN")
DO i=1,n
   WRITE(251,*) omega(i), delta5(i,1), delta5(i,2)
END DO
CLOSE(251)

RETURN
END SUBROUTINE


program hmipt_matsuara_multi_band
  Use DMFT_IPT
  USE IOTOOLS
  USE ERROR
  implicit none
  logical                :: converged,check

  integer                :: i,iloop
  integer                :: Nband
  complex(8),allocatable :: zeta(:),fg(:,:),fg0(:,:),sigma(:,:)
  real(8),allocatable    :: wm(:),n(:),z(:)

  call read_input("inputIPT.in")
  call parse_cmd_variable(nband,"NBAND",default=2)

  !allocate functions:
  allocate(fg(Nband,L))
  allocate(sigma(Nband,L))
  allocate(fg0(Nband,L))
  allocate(zeta(2),n(2),z(2))

  !build freq. array
  allocate(wm(L))
  wm(:)  = pi/beta*real(2*arange(1,L)-1,8)

  !get or read first sigma
  sigma=zero !U_a*(n_a-1/2)

  !dmft loop:
  D=2.d0*ts ;  iloop=0 ; converged=.false.
  do while(.not.converged.AND.iloop<nloop)
     iloop=iloop+1
     write(*,"(A,i5)",advance="no")"DMFT-loop",iloop
     !SELF-CONSISTENCY:
     do i=1,L
        zeta(1) = xi*wm(i) - sigma(1,i)
        zeta(2) = xi*wm(i) - sigma(2,i)
        fg(1,i) = gfbethe(wm(i),zeta(1),D)
        fg(2,i) = gfbethe(wm(i),zeta(2),D)
     enddo
     n(1)   = get_local_density(fg(1,:),beta)
     n(2)   = get_local_density(fg(2,:),beta)
     fg0(1,:) = one/(one/fg(1,:) + sigma(1,:))
     fg0(2,:) = one/(one/fg(2,:) + sigma(2,:))
     !
     !IMPURITY SOLVER
     sigma = solve_ipt_matsubara(fg0)
     converged=check_convergence(fg0(1,:)+fg0(2,:),dmft_error,nsuccess,nloop)
     !GET OBSERVABLES
     z(1)=1.d0 - dimag(sigma(1,1))/wm(1);z(1)=1.d0/z(1)
     z(2)=1.d0 - dimag(sigma(2,1))/wm(1);z(2)=1.d0/z(2)
     call splot("observables_all.ipt",dble(iloop),u,n(1),n(2),z(1),z(2),append=.true.)
  enddo
  call splot("G_iw.ipt",wm,fg(1,:),fg(2,:))
  call splot("G0_iw.ipt",wm,fg0(1,:),fg0(2,:))
  call splot("Sigma_iw.ipt",wm,sigma(1,:),sigma(2,:))
  call splot("observables.ipt",u,n(1),n(2),z(1),z(2))

  ! call fftgf_iw2tau(sigma,sigt(0:),beta,notail=.true.)
  ! open(100,file="fft_sigma_iw.ipt")
  ! do i=0,L
  !    write(100,*)i*beta/dble(L),sigt(i)
  ! enddo
  ! close(100)

contains

  subroutine get_inital_sigma(self,file)
    complex(8),dimension(:,:)       :: self
    real(8),dimension(size(self,2)) :: wm
    character(len=*)                :: file
    logical                         :: check
    inquire(file=file,exist=check)
    if(check)then
       print*,'Reading sigma'
       call sread(file,wm,self)
    else
       print*,"Using Hartree-Fock self-energy"
       print*,"===================================="
       self=zero !U*(n-1/2)
    endif
  end subroutine get_inital_sigma

end program hmipt_matsuara_multi_band


module m_percolations_float_stephan
implicit none
contains
subroutine perc(cluster_strength,L, nclouds, rA, rA_ring, cloud_field, cloud_centers, gauss_field_out)
  real,intent(in) :: rA(:), rA_ring(:)
  integer,intent(in) :: cluster_strength, L, nclouds

  real :: p0, A0, A1, dx, dy, distance_center2, distance_x, distance_y, value_func, value_field, val_center, offset
  real, dimension(2*nclouds) :: random
  integer,dimension(L,L) :: m0,m1,m12,m2
  integer,dimension(nclouds,2) :: center
  real,   dimension(nclouds,2) :: random_dx
  real,   dimension(L,L) :: gauss_field
  real,   dimension(L,L), intent(out) :: gauss_field_out
  integer,dimension(nclouds-1,2),intent(out) :: cloud_centers
  integer,dimension(L,L),intent(out) :: cloud_field
  integer :: k1,k2,num,area_lim_1_max,area_lim_1_min,area_lim_2_max,area_lim_2_min,random_int, ini_ran, ini_ran2
  integer(kind=8) :: u,v,w,r,clock

  val_center=10.0 !value of gauss_field at cloud center (decreases linearly to offset at r=r_disc)
  offset=8.0

  !m fields indicate presence or absence of clouds or cloud rings

  m0(:,:) = 1   !m0 [x,y]=1 means no cloud at [x,y]
  m2(:,:) = 0   !m2 [x,y]=1 means cloud at [x,y]
  m12(:,:)= 0   !m12[x,y]=1 means cloud or cloud ring at [x,y]

  center(:,:)=1 !Initilize 2D array for cloud center coordinates
  gauss_field(:,:)=0 !Initilize cloud field which has a maximum at cloud center and decreases towards the edges

  call system_clock(count=clock)
  call initran(clock,u,v,w)

  !draw all random numbers necessary for drawing cloud center indices

  do ini_ran=1,2*nclouds
    call getran(r,u,v,w)
    random(ini_ran)=i2f(r)
  end do

  !draw all random numbers to get a position of the cloud center within a grid-box [dx, dy]
  !for example if [i,j] are indices of grid-box within which the cloud center is located, [i+dx, i+dy] is the position of the cloud center

  do ini_ran2=1,nclouds
    call getran(r,u,v,w)
    random_dx(ini_ran2,1)=i2f(r)
    call getran(r,u,v,w)
    random_dx(ini_ran2,2)=i2f(r)
  end do

  !Distribute first center randomly

  center(1,1)=floor(L*random(1))+1 !choose one from interval {n,n+1,...,m} with equal probability
  center(1,2)=floor(L*random(2))+1

  do num=2,nclouds

    !Search around center to asign supressed, increased and neutral state

    !Start by defining a box around the cloud center within which the new cloud can have an impact:
    !a box around the cloud center with side-lengths of 2*radius*fac_cw

    area_lim_1_min=max(center(num-1,1)-ceiling(rA_ring(num-1)),1)
    area_lim_1_max=min(center(num-1,1)+ceiling(rA_ring(num-1)),L)

    area_lim_2_min=max(center(num-1,2)-ceiling(rA_ring(num-1)),1)
    area_lim_2_max=min(center(num-1,2)+ceiling(rA_ring(num-1)),L)

    dx=random_dx(num-1,1)-0.5
    dy=random_dx(num-1,2)-0.5

    !identify within this box distances to the center smaller than radius --> cloud, smaller than fac_cw*radius --> cloud ring
    do k1=area_lim_1_min,area_lim_1_max
        do k2=area_lim_2_min, area_lim_2_max

        distance_x=(real(k1-center(num-1,1))-dx)
        distance_y=(real(k2-center(num-1,2))-dy)

        distance_center2=distance_x*distance_x+distance_y*distance_y

        if (distance_center2<=rA(num-1)*rA(num-1)) then
            m2(k1,k2)=1
            m12(k1,k2)=1
            value_func=f_r(sqrt(distance_center2), real(rA(num-1)), val_center, offset)
            value_field=gauss_field(k1,k2)
            gauss_field(k1,k2)=max(value_field,value_func)

        else if (distance_center2<=rA_ring(num-1)*rA_ring(num-1)) then
            m12(k1,k2)=1
        end if
        end do
    end do

    !Determine masks for regions 0 (cloud free) and 1 (cloud ring)

    where(m12==1) m0 =0
    m1=m12-m2

    !Determine area of regions 0 and 1

    A0=sum(m0)
    A1=sum(m1)

    !Calculate probability of each site in region 0

    p0=1.0/(A1*cluster_strength+A0)

    !Choose region 0 or 1 randomly

    if (random((num-1)*2+1)<=p0*A0) then
        !randomly pick one of the elements in A0
        random_int=floor(A0*random((num-1)*2+2))+1
        call find_new_center(L,num,random_int,m0,A0,center)

    else
        !randomly pick one of the elements in A1
        random_int=floor(A1*random((num-1)*2+2))+1
        call find_new_center(L,num,random_int,m1,A1,center)

    end if

  end do

  cloud_field=m2

  cloud_centers=center(1:nclouds-1,:)
  gauss_field_out = gauss_field
! call writeMatrix(L,m2)
end subroutine

subroutine writeMatrix(L,field)
  integer, intent(in) :: L
  integer,dimension(L,L) :: field(:,:)
  integer :: i,j

  do i=1,L
    do j=1,L
      write(*, '(I1,X)',advance='no') field(i,j)
    end do
    write(*,*)''
  end do

end subroutine

real function f_r(r, r_disc, val_center, offset)
    real,intent(in) :: val_center, offset,r_disc
    real :: r
    f_r=val_center-(val_center-offset)*r/r_disc
    return
end

subroutine find_new_center(L,num,random_int,m_chosen,A_chosen,center)
    integer, intent(in) :: L,num,random_int
    integer,dimension(L,L) :: m_chosen(:,:)
    integer,dimension(L,2) :: center(:,:)
    integer :: l1, l2, cum_int
    real :: A_chosen

    if (random_int<=nint(A_chosen/2.0)) then

        cum_int=0

        outer: do l2=1,L
            do l1=1,L
                cum_int=m_chosen(l1,l2)+cum_int
                if (cum_int==random_int) then
                    center(num,1)=l1
                    center(num,2)=l2
                    exit outer
                end if
            end do
        end do outer

    else
        cum_int=nint(A_chosen)

         outer2: do l2=L,1,-1
            do l1=L,1,-1
                cum_int=cum_int-m_chosen(l1,l2)
                if (cum_int==random_int) then
                    center(num,1)=l1
                    center(num,2)=l2
                    exit outer2
                end if
            end do
        end do outer2

    end if

end subroutine

subroutine getran(r,u,v,w)

    implicit none
    integer(kind=8), intent(out)   :: r
    integer(kind=8), intent(inout) :: u,v,w
    integer(kind=8) :: x

    u=u*2862933555777941757_8+7046029254386353087_8
    v=ieor(v,ishft(v,-17))
    v=ieor(v,ishft(v,31))
    v=ieor(v,ishft(v,-8))
    w=int(4294957665_8*iand(w,Z'ffffffff') + ishft(w,-32),8)
    x=ieor(u,ishft(u,21))
    x=ieor(x,ishft(x,-35))
    x=ieor(x,ishft(x,4))
    r=ieor(x+v,w)

end subroutine getran

function i2f(r) result(f)
    implicit none
    integer(kind=8), intent(in)   :: r
    real(kind=8) :: f
    f=5.42101086242752217e-20_8*r
    if (f<0) then
      f=1.0_8+f
    end if
end function i2f

subroutine initran(seed,u,v,w)
    implicit none
    integer(kind=8), intent(in)    :: seed
    integer(kind=8), intent(out)   :: u,v,w
    integer(kind=8) :: d

    v=4101842887655102017_8
    w=1_8
    u=ieor(seed,v)
    call getran(d,u,v,w)
    v=u
    call getran(d,u,v,w)
    w=v
    call getran(d,u,v,w)

end subroutine initran

end module

! program main
!   use m_percolations_float
!   integer,parameter :: L=40
!   integer,parameter :: nclouds=4
!   integer,parameter :: cluster_strength=1
!   real :: rA(nclouds), rA_ring(nclouds)
!   real :: start_time, stop_time
!   integer,dimension(L,L) :: cloud_field
!   integer,dimension(nclouds,2) :: cloud_centers
!   integer :: i
!   call cpu_time(start_time)
!
!   do i=1,nclouds
!     rA(i)=i+2
!     rA_ring(i)=2*rA(i)
!   end do
!
!
! !   rA(:)=8
! !   rA_ring(:)=20
!
!   call perc(cluster_strength,L,nclouds,rA,rA_ring,cloud_field,cloud_centers)
! !   call writeMatrix_real(L,cs_field)
!   call writeMatrix(L,cloud_field)
!   write (*,*) sum(cloud_field)
!   call cpu_time(stop_time)
!   print *, "Time:", &
!    stop_time - start_time, "seconds"
!
! end


Real Function akpel(pkaon)
  Save
  If (pkaon<0.25 .Or. pkaon>=4.0) sigma2 = 0.
  If (pkaon>=0.25 .And. pkaon<4.0) sigma2 = 13.*pkaon**(-0.9)
  akpel = sigma2
  Return
End Function akpel