build_heights Subroutine

public subroutine build_heights(vec_out, use_fct_expo, stats_in, lg)

Note

Function that returns a set of heights that matches desired statistical moments.

Arguments

Type IntentOptional Attributes Name
real(kind=R8), intent(out), dimension(1:lg) :: vec_out

height vector
logical(kind=I4), intent(in) :: use_fct_expo

should exponential function rather than tangent function be used?
type(moment_stat), intent(in) :: stats_in

input statistical moments
integer(kind=I4), intent(in) :: lg

length of the height vector

Calls

proc~~build_heights~~CallsGraph proc~build_heights build_heights calc_moments calc_moments proc~build_heights->calc_moments proc~pikaia_skku_solver pikaia_skku_solver proc~build_heights->proc~pikaia_skku_solver proc~profil_theo_trie_1d profil_theo_trie_1D proc~build_heights->proc~profil_theo_trie_1d sort_array2 sort_array2 proc~build_heights->sort_array2 init pikaia_class%init proc~pikaia_skku_solver->init solve pikaia_class%solve proc~pikaia_skku_solver->solve proc~profil_theo_trie_1d->calc_moments

Called by

proc~~build_heights~~CalledByGraph proc~build_heights build_heights proc~calc_z_f calc_z_f proc~calc_z_f->proc~build_heights proc~calc_z_i calc_z_i proc~calc_z_i->proc~build_heights proc~sub_surf sub_surf proc~sub_surf->proc~build_heights proc~read_job read_job proc~read_job->proc~calc_z_f proc~read_job->proc~calc_z_i proc~read_job->proc~sub_surf proc~prg_surf prg_surf proc~prg_surf->proc~read_job program~main main program~main->proc~prg_surf

Source Code

   subroutine build_heights(vec_out, use_fct_expo, stats_in, lg)
   !================================================================================================
   !<@note Function that returns a set of heights that matches desired statistical moments.
   !<
   !<@endnote
   !------------------------------------------------------------------------------------------------
   implicit none
   integer (kind=I4), intent(in )                    :: lg              !! *length of the height vector*
   type(MOMENT_STAT), intent(in )                    :: stats_in        !! *input statistical moments*
   logical (kind=I4), intent(in )                    :: use_fct_expo    !! *should exponential function rather than tangent function be used?*
   real    (kind=R8), intent(out), dimension(1:lg)   :: vec_out         !! *height vector*

      integer(kind=I4) :: istat, fct_sav
      real(kind=R8)    :: cost_val

      type(MOMENT_STAT) :: m_tmp

      real(kind=R8), dimension(1:PARAM%nparam) :: xlower
      real(kind=R8), dimension(1:PARAM%nparam) :: xupper
      real(kind=R8), dimension(1:PARAM%nparam) :: xresul

      ! put input parameters in global variables, so that they can be used in the function "fitness_skku_anal"
      PARAM%m_inp%sk = stats_in%sk
      PARAM%m_inp%ku = stats_in%ku

      ! save PARAM%func_gen value
      fct_sav = PARAM%func_gen

      ! if the Pearson limit is to close to the point (Ssk, Sku), an exponential function is used
      if ( use_fct_expo ) PARAM%func_gen = FCT_EXPO

      ! Genetic algorithm is used to determinate the tangent parameters \alpha and \beta so that, the set of lg heights
      ! will match the statistical moments.
      !..............................................................................

      ! initialization
      xresul(1:PARAM%nparam) = 0.0_R8
      xlower(1:PARAM%nparam) = 0.0_R8
      xupper(1:PARAM%nparam) = 1.0_R8

      call pikaia_skku_solver( pik_class = PARAM%pik_class,          &  ! INOUT
                                    step = 'init',                   &  ! IN
                                      xl = xlower(1:PARAM%nparam),   &  ! IN
                                      xu = xupper(1:PARAM%nparam),   &  ! IN
                                      xx = xresul(1:PARAM%nparam),   &  ! IN
                                  nparam = PARAM%nparam,             &  ! IN
                                    cost = cost_func_skku,           &  ! IN
                                   istat = istat,                    &  ! OUT
                                       f = cost_val )                   ! IN

      call pikaia_skku_solver( pik_class = PARAM%pik_class,          &  ! INOUT
                                    step = 'solv',                   &  ! IN
                                      xl = xlower(1:PARAM%nparam),   &  ! IN
                                      xu = xupper(1:PARAM%nparam),   &  ! IN
                                      xx = xresul(1:PARAM%nparam),   &  ! OUT
                                  nparam = PARAM%nparam,             &  ! IN
                                    cost = cost_func_skku,           &  ! IN
                                   istat = istat,                    &  ! OUT
                                       f = cost_val )                   ! IN
      !..............................................................................

      ! the parameters habe been found, let generate lg heights
      !..............................................................................
      call profil_theo_trie_1D( tab = vec_out(1:lg),               &  ! OUT
                                 lg = lg,                          &  ! IN
                                  x = xresul(1:PARAM%nparam),      &  ! IN
                                 mx = m_tmp )                         ! OUT
      !..............................................................................

      ! PARAM%func_gen value is retrieved
      PARAM%func_gen = fct_sav

      ! height moments calculation
      call calc_moments(   tab = vec_out(1:lg),      &  ! IN
                            mx = m_tmp,              &  ! OUT
                        nb_mom = 4 )                    ! IN

      ! scale and center
      vec_out(1:lg) = ( vec_out(1:lg) - m_tmp%mu ) / m_tmp%si

      ! the parameter found can lead to inverted heights
      if (stats_in%sk * m_tmp%sk < 0.) then

         vec_out(1:lg) = -vec_out(1:lg)

      endif

      ! heights are sorted
      call sort_array2(tab_inout = vec_out(1:lg), n = lg)

   return
   endsubroutine build_heights