fcn Subroutine

public pure subroutine fcn(beta, xplusd, ifixb, ifixx, ideval, f, fjacb, fjacd, istop)

User-supplied subroutine for evaluating the model.

Arguments

Type IntentOptional Attributes Name
real(kind=wp), intent(in) :: beta(:)
real(kind=wp), intent(in) :: xplusd(:,:)
integer, intent(in) :: ifixb(:)
integer, intent(in) :: ifixx(:,:)
integer, intent(in) :: ideval
real(kind=wp), intent(out) :: f(:,:)
real(kind=wp), intent(out) :: fjacb(:,:,:)
real(kind=wp), intent(out) :: fjacd(:,:,:)
integer, intent(out) :: istop

Variables

Type Visibility Attributes Name Initial
real(kind=wp), public :: freq
real(kind=wp), public :: omega
real(kind=wp), public :: ctheta
real(kind=wp), public :: stheta
real(kind=wp), public :: theta
real(kind=wp), public :: phi
real(kind=wp), public :: r
real(kind=wp), public, parameter :: pi = 4*atan(one)
integer, public :: i

Source Code

   pure subroutine fcn(beta, xplusd, ifixb, ifixx, ideval, f, fjacb, fjacd, istop)
   !! User-supplied subroutine for evaluating the model.

      integer, intent(in) :: ideval, ifixb(:), ifixx(:, :)
      real(kind=wp), intent(in) :: beta(:), xplusd(:, :)
      real(kind=wp), intent(out) :: f(:, :), fjacb(:, :, :), fjacd(:, :, :)
      integer, intent(out) :: istop

      ! Local variables
      real(kind=wp) :: freq, omega, ctheta, stheta, theta, phi, r
      real(kind=wp), parameter :: pi = 4*atan(one)
      integer :: i

      ! Check for unacceptable values for this problem
      do i = 1, ubound(xplusd, 1)
         if (xplusd(i, 1) < zero) then
            istop = 1
            return
         end if
      end do
      istop = 0

      theta = pi*beta(4)*0.5E0_wp
      ctheta = cos(theta)
      stheta = sin(theta)

      ! Compute predicted values
      if (mod(ideval, 10) >= 1) then
         do i = 1, ubound(xplusd, 1)
            freq = xplusd(i, 1)
            omega = (2.0E0_wp*pi*freq*exp(-beta(3)))**beta(4)
            phi = atan2((omega*stheta), (1 + omega*ctheta))
            r = (beta(1) - beta(2))*sqrt((1 + omega*ctheta)**2 + (omega*stheta)**2)**(-beta(5))
            f(i, 1) = beta(2) + r*cos(beta(5)*phi)
            f(i, 2) = r*sin(beta(5)*phi)
         end do
      end if

   end subroutine fcn