feedback.f

Go to the documentation of this file.

!*******************************************************************************
!
!  Note separating the Doxygen comment block here so detailed decription is
!  found in the Module not the file.
!
!*******************************************************************************
 
      MODULE feedback
 
      USE signal
 
      IMPLICIT NONE
 
!*******************************************************************************
!  DERIVED-TYPE DECLARATIONS
!  1) feedback base class
!
!*******************************************************************************
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      TYPE, EXTENDS(signal_class) :: feedback_class
         class(signal_class), POINTER :: signal => null()
      CONTAINS
         final                         :: feedback_destruct
      END TYPE feedback_class
 
!*******************************************************************************
!  INTERFACE BLOCKS
!*******************************************************************************
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      INTERFACE feedback_class
         MODULE PROCEDURE feedback_construct
      END INTERFACE
 
      CONTAINS
!*******************************************************************************
!  CONSTRUCTION SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      FUNCTION feedback_construct(signal)
 
      IMPLICIT NONE
 
!  Declare Arguments
      class(feedback_class), POINTER :: feedback_construct_ratio
      class(signal_class), POINTER   :: signal
 
!  local variables
      REAL (rprec)                    :: start_time
 
!  Start of executable code
      start_time = profiler_get_start_time()
 
      ALLOCATE(feedback_construct_ratio)
 
      feedback_construct_ratio%signal => signal
 
      CALL profiler_set_stop_time('feedback_construct', start_time)
 
      END FUNCTION
 
!*******************************************************************************
!  DESTRUCTION SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      SUBROUTINE feedback_destruct(this)
 
      IMPLICIT NONE
 
!  Declare Arguments
      TYPE (feedback_class), POINTER :: this
 
!  Start of executable code
      IF (ASSOCIATED(this%signal)) THEN
         this%signal => null()
      END IF
 
      DEALLOCATE(this)
 
      END SUBROUTINE
 
!*******************************************************************************
!  GETTER SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      FUNCTION feedback_get_modeled_signal(this, a_model, sigma,               &
     &                                     last_value)
 
      IMPLICIT NONE
 
!  Declare Arguments
      REAL (rprec), DIMENSION(4) :: feedback_get_modeled_signal
      class(feedback_class), INTENT(in)      :: this
      TYPE (model_class), POINTER             :: a_model
      REAL (rprec), DIMENSION(4), INTENT(out) :: sigma
      REAL (rprec), DIMENSION(4), INTENT(in)  :: last_value
 
!  local variables
      REAL (rprec)                            :: start_time
 
!  Start of executable code
      start_time = profiler_get_start_time()
 
      SELECT CASE(this%type)
 
         CASE (feedback_sxrem_ratio_type)
            feedback_get_modeled_signal =                                      &
     &         sxrem_ratio_get_modeled_signal(this%ratio, a_model,             &
     &                                        sigma, last_value,               &
     &                                        scale_factor,                    &
     &                                        offset_factor)
 
      END SELECT
 
      CALL profiler_set_stop_time('feedback_get_modeled_signal',               &
     &                            start_time)
 
      END FUNCTION
 
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      FUNCTION feedback_get_observed_signal(this, a_model)
 
      IMPLICIT NONE
 
!  Declare Arguments
      REAL(rprec) :: feedback_get_observed_signal
      TYPE(feedback_class), INTENT(in) :: this
      TYPE (model_class), INTENT(in)   :: a_model
 
!  local variables
      REAL (rprec)                     :: start_time
 
!  Start of executable code
      start_time = profiler_get_start_time()
 
      SELECT CASE(this%type)
 
         CASE (feedback_sxrem_ratio_type)
            feedback_get_observed_signal =                                     &
     &         sxrem_ratio_get_observed_signal(this%ratio, a_model)
 
         CASE DEFAULT
            feedback_get_observed_signal = 0.0
 
      END SELECT
 
      CALL profiler_set_stop_time('feedback_get_observed_signal',              &
     &                            start_time)
 
      END FUNCTION
 
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      FUNCTION feedback_get_signal_type(this)
      USE data_parameters
 
      IMPLICIT NONE
 
!  Declare Arguments
      CHARACTER (len=data_name_length)  :: feedback_get_signal_type
      TYPE (feedback_class), INTENT(in) :: this
 
!  local variables
      REAL (rprec)                      :: start_time
 
!  Start of executable code
      start_time = profiler_get_start_time()
 
      SELECT CASE(this%type)
 
         CASE (feedback_sxrem_ratio_type)
            feedback_get_signal_type = trim('feedback ' //                     &
     &         sxrem_ratio_get_signal_type(this%ratio))
 
      END SELECT
 
      CALL profiler_set_stop_time('feedback_get_signal_type',                  &
     &                            start_time)
 
      END FUNCTION
 
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      FUNCTION feedback_get_header(this)
 
      IMPLICIT NONE
 
!  Declare Arguments
      CHARACTER (len=data_name_length), DIMENSION(7)                           &
     &   :: feedback_get_header
      TYPE (feedback_class), INTENT(in) :: this
 
!  local variables
      REAL (rprec)                      :: start_time
 
!  Start of executable code
      start_time = profiler_get_start_time()
 
      SELECT CASE(this%type)
 
         CASE DEFAULT
            feedback_get_header(1:3) = 'N/A'
            feedback_get_header(4) = 'model_sig(1)'
            feedback_get_header(5) = 'model_sig(2)'
            feedback_get_header(6) = 'model_sig(3)'
            feedback_get_header(7) = 'model_sig(4)'
 
      END SELECT
 
      CALL profiler_set_stop_time('feedback_get_header', start_time)
 
      END FUNCTION
 
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      FUNCTION feedback_get_feedback_type(this)
 
      IMPLICIT NONE
 
!  Declare Arguments
      CHARACTER (len=data_name_length)  :: feedback_get_feedback_type
      TYPE (feedback_class), INTENT(in) :: this
 
!  local variables
      REAL (rprec)                      :: start_time
 
!  Start of executable code
      start_time = profiler_get_start_time()
 
      SELECT CASE(this%type)
 
         CASE (feedback_sxrem_ratio_type)
            feedback_get_feedback_type =                                       &
     &         sxrem_ratio_get_signal_type(this%ratio)
      END SELECT
 
      CALL profiler_set_stop_time('feedback_get_feedback_type',                &
     &                            start_time)
 
      END FUNCTION
 
!*******************************************************************************
!  UTILITY SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      SUBROUTINE feedback_write_auxiliary(this, iou, index)
 
      IMPLICIT NONE
 
!  Declare Arguments
      TYPE (feedback_class), INTENT(in) :: this
      INTEGER, INTENT(in)               :: iou
      INTEGER, INTENT(in)               :: index
 
!  local variables
      REAL (rprec)                      :: start_time
 
!  Start of executable code
      start_time = profiler_get_start_time()
 
      WRITE (iou,*)
      WRITE (iou,1000) index, feedback_get_feedback_type(this)
 
      SELECT CASE(this%type)
 
         CASE (feedback_sxrem_ratio_type)
            CALL sxrem_ratio_write_auxiliary(this%ratio, iou)
 
      END SELECT
 
      CALL profiler_set_stop_time('feedback_write_auxiliary',                  &
     &                            start_time)
 
1000  FORMAT('Signal',1x,i4,1x,'is a feedback signal, type: ',a)
 
      END SUBROUTINE
 
      END MODULE