cPCHIP Subroutine

public subroutine cPCHIP(x, t, c, cimag, gradc, crr, crz, czz, rho, freq, Task)

Uses

  • proc~~cpchip~~UsesGraph proc~cpchip cPCHIP module~pchipmod pchipmod proc~cpchip->module~pchipmod module~splinec splinec module~pchipmod->module~splinec

PCHIP for interpolation of sound speed

Arguments

Type IntentOptional Attributes Name
real(kind=8), intent(in) :: x(2)
real(kind=8), intent(in) :: t(2)
real(kind=8), intent(out) :: c
real(kind=8), intent(out) :: cimag
real(kind=8), intent(out) :: gradc(2)
real(kind=8), intent(out) :: crr
real(kind=8), intent(out) :: crz
real(kind=8), intent(out) :: czz
real(kind=8), intent(out) :: rho
real(kind=8), intent(in) :: freq
character(len=3), intent(in) :: Task

Calls

proc~~cpchip~~CallsGraph proc~cpchip cPCHIP proc~pchip PCHIP proc~cpchip->proc~pchip proc~readssp ReadSSP proc~cpchip->proc~readssp proc~updatedepthsegmentt UpdateDepthSegmentT proc~cpchip->proc~updatedepthsegmentt proc~cspline CSPLINE proc~pchip->proc~cspline proc~fprime_interior_cmplx fprime_interior_Cmplx proc~pchip->proc~fprime_interior_cmplx proc~fprime_left_end_cmplx fprime_left_end_Cmplx proc~pchip->proc~fprime_left_end_cmplx proc~fprime_right_end_cmplx fprime_right_end_Cmplx proc~pchip->proc~fprime_right_end_cmplx proc~h_del h_del proc~pchip->proc~h_del proc~crci CRCI proc~readssp->proc~crci proc~errout ERROUT proc~readssp->proc~errout proc~crci->proc~errout proc~franc_garr Franc_Garr proc~crci->proc~franc_garr proc~fprime_interior fprime_interior proc~fprime_interior_cmplx->proc~fprime_interior proc~fprime_left_end fprime_left_end proc~fprime_left_end_cmplx->proc~fprime_left_end proc~fprime_right_end fprime_right_end proc~fprime_right_end_cmplx->proc~fprime_right_end

Called by

proc~~cpchip~~CalledByGraph proc~cpchip cPCHIP proc~evaluatessp EvaluateSSP proc~evaluatessp->proc~cpchip proc~bellhopcore~2 BellhopCore proc~bellhopcore~2->proc~evaluatessp proc~influencecervenycart InfluenceCervenyCart proc~bellhopcore~2->proc~influencecervenycart proc~traceray2d~2 TraceRay2D proc~bellhopcore~2->proc~traceray2d~2 proc~influencecervenycart->proc~evaluatessp proc~readenvironment ReadEnvironment proc~readenvironment->proc~evaluatessp proc~reflect2d~2 Reflect2D proc~reflect2d~2->proc~evaluatessp proc~step2d Step2D proc~step2d->proc~evaluatessp proc~traceray2d~2->proc~evaluatessp proc~traceray2d~2->proc~reflect2d~2 proc~traceray2d~2->proc~step2d proc~bellhopcore BellhopCore proc~bellhopcore->proc~influencecervenycart program~bellhop BELLHOP program~bellhop->proc~bellhopcore~2 program~bellhop->proc~readenvironment program~bellhop3d BELLHOP3D program~bellhop3d->proc~readenvironment program~bellhop3d->proc~bellhopcore

Source Code

  SUBROUTINE cPCHIP( x, t, c, cimag, gradc, crr, crz, czz, rho, freq, Task )
    !! PCHIP for interpolation of sound speed

    ! This implements the new monotone piecewise cubic Hermite interpolating
    ! polynomial (PCHIP) algorithm for the interpolation of the sound speed c.

    USE pchipMod
    REAL     (KIND=8), INTENT( IN  ) :: freq
    REAL     (KIND=8), INTENT( IN  ) :: x( 2 )   ! r-z coordinate where sound speed is evaluated
    REAL     (KIND=8), INTENT( IN  ) :: t( 2 )   ! ray tangent; for edge cases of updating segments
    CHARACTER (LEN=3), INTENT( IN  ) :: Task
    REAL     (KIND=8), INTENT( OUT ) :: c, cimag, gradc( 2 ), crr, crz, czz, rho ! sound speed and its derivatives
    REAL     (KIND=8) :: xt
    COMPLEX  (KIND=8) :: c_cmplx

    IF ( Task == 'INI' ) THEN   ! read in SSP data

       Depth     = x( 2 )
       CALL ReadSSP( Depth, freq )

       !                                                               2      3
       ! compute coefficients of std cubic polynomial: c0 + c1*x + c2*x + c3*x
       !

       CALL PCHIP( SSP%z, SSP%c, SSP%NPts, SSP%cCoef, SSP%CSWork )

    ELSE                        ! return SSP info

       CALL UpdateDepthSegmentT( x, t )

       xt = x( 2 ) - SSP%z( iSegz )
       c_cmplx = SSP%cCoef( 1, iSegz ) &
             + ( SSP%cCoef( 2, iSegz ) &
             + ( SSP%cCoef( 3, iSegz ) &
             +   SSP%cCoef( 4, iSegz ) * xt ) * xt ) * xt

       c     = REAL(  c_cmplx )
       cimag = AIMAG( c_cmplx )

       gradc = [ 0.0D0, REAL( SSP%cCoef( 2, iSegz ) &
                  + ( 2.0D0 * SSP%cCoef( 3, iSegz ) &
                    + 3.0D0 * SSP%cCoef( 4, iSegz ) * xt ) * xt ) ]

       crr   = 0.0D0
       crz   = 0.0D0
       czz   = REAL( 2.0D0 * SSP%cCoef( 3, iSegz ) + 6.0D0 * SSP%cCoef( 4, iSegz ) * xt )

       W     = ( x( 2 ) - SSP%z( iSegz ) ) / ( SSP%z( iSegz + 1 ) - SSP%z( iSegz ) )
       rho   = ( 1.0D0 - W ) * SSP%rho( iSegz ) + W * SSP%rho( iSegz + 1 )   ! linear interp of density

    END IF

  END SUBROUTINE cPCHIP