Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
10 changes: 6 additions & 4 deletions sorc/grid_tools.fd/regional_esg_grid.fd/pesg.f90
Original file line number Diff line number Diff line change
Expand Up @@ -431,7 +431,7 @@ end subroutine xmtoxc_vak1
!! @param a ESG mapping parameterization
!! @param k ESG mapping parameterization
!! @param xm map-space vector
!! @param xm derivative
!! @param xc derivative
!! @param xcd jacobian matrix
!! @param ff error flag
!! @author R. J. Purser
Expand All @@ -451,7 +451,7 @@ subroutine xmtoxc_ak(a,k,xm,xc,xcd,ff)! [xmtoxc_ak]
xcd=matmul(xcd,xsd)
end subroutine xmtoxc_ak

!! Inverse mapping of xmtoxc_ak. That is, go from given cartesian unit
!> Inverse mapping of xmtoxc_ak. That is, go from given cartesian unit
!! 3-vector, xc, to map coordinate 2-vector xm (or return a raised
!! failure flag, FF, if the attempt fails).
!!
Expand Down Expand Up @@ -1598,7 +1598,7 @@ subroutine hgrid_ak_rc(lx,ly,nx,ny,A,K,plat,plon,pazi, & ! [hgrid_ak_rc]
enddo
end subroutine hgrid_ak_rc

!! Use a and k as the parameters of an Extended Schmidt-transformed
!> Use a and k as the parameters of an Extended Schmidt-transformed
!! Gnomonic (ESG) mapping centered at (pdlat,pdlon) and twisted about
!! this center by an azimuth angle of pdazi counterclockwise (these
!! angles in degrees).
Expand Down Expand Up @@ -1644,7 +1644,7 @@ subroutine hgrid_ak_dd(lx,ly,nx,ny,a,k,pdlat,pdlon,pdazi, & ! [hgrid_ak_dd]
gdlon=gdlon*rtod !
end subroutine hgrid_ak_dd

!! Like hgrid_ak_rr_c, except all the angle arguments (but not
!> Like hgrid_ak_rr_c, except all the angle arguments (but not
!! delx,dely) are in degrees instead of radians.
!!
!! @param[in] lx x grid index for left-lower corner of the grid at center
Expand Down Expand Up @@ -1973,6 +1973,8 @@ end subroutine gtoxm_ak_dd_m
!! @param[in] pdazi ???
!! @param[in] delx central x-spacing grid point
!! @param[in] dely central y-spacing grid point
!! @param[in] dlat ???
!! @param[in] dlon ???
!! @param[out] xm ???
!! @param[out] ff failure flag
!! @author R. J. Purser
Expand Down
182 changes: 127 additions & 55 deletions sorc/grid_tools.fd/regional_esg_grid.fd/pfun.f90
Original file line number Diff line number Diff line change
@@ -1,8 +1,10 @@
!> @file
!! ???
!! @author R. J. Purser
!! Direct dependencies:
!! Modules: pkind, pietc_s, pietc

!> This module is for ???
!!
!! @author R. J. Purser
module pfun
!=============================================================================
use pkind, only: sp,dp
Expand All @@ -27,125 +29,169 @@ module pfun

contains

!=============================================================================
!> ???
!!
!! @param[in] x ???
!! @return y ???
!! @author R. J. Purser
function gd_s(x) result(y)! [gd]
!=============================================================================
! Gudermannian function
implicit none
real(sp),intent(in ):: x
real(sp) :: y
y=atan(sinh(x))
end function gd_s
!=============================================================================

!> ???
!!
!! @param[in] x ???
!! @return y ???
!! @author R. J. Purser
function gd_d(x) result(y)! [gd]
!=============================================================================
implicit none
real(dp),intent(in ):: x
real(dp) :: y
y=atan(sinh(x))
end function gd_d

!=============================================================================
!> Inverse Gudermannian function for single precision real.
!!
!! @param[in] y ???
!! @return x ???
!! @author R. J. Purser
function gdi_s(y) result(x)! [gdi]
!=============================================================================
! Inverse Gudermannian function
implicit none
real(sp),intent(in ):: y
real(sp) :: x
x=atanh(sin(y))
end function gdi_s
!=============================================================================

!> Inverse Gudermannian function for double precision real.
!!
!! @param[in] y ???
!! @return x ???
!! @author R. J. Purser
function gdi_d(y) result(x)! [gdi]
!=============================================================================
implicit none
real(dp),intent(in ):: y
real(dp) :: x
x=atanh(sin(y))
end function gdi_d

!=============================================================================
!> Haversine function for single precision real.
!!
!! @param[in] t ???
!! @return a ???
!! @author R. J. Purser
function hav_s(t) result(a)! [hav]
!=============================================================================
! Haversine function
use pietc_s, only: o2
implicit none
real(sp),intent(in ):: t
real(sp) :: a
a=(sin(t*o2))**2
end function hav_s
!=============================================================================

!> Haversine function for double precision real.
!!
!! @param[in] t ???
!! @return a ???
!! @author R. J. Purser
function hav_d(t) result(a)! [hav]
!=============================================================================
use pietc, only: o2
implicit none
real(dp),intent(in ):: t
real(dp) :: a
a=(sin(t*o2))**2
end function hav_d

!=============================================================================
!> Hyperbolic-haversine for single precision real.
!!
!! @note The minus sign in the hyperbolic-haversine definition.
!!
!! @param[in] t ???
!! @return a ???
!! @author R. J. Purser
function havh_s(t) result(a)! [havh]
!=============================================================================
! Note the minus sign in the hyperbolic-haversine definition
use pietc_s, only: o2
implicit none
real(sp),intent(in ):: t
real(sp) :: a
a=-(sinh(t*o2))**2
end function havh_s
!=============================================================================

!> Hyperbolic-haversine for double precision real.
!!
!! @param[in] t ???
!! @return a ???
!! @author R. J. Purser
function havh_d(t) result(a)! [havh]
!=============================================================================
use pietc, only: o2
implicit none
real(dp),intent(in ):: t
real(dp) :: a
a=-(sinh(t*o2))**2
end function havh_d

!=============================================================================
!> Arc-haversine function for single precision real.
!!
!! @param[in] a ???
!! @return t ???
!! @author R. J. Purser
function ahav_s(a) result(t)! [ahav]
!=============================================================================
use pietc_s, only: u2
! Arc-haversine function
implicit none
real(sp),intent(in ):: a
real(sp) :: t
t=u2*asin(sqrt(a))
end function ahav_s
!=============================================================================

!> Arc-haversine function for double precision real.
!!
!! @param[in] a ???
!! @return t ???
!! @author R. J. Purser
function ahav_d(a) result(t)! [ahav]
!=============================================================================
use pietc, only: u2
implicit none
real(dp),intent(in ):: a
real(dp) :: t
t=u2*asin(sqrt(a))
end function ahav_d

!=============================================================================
!> Hyperbolic arc-haversine for single precision real.
!!
!! @note The minus sign in the hyperbolic arc-haversine definition.
!!
!! @param[in] a ???
!! @return t ???
!! @author R. J. Purser
function ahavh_s(a) result(t)! [ahavh]
!=============================================================================
use pietc_s, only: u2
! Note the minus sign in the hyperbolic arc-haversine definition
implicit none
real(sp),intent(in ):: a
real(sp) :: t
t=u2*asinh(sqrt(-a))
end function ahavh_s
!=============================================================================

!> Hyperbolic arc-haversine for double precision real.
!!
!! @param[in] a ???
!! @return t ???
!! @author R. J. Purser
function ahavh_d(a) result(t)! [ahavh]
!=============================================================================
use pietc, only: u2
implicit none
real(dp),intent(in ):: a
real(dp) :: t
t=u2*asinh(sqrt(-a))
end function ahavh_d

!=============================================================================
!> ???
!!
!! @param[in] t ???
!! @return a ???
!! @author R. J. Purser
function atanh_s(t) result(a)! [atanh]
!=============================================================================
use pietc_s, only: u1,o2,o3,o5
implicit none
real(sp),intent(IN ):: t
Expand All @@ -157,9 +203,13 @@ function atanh_s(t) result(a)! [atanh]
else; tt=t*t; a=t*(u1+tt*(o3+tt*(o5+tt*(o7+tt*o9))))
endif
end function atanh_s
!=============================================================================

!> ???
!!
!! @param[in] t ???
!! @return a ???
!! @author R. J. Purser
function atanh_d(t) result(a)! [atanh]
!=============================================================================
use pietc, only: u1,o2,o3,o5
implicit none
real(dp),intent(IN ):: t
Expand All @@ -172,9 +222,12 @@ function atanh_d(t) result(a)! [atanh]
endif
end function atanh_d

!=============================================================================
!> ???
!!
!! @param[in] x ???
!! @return t ???
!! @author R. J. Purser
function sech_s(x)result(r)! [sech]
!=============================================================================
! This indirect way of computing 1/cosh(x) avoids overflows at large x
use pietc_s, only: u1,u2
implicit none
Expand All @@ -185,9 +238,13 @@ function sech_s(x)result(r)! [sech]
e=exp(-ax)
r=e*u2/(u1+e*e)
end function sech_s
!=============================================================================

!> ???
!!
!! @param[in] x ???
!! @return r ???
!! @author R. J. Purser
function sech_d(x)result(r)! [sech]
!=============================================================================
use pietc, only: u1,u2
implicit none
real(dp),intent(in ):: x
Expand All @@ -198,27 +255,36 @@ function sech_d(x)result(r)! [sech]
r=e*u2/(u1+e*e)
end function sech_d

!=============================================================================
!> ???
!!
!! @param[in] x ???
!! @return r ???
!! @author R. J. Purser
function sechs_s(x)result(r)! [sechs]
!=============================================================================
implicit none
real(sp),intent(in ):: x
real(sp) :: r
r=sech(x)**2
end function sechs_s
!=============================================================================

!> ???
!!
!! @param[in] x ???
!! @return r ???
!! @author R. J. Purser
function sechs_d(x)result(r)! [sechs]
!=============================================================================
implicit none
real(dp),intent(in ):: x
real(dp) :: r
r=sech(x)**2
end function sechs_d

!=============================================================================
!> Evaluate the symmetric real function sin(x)/x-1.
!!
!! @param[in] x ???
!! @return r ???
!! @author R. J. Purser
function sinoxm_d(x) result(r)! [sinoxm]
!=============================================================================
! Evaluate the symmetric real function sin(x)/x-1
use pietc, only: u1
implicit none
real(dp),intent(in ):: x
Expand All @@ -233,10 +299,12 @@ function sinoxm_d(x) result(r)! [sinoxm]
endif
end function sinoxm_d

!=============================================================================
!> Evaluate the symmetric real function sin(x)/x.
!!
!! @param[in] x ???
!! @return r ???
!! @author R. J. Purser
function sinox_d(x) result(r)! [sinox]
!=============================================================================
! Evaluate the symmetric real function sin(x)/x
use pietc, only: u1
implicit none
real(dp),intent(in ):: x
Expand All @@ -245,10 +313,12 @@ function sinox_d(x) result(r)! [sinox]
r=sinoxm(x)+u1
end function sinox_d

!=============================================================================
!> Evaluate the symmetric real function sinh(x)/x-1.
!!
!! @param[in] x ???
!! @return r ???
!! @author R. J. Purser
function sinhoxm_d(x) result(r)! [sinhoxm]
!=============================================================================
! Evaluate the symmetric real function sinh(x)/x-1
use pietc, only: u1
implicit none
real(dp),intent(in ):: x
Expand All @@ -263,10 +333,12 @@ function sinhoxm_d(x) result(r)! [sinhoxm]
endif
end function sinhoxm_d

!=============================================================================
!> Evaluate the symmetric real function sinh(x)/x.
!!
!! @param[in] x ???
!! @return r ???
!! @author R. J. Purser
function sinhox_d(x) result(r)! [sinhox]
!=============================================================================
! Evaluate the symmetric real function sinh(x)/x
use pietc, only: u1
implicit none
real(dp),intent(in ):: x
Expand Down
Loading