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 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 std_array std_array proc~build_heights->std_array init pikaia_class%init proc~pikaia_skku_solver->init solve pikaia_class%solve proc~pikaia_skku_solver->solve proc~profil_theo_trie_1d->std_array

Called by

proc~~build_heights~~CalledByGraph proc~build_heights build_heights proc~add_nois add_nois proc~add_nois->proc~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~add_nois 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
      real(kind=R8)    :: cost_val

      type(MOMENT_STAT) :: m_tmp

      real(kind=R8), dimension(:), allocatable :: xlower
      real(kind=R8), dimension(:), allocatable :: xupper
      real(kind=R8), dimension(:), allocatable :: 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

      ! if the Pearson limit is to close to the point (Ssk, Sku), an exponential function is used
      if ( use_fct_expo ) then

         PARAM%func_gen = FCT_EXPO
         PARAM%nparam   = 3

      else

         PARAM%func_gen = FCT_TANG
         PARAM%nparam   = 2

      endif

      ! 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
      allocate( xresul(1:PARAM%nparam) ) ; xresul = 0.0_R8
      allocate( xlower(1:PARAM%nparam) ) ; xlower = 1.e-6_R8
      allocate( xupper(1:PARAM%nparam) ) ; xupper = 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

      deallocate( xresul )
      deallocate( xlower )
      deallocate( xupper )

      call std_array( tab = vec_out(1:lg), mx = m_tmp)

      ! 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