diff --git a/CMakeLists.txt b/CMakeLists.txt index 06f4ef5..d53694c 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -49,6 +49,7 @@ list(APPEND SUBLIST "PM") list(APPEND SUBLIST "RADMON") list(APPEND SUBLIST "REF2TTEN") list(APPEND SUBLIST "RTMA_MINMAXTRH") +list(APPEND SUBLIST "RTMA_ESG_CONVERSION") list(APPEND SUBLIST "UPDATE_BC") list(APPEND SUBLIST "UPDATE_GVF") list(APPEND SUBLIST "UPDATE_ICE") @@ -86,6 +87,8 @@ find_package(gsi REQUIRED) add_subdirectory(baselib/regional_esg_grid.fd) add_subdirectory(baselib) +add_subdirectory(rtma_esg_conversion.fd/esg_lib.fd) + foreach(X IN LISTS SUBLIST) if(${${X}}) string(TOLOWER ${X} x) diff --git a/rtma_esg_conversion.fd/CMakeLists.txt b/rtma_esg_conversion.fd/CMakeLists.txt new file mode 100644 index 0000000..2a1dfb9 --- /dev/null +++ b/rtma_esg_conversion.fd/CMakeLists.txt @@ -0,0 +1,51 @@ +list(APPEND src_rll2esg + mod_rtma_regrid.F90 + rtma_regrid_rll2esg.F90) + +add_executable(rtma_regrid_rll2esg.exe ${src_rll2esg}) +target_link_libraries(rtma_regrid_rll2esg.exe PRIVATE ${PROJECT_NAME}::pesglib2 + PRIVATE bacio::bacio_4 + PRIVATE g2::g2_4 + PRIVATE g2tmpl::g2tmpl + PRIVATE ip::ip_d + PRIVATE sp::sp_d + PRIVATE w3emc::w3emc_4 + PRIVATE NetCDF::NetCDF_Fortran + PRIVATE MPI::MPI_Fortran) +if(OpenMP_Fortran_FOUND) + target_link_libraries(rtma_regrid_rll2esg.exe PRIVATE OpenMP::OpenMP_Fortran) +endif() +list(APPEND ESG_CONVERSION_Targets rtma_regrid_rll2esg.exe) + +list(APPEND src_esg2rll + mod_rtma_regrid.F90 + rtma_regrid_esg2rll.F90) + +add_executable(rtma_regrid_esg2rll.exe ${src_esg2rll}) +target_link_libraries(rtma_regrid_esg2rll.exe PRIVATE ${PROJECT_NAME}::pesglib2 + PRIVATE bacio::bacio_4 + PRIVATE g2::g2_4 + PRIVATE g2tmpl::g2tmpl + PRIVATE ip::ip_d + PRIVATE sp::sp_d + PRIVATE w3emc::w3emc_4 + PRIVATE NetCDF::NetCDF_Fortran + PRIVATE MPI::MPI_Fortran) +if(OpenMP_Fortran_FOUND) + target_link_libraries(rtma_regrid_esg2rll.exe PRIVATE OpenMP::OpenMP_Fortran) +endif() +list(APPEND ESG_CONVERSION_Targets rtma_regrid_esg2rll.exe) + +# if(ip_VERSION GREATER_EQUAL 4.0.0) +# set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -DIP_V4") +# endif() +if(ip_VERSION LESS 4.0.0) + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -DIP_V3") +endif() + +install( + TARGETS ${ESG_CONVERSION_Targets} + EXPORT ${PROJECT_NAME}Exports + RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR} + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR} + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR}) diff --git a/rtma_esg_conversion.fd/esg_lib.fd/CMakeLists.txt b/rtma_esg_conversion.fd/esg_lib.fd/CMakeLists.txt new file mode 100644 index 0000000..ddf7a3d --- /dev/null +++ b/rtma_esg_conversion.fd/esg_lib.fd/CMakeLists.txt @@ -0,0 +1,28 @@ +list(APPEND src_esg_lib + pkind.f90 + pietc.f90 + pietc_s.f90 + pmat.f90 + pmat2.f90 + pmat4.f90 + pmat5.f90 + pfun.f90 + psym2.f90 + pesg.f90 + pbswi.f90) + +set(module_dir "${CMAKE_CURRENT_BINARY_DIR}/include") +add_library(pesglib2 STATIC ${src_esg_lib}) +add_library(${PROJECT_NAME}::pesglib2 ALIAS pesglib2) +# target_link_libraries(pesglib2 PUBLIC ${PROJECT_NAME}::ncio) +set_target_properties(pesglib2 PROPERTIES Fortran_MODULE_DIRECTORY "${module_dir}") +target_include_directories(pesglib2 PUBLIC $ + $) +install(DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/include DESTINATION ${CMAKE_INSTALL_PREFIX}) + +install( + TARGETS pesglib2 + EXPORT ${PROJECT_NAME}Exports + RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR} + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR} + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR}) diff --git a/rtma_esg_conversion.fd/esg_lib.fd/pbswi.f90 b/rtma_esg_conversion.fd/esg_lib.fd/pbswi.f90 new file mode 100644 index 0000000..fd52657 --- /dev/null +++ b/rtma_esg_conversion.fd/esg_lib.fd/pbswi.f90 @@ -0,0 +1,415 @@ +!# +! ***************************** +! * pbswi.f90 * +! * R. J. Purser * +! * NOAA/NCEP/EMC * +! * February 2022 * +! ***************************** +! NOAA/NCEP Environmental Modeling Center. +! jim.purser@noaa.gov +! Suite of routines to perform B-Spline-Weighted Interpllations (BSWI) +! using ! stencils of 4 pts, 6 pts, or 8 pts. +! The interpolations are performed at points within the central interval +! of ! each stencil laid on the uniform unit grid in 1D or 2D. +! The 4-point stencil scheme uses linearly-weighted quadratic interpolation, +! which is already widely used, but not generally recognized as being one +! member of the wider family of the interpolations by overlapping +! Lagrange polynomials that are themselves weighted according to the values +! across the interpolation interval of segments of a B-spline of degree +! one-less than that of the component Lagrnage polynomial. Thus, the 6-pt +! scheme weights three overlapping Lagrange cubics with weights from the +! three segments of the 2nd degree B-spline; the 8-pt scheme weights four +! overlapping quartic Lagrangen polynomials with weights from the four +! segments of the 3rd degree B-spline. Although this technique generalizes +! to non-uniformly spaced grids, the codes for uniform unit grids (where the +! assumed coordinates are also the indices in each dimension) are particularly +! simple since the coefficient matrices involved in constructing the +! interpolation weights have rational components that have been precomputed. +! The interpolating polynomial of these schemes are of degree one-less than +! the number of stencil points (for example, the 4-pt scheme is a cubic in +! the central interval, passing through the values at both sides of the +! interval but, unlike the Lagrange cubic, does not generally fit the other +! values touched by the 4-pt stencil.) The interpolating polynomial is +! constructed explicitly by way of its power series, which seems to be the +! most efficient way to obtain the result. +! The most trivial members of the BSWI family, linear or bilinear schemes, +! with 2-pt stencils, are included for completeness (the relevant B-spline +! in this case is the single segment unit "hat" function, which weights by +! one the equally trivial linear Lagrange polynomial.) +! +! DEPENDENCIES +! Modules: pkind, pietc +!============================================================================= +module pbswi +!============================================================================= +private +public :: pown,getrp4,getrp6,getrp8,abswi2,abswi4,abswi6,abswi8 + +interface pown; module procedure pown; end interface +interface getrp4; module procedure getrp4; end interface +interface getrp6; module procedure getrp6; end interface +interface getrp8; module procedure getrp8; end interface +interface abswi2; module procedure abswi2_1,abswi2_2; end interface +interface abswi4; module procedure abswi4_1,abswi4_2; end interface +interface abswi6; module procedure abswi6_1,abswi6_2; end interface +interface abswi8; module procedure abswi8_1,abswi8_2; end interface + +contains + +!============================================================================ +subroutine pown(n,x,xps)! [pown] +!============================================================================ +! Return a vector, xps, containing the powers of x up to x**n. +!============================================================================ +use pkind, only: spi,dp +use pietc, only: u1 +implicit none +integer(spi), intent(in ):: n +real(dp), intent(in ):: x +real(dp),dimension(0:n),intent(out):: xps +!---------------------------------------------------------------------------- +real(dp) :: xp +integer(spi):: i +!============================================================================ +xp=u1 +do i=0,n + xps(i)=xp + xp=xp*x +enddo +end subroutine pown + +!============================================================================ +subroutine getrp4(rp4)! [getrp4] +!============================================================================ +! Return the matrix rp4 that converts the 4 consecutive stencil values +! of a unit grid to the power-series coefficients in the central +! interval, relative to the origin at the lower side of it, of the +! B-spline-weighted interpolation polynomial. +!============================================================================ +use pkind, only: spi,dp +use pietc, only: u2 +implicit none +real(dp),dimension(0:3,0:3),intent(out):: rp4 +!---------------------------------------------------------------------------- +integer(spi),dimension(0:3,0:3):: irp4 +data irp4/0,-1,2,-1, 2,0,-5,3, 0,1,4,-3, 0,0,-1,1/ +!============================================================================ +rp4=irp4/u2 +end subroutine getrp4 + +!============================================================================ +subroutine getrp6(rp6)! [getrp6] +!============================================================================ +! Return the matrix rp6 that converts the 6 consecutive stencil values +! of a unit grid to the power-series coefficients in the central +! interval, relative to the origin at the lower side of it, of the +! B-spline-weighted interpolation polynomial. +!============================================================================ +use pkind, only: spi,dp +implicit none +real(dp),parameter:: u12=12 +real(dp),dimension(0:5,0:5),intent(out):: rp6 +!---------------------------------------------------------------------------- +integer(spi),dimension(0:5,0:5):: irp6 +data irp6/& + 0, 1, -2, 0, 2, -1, & + 0,-8, 14, 0,-11, 5, & + 12, 0,-24,-2, 24,-10, & + 0, 8, 14, 6,-26, 10, & + 0,-1, -2,-6, 14, -5, & + 0, 0, 0, 2, -3, 1/ +!============================================================================ +rp6=irp6/u12 +end subroutine getrp6 + +!============================================================================ +subroutine getrp8(rp8)! [getrp8] +!============================================================================ +! Return the matrix rp8 that converts the 8 consecutive stencil values +! of a unit grid to the power-series coefficients in the central +! interval, relative to the origin at the lower side of it, of the +! B-spline-weighted interpolation polynomial. +!============================================================================ +use pkind, only: spi,dp +implicit none +real(dp),parameter:: u144=144 +real(dp),dimension(0:7,0:7),intent(out):: rp8 +!---------------------------------------------------------------------------- +integer(spi),dimension(0:7,0:7):: irp8 +data irp8/& + 0, -2, 5, -1, -6, 4, 1, -1, & + 0, 20, -36, -8, 48, -19, -12, 7, & + 0,-106, 171, 19,-138, 24, 51,-21, & + 144, 0,-280, 0, 186, 25,-110, 35, & + 0, 106, 171,-19,-114,-100, 135,-35, & + 0, -20, -36, 8, 12, 111, -96, 21, & + 0, 2, 5, 1, 18, -56, 37, -7, & + 0, 0, 0, 0, -6, 11, -6, 1/ +!============================================================================ +rp8=irp8/u144 +end subroutine getrp8 + +!============================================================================ +subroutine abswi2_1(lx,mx,ax,x, a,ff)! [abswi2] +!============================================================================ +! Linear interpolation (trivial member of the BSWI family). +!============================================================================ +use pkind, only: spi,dp +use pietc, only: u1 +implicit none +integer(spi), intent(in ):: lx,mx +real(dp),dimension(lx:mx),intent(in ):: ax +real(dp), intent(in ):: x +real(dp), intent(out):: a +logical, intent(out):: ff +!---------------------------------------------------------------------------- +real(dp) :: wx0,wx1 +integer(spi):: ix +!============================================================================ +ix=floor(x) +ff=ix=mx +if(ff)return +wx1=x-ix +wx0=u1-wx1 +a=wx0*ax(ix)+wx1*ax(ix+1) +end subroutine abswi2_1 +!============================================================================ +subroutine abswi2_2(lx,mx,ly,my,axy,x,y, a,ff)! [abswi2] +!============================================================================ +! Bilinear interpolation (trivial member of the BSWI family). +!============================================================================ +use pkind, only: spi,dp +use pietc, only: u1 +implicit none +integer(spi), intent(in ):: lx,mx,ly,my +real(dp),dimension(lx:mx,ly:my),intent(in ):: axy +real(dp), intent(in ):: x,y +real(dp), intent(out):: a +logical, intent(out):: ff +!---------------------------------------------------------------------------- +real(dp) :: wx0,wx1,wy0,wy1 +integer(spi):: ix,iy +!============================================================================ +ix=floor(x); iy=floor(y) +ff=ix=mx .or. iy=my +if(ff)return +wx1=x-ix; wy1=y-iy +wx0=u1-wx1; wy0=u1-wy1 +a=wy0*(wx0*axy(ix,iy )+wx1*axy(ix+1,iy )) & + +wy1*(wx0*axy(ix,iy+1)+wx1*axy(ix+1,iy+1)) +end subroutine abswi2_2 + +!============================================================================ +subroutine abswi4_1(lx,mx,rp4,ax,x, a,ff)! [abswi4] +!============================================================================ +! Apply the B-Spline-Weighted Interpolation with 4-point stnecil to a 1D +! array of real values, ax(lx:mx), with a target point at (x) in +! the index unit coordinates. If the target is outside the region of the +! grid that allows for centered 4-point interpolation, +! the logical Failure Flag, FF, is returned .true. and no interpolation +! is attempted; otherwise, for a normal condition, the interpolated values +! is returned as "a". +! Real 4*4 array, rp4, is the constant coefficients matrix precomputed in +! subroutine getrp4 +!=========================================================================== +use pkind, only: spi,dp +implicit none +integer(spi), intent(in ):: lx,mx +real(dp),dimension(0:3,0:3), intent(in ):: rp4 +real(dp),dimension(lx:mx), intent(in ):: ax +real(dp), intent(in ):: x +real(dp), intent(out):: a +logical, intent(out):: ff +!---------------------------------------------------------------------------- +real(dp),dimension(-1:2):: xp,wx +real(dp) :: rx +integer(spi) :: i,ix +!============================================================================ +ix=floor(x) +ff=ix=mx-1 +if(ff)return +rx=x-ix +call pown(3,rx,xp) +wx=matmul(xp,rp4) +a=dot_product(wx,ax(ix-1:ix+2)) +end subroutine abswi4_1 +!============================================================================ +subroutine abswi4_2(lx,mx,ly,my,rp4,axy,x,y, a,ff)! [abswi4] +!============================================================================ +! Apply the B-Spline-Weighted Interpolation with 4-point stnecil to a 2D +! array of real values, axy(lx:mx,ly:my), with a target point at (x,y) in +! the index unit coordinates. If the target is outside the region of the +! grid that allows for centered 4-point interpolation in both directions, +! the logical Failure Flag, FF, is returned .true. and no interpolation +! is attempted; otherwise, for a normal condition, the interpolated values +! is returned as "a". +! Real 4*4 array, rp4, is the constant coefficients matrix precomputed in +! subroutine getrp4 +!=========================================================================== +use pkind, only: spi,dp +implicit none +integer(spi), intent(in ):: lx,mx,ly,my +real(dp),dimension(0:3,0:3), intent(in ):: rp4 +real(dp),dimension(lx:mx,ly:my),intent(in ):: axy +real(dp), intent(in ):: x,y +real(dp), intent(out):: a +logical, intent(out):: ff +!---------------------------------------------------------------------------- +real(dp),dimension(-1:2):: ax,xp,yp,wx,wy +real(dp) :: rx,ry +integer(spi) :: i,ix,iy +!============================================================================ +ix=floor(x); iy=floor(y) +ff=ix=mx-1 .or. iy=my-1 +if(ff)return +rx=x-ix; ry=y-iy +call pown(3,rx,xp); call pown(3,ry,yp) +wx=matmul(xp,rp4); wy=matmul(yp,rp4) +do i=-1,2; ax(i)=dot_product(wy,axy(ix+i,iy-1:iy+2)); enddo +a=dot_product(wx,ax) +end subroutine abswi4_2 + +!============================================================================ +subroutine abswi6_1(lx,mx,rp6,ax,x, a,ff)! [abswi6] +!============================================================================ +! Apply the B-Spline-Weighted Interpolation with 6-point stnecil to a 1D +! array of real values, ax(lx:mx), with a target point at (x) in +! the index unit coordinates. If the target is outside the region of the +! grid that allows for centered 6-point interpolation, +! the logical Failure Flag, FF, is returned .true. and no interpolation +! is attempted; otherwise, for a normal condition, the interpolated values +! is returned as "a". +! Real 6*6 array, rp6, is the constant coefficients matrix precomputed in +! subroutine getrp6 +!=========================================================================== +use pkind, only: spi,dp +implicit none +integer(spi), intent(in ):: lx,mx +real(dp),dimension(0:5,0:5), intent(in ):: rp6 +real(dp),dimension(lx:mx), intent(in ):: ax +real(dp), intent(in ):: x +real(dp), intent(out):: a +logical, intent(out):: ff +!---------------------------------------------------------------------------- +real(dp),dimension(-2:3):: xp,wx +real(dp) :: rx +integer(spi) :: i,ix +!============================================================================ +ix=floor(x) +ff=ix=mx-2 +if(ff)return +rx=x-ix +call pown(5,rx,xp) +wx=matmul(xp,rp6) +a=dot_product(wx,ax(ix-2:ix+3)) +end subroutine abswi6_1 +!============================================================================ +subroutine abswi6_2(lx,mx,ly,my,rp6,axy,x,y, a,ff)! [abswi6] +!============================================================================ +! Apply the B-Spline-Weighted Interpolation with 6-point stnecil to a 2D +! array of real values, axy(lx:mx,ly:my), with a target point at (x,y) in +! the index unit coordinates. If the target is outside the region of the +! grid that allows for centered 6-point interpolation in both directions, +! the logical Failure Flag, FF, is returned .true. and no interpolation +! is attempted; otherwise, for a normal condition, the interpolated +! values is returned as "a". +! Real 6*6 array, rp6, is the constant coefficients matrix precomputed in +! subroutine getrp6 +!=========================================================================== +use pkind, only: spi,dp +implicit none +integer(spi), intent(in ):: lx,mx,ly,my +real(dp),dimension(0:5,0:5), intent(in ):: rp6 +real(dp),dimension(lx:mx,ly:my),intent(in ):: axy +real(dp), intent(in ):: x,y +real(dp), intent(out):: a +logical, intent(out):: ff +!---------------------------------------------------------------------------- +real(dp),dimension(-2:3):: ax,xp,yp,wx,wy +real(dp) :: rx,ry +integer(spi) :: i,ix,iy +!============================================================================ +ix=floor(x); iy=floor(y) +ff=ix=mx-2 .or. iy=my-2 +if(ff)return +rx=x-ix; ry=y-iy +call pown(5,rx,xp); call pown(5,ry,yp) +wx=matmul(xp,rp6); wy=matmul(yp,rp6) +do i=-2,3; ax(i)=dot_product(wy,axy(ix+i,iy-2:iy+3)); enddo +a=dot_product(wx,ax) +end subroutine abswi6_2 + +!============================================================================ +subroutine abswi8_1(lx,mx,rp8,ax,x, a,ff)! [abswi8] +!============================================================================ +! Apply the B-Spline-Weighted Interpolation with 8-point stnecil to a 1D +! array of real values, ax(lx:mx), with a target point at (x) in +! the index unit coordinates. If the target is outside the region of the +! grid that allows for centered 8-point interpolation, +! the logical Failure Flag, FF, is returned .true. and no interpolation +! is attempted; otherwise, for a normal condition, the interpolated values +! is returned as "a". +! Real 8*8 array, rp8, is the constant coefficients matrix precomputed in +! subroutine getrp8 +!=========================================================================== +use pkind, only: spi,dp +implicit none +integer(spi), intent(in ):: lx,mx +real(dp),dimension(0:7,0:7), intent(in ):: rp8 +real(dp),dimension(lx:mx), intent(in ):: ax +real(dp), intent(in ):: x +real(dp), intent(out):: a +logical, intent(out):: ff +!---------------------------------------------------------------------------- +real(dp),dimension(-3:4):: xp,wx +real(dp) :: rx +integer(spi) :: i,ix +!============================================================================ +ix=floor(x) +ff=ix=mx-3 +if(ff)return +rx=x-ix +call pown(7,rx,xp) +wx=matmul(xp,rp8) +a=dot_product(wx,ax(ix-3:ix+4)) +end subroutine abswi8_1 +!============================================================================ +subroutine abswi8_2(lx,mx,ly,my,rp8,axy,x,y, a,ff)! [abswi8] +!============================================================================ +! Apply the B-Spline-Weighted Interpolation with 8-point stnecil to a 2D +! array of real values, axy(lx:mx,ly:my), with a target point at (x,y) in +! the index unit coordinates. If the target is outside the region of the +! grid that allows for centered 8-point interpolation in both directions, +! the logical Failure Flag, FF, is returned .true. and no interpolation +! is attempted; otherwise, for a normal condition, the interpolated values +! is returned as "a". +! Real 8*8 array, rp8, is the constant coefficients matrix precomputed in +! subroutine getrp8 +!=========================================================================== +use pkind, only: spi,dp +implicit none +integer(spi), intent(in ):: lx,mx,ly,my +real(dp),dimension(0:7,0:7), intent(in ):: rp8 +real(dp),dimension(lx:mx,ly:my),intent(in ):: axy +real(dp), intent(in ):: x,y +real(dp), intent(out):: a +logical, intent(out):: ff +!---------------------------------------------------------------------------- +real(dp),dimension(-3:4):: ax,xp,yp,wx,wy +real(dp) :: rx,ry +integer(spi) :: i,ix,iy +!============================================================================ +ix=floor(x); iy=floor(y) +ff=ix=mx-3 .or. iy=my-3 +if(ff)return +rx=x-ix; ry=y-iy +call pown(7,rx,xp); call pown(7,ry,yp) +wx=matmul(xp,rp8); wy=matmul(yp,rp8) +do i=-3,4; ax(i)=dot_product(wy,axy(ix+i,iy-3:iy+4)); enddo +a=dot_product(wx,ax) +end subroutine abswi8_2 + +end module pbswi + +!# + diff --git a/rtma_esg_conversion.fd/esg_lib.fd/pesg.f90 b/rtma_esg_conversion.fd/esg_lib.fd/pesg.f90 new file mode 100644 index 0000000..b858f2e --- /dev/null +++ b/rtma_esg_conversion.fd/esg_lib.fd/pesg.f90 @@ -0,0 +1,1841 @@ +!> @file +!! @author R. J. Purser +!! @date May 2020 +!! +!! Suite of routines to perform the 2-parameter family of Extended +!! Schmidt Gnomonic (ESG) regional grid mappings, and to optimize the +!! the two parameters, A and K, of those mappings for a given rectangular +!! domain's principal (median) semi-arcs with respect to a domain-averaged +!! measure of distortion. This criterion is itself endowed with a parameter, +!! lam (for "lambda" in [0,1) ) which gives weight to additional weight +!! areal inhomogeneities instead of treating all distortion components +!! equally. +!! +!! DEPENDENCIES +!! Libraries: pmat, psym2, pfun +!! Modules: pkind, pietc, pietc_s +!! +module pesg +!============================================================================= +use pkind, only: spi,dp +use pietc, only: F,T,u0,u1,u2,o2,rtod,dtor,pih,pi2 +implicit none +private +public :: xctoxm_ak,xmtoxc_ak,get_edges,bestesg_geo,bestesg_map, & + hgrid_ak_rr,hgrid_ak_rc,hgrid_ak_dd,hgrid_ak_dc,hgrid_ak, & + gtoxm_ak_rr,gtoxm_ak_dd,xmtog_ak_rr,xmtog_ak_dd,gtoxm_ak_dd_g + +interface xctoxs; module procedure xctoxs; end interface +interface xstoxc; module procedure xstoxc,xstoxc1; end interface +interface xstoxt; module procedure xstoxt; end interface +interface xttoxs; module procedure xttoxs,xttoxs1; end interface +interface xttoxm; module procedure xttoxm; end interface +interface zttozm; module procedure zttozm; end interface +interface xmtoxt; module procedure xmtoxt,xmtoxt1; end interface +interface zmtozt; module procedure zmtozt,zmtozt1; end interface +interface xctoxm_ak; module procedure xctoxm_ak; end interface +interface xmtoxc_ak + module procedure xmtoxc_ak,xmtoxc_vak,xmtoxc_vak1; end interface +interface get_edges; module procedure get_edges; end interface +interface get_qx; module procedure get_qx,get_qxd; end interface +interface get_qofv;module procedure get_qofv,get_qofvd,get_qsofvs;end interface +interface get_meanq; module procedure get_meanqd,get_meanqs; end interface +interface guessak_map; module procedure guessak_map; end interface +interface guessak_geo; module procedure guessak_geo; end interface +interface bestesg_geo; module procedure bestesg_geo; end interface +interface bestesg_map; module procedure bestesg_map; end interface +interface hgrid_ak_rr;module procedure hgrid_ak_rr,hgrid_ak_rr_c; end interface +interface hgrid_ak_rc; module procedure hgrid_ak_rc; end interface +interface hgrid_ak_dd;module procedure hgrid_ak_dd,hgrid_ak_dd_c; end interface +interface hgrid_ak_dc; module procedure hgrid_ak_dc; end interface +interface hgrid_ak; module procedure hgrid_ak,hgrid_ak_c; end interface +interface gtoxm_ak_rr + module procedure gtoxm_ak_rr_m,gtoxm_ak_rr_g; end interface +interface gtoxm_ak_dd + module procedure gtoxm_ak_dd_m,gtoxm_ak_dd_g; end interface +interface xmtog_ak_rr + module procedure xmtog_ak_rr_m,xmtog_ak_rr_g; end interface +interface xmtog_ak_dd + module procedure xmtog_ak_dd_m,xmtog_ak_dd_g; end interface + +interface gaulegh; module procedure gaulegh; end interface + +contains + +!============================================================================= +subroutine xctoxs(xc,xs)! [xctoxs] +!============================================================================= +! Inverse of xstoxc. I.e., cartesians to stereographic +!============================================================================= +implicit none +real(dp),dimension(3),intent(in ):: xc +real(dp),dimension(2),intent(out):: xs +!----------------------------------------------------------------------------- +real(dp):: zp +!============================================================================= +zp=u1+xc(3); xs=xc(1:2)/zp +end subroutine xctoxs + +!============================================================================= +subroutine xstoxc(xs,xc,xcd)! [xstoxc] +!============================================================================= +! Standard transformation from polar stereographic map coordinates, xs, to +! cartesian, xc, assuming the projection axis is polar. +! xcd=d(xc)/d(xs) is the jacobian matrix, encoding distortion and metric. +!============================================================================= +use pmat4, only: outer_product +implicit none +real(dp),dimension(2), intent(in ):: xs +real(dp),dimension(3), intent(out):: xc +real(dp),dimension(3,2),intent(out):: xcd +!----------------------------------------------------------------------------- +real(dp):: zp +!============================================================================= +zp=u2/(u1+dot_product(xs,xs)); xc(1:2)=xs*zp; xc(3)=zp +xcd=-outer_product(xc,xs)*zp; xcd(1,1)=xcd(1,1)+zp; xcd(2,2)=xcd(2,2)+zp +xc(3)=xc(3)-u1 +end subroutine xstoxc +!============================================================================= +subroutine xstoxc1(xs,xc,xcd,xcdd)! [xstoxc] +!============================================================================= +! Standard transformation from polar stereographic map coordinates, xs, to +! cartesian, xc, assuming the projection axis is polar. +! xcd=d(xc)/d(xs) is the jacobian matrix, encoding distortion and metric. +! xcdd is the further derivative, wrt xs, of xcd. +!============================================================================= +use pmat4, only: outer_product +implicit none +real(dp),dimension(2), intent(in ):: xs +real(dp),dimension(3), intent(out):: xc +real(dp),dimension(3,2), intent(out):: xcd +real(dp),dimension(3,2,2),intent(out):: xcdd +!----------------------------------------------------------------------------- +real(dp),dimension(3,2):: zpxcdxs +real(dp),dimension(3) :: zpxc +real(dp) :: zp +integer(spi) :: i +!============================================================================= +zp=u2/(u1+dot_product(xs,xs)); xc(1:2)=xs*zp; xc(3)=zp +xcd=-outer_product(xc,xs)*zp +zpxc=zp*xc; xc(3)=xc(3)-u1; xcdd=u0 +do i=1,2 + zpxcdxs=xcd*xc(i) + xcdd(:,i,i)=xcdd(:,i,i)-zpxc + xcdd(:,i,:)=xcdd(:,i,:)-zpxcdxs + xcdd(:,:,i)=xcdd(:,:,i)-zpxcdxs + xcdd(i,:,i)=xcdd(i,:,i)-zpxc(1:2) + xcdd(i,i,:)=xcdd(i,i,:)-zpxc(1:2) +enddo +do i=1,2; xcd(i,i)=xcd(i,i)+zp; enddo +end subroutine xstoxc1 + +!============================================================================= +subroutine xstoxt(k,xs,xt,ff)! [xstoxt] +!============================================================================= +! Inverse of xttoxs. +!============================================================================= +implicit none +real(dp), intent(in ):: k +real(dp),dimension(2),intent(in ):: xs +real(dp),dimension(2),intent(out):: xt +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp):: s,sc +!============================================================================= +s=k*(xs(1)*xs(1)+xs(2)*xs(2)); sc=u1-s +ff=abs(s)>=u1; if(ff)return +xt=u2*xs/sc +end subroutine xstoxt + +!============================================================================= +subroutine xttoxs(k,xt,xs,xsd,ff)! [xttoxs +!============================================================================= +! Scaled gnomonic plane xt to standard stereographic plane xs +!============================================================================= +use pmat4, only: outer_product +implicit none +real(dp), intent(in ):: k +real(dp),dimension(2), intent(in ):: xt +real(dp),dimension(2), intent(out):: xs +real(dp),dimension(2,2),intent(out):: xsd +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp),dimension(2):: rspd +real(dp) :: s,sp,rsp,rsppi,rsppis +integer(spi) :: i +!============================================================================= +s=k*dot_product(xt,xt); sp=u1+s +ff=(sp<=u0); if(ff)return +rsp=sqrt(sp) +rsppi=u1/(u1+rsp) +rsppis=rsppi**2 +xs=xt*rsppi +rspd=k*xt/rsp +xsd=-outer_product(xt,rspd)*rsppis +do i=1,2; xsd(i,i)=xsd(i,i)+rsppi; enddo +end subroutine xttoxs +!============================================================================= +subroutine xttoxs1(k,xt,xs,xsd,xsdd,xs1,xsd1,ff)! [xttoxs] +!============================================================================= +! Like xttoxs, but also, return the derivatives, wrt K, of xs and xsd +!============================================================================= +use pmat4, only: outer_product +implicit none +real(dp), intent(in ):: k +real(dp),dimension(2), intent(in ):: xt +real(dp),dimension(2), intent(out):: xs ,xs1 +real(dp),dimension(2,2), intent(out):: xsd,xsd1 +real(dp),dimension(2,2,2),intent(out):: xsdd +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp),dimension(2,2):: rspdd +real(dp),dimension(2) :: rspd,rspd1,rsppid +real(dp) :: s,sp,rsp,rsppi,rsppis,s1,rsp1 +integer(spi) :: i +!============================================================================= +s1=dot_product(xt,xt); s=k*s1; sp=u1+s +ff=(sp<=u0); if(ff)return +rsp=sqrt(sp); rsp1=o2*s1/rsp +rsppi=u1/(u1+rsp); rsppis=rsppi**2 +xs=xt*rsppi; xs1=-xt*rsp1*rsppis +rspd=k*xt/rsp; rspd1=(xt*rsp-k*xt*rsp1)/sp +rsppid=-rspd*rsppis +xsd1=-outer_product(xt,rspd1-u2*rspd*rsp1*rsppi) +do i=1,2; xsd1(i,i)=xsd1(i,i)-rsp1; enddo; xsd1=xsd1*rsppis + +xsd=-outer_product(xt,rspd)*rsppis +do i=1,2; xsd(i,i)=xsd(i,i)+rsppi; enddo + +rspdd=-outer_product(xt,rspd)*rsppi +xsdd=u0 +do i=1,2; xsdd(i,:,i)= rsppid; enddo +do i=1,2; xsdd(i,i,:)=xsdd(i,i,:)+rsppid; enddo +do i=1,2; xsdd(:,:,i)=xsdd(:,:,i)+u2*rspdd*rsppid(i); enddo +do i=1,2; rspdd(i,i)=rspdd(i,i)+rsp*rsppi; enddo +do i=1,2; xsdd(i,:,:)=xsdd(i,:,:)-xt(i)*rspdd*rsppi*k/sp; enddo +end subroutine xttoxs1 + +!============================================================================= +subroutine xttoxm(a,xt,xm,ff)! [xttoxm] +!============================================================================= +! Inverse of xmtoxt +!============================================================================= +implicit none +real(dp), intent(in ):: a +real(dp),dimension(2),intent(in ):: xt +real(dp),dimension(2),intent(out):: xm +logical ,intent(out):: ff +!----------------------------------------------------------------------------- +integer(spi):: i +!============================================================================= +do i=1,2; call zttozm(a,xt(i),xm(i),ff); if(ff)return; enddo +end subroutine xttoxm + +!============================================================================= +subroutine xmtoxt(a,xm,xt,xtd,ff)! [xmtoxt] +!============================================================================= +! Like zmtozt, but for 2-vector xm and xt, and 2*2 diagonal Jacobian xtd +!============================================================================= +implicit none +real(dp), intent(in ):: a +real(dp),dimension(2), intent(in ):: xm +real(dp),dimension(2), intent(out):: xt +real(dp),dimension(2,2),intent(out):: xtd +logical, intent(out):: ff +!----------------------------------------------------------------------------- +integer(spi):: i +!============================================================================= +xtd=u0; do i=1,2; call zmtozt(a,xm(i),xt(i),xtd(i,i),ff); if(ff)return; enddo +end subroutine xmtoxt +!============================================================================= +subroutine xmtoxt1(a,xm,xt,xtd,xt1,xtd1,ff)! [xmtoxt] +!============================================================================= +! Like zmtozt1, but for 2-vector xm and xt, and 2*2 diagonal Jacobian xtd +! Also, the derivatives, wrt a, of these quantities. +!============================================================================= +implicit none +real(dp), intent(in ):: a +real(dp),dimension(2), intent(in ):: xm +real(dp),dimension(2), intent(out):: xt,xt1 +real(dp),dimension(2,2), intent(out):: xtd,xtd1 +logical, intent(out):: ff +!----------------------------------------------------------------------------- +integer(spi):: i +!============================================================================= +xtd=u0 +xtd1=u0 +do i=1,2 + call zmtozt1(a,xm(i),xt(i),xtd(i,i),xt1(i),xtd1(i,i),ff) + if(ff)return +enddo +end subroutine xmtoxt1 + +!============================================================================= +subroutine zttozm(a,zt,zm,ff)! [zttozm] +!============================================================================= +! Inverse of zmtozt +!============================================================================= +implicit none +real(dp),intent(in ):: a,zt +real(dp),intent(out):: zm +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp):: ra,razt +!============================================================================= +ff=F +if (a>u0)then; ra=sqrt( a); razt=ra*zt; zm=atan (razt)/ra +elseif(a=u1; if(ff)return + zm=atanh(razt)/ra +else ; zm=zt +endif +end subroutine zttozm + +!============================================================================= +subroutine zmtozt(a,zm,zt,ztd,ff)! [zmtozt] +!============================================================================= +! Evaluate the function, zt = tan(sqrt(A)*z)/sqrt(A), and its derivative, ztd, +! for positive and negative A and for the limiting case, A --> 0 +!============================================================================= +implicit none +real(dp),intent(in ):: a,zm +real(dp),intent(out):: zt,ztd +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp):: ra +!============================================================================= +ff=f +if (a>u0)then; ra=sqrt( a); zt=tan (ra*zm)/ra; ff=abs(ra*zm)>=pih +elseif(au0)then;ra=sqrt( a);razm=ra*zm; zt=tan(razm)/ra; ff=abs(razm)>=pih +rad=o2/ra +zt1=(rad*zm/ra)*((-u2*sin(razm*o2)**2-sinoxm(razm))/cos(razm)+(tan(razm))**2) +elseif(anasp)stop 'Guessak_geo; Aspect ratio out of range' +if(iarc0<0 .or. iarc1>narc)stop 'Guessak_geo; Major semi-arc is out of range' + +! Bilinearly interpolate A and K from crude table into a 2-vector: +ak=(/wx0*(wa0*adarc(iasp0,iarc0)+wa1*adarc(iasp1,iarc0))+ & + wx1*(wa0*adarc(iasp0,iarc1)+wa1*adarc(iasp1,iarc1)), & + wx0*(wa0*kdarc(iasp0,iarc0)+wa1*kdarc(iasp1,iarc0))+ & + wx1*(wa0*kdarc(iasp0,iarc1)+wa1*kdarc(iasp1,iarc1))/) +end subroutine guessak_geo + +!============================================================================= +subroutine bestesg_geo(lam,garcx,garcy, a,k,marcx,marcy,q,ff)! [bestesg_geo] +!============================================================================= +! Get the best Extended Schmidt Gnomonic parameter, (a,k), for the given +! geographical half-spans, garcx and garcy, as well as the corresponding +! map-space half-spans, garcx and garcy (in degrees) and the quality +! diagnostic, Q(lam) for this optimal parameter choice. If this process +! fails for any reason, the failure is alerted by a raised flag, FF, and +! the other output arguments must then be taken to be meaningless. +! +! The diagnostic Q measures the variance over the domain of a local measure +! of grid distortion. A logarithmic measure of local grid deformation is +! give by L=log(J^t.J)/2, where J is the mapping Jacobian matrix, dX/dx, +! where X is the cartesian unit 3-vector representation of the image of the +! mapping of the map-coordinate 2-vector, x. +! The Frobenius squared-norm, Trace(L*L), of L is the basis for the simplest +! (lam=0) definition of the variance of L, but (Trace(L))**2 is another. +! Here, we weight both contributions, by lam and (1-lam) respectively, with +! 0 <= lam <1, to compute the variance Q(lam,a,k), and search for the (a,k) +! that minimizes this Q. +! +! The domain averages are computed by double Gauss-Legendre quadrature (i.e., +! in both the x and y directions), but restricted to a mere quadrant of the +! domain (since bilateral symmetry pertains across both domain medians, +! yielding a domain mean L that is strictly diagonal. +!============================================================================= +use pietc, only: u5,o5,s18,s36,s54,s72,ms18,ms36,ms54,ms72 +use pmat, only: inv +use psym2, only: chol2 +implicit none +real(dp),intent(in ):: lam,garcx,garcy +real(dp),intent(out):: a,k,marcx,marcy,q +logical ,intent(out):: FF +!----------------------------------------------------------------------------- +integer(spi),parameter :: nit=200,mit=20,ngh=25 +real(dp) ,parameter :: u2o5=u2*o5,& + f18=u2o5*s18,f36=u2o5*s36,f54=u2o5*s54,& + f72=u2o5*s72,mf18=-f18,mf36=-f36,mf54=-f54,& + mf72=-f72,& !<- (Fourier transform coefficients) + r=0.001_dp,rr=r*r,dang=pi2*o5,crit=1.e-14_dp +real(dp),dimension(ngh) :: wg,xg +real(dp),dimension(0:4,0:4):: em5 ! <- Fourier matrix for 5 points +real(dp),dimension(0:4) :: qs +real(dp),dimension(2,0:4) :: aks,mas +real(dp),dimension(2,2) :: basis0,basis,hess,el,gadak,gadma,madga,madak +real(dp),dimension(2) :: ak,dak,dma,vec2,grad,qdak,qdma,ga,ma,gat +real(dp) :: s,tgarcx,tgarcy,asp,ang +integer(spi) :: i,it +logical :: flip +data em5/o5,u2o5, u0,u2o5, u0,& ! <-The Fourier matrix for 5 points. Applied + o5, f18, f72,mf54, f36,& ! to the five 72-degree spaced values in a + o5,mf54, f36, f18,mf72,& ! column-vector, the product vector has the + o5,mf54,mf36, f18, f72,& ! components, wave-0, cos and sin wave-1, + o5, f18,mf72,mf54,mf36/ ! cos and sin wave-2. +! First guess upper-triangular basis regularizing the samples used to +! estimate the Hessian of q by finite differencing: +data basis0/0.1_dp,u0, 0.3_dp,0.3_dp/ +!============================================================================= +ff=lam=u1 +if(ff)then; print'("In bestesg_geo; lam out of range")';return; endif +ff= garcx<=u0 .or. garcy<=u0 +if(ff)then + print'("In bestesg_geo; a nonpositive domain parameter, garcx or garcy")' + return +endif +call gaulegh(ngh,xg,wg)! <- Prepare Gauss-Legendre nodes xg and weights wg +flip=garcy>garcx +if(flip)then; tgarcx=garcy; tgarcy=garcx! <- Switch +else ; tgarcx=garcx; tgarcy=garcy! <- Don't switch +endif +ga=(/tgarcx,tgarcy/) +asp=tgarcy/tgarcx +basis=basis0 + +call guessak_geo(asp,tgarcx,ak) +ma=ga*dtor*0.9_dp ! Shrink first estimate, to start always within bounds + +! Perform a Newton iteration (except with imperfect Hessian) to find the +! parameter vector, ak, at which the derivative of Q at constant geographical +! semi-axes, ga, as given, goes to zero. The direct evaluation of the +! Q-derivative at constant ma (which is what is actually computed in +! get_meanq) therefore needs modification to obtain Q-derivarive at constant +! ga: +! dQ/d(ak)|_ga = dQ/d(ak)|_ma - dQ/d(ma)|_ak*d(ma)/d(ga)|_ak*d(ga)/d(ak)|_ma +! +! Since the Hessian evaluation is only carried out at constant map-space +! semi-axes, ma, it is not ideal for this problem; consequently, the allowance +! of newton iterations, nit, is much more liberal than we allow for the +! companion routine, bestesg_map, where the constant ma condition WAS +! appropriate. +do it=1,nit + call get_meanq(ngh,lam,xg,wg,ak,ma,q,qdak,qdma,gat,gadak,gadma,ff) + if(ff)return + madga=gadma; call inv(madga)! <- d(ma)/d(ga)|_ak ("at constant ak") + madak=-matmul(madga,gadak) + qdak=qdak+matmul(qdma,madak)! dQ/d(ak)|_ga + if(it<=mit)then ! <- Only recompute aks if the basis is new +! Place five additional sample points around the stencil-ellipse: + do i=0,4 + ang=i*dang ! steps of 72 degrees + vec2=(/cos(ang),sin(ang)/)*r ! points on a circle of radius r ... + dak=matmul(basis,vec2) + dma=matmul(madak,dak) + aks(:,i)=ak+dak ! ... become points on an ellipse. + mas(:,i)=ma+dma + enddo + call get_meanq(5,ngh,lam,xg,wg,aks,mas, qs,ff) + endif + grad=matmul(qdak,basis)/q ! <- New grad estimate, accurate to near roundoff + if(itnit)print'("WARNING; Relatively inferior convergence in bestesg_geo")' +a=ak(1) +k=ak(2) +if(flip)then; marcx=ma(2); marcy=ma(1)! Remember to switch back +else ; marcx=ma(1); marcy=ma(2)! don't switch +endif +end subroutine bestesg_geo + +!============================================================================= +subroutine bestesg_map(lam,marcx,marcy, a,k,garcx,garcy,q,ff) ![bestesg_map] +!============================================================================= +! Get the best Extended Schmidt Gnomonic parameter, (a,k), for the given +! map-coordinate half-spans, marcx and marcy, as well as the corresponding +! geographical half-spans, garcx and garcy (in degrees) and the quality +! diagnostic, Q(lam) for this optimal parameter choice. If this process +! fails for any reason, the failure is alerted by a raised flag, FF, and +! the other output arguments must then be taken to be meaningless. +! +! The diagnostic Q measures the variance over the domain of a local measure +! of grid distortion. A logarithmic measure of local grid deformation is +! give by L=log(J^t.J)/2, where J is the mapping Jacobian matrix, dX/dx, +! where X is the cartesian unit 3-vector representation of the image of the +! mapping of the map-coordinate 2-vector, x. +! The Frobenius squared-norm, Trace(L*L), of L is the basis for the simplest +! (lam=0) definition of the variance of L, but (Trace(L))**2 is another. +! Here, we weight both contributions, by lam and (1-lam) respectively, with +! 0 <= lam <1, to compute the variance Q(lam,a,k), and search for the (a,k) +! that minimizes this Q. +! +! The domain averages are computed by double Gauss-Legendre quadrature (i.e., +! in both the x and y directions), but restricted to a mere quadrant of the +! domain (since bilateral symmetry pertains across both domain medians, +! yielding a domain mean L that is strictly diagonal. +!============================================================================= +use pietc, only: u5,o5,s18,s36,s54,s72,ms18,ms36,ms54,ms72 +use psym2, only: chol2 +implicit none +real(dp),intent(in ):: lam,marcx,marcy +real(dp),intent(out):: a,k,garcx,garcy,q +logical ,intent(out):: FF +!----------------------------------------------------------------------------- +integer(spi),parameter :: nit=25,mit=7,ngh=25 +real(dp),parameter :: u2o5=u2*o5, & + f18=u2o5*s18,f36=u2o5*s36,f54=u2o5*s54, & + f72=u2o5*s72,mf18=-f18,mf36=-f36,mf54=-f54,& + mf72=-f72,& !<- (Fourier) + r=0.001_dp,rr=r*r,dang=pi2*o5,crit=1.e-12_dp +real(dp),dimension(ngh) :: wg,xg +real(dp),dimension(0:4,0:4):: em5 ! <- Fourier matrix for 5 points +real(dp),dimension(0:4) :: qs ! <-Sampled q, its Fourier coefficients +real(dp),dimension(2,0:4) :: aks,mas! <- tiny elliptical array of ak +real(dp),dimension(2,2) :: basis0,basis,hess,el,gadak,gadma +real(dp),dimension(2) :: ak,dak,vec2,grad,qdak,qdma,ga,ma +real(dp) :: s,tmarcx,tmarcy,asp,ang +integer(spi) :: i,it +logical :: flip +data em5/o5,u2o5, u0,u2o5, u0,& ! <-The Fourier matrix for 5 points. Applied + o5, f18, f72,mf54, f36,& ! to the five 72-degree spaced values in a + o5,mf54, f36, f18,mf72,& ! column-vector, the product vector has the + o5,mf54,mf36, f18, f72,& ! components, wave-0, cos and sin wave-1, + o5, f18,mf72,mf54,mf36/ ! cos and sin wave-2. +! First guess upper-triangular basis regularizing the samples used to +! estimate the Hessian of q by finite differencing: +data basis0/0.1_dp,u0, 0.3_dp,0.3_dp/ +!============================================================================= +ff=lam=u1 +if(ff)then; print'("In bestesg_map; lam out of range")';return; endif +ff= marcx<=u0 .or. marcy<=u0 +if(ff)then + print'("In bestesg_map; a nonpositive domain parameter, marcx or marcy")' + return +endif +call gaulegh(ngh,xg,wg) +flip=marcy>marcx +if(flip)then; tmarcx=marcy; tmarcy=marcx! <- Switch +else ; tmarcx=marcx; tmarcy=marcy! <- Don't switch +endif +ma=(/tmarcx,tmarcy/); do i=0,4; mas(:,i)=ma; enddo +asp=tmarcy/tmarcx +basis=basis0 + +call guessak_map(asp,tmarcx,ak) + +do it=1,nit + call get_meanq(ngh,lam,xg,wg,ak,ma,q,qdak,qdma,ga,gadak,gadma,ff) + if(ff)return + if(it<=mit)then +! Place five additional sample points around the stencil-ellipse: + do i=0,4 + ang=i*dang ! steps of 72 degrees + vec2=(/cos(ang),sin(ang)/)*r ! points on a circle of radius r ... + aks(:,i)=ak+matmul(basis,vec2) ! ... become points on an ellipse. + enddo + call get_meanq(5,ngh,lam,xg,wg,aks,mas, qs,ff) + endif + grad=matmul(qdak,basis)/q ! <- New grad estimate, accurate to near roundoff + if(itnit)print'("WARNING; Relatively inferior convergence in bestesg_map")' +a=ak(1) +k=ak(2) +if(flip)then; garcx=ga(2); garcy=ga(1)! Remember to switch back +else ; garcx=ga(1); garcy=ga(2)! don't switch +endif +end subroutine bestesg_map + +!============================================================================= +subroutine hgrid_ak_rr(lx,ly,nx,ny,A,K,plat,plon,pazi, & ! [hgrid_ak_rr] + delx,dely, glat,glon,garea, ff) +!============================================================================= +! Use a and k as the parameters of an Extended Schmidt-transformed +! Gnomonic (ESG) mapping centered at (plat,plon) and twisted about this center +! by an azimuth angle of pazi counterclockwise (these angles in radians). +! +! Assume the radius of the earth is unity, and using the central mapping +! point as the coordinate origin, set up the grid with central x-spacing delx +! and y-spacing dely. The grid index location of the left-lower +! corner of the domain is (lx,ly) (typically both NEGATIVE). +! The numbers of the grid spaces in x and y directions are nx and ny. +! (Note that, for a centered rectangular grid lx and ly are negative and, in +! magnitude, half the values of nx and ny respectively.) +! Return the latitude and longitude, in radians again, of the grid points thus +! defined in the arrays, glat and glon, and return a rectangular array, garea, +! of dimensions nx-1 by ny-1, that contains the areas of each of the grid +! cells +! +! If all goes well, return a lowered failure flag, ff=.false. . +! But if, for some reason, it is not possible to complete this task, +! return the raised failure flag, ff=.TRUE. . +!============================================================================= +use pmat4, only: sarea +use pmat5, only: ctogr +implicit none +integer(spi), intent(in ):: lx,ly,nx,ny +real(dp), intent(in ):: a,k,plat,plon,pazi, & + delx,dely +real(dp),dimension(lx:lx+nx ,ly:ly+ny ),intent(out):: glat,glon +real(dp),dimension(lx:lx+nx-1,ly:ly+ny-1),intent(out):: garea +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp),dimension(3,3):: prot,azirot +real(dp),dimension(3,2):: xcd +real(dp),dimension(3) :: xc +real(dp),dimension(2) :: xm +real(dp) :: clat,slat,clon,slon,cazi,sazi,& + rlat,drlata,drlatb,drlatc, & + rlon,drlona,drlonb,drlonc +integer(spi) :: ix,iy,mx,my +!============================================================================= +clat=cos(plat); slat=sin(plat) +clon=cos(plon); slon=sin(plon) +cazi=cos(pazi); sazi=sin(pazi) + +azirot(:,1)=(/ cazi, sazi, u0/) +azirot(:,2)=(/-sazi, cazi, u0/) +azirot(:,3)=(/ u0, u0, u1/) + +prot(:,1)=(/ -slon, clon, u0/) +prot(:,2)=(/-slat*clon, -slat*slon, clat/) +prot(:,3)=(/ clat*clon, clat*slon, slat/) +prot=matmul(prot,azirot) +mx=lx+nx ! Index of the 'right' edge of the rectangular grid +my=ly+ny ! Index of the 'top' edge of the rectangular grid +do iy=ly,my + xm(2)=iy*dely + do ix=lx,mx + xm(1)=ix*delx + call xmtoxc_ak(a,k,xm,xc,xcd,ff) + if(ff)return + xcd=matmul(prot,xcd) + xc =matmul(prot,xc ) + call ctogr(xc,glat(ix,iy),glon(ix,iy)) + enddo +enddo + +! Compute the areas of the quadrilateral grid cells: +do iy=ly,my-1 + do ix=lx,mx-1 + rlat =glat(ix ,iy ) + drlata=glat(ix+1,iy )-rlat + drlatb=glat(ix+1,iy+1)-rlat + drlatc=glat(ix ,iy+1)-rlat + rlon =glon(ix ,iy ) + drlona=glon(ix+1,iy )-rlon + drlonb=glon(ix+1,iy+1)-rlon + drlonc=glon(ix ,iy+1)-rlon +! If 'I' is the grid point (ix,iy), 'A' is (ix+1,iy); 'B' is (ix+1,iy+1) +! and 'C' is (ix,iy+1), then the area of the grid cell IABC is the sum of +! the areas of the traingles, IAB and IBC (the latter being the negative +! of the signed area of triangle, ICB): + garea(ix,iy)=sarea(rlat, drlata,drlona, drlatb,drlonb) & + -sarea(rlat, drlatc,drlonc, drlatb,drlonb) + enddo +enddo +end subroutine hgrid_ak_rr +!============================================================================= +subroutine hgrid_ak_rr_c(lx,ly,nx,ny,a,k,plat,plon,pazi, & ! [hgrid_ak_rr] + delx,dely, glat,glon,garea,dx,dy,angle_dx,angle_dy, ff) +!============================================================================= +! Use a and k as the parameters of an extended Schmidt-transformed +! gnomonic (ESG) mapping centered at (plat,plon) and twisted about this center +! by an azimuth angle of pazi counterclockwise (these angles in radians). +! +! Using the central mapping point as the coordinate origin, set up the grid +! with central x-spacing delx and y-spacing dely in nondimensional units, +! (i.e., as if the earth had unit radius) and with the location of the left- +! lower corner of the grid at center-relative grid index pair, (lx,ly) and +! with the number of the grid spaces in x and y directions given by nx and ny. +! (Note that, for a centered rectangular grid lx and ly are negative and, in +! magnitude, half the values of nx and ny respectively.) +! Return the latitude and longitude, again, in radians, of the grid pts thus +! defined in the arrays, glat and glon; return a rectangular array, garea, +! of dimensions nx-1 by ny-1, that contains the areas of each of the grid +! cells in nondimensional "steradian" units. +! +! In this version, these grid cell areas are computed by 2D integrating the +! scalar jacobian of the transformation, using a 4th-order centered scheme. +! The estimated grid steps, dx and dy, are returned at the grid cell edges, +! using the same 4th-order scheme to integrate the 1D projected jacobian. +! The angles, relative to local east and north, are returned respectively +! as angle_dx and angle_dy at grid cell corners, in radians counterclockwise. +! +! if all goes well, return a .FALSE. failure flag, ff. If, for some +! reason, it is not possible to complete this task, return the failure flag +! as .TRUE. +!============================================================================= +use pmat4, only: cross_product,triple_product +use pmat5, only: ctogr +implicit none +integer(spi), intent(in ):: lx,ly,nx,ny +real(dp), intent(in ):: a,k,plat,plon,pazi, & + delx,dely +real(dp),dimension(lx:lx+nx ,ly:ly+ny ),intent(out):: glat,glon +real(dp),dimension(lx:lx+nx-1,ly:ly+ny-1),intent(out):: garea +real(dp),dimension(lx:lx+nx-1,ly:ly+ny ),intent(out):: dx +real(dp),dimension(lx:lx+nx ,ly:ly+ny-1),intent(out):: dy +real(dp),dimension(lx:lx+nx ,ly:ly+ny ),intent(out):: angle_dx,angle_dy +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp),dimension(lx-1:lx+nx+1,ly-1:ly+ny+1):: gat ! Temporary area array +real(dp),dimension(lx-1:lx+nx+1,ly :ly+ny ):: dxt ! Temporary dx array +real(dp),dimension(lx :lx+nx ,ly-1:ly+ny+1):: dyt ! Temporary dy array +real(dp),dimension(3,3):: prot,azirot +real(dp),dimension(3,2):: xcd,eano +real(dp),dimension(2,2):: xcd2 +real(dp),dimension(3) :: xc,east,north +real(dp),dimension(2) :: xm +real(dp) :: clat,slat,clon,slon,cazi,sazi,delxy +integer(spi) :: ix,iy,mx,my,lxm,lym,mxp,myp +!============================================================================= +delxy=delx*dely +clat=cos(plat); slat=sin(plat) +clon=cos(plon); slon=sin(plon) +cazi=cos(pazi); sazi=sin(pazi) + +azirot(:,1)=(/ cazi, sazi, u0/) +azirot(:,2)=(/-sazi, cazi, u0/) +azirot(:,3)=(/ u0, u0, u1/) + +prot(:,1)=(/ -slon, clon, u0/) +prot(:,2)=(/-slat*clon, -slat*slon, clat/) +prot(:,3)=(/ clat*clon, clat*slon, slat/) +prot=matmul(prot,azirot) + +mx=lx+nx ! Index of the 'right' edge of the rectangular grid +my=ly+ny ! Index of the 'top' edge of the rectangular grid +lxm=lx-1; mxp=mx+1 ! Indices of extra left and right edges +lym=ly-1; myp=my+1 ! Indices of extra bottom and top edges + +!-- main body of horizontal grid: +do iy=ly,my + xm(2)=iy*dely + do ix=lx,mx + xm(1)=ix*delx + call xmtoxc_ak(a,k,xm,xc,xcd,ff); if(ff)return + xcd=matmul(prot,xcd) + xc =matmul(prot,xc ) + call ctogr(xc,glat(ix,iy),glon(ix,iy)) + east=(/-xc(2),xc(1),u0/); east=east/sqrt(dot_product(east,east)) + north=cross_product(xc,east) + eano(:,1)=east; eano(:,2)=north + xcd2=matmul(transpose(eano),xcd) + angle_dx(ix,iy)=atan2( xcd2(2,1),xcd2(1,1)) + angle_dy(ix,iy)=atan2(-xcd2(1,2),xcd2(2,2)) + dxt(ix,iy)=sqrt(dot_product(xcd2(:,1),xcd2(:,1)))*delx + dyt(ix,iy)=sqrt(dot_product(xcd2(:,2),xcd2(:,2)))*dely + gat(ix,iy)=triple_product(xc,xcd(:,1),xcd(:,2))*delxy + enddo +enddo + +!-- extra left edge, gat, dxt only: +xm(1)=lxm*delx +do iy=ly,my + xm(2)=iy*dely + call xmtoxc_ak(a,k,xm,xc,xcd,ff); if(ff)return + xcd=matmul(prot,xcd) + xc =matmul(prot,xc ) + east=(/-xc(2),xc(1),u0/); east=east/sqrt(dot_product(east,east)) + north=cross_product(xc,east) + eano(:,1)=east; eano(:,2)=north + xcd2=matmul(transpose(eano),xcd) + dxt(lxm,iy)=sqrt(dot_product(xcd2(:,1),xcd2(:,1)))*delx + gat(lxm,iy)=triple_product(xc,xcd(:,1),xcd(:,2))*delxy +enddo + +!-- extra right edge, gat, dxt only: +xm(1)=mxp*delx +do iy=ly,my + xm(2)=iy*dely + call xmtoxc_ak(a,k,xm,xc,xcd,ff); if(ff)return + xcd=matmul(prot,xcd) + xc =matmul(prot,xc ) + east=(/-xc(2),xc(1),u0/); east=east/sqrt(dot_product(east,east)) + north=cross_product(xc,east) + eano(:,1)=east; eano(:,2)=north + xcd2=matmul(transpose(eano),xcd) + dxt(mxp,iy)=sqrt(dot_product(xcd2(:,1),xcd2(:,1)))*delx + gat(mxp,iy)=triple_product(xc,xcd(:,1),xcd(:,2))*delxy +enddo + +!-- extra bottom edge, gat, dyt only: +xm(2)=lym*dely +do ix=lx,mx + xm(1)=ix*delx + call xmtoxc_ak(a,k,xm,xc,xcd,ff); if(ff)return + xcd=matmul(prot,xcd) + xc =matmul(prot,xc ) + east=(/-xc(2),xc(1),u0/); east=east/sqrt(dot_product(east,east)) + north=cross_product(xc,east) + eano(:,1)=east; eano(:,2)=north + xcd2=matmul(transpose(eano),xcd) + dyt(ix,lym)=sqrt(dot_product(xcd2(:,2),xcd2(:,2)))*dely + gat(ix,lym)=triple_product(xc,xcd(:,1),xcd(:,2))*delxy +enddo + +!-- extra top edge, gat, dyt only: +xm(2)=myp*dely +do ix=lx,mx + xm(1)=ix*delx + call xmtoxc_ak(a,k,xm,xc,xcd,ff); if(ff)return + xcd=matmul(prot,xcd) + xc =matmul(prot,xc ) + east=(/-xc(2),xc(1),u0/); east=east/sqrt(dot_product(east,east)) + north=cross_product(xc,east) + eano(:,1)=east; eano(:,2)=north + xcd2=matmul(transpose(eano),xcd) + dyt(ix,myp)=sqrt(dot_product(xcd2(:,2),xcd2(:,2)))*dely + gat(ix,myp)=triple_product(xc,xcd(:,1),xcd(:,2))*delxy +enddo + +! Extra four corners, gat only: +xm(2)=lym*dely +!-- extra bottom left corner: +xm(1)=lxm*delx +call xmtoxc_ak(a,k,xm,xc,xcd,ff); if(ff)return +xcd=matmul(prot,xcd) +xc =matmul(prot,xc ) +gat(lxm,lym)=triple_product(xc,xcd(:,1),xcd(:,2))*delxy + +!-- extra bottom right corner: +xm(1)=mxp*delx +call xmtoxc_ak(a,k,xm,xc,xcd,ff); if(ff)return +xcd=matmul(prot,xcd) +xc =matmul(prot,xc ) +gat(mxp,lym)=triple_product(xc,xcd(:,1),xcd(:,2))*delxy + +xm(2)=myp*dely +!-- extra top left corner: +xm(1)=lxm*delx +call xmtoxc_ak(a,k,xm,xc,xcd,ff); if(ff)return +xcd=matmul(prot,xcd) +xc =matmul(prot,xc ) +gat(lxm,myp)=triple_product(xc,xcd(:,1),xcd(:,2))*delxy + +!-- extra top right corner: +xm(1)=mxp*delx +call xmtoxc_ak(a,k,xm,xc,xcd,ff); if(ff)return +xcd=matmul(prot,xcd) +xc =matmul(prot,xc ) +gat(mxp,myp)=triple_product(xc,xcd(:,1),xcd(:,2))*delxy + +!-- 4th-order averaging over each central interval using 4-pt. stencils: +dx =(13_dp*(dxt(lx :mx-1,:)+dxt(lx+1:mx ,:)) & + -(dxt(lxm:mx-2,:)+dxt(lx+2:mxp,:)))/24_dp +dy =(13_dp*(dyt(:,ly :my-1)+dyt(:,ly+1:my )) & + -(dyt(:,lym:my-2)+dyt(:,ly+2:myp)))/24_dp +gat(lx:mx-1,:)=(13_dp*(gat(lx :mx-1,:)+gat(lx+1:mx ,:)) & + -(gat(lxm:mx-2,:)+gat(lx+2:mxp,:)))/24_dp +garea =(13_dp*(gat(lx:mx-1,ly :my-1)+gat(lx:mx-1,ly+1:my )) & + -(gat(lx:mx-1,lym:my-2)+gat(lx:mx-1,ly+2:myp)))/24_dp +end subroutine hgrid_ak_rr_c + +!============================================================================= +subroutine hgrid_ak_rc(lx,ly,nx,ny,A,K,plat,plon,pazi, & ! [hgrid_ak_rc] + delx,dely, xc,xcd,garea, ff) +!============================================================================= +! Use a and k as the parameters of an Extended Schmidt-transformed +! Gnomonic (ESG) mapping centered at (plat,plon) and twisted about this center +! by an azimuth angle of pazi counterclockwise (these angles in radians). +! +! Assume the radius of the earth is unity, and using the central mapping +! point as the coordinate origin, set up the grid with central x-spacing delx +! and y-spacing dely. The grid index location of the left-lower +! corner of the domain is (lx,ly) (typically both NEGATIVE). +! The numbers of the grid spaces in x and y directions are nx and ny. +! (Note that, for a centered rectangular grid lx and ly are negative and, in +! magnitude, half the values of nx and ny respectively.) +! Return the unit cartesian vectors xc of the grid points and their jacobian +! matrices xcd wrt the map coordinates, and return a rectangular array, garea, +! of dimensions nx-1 by ny-1, that contains the areas of each of the grid +! cells +! +! If all goes well, return a lowered failure flag, ff=.false. . +! But if, for some reason, it is not possible to complete this task, +! return the raised failure flag, ff=.TRUE. . +!============================================================================= +use pmat4, only: sarea +use pmat5, only: ctogr +implicit none +integer(spi),intent(in ):: lx,ly,nx,ny +real(dp), intent(in ):: a,k,plat,plon,pazi,delx,dely +real(dp),dimension(3, lx:lx+nx ,ly:ly+ny ),intent(out):: xc +real(dp),dimension(3,2,lx:lx+nx ,ly:ly+ny ),intent(out):: xcd +real(dp),dimension( lx:lx+nx-1,ly:ly+ny-1),intent(out):: garea +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp),dimension(3,3):: prot,azirot +real(dp),dimension(2) :: xm +real(dp) :: clat,slat,clon,slon,cazi,sazi, & + rlat,rlata,rlatb,rlatc,drlata,drlatb,drlatc, & + rlon,rlona,rlonb,rlonc,drlona,drlonb,drlonc +integer(spi) :: ix,iy,mx,my +!============================================================================= +clat=cos(plat); slat=sin(plat) +clon=cos(plon); slon=sin(plon) +cazi=cos(pazi); sazi=sin(pazi) + +azirot(:,1)=(/ cazi, sazi, u0/) +azirot(:,2)=(/-sazi, cazi, u0/) +azirot(:,3)=(/ u0, u0, u1/) + +prot(:,1)=(/ -slon, clon, u0/) +prot(:,2)=(/-slat*clon, -slat*slon, clat/) +prot(:,3)=(/ clat*clon, clat*slon, slat/) +prot=matmul(prot,azirot) +mx=lx+nx ! Index of the 'right' edge of the rectangular grid +my=ly+ny ! Index of the 'top' edge of the rectangular grid +do iy=ly,my + xm(2)=iy*dely + do ix=lx,mx + xm(1)=ix*delx + call xmtoxc_ak(a,k,xm,xc(:,ix,iy),xcd(:,:,ix,iy),ff) + if(ff)return + xcd(:,:,ix,iy)=matmul(prot,xcd(:,:,ix,iy)) + xc (:, ix,iy)=matmul(prot,xc (:, ix,iy)) + enddo +enddo + +! Compute the areas of the quadrilateral grid cells: +do iy=ly,my-1 + do ix=lx,mx-1 + call ctogr(xc(:,ix ,iy ),rlat ,rlon ) + call ctogr(xc(:,ix+1,iy ),rlata,rlona) + call ctogr(xc(:,ix+1,iy+1),rlatb,rlonb) + call ctogr(xc(:,ix ,iy+1),rlatc,rlonc) + drlata=rlata-rlat; drlona=rlona-rlon + drlatb=rlatb-rlat; drlonb=rlonb-rlon + drlatc=rlatc-rlat; drlonc=rlonc-rlon + +! If 'I' is the grid point (ix,iy), 'A' is (ix+1,iy); 'B' is (ix+1,iy+1) +! and 'C' is (ix,iy+1), then the area of the grid cell IABC is the sum of +! the areas of the triangles, IAB and IBC (the latter being the negative +! of the signed area of triangle, ICB): + garea(ix,iy)=sarea(rlat, drlata,drlona, drlatb,drlonb) & + -sarea(rlat, drlatc,drlonc, drlatb,drlonb) + enddo +enddo +end subroutine hgrid_ak_rc + +!============================================================================= +subroutine hgrid_ak_dd(lx,ly,nx,ny,a,k,pdlat,pdlon,pdazi, & ! [hgrid_ak_dd] + delx,dely, gdlat,gdlon,garea, ff) +!============================================================================= +! 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). +! Like hgrid_ak_rr, return the grid points' lats and lons, except that here +! the angles are returned in degrees. Garea, the area of each grid cell, is +! returned as in hgrid_ak_rr, and a failure flag, ff, raised when a failure +! occurs anywhere in these calculations. +!============================================================================ +implicit none +integer(spi), intent(in ):: lx,ly,nx,ny +real(dp), intent(in ):: A,K,pdlat,pdlon,& + pdazi,delx,dely +real(dp),dimension(lx:lx+nx ,ly:ly+ny ),intent(out):: gdlat,gdlon +real(dp),dimension(lx:lx+nx-1,ly:ly+ny-1),intent(out):: garea +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp):: plat,plon,pazi +!============================================================================= +plat=pdlat*dtor ! Convert these angles from degrees to radians +plon=pdlon*dtor ! +pazi=pdazi*dtor ! +call hgrid_ak_rr(lx,ly,nx,ny,A,K,plat,plon,pazi, & + delx,dely, gdlat,gdlon,garea, ff) +if(ff)return +gdlat=gdlat*rtod ! Convert these angles from radians to degrees +gdlon=gdlon*rtod ! +end subroutine hgrid_ak_dd +!============================================================================= +subroutine hgrid_ak_dd_c(lx,ly,nx,ny,a,k,pdlat,pdlon,pdazi, &! [hgrid_ak_dd] + delx,dely, gdlat,gdlon,garea,dx,dy,dangle_dx,dangle_dy, ff) +!============================================================================= +! Like hgrid_ak_rr_c, except all the angle arguments (but not delx,dely) +! are in degrees instead of radians. +!============================================================================= +implicit none +integer(spi), intent(in ):: lx,ly,nx,ny +real(dp), intent(in ):: a,k,pdlat,pdlon,& + pdazi,delx,dely +real(dp),dimension(lx:lx+nx ,ly:ly+ny ),intent(out):: gdlat,gdlon +real(dp),dimension(lx:lx+nx-1,ly:ly+ny-1),intent(out):: garea +real(dp),dimension(lx:lx+nx-1,ly:ly+ny ),intent(out):: dx +real(dp),dimension(lx:lx+nx ,ly:ly+ny-1),intent(out):: dy +real(dp),dimension(lx:lx+nx ,ly:ly+ny ),intent(out):: dangle_dx,dangle_dy +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp):: plat,plon,pazi +!============================================================================= +plat=pdlat*dtor ! Convert these angles from degrees to radians +plon=pdlon*dtor ! +pazi=pdazi*dtor ! +call hgrid_ak_rr_c(lx,ly,nx,ny,A,K,plat,plon,pazi, & + delx,dely, gdlat,gdlon,garea,dx,dy,dangle_dx,dangle_dy, ff) +if(ff)return +gdlat =gdlat *rtod ! Convert these angles from radians to degrees +gdlon =gdlon *rtod ! +dangle_dx=dangle_dx*rtod ! +dangle_dy=dangle_dy*rtod ! +end subroutine hgrid_ak_dd_c + +!============================================================================= +subroutine hgrid_ak_dc(lx,ly,nx,ny,a,k,pdlat,pdlon,pdazi, & ! [hgrid_ak_dc] + delx,dely, xc,xcd,garea, ff) +!============================================================================= +! 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). +! Like hgrid_ak_rx, return the grid points' cartesians xc and Jacobian +! matrices, xcd. Garea, the area of each grid cell, is also +! returned as in hgrid_ak_rx, and a failure flag, ff, raised when a failure +! occurs anywhere in these calculations. +!============================================================================ +implicit none +integer(spi),intent(in ):: lx,ly,nx,ny +real(dp), intent(in ):: A,K,pdlat,pdlon,pdazi,delx,dely +real(dp),dimension(3, lx:lx+nx ,ly:ly+ny ),intent(out):: xc +real(dp),dimension(3,2,lx:lx+nx ,ly:ly+ny ),intent(out):: xcd +real(dp),dimension( lx:lx+nx-1,ly:ly+ny-1),intent(out):: garea +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp):: plat,plon,pazi +!============================================================================= +plat=pdlat*dtor +plon=pdlon*dtor +pazi=pdazi*dtor +call hgrid_ak_rc(lx,ly,nx,ny,A,K,plat,plon,pazi, & + delx,dely, xc,xcd,garea, ff) +end subroutine hgrid_ak_dc + +!============================================================================= +subroutine hgrid_ak(lx,ly,nx,ny,a,k,plat,plon,pazi, & ! [hgrid_ak] + re,delxre,delyre, glat,glon,garea, ff) +!============================================================================= +! Like hgrid_ak_rr_c except the argument list includes the earth radius, re, +! and this is used to express the map-space grid increments in the dimensional +! units, delxre, delyre on entry, and to express the grid cell areas, garea, +! in dimensional units upon return. +! The gridded lats and lons, glat and glon, remain in radians. +!============================================================================ +implicit none +integer(spi), intent(in ):: lx,ly,nx,ny +real(dp), intent(in ):: a,k,plat,plon,pazi, & + re,delxre,delyre +real(dp),dimension(lx:lx+nx ,ly:ly+ny ),intent(out):: glat,glon +real(dp),dimension(lx:lx+nx-1,ly:ly+ny-1),intent(out):: garea +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp):: delx,dely,rere +!============================================================================= +delx=delxre/re ! <- set nondimensional grid step delx +dely=delyre/re ! <- set nondimensional grid step dely +call hgrid_ak_rr(lx,ly,nx,ny,a,k,plat,plon,pazi, & + delx,dely, glat,glon,garea, ff) +if(ff)return +rere=re*re +garea=garea*rere ! <- Convert from steradians to physical area units. +end subroutine hgrid_ak + +!============================================================================= +subroutine hgrid_ak_c(lx,ly,nx,ny,a,k,plat,plon,pazi, & ! [hgrid_ak] + re,delxre,delyre, glat,glon,garea,dx,dy,dangle_dx,dangle_dy, ff) +!============================================================================= +! Like hgrid_ak_rr_c except the argument list includes the earth radius, re, +! and this is used to express the map-space grid increments in the dimensional +! units, delxre, delyre on entry, and to express the grid cell areas, garea, +! and the x- and y- grid steps, dx and dy, in dimensional units upon return. +! The gridded lats and lons, glat and glon, remain in radians. +! Also, in order for the argument list to remain compatible with an earlier +! version of this routine, the relative rotations of the steps, dangle_dx +! and dangle_dy, are returned as degrees instead of radians (all other angles +! in the argument list, i.e., plat,plon,pazi,glat,glon, remain radians). +!============================================================================= +implicit none +integer(spi), intent(in ):: lx,ly,nx,ny +real(dp), intent(in ):: a,k,plat,plon,pazi, & + re,delxre,delyre +real(dp),dimension(lx:lx+nx ,ly:ly+ny ),intent(out):: glat,glon +real(dp),dimension(lx:lx+nx-1,ly:ly+ny-1),intent(out):: garea +real(dp),dimension(lx:lx+nx-1,ly:ly+ny ),intent(out):: dx +real(dp),dimension(lx:lx+nx ,ly:ly+ny-1),intent(out):: dy +real(dp),dimension(lx:lx+nx ,ly:ly+ny ),intent(out):: dangle_dx,dangle_dy +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp):: delx,dely,rere +!============================================================================= +delx=delxre/re ! <- set nondimensional grid step delx +dely=delyre/re ! <- set nondimensional grid step dely +call hgrid_ak_rr_c(lx,ly,nx,ny,a,k,plat,plon,pazi, & + delx,dely, glat,glon,garea,dx,dy,dangle_dx,dangle_dy, ff) +if(ff)return +rere=re*re +garea=garea*rere ! <- Convert from steradians to physical area units. +dx=dx*re ! <- Convert from nondimensional to physical length units. +dy=dy*re ! <- +dangle_dx=dangle_dx*rtod ! <-Convert from radians to degrees +dangle_dy=dangle_dy*rtod ! <-Convert from radians to degrees +end subroutine hgrid_ak_c + +!============================================================================= +subroutine gaulegh(m,x,w)! [gaulegh] +!============================================================================= +! This Gauss-Legendre quadrature integrates exactly any even polynomial +! up to degree m*4-2 in the half-interval [0,1]. This code is liberally +! adapted from the algorithm given in Press et al., Numerical Recipes. +!============================================================================= +implicit none +integer(spi), intent(IN ):: m ! <- number of nodes in half-interval +real(dp),dimension(m),intent(OUT):: x,w ! <- nodes and weights +!----------------------------------------------------------------------------- +integer(spi),parameter:: nit=8 +real(dp), parameter:: eps=3.e-14_dp +integer(spi) :: i,ic,j,jm,it,m2,m4p,m4p3 +real(dp) :: z,zzm,p1,p2,p3,pp,z1 +!============================================================================= +m2=m*2; m4p=m*4+1; m4p3=m4p+2 +do i=1,m; ic=m4p3-4*i + z=cos(pih*ic/m4p); zzm=z*z-u1 + do it=1,nit + p1=u1; p2=u0 + do j=1,m2; jm=j-1; p3=p2; p2=p1; p1=((j+jm)*z*p2-jm*p3)/j; enddo + pp=m2*(z*p1-p2)/zzm; z1=z; z=z1-p1/pp; zzm=z*z-u1 + if(abs(z-z1) <= eps)exit + enddo + x(i)=z; w(i)=-u2/(zzm*pp*pp) +enddo +end subroutine gaulegh + +!============================================================================= +subroutine gtoxm_ak_rr_m(A,K,plat,plon,pazi,lat,lon,xm,ff)! [gtoxm_ak_rr] +!============================================================================= +! Given the map specification (angles in radians), the grid spacing (in +! map-space units) and the sample lat-lon (in radian), return the the +! image in map space in a 2-vector in grid units. If the transformation +! is invalid, return a .true. failure flag. +!============================================================================= +use pmat5, only: grtoc +implicit none +real(dp), intent(in ):: a,k,plat,plon,pazi,lat,lon +real(dp),dimension(2),intent(out):: xm +logical, intent(out):: ff +real(dp),dimension(3,3):: prot,azirot +real(dp) :: clat,slat,clon,slon,cazi,sazi +real(dp),dimension(3) :: xc +!============================================================================= +clat=cos(plat); slat=sin(plat) +clon=cos(plon); slon=sin(plon) +cazi=cos(pazi); sazi=sin(pazi) + +azirot(:,1)=(/ cazi, sazi, u0/) +azirot(:,2)=(/-sazi, cazi, u0/) +azirot(:,3)=(/ u0, u0, u1/) + +prot(:,1)=(/ -slon, clon, u0/) +prot(:,2)=(/-slat*clon, -slat*slon, clat/) +prot(:,3)=(/ clat*clon, clat*slon, slat/) +prot=matmul(prot,azirot) + +call grtoc(lat,lon,xc) +xc=matmul(transpose(prot),xc) +call xctoxm_ak(a,k,xc,xm,ff) +end subroutine gtoxm_ak_rr_m +!============================================================================= +subroutine gtoxm_ak_rr_g(A,K,plat,plon,pazi,delx,dely,lat,lon,&! [gtoxm_ak_rr] + xm,ff) +!============================================================================= +! Given the map specification (angles in radians), the grid spacing (in +! map-space units) and the sample lat-lon (in radian), return the the +! image in map space in a 2-vector in grid units. If the transformation +! is invalid, return a .true. failure flag. +!============================================================================= +implicit none +real(dp), intent(in ):: a,k,plat,plon,pazi,delx,dely,lat,lon +real(dp),dimension(2),intent(out):: xm +logical, intent(out):: ff +!============================================================================= +call gtoxm_ak_rr_m(A,K,plat,plon,pazi,lat,lon,xm,ff); if(ff)return +xm(1)=xm(1)/delx; xm(2)=xm(2)/dely +end subroutine gtoxm_ak_rr_g + +!============================================================================= +subroutine gtoxm_ak_dd_m(A,K,pdlat,pdlon,pdazi,dlat,dlon,&! [gtoxm_ak_dd] + xm,ff) +!============================================================================= +! Like gtoxm_ak_rr_m, except input angles are expressed in degrees +!============================================================================= +implicit none +real(dp), intent(in ):: a,k,pdlat,pdlon,pdazi,dlat,dlon +real(dp),dimension(2),intent(out):: xm +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp):: plat,plon,pazi,lat,lon +!============================================================================= +plat=pdlat*dtor ! Convert these angles from degrees to radians +plon=pdlon*dtor ! +pazi=pdazi*dtor ! +lat=dlat*dtor +lon=dlon*dtor +call gtoxm_ak_rr_m(A,K,plat,plon,pazi,lat,lon,xm,ff) +end subroutine gtoxm_ak_dd_m +!============================================================================= +subroutine gtoxm_ak_dd_g(A,K,pdlat,pdlon,pdazi,delx,dely,&! [gtoxm_ak_dd] +dlat,dlon, xm,ff) +!============================================================================= +! Like gtoxm_ak_rr_g, except input angles are expressed in degrees +!============================================================================= +implicit none +real(dp), intent(in ):: a,k,pdlat,pdlon,pdazi,delx,dely,dlat,dlon +real(dp),dimension(2),intent(out):: xm +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp):: plat,plon,pazi,lat,lon +!============================================================================= +plat=pdlat*dtor ! Convert these angles from degrees to radians +plon=pdlon*dtor ! +pazi=pdazi*dtor ! +lat=dlat*dtor +lon=dlon*dtor +call gtoxm_ak_rr_g(A,K,plat,plon,pazi,delx,dely,lat,lon,xm,ff) +end subroutine gtoxm_ak_dd_g + +!============================================================================= +subroutine xmtog_ak_rr_m(A,K,plat,plon,pazi,xm,lat,lon,ff)! [xmtog_ak_rr] +!============================================================================= +! Given the ESG map specified by parameters (A,K) and geographical +! orientation, plat,plon,pazi (radians), and a position, in map-space +! coordinates given by the 2-vector, xm, return the geographical +! coordinates, lat and lon (radians). If the transformation is invalid for +! any reason, return instead with a raised failure flag, FF= .true. +!============================================================================= +use pmat5, only: ctogr +implicit none +real(dp), intent(in ):: a,k,plat,plon,pazi +real(dp),dimension(2),intent(in ):: xm +real(dp), intent(out):: lat,lon +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp),dimension(3,2):: xcd +real(dp),dimension(3,3):: prot,azirot +real(dp) :: clat,slat,clon,slon,cazi,sazi +real(dp),dimension(3) :: xc +!============================================================================= +clat=cos(plat); slat=sin(plat) +clon=cos(plon); slon=sin(plon) +cazi=cos(pazi); sazi=sin(pazi) + +azirot(:,1)=(/ cazi, sazi, u0/) +azirot(:,2)=(/-sazi, cazi, u0/) +azirot(:,3)=(/ u0, u0, u1/) + +prot(:,1)=(/ -slon, clon, u0/) +prot(:,2)=(/-slat*clon, -slat*slon, clat/) +prot(:,3)=(/ clat*clon, clat*slon, slat/) +prot=matmul(prot,azirot) +call xmtoxc_ak(a,k,xm,xc,xcd,ff); if(ff)return +xc=matmul(prot,xc) +call ctogr(xc,lat,lon) +end subroutine xmtog_ak_rr_m +!============================================================================= +subroutine xmtog_ak_rr_g(A,K,plat,plon,pazi,delx,dely,xm,&! [xmtog_ak_rr] + lat,lon,ff) +!============================================================================= +! For an ESG map with parameters, (A,K), and geographical orientation, +! given by plon,plat,pazi (radians), and given a point in grid-space units +! as the 2-vector, xm, return the geographical coordinates, lat, lon, (radians) +! of this point. If instead the transformation is invalid for any reason, then +! return the raised failure flag, FF=.true. +!============================================================================= +implicit none +real(dp), intent(in ):: a,k,plat,plon,pazi,delx,dely +real(dp),dimension(2),intent(in ):: xm +real(dp), intent(out):: lat,lon +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp),dimension(2):: xmt +!============================================================================= +xmt(1)=xm(1)*delx ! Convert from grid units to intrinsic map-space units +xmt(2)=xm(2)*dely ! +call xmtog_ak_rr_m(A,K,plat,plon,pazi,xmt,lat,lon,ff) +end subroutine xmtog_ak_rr_g + +!============================================================================= +subroutine xmtog_ak_dd_m(A,K,pdlat,pdlon,pdazi,xm,dlat,dlon,ff)! [xmtog_ak_dd] +!============================================================================= +! Like xmtog_ak_rr_m, except angles are expressed in degrees +!============================================================================= +use pmat5, only: ctogr +implicit none +real(dp), intent(in ):: a,k,pdlat,pdlon,pdazi +real(dp),dimension(2),intent(in ):: xm +real(dp), intent(out):: dlat,dlon +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp):: plat,plon,pazi,lat,lon +!============================================================================= +plat=pdlat*dtor ! Convert these angles from degrees to radians +plon=pdlon*dtor ! +pazi=pdazi*dtor ! +call xmtog_ak_rr_m(A,K,plat,plon,pazi,xm,lat,lon,ff) +dlat=lat*rtod +dlon=lon*rtod +end subroutine xmtog_ak_dd_m +!============================================================================= +subroutine xmtog_ak_dd_g(A,K,pdlat,pdlon,pdazi,delx,dely,xm,&! [xmtog_ak_dd] + dlat,dlon,ff) +!============================================================================= +! Like xmtog_ak_rr_g, except angles are expressed in degrees +!============================================================================= +implicit none +real(dp), intent(in ):: a,k,pdlat,pdlon,pdazi,delx,dely +real(dp),dimension(2),intent(in ):: xm +real(dp), intent(out):: dlat,dlon +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp),dimension(2):: xmt +real(dp) :: plat,plon,pazi,lat,lon +!============================================================================= +xmt(1)=xm(1)*delx ! Convert from grid units to intrinsic map-space units +xmt(2)=xm(2)*dely ! +plat=pdlat*dtor ! Convert these angles from degrees to radians +plon=pdlon*dtor ! +pazi=pdazi*dtor ! +call xmtog_ak_rr_m(A,K,plat,plon,pazi,xmt,lat,lon,ff) +dlat=lat*rtod +dlon=lon*rtod +end subroutine xmtog_ak_dd_g + +end module pesg + diff --git a/rtma_esg_conversion.fd/esg_lib.fd/pfun.f90 b/rtma_esg_conversion.fd/esg_lib.fd/pfun.f90 new file mode 100644 index 0000000..e5415ef --- /dev/null +++ b/rtma_esg_conversion.fd/esg_lib.fd/pfun.f90 @@ -0,0 +1,278 @@ +!> @file +!! @author R. J. Purser +!! Direct dependencies: +!! Modules: pkind, pietc_s, pietc +!! +module pfun +!============================================================================= +use pkind, only: sp,dp +implicit none +private +public:: gd,gdi,hav,havh,ahav,ahavh,sech,sechs,atanh,sinoxm,sinox,& + sinhoxm,sinhox + +interface gd; module procedure gd_s, gd_d; end interface +interface gdi; module procedure gdi_s, gdi_d; end interface +interface hav; module procedure hav_s, hav_d; end interface +interface havh; module procedure havh_s, havh_d; end interface +interface ahav; module procedure ahav_s, ahav_d; end interface +interface ahavh; module procedure ahavh_s, ahavh_d; end interface +interface atanh; module procedure atanh_s, atanh_d; end interface +interface sech; module procedure sech_s, sech_d; end interface +interface sechs; module procedure sechs_s, sechs_d; end interface +interface sinoxm; module procedure sinoxm_d; end interface +interface sinox; module procedure sinox_d; end interface +interface sinhoxm; module procedure sinhoxm_d;end interface +interface sinhox; module procedure sinhox_d; end interface + +contains + +!============================================================================= +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 +!============================================================================= +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 + +!============================================================================= +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 +!============================================================================= +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 + +!============================================================================= +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 +!============================================================================= +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 + +!============================================================================= +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 +!============================================================================= +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 + +!============================================================================= +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 +!============================================================================= +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 + +!============================================================================= +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 +!============================================================================= +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 + +!============================================================================= +function atanh_s(t) result(a)! [atanh] +!============================================================================= +use pietc_s, only: u1,o2,o3,o5 +implicit none +real(sp),intent(IN ):: t +real(sp) :: a,tt +real(sp),parameter :: o7=u1/7_sp,o9=u1/9_sp +!============================================================================= +if(abs(t)>=u1)stop 'In atanh; no solution' +if(abs(t)>1.e-3_sp)then; a=log((u1+t)/(u1-t))*o2 +else; tt=t*t; a=t*(u1+tt*(o3+tt*(o5+tt*(o7+tt*o9)))) +endif +end function atanh_s +!============================================================================= +function atanh_d(t) result(a)! [atanh] +!============================================================================= +use pietc, only: u1,o2,o3,o5 +implicit none +real(dp),intent(IN ):: t +real(dp) :: a,tt +real(dp),parameter :: o7=u1/7_dp,o9=u1/9_dp +!============================================================================= +if(abs(t)>=u1)stop 'In atanh; no solution' +if(abs(t)>1.e-3_dp)then; a=log((u1+t)/(u1-t))*o2 +else; tt=t*t; a=t*(u1+tt*(o3+tt*(o5+tt*(o7+tt*o9)))) +endif +end function atanh_d + +!============================================================================= +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 +real(sp),intent(in ):: x +real(sp) :: r +real(sp) :: e,ax +ax=abs(x) +e=exp(-ax) +r=e*u2/(u1+e*e) +end function sech_s +!============================================================================= +function sech_d(x)result(r)! [sech] +!============================================================================= +use pietc, only: u1,u2 +implicit none +real(dp),intent(in ):: x +real(dp) :: r +real(dp) :: e,ax +ax=abs(x) +e=exp(-ax) +r=e*u2/(u1+e*e) +end function sech_d + +!============================================================================= +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 +!============================================================================= +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 + +!============================================================================= +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 +real(dp) :: r +!----------------------------------------------------------------------------- +real(dp):: xx +!============================================================================= +xx=x*x +if(xx > .05_dp)then; r=sin(x)/x-u1 +else ; r=-xx*(u1-xx*(u1-xx*(u1-xx*(u1-xx*(u1-xx/& + 156._dp)/110._dp)/72._dp)/42._dp)/20._dp)/6._dp +endif +end function sinoxm_d + +!============================================================================= +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 +real(dp) :: r +!============================================================================= +r=sinoxm(x)+u1 +end function sinox_d + +!============================================================================= +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 +real(dp) :: r +!----------------------------------------------------------------------------- +real(dp):: xx +!============================================================================= +xx=x*x +if(xx > .05_dp)then; r=sinh(x)/x-u1 +else; r=xx*(u1+xx*(u1+xx*(u1+xx*(u1+xx*(u1+xx/& + 156._dp)/110._dp)/72._dp)/42._dp)/20._dp)/6._dp +endif +end function sinhoxm_d + +!============================================================================= +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 +real(dp) :: r +!============================================================================= +r=sinhoxm(x)+u1 +end function sinhox_d + +end module pfun diff --git a/rtma_esg_conversion.fd/esg_lib.fd/pietc.f90 b/rtma_esg_conversion.fd/esg_lib.fd/pietc.f90 new file mode 100644 index 0000000..ae90707 --- /dev/null +++ b/rtma_esg_conversion.fd/esg_lib.fd/pietc.f90 @@ -0,0 +1,97 @@ +! +!============================================================================= +module pietc +!============================================================================= +! R. J. Purser (jim.purser@noaa.gov) 2014 +! Some of the commonly used constants (pi etc) mainly for double-precision +! subroutines. +! ms10 etc are needed to satisfy the some (eg., gnu fortran) compilers' +! more rigorous standards regarding the way "data" statements are initialized. +! Zero and the first few units are u0,u1,u2, etc., their reciprocals being, +! o2,o3 etc and their square roots, r2,r3. Reciprocal roots are or2,or3 etc. +!============================================================================= +use pkind, only: dp,dpc +implicit none +logical ,parameter:: T=.true.,F=.false. !<- for pain-relief in logical ops +real(dp),parameter:: & + u0=0_dp,u1=1_dp,mu1=-u1,u2=2_dp,mu2=-u2,u3=3_dp,mu3=-u3,u4=4_dp, & + mu4=-u4,u5=5_dp,mu5=-u5,u6=6_dp,mu6=-u6,o2=u1/u2,o3=u1/u3,o4=u1/u4, & + o5=u1/u5,o6=u1/u6,mo2=-o2,mo3=-o3,mo4=-o4,mo5=-o5,mo6=-o6, & + pi =3.1415926535897932384626433832795028841971693993751058209749e0_dp, & + pi2=6.2831853071795864769252867665590057683943387987502116419498e0_dp, & + pih=1.5707963267948966192313216916397514420985846996875529104874e0_dp, & + rpi=1.7724538509055160272981674833411451827975494561223871282138e0_dp, & +! Important square-roots + r2 =1.4142135623730950488016887242096980785696718753769480731766e0_dp, & + r3 =1.7320508075688772935274463415058723669428052538103806280558e0_dp, & + r5 =2.2360679774997896964091736687312762354406183596115257242708e0_dp, & + or2=u1/r2,or3=u1/r3,or5=u1/r5, & +! Golden number: + phi=1.6180339887498948482045868343656381177203091798057628621354e0_dp, & +! Euler-Mascheroni constant: + euler=0.57721566490153286060651209008240243104215933593992359880e0_dp, & +! Degree to radians; radians to degrees: + dtor=pi/180,rtod=180/pi, & +! Sines of all main fractions of 90 degrees (down to ninths): + s10=.173648177666930348851716626769314796000375677184069387236241e0_dp,& + s11=.195090322016128267848284868477022240927691617751954807754502e0_dp,& + s13=.222520933956314404288902564496794759466355568764544955311987e0_dp,& + s15=.258819045102520762348898837624048328349068901319930513814003e0_dp,& + s18=.309016994374947424102293417182819058860154589902881431067724e0_dp,& + s20=.342020143325668733044099614682259580763083367514160628465048e0_dp,& + s22=.382683432365089771728459984030398866761344562485627041433800e0_dp,& + s26=.433883739117558120475768332848358754609990727787459876444547e0_dp,& + s30=o2, & + s34=.555570233019602224742830813948532874374937190754804045924153e0_dp,& + s36=.587785252292473129168705954639072768597652437643145991072272e0_dp,& + s39=.623489801858733530525004884004239810632274730896402105365549e0_dp,& + s40=.642787609686539326322643409907263432907559884205681790324977e0_dp,& + s45=or2, & + s50=.766044443118978035202392650555416673935832457080395245854045e0_dp,& + s51=.781831482468029808708444526674057750232334518708687528980634e0_dp,& + s54=.809016994374947424102293417182819058860154589902881431067724e0_dp,& + s56=.831469612302545237078788377617905756738560811987249963446124e0_dp,& + s60=r3*o2, & + s64=.900968867902419126236102319507445051165919162131857150053562e0_dp,& + s68=.923879532511286756128183189396788286822416625863642486115097e0_dp,& + s70=.939692620785908384054109277324731469936208134264464633090286e0_dp,& + s72=.951056516295153572116439333379382143405698634125750222447305e0_dp,& + s75=.965925826289068286749743199728897367633904839008404550402343e0_dp,& + s77=.974927912181823607018131682993931217232785800619997437648079e0_dp,& + s79=.980785280403230449126182236134239036973933730893336095002916e0_dp,& + s80=.984807753012208059366743024589523013670643251719842418790025e0_dp,& +! ... and their minuses: + ms10=-s10,ms11=-s11,ms13=-s13,ms15=-s15,ms18=-s18,ms20=-s20,ms22=-s22,& + ms26=-s26,ms30=-s30,ms34=-s34,ms36=-s36,ms39=-s39,ms40=-s40,ms45=-s45,& + ms50=-s50,ms51=-s51,ms54=-s54,ms56=-s56,ms60=-s60,ms64=-s64,ms68=-s68,& + ms70=-s70,ms72=-s72,ms75=-s75,ms77=-s77,ms79=-s79,ms80=-s80 + +complex(dpc),parameter:: & + c0=(u0,u0),c1=(u1,u0),mc1=-c1,ci=(u0,u1),mci=-ci,cipi=ci*pi, & +! Main fractional rotations, as unimodular complex numbers: + z000=c1 ,z010=( s80,s10),z011=( s79,s11),z013=( s77,s13),& + z015=( s75,s15),z018=( s72,s18),z020=( s70,s20),z022=( s68,s22),& + z026=( s64,s26),z030=( s60,s30),z034=( s56,s34),z036=( s54,s36),& + z039=( s51,s39),z040=( s50,s40),z045=( s45,s45),z050=( s40,s50),& + z051=( s39,s51),z054=( s36,s54),z056=( s34,s56),z060=( s30,s60),& + z064=( s26,s64),z068=( s22,s68),z070=( s20,s70),z072=( s18,s72),& + z075=( s15,s75),z077=( s13,s77),z079=( s11,s79),z080=( s10,s80),& + z090=ci, z100=(ms10,s80),z101=(ms11,s79),z103=(ms13,s77),& + z105=(ms15,s75),z108=(ms18,s72),z110=(ms20,s70),z112=(ms22,s68),& + z116=(ms26,s64),z120=(ms30,s60),z124=(ms34,s56),z126=(ms36,s54),& + z129=(ms39,s51),z130=(ms40,s50),z135=(ms45,s45),z140=(ms50,s40),& + z141=(ms51,s39),z144=(ms54,s36),z146=(ms56,s34),z150=(ms60,s30),& + z154=(ms64,s26),z158=(ms68,s22),z160=(ms70,s20),z162=(ms72,s18),& + z165=(ms75,s15),z167=(ms77,s13),z169=(ms79,s11),z170=(ms80,s10),& + z180=-z000,z190=-z010,z191=-z011,z193=-z013,z195=-z015,z198=-z018,& + z200=-z020,z202=-z022,z206=-z026,z210=-z030,z214=-z034,z216=-z036,& + z219=-z039,z220=-z040,z225=-z045,z230=-z050,z231=-z051,z234=-z054,& + z236=-z056,z240=-z060,z244=-z064,z248=-z068,z250=-z070,z252=-z072,& + z255=-z075,z257=-z077,z259=-z079,z260=-z080,z270=-z090,z280=-z100,& + z281=-z101,z283=-z103,z285=-z105,z288=-z108,z290=-z110,z292=-z112,& + z296=-z116,z300=-z120,z304=-z124,z306=-z126,z309=-z129,z310=-z130,& + z315=-z135,z320=-z140,z321=-z141,z324=-z144,z326=-z146,z330=-z150,& + z334=-z154,z338=-z158,z340=-z160,z342=-z162,z345=-z165,z347=-z167,& + z349=-z169,z350=-z170 +end module pietc + diff --git a/rtma_esg_conversion.fd/esg_lib.fd/pietc_s.f90 b/rtma_esg_conversion.fd/esg_lib.fd/pietc_s.f90 new file mode 100644 index 0000000..46ea162 --- /dev/null +++ b/rtma_esg_conversion.fd/esg_lib.fd/pietc_s.f90 @@ -0,0 +1,93 @@ +!> @file +!! @author R. J. Purser @date 2014 +!! Some of the commonly used constants (pi etc) +!! ms10 etc are needed to satisfy the some (eg., gnu fortran) compilers' +!! more rigorous standards regarding the way "data" statements are initialized. +!! Zero and the first few units are u0,u1,u2, etc., their reciprocals being, +!! o2,o3 etc and their square roots, r2,r3. Reciprocal roots are or2,or3 etc. +!! +module pietc_s +use pkind, only: sp,spc +implicit none +logical ,parameter:: T=.true.,F=.false. !<- for pain-relief in logical ops +real(sp),parameter:: & + u0=0_sp,u1=1_sp,mu1=-u1,u2=2_sp,mu2=-u2,u3=3_sp,mu3=-u3,u4=4_sp, & + mu4=-u4,u5=5_sp,mu5=-u5,u6=6_sp,mu6=-u6,o2=u1/u2,o3=u1/u3,o4=u1/u4, & + o5=u1/u5,o6=u1/u6,mo2=-o2,mo3=-o3,mo4=-o4,mo5=-o5,mo6=-06, & + pi =3.1415926535897932384626433832795028841971693993751058209749e0_sp, & + pi2=6.2831853071795864769252867665590057683943387987502116419498e0_sp, & + pih=1.5707963267948966192313216916397514420985846996875529104874e0_sp, & + rpi=1.7724538509055160272981674833411451827975494561223871282138e0_sp, & +! Important square-roots + r2 =1.4142135623730950488016887242096980785696718753769480731766e0_sp, & + r3 =1.7320508075688772935274463415058723669428052538103806280558e0_sp, & + r5 =2.2360679774997896964091736687312762354406183596115257242708e0_sp, & + or2=u1/r2,or3=u1/r3,or5=u1/r5, & +! Golden number: + phi=1.6180339887498948482045868343656381177203091798057628621354e0_sp, & +! Euler-Mascheroni constant: + euler=0.57721566490153286060651209008240243104215933593992359880e0_sp, & +! Degree to radians; radians to degrees: + dtor=pi/180,rtod=180/pi, & +! Sines of all main fractions of 90 degrees (down to ninths): + s10=.173648177666930348851716626769314796000375677184069387236241e0_sp,& + s11=.195090322016128267848284868477022240927691617751954807754502e0_sp,& + s13=.222520933956314404288902564496794759466355568764544955311987e0_sp,& + s15=.258819045102520762348898837624048328349068901319930513814003e0_sp,& + s18=.309016994374947424102293417182819058860154589902881431067724e0_sp,& + s20=.342020143325668733044099614682259580763083367514160628465048e0_sp,& + s22=.382683432365089771728459984030398866761344562485627041433800e0_sp,& + s26=.433883739117558120475768332848358754609990727787459876444547e0_sp,& + s30=o2, & + s34=.555570233019602224742830813948532874374937190754804045924153e0_sp,& + s36=.587785252292473129168705954639072768597652437643145991072272e0_sp,& + s39=.623489801858733530525004884004239810632274730896402105365549e0_sp,& + s40=.642787609686539326322643409907263432907559884205681790324977e0_sp,& + s45=or2, & + s50=.766044443118978035202392650555416673935832457080395245854045e0_sp,& + s51=.781831482468029808708444526674057750232334518708687528980634e0_sp,& + s54=.809016994374947424102293417182819058860154589902881431067724e0_sp,& + s56=.831469612302545237078788377617905756738560811987249963446124e0_sp,& + s60=r3*o2, & + s64=.900968867902419126236102319507445051165919162131857150053562e0_sp,& + s68=.923879532511286756128183189396788286822416625863642486115097e0_sp,& + s70=.939692620785908384054109277324731469936208134264464633090286e0_sp,& + s72=.951056516295153572116439333379382143405698634125750222447305e0_sp,& + s75=.965925826289068286749743199728897367633904839008404550402343e0_sp,& + s77=.974927912181823607018131682993931217232785800619997437648079e0_sp,& + s79=.980785280403230449126182236134239036973933730893336095002916e0_sp,& + s80=.984807753012208059366743024589523013670643251719842418790025e0_sp,& +! ... and their minuses: + ms10=-s10,ms11=-s11,ms13=-s13,ms15=-s15,ms18=-s18,ms20=-s20,ms22=-s22,& + ms26=-s26,ms30=-s30,ms34=-s34,ms36=-s36,ms39=-s39,ms40=-s40,ms45=-s45,& + ms50=-s50,ms51=-s51,ms54=-s54,ms56=-s56,ms60=-s60,ms64=-s64,ms68=-s68,& + ms70=-s70,ms72=-s72,ms75=-s75,ms77=-s77,ms79=-s79,ms80=-s80 + +complex(spc),parameter:: & + c0=(u0,u0),c1=(u1,u0),mc1=-c1,ci=(u0,u1),mci=-ci,cipi=ci*pi, & +! Main fractional rotations, as unimodualr complex numbers: + z000=c1 ,z010=( s80,s10),z011=( s79,s11),z013=( s77,s13),& + z015=( s75,s15),z018=( s72,s18),z020=( s70,s20),z022=( s68,s22),& + z026=( s64,s26),z030=( s60,s30),z034=( s56,s34),z036=( s54,s36),& + z039=( s51,s39),z040=( s50,s40),z045=( s45,s45),z050=( s40,s50),& + z051=( s39,s51),z054=( s36,s54),z056=( s34,s56),z060=( s30,s60),& + z064=( s26,s64),z068=( s22,s68),z070=( s20,s70),z072=( s18,s72),& + z075=( s15,s75),z077=( s13,s77),z079=( s11,s79),z080=( s10,s80),& + z090=ci, z100=(ms10,s80),z101=(ms11,s79),z103=(ms13,s77),& + z105=(ms15,s75),z108=(ms18,s72),z110=(ms20,s70),z112=(ms22,s68),& + z116=(ms26,s64),z120=(ms30,s60),z124=(ms34,s56),z126=(ms36,s54),& + z129=(ms39,s51),z130=(ms40,s50),z135=(ms45,s45),z140=(ms50,s40),& + z141=(ms51,s39),z144=(ms54,s36),z146=(ms56,s34),z150=(ms60,s30),& + z154=(ms64,s26),z158=(ms68,s22),z160=(ms70,s20),z162=(ms72,s18),& + z165=(ms75,s15),z167=(ms77,s13),z169=(ms79,s11),z170=(ms80,s10),& + z180=-z000,z190=-z010,z191=-z011,z193=-z013,z195=-z015,z198=-z018,& + z200=-z020,z202=-z022,z206=-z026,z210=-z030,z214=-z034,z216=-z036,& + z219=-z039,z220=-z040,z225=-z045,z230=-z050,z231=-z051,z234=-z054,& + z236=-z056,z240=-z060,z244=-z064,z248=-z068,z250=-z070,z252=-z072,& + z255=-z075,z257=-z077,z259=-z079,z260=-z080,z270=-z090,z280=-z100,& + z281=-z101,z283=-z103,z285=-z105,z288=-z108,z290=-z110,z292=-z112,& + z296=-z116,z300=-z120,z304=-z124,z306=-z126,z309=-z129,z310=-z130,& + z315=-z135,z320=-z140,z321=-z141,z324=-z144,z326=-z146,z330=-z150,& + z334=-z154,z338=-z158,z340=-z160,z342=-z162,z345=-z165,z347=-z167,& + z349=-z169,z350=-z170 +end module pietc_s diff --git a/rtma_esg_conversion.fd/esg_lib.fd/pkind.f90 b/rtma_esg_conversion.fd/esg_lib.fd/pkind.f90 new file mode 100644 index 0000000..456f16b --- /dev/null +++ b/rtma_esg_conversion.fd/esg_lib.fd/pkind.f90 @@ -0,0 +1,13 @@ +module pkind +integer,parameter:: spi=selected_int_kind(6),& + dpi=selected_int_kind(12),& + sp =selected_real_kind(6,30),& + dp =selected_real_kind(15,300),& + spc=sp,dpc=dp +!private:: one_dpi; integer(8),parameter:: one_dpi=1 +!integer,parameter:: dpi=kind(one_dpi) +!integer,parameter:: sp=kind(1.0) +!integer,parameter:: dp=kind(1.0d0) +!integer,parameter:: spc=kind((1.0,1.0)) +!integer,parameter:: dpc=kind((1.0d0,1.0d0)) +end module pkind diff --git a/rtma_esg_conversion.fd/esg_lib.fd/pmat.f90 b/rtma_esg_conversion.fd/esg_lib.fd/pmat.f90 new file mode 100644 index 0000000..fc7924f --- /dev/null +++ b/rtma_esg_conversion.fd/esg_lib.fd/pmat.f90 @@ -0,0 +1,1088 @@ +!> @file +!! @author R. J. Purser, NOAA/NCEP/EMC, Tsukasa Fujita, JMA. +!! +!! Utility routines for various linear inversions and Cholesky. +!! Dependency: modules pkind, pietc +!! Originally, these routines were copies of the purely "inversion" members +!! of pmat1.f90 (a most extensive collection of matrix routines -- not just +!! inversions). As well as having both single and double precision versions +!! of each routine, these versions also make provision for a more graceful +!! termination in cases where the system matrix is detected to be +!! essentially singular (and therefore noninvertible). This provision takes +!! the form of an optional "failure flag", FF, which is normally returned +!! as .FALSE., but is returned as .TRUE. when inversion fails. +!! In Sep 2012, these routines were collected together into pmat.f90 so +!! that all the main matrix routines could be in the same library, pmat.a. +!! +!! DIRECT DEPENDENCIES: +!! Modules: pkind, pietc +!! +module pmat +!============================================================================= +use pkind, only: spi,sp,dp,spc,dpc +use pietc, only: t,f +implicit none +private +public:: ldum,udlmm,inv,L1Lm,LdLm,invl,invu +interface swpvv; module procedure sswpvv,dswpvv,cswpvv; end interface +interface ldum + module procedure sldum,dldum,cldum,sldumf,dldumf,cldumf; end interface +interface udlmm + module procedure sudlmm,dudlmm,cudlmm,sudlmv,dudlmv,cudlmv; end interface +interface inv + module procedure & +sinvmt, dinvmt, cinvmt, slinmmt, dlinmmt, clinmmt, slinmvt, dlinmvt, clinmvt, & +sinvmtf,dinvmtf,cinvmtf,slinmmtf,dlinmmtf,clinmmtf,slinmvtf,dlinmvtf,clinmvtf,& +iinvf + end interface +interface L1Lm; module procedure sL1Lm,dL1Lm,sL1Lmf,dL1Lmf; end interface +interface LdLm; module procedure sLdLm,dLdLm,sLdLmf,dLdLmf; end interface +interface invl; module procedure sinvl,dinvl,slinlv,dlinlv; end interface +interface invu; module procedure sinvu,dinvu,slinuv,dlinuv; end interface + +contains + +!============================================================================= +subroutine sswpvv(d,e)! [swpvv] +!============================================================================= +! Swap vectors +!------------- +real(sp), intent(inout) :: d(:), e(:) +real(sp) :: tv(size(d)) +!============================================================================= +tv = d; d = e; e = tv +end subroutine sswpvv +!============================================================================= +subroutine dswpvv(d,e)! [swpvv] +!============================================================================= +real(dp), intent(inout) :: d(:), e(:) +real(dp) :: tv(size(d)) +!============================================================================= +tv = d; d = e; e = tv +end subroutine dswpvv +!============================================================================= +subroutine cswpvv(d,e)! [swpvv] +!============================================================================= +complex(dpc),intent(inout) :: d(:), e(:) +complex(dpc) :: tv(size(d)) +!============================================================================= +tv = d; d = e; e = tv +end subroutine cswpvv + +!============================================================================= +subroutine sinvmt(a)! [inv] +!============================================================================= +real(sp),dimension(:,:),intent(INOUT):: a +logical :: ff +call sinvmtf(a,ff) +if(ff)stop 'In sinvmt; Unable to invert matrix' +end subroutine sinvmt +!============================================================================= +subroutine dinvmt(a)! [inv] +!============================================================================= +real(dp),dimension(:,:),intent(inout):: a +logical :: ff +call dinvmtf(a,ff) +if(ff)stop 'In dinvmt; Unable to invert matrix' +end subroutine dinvmt +!============================================================================= +subroutine cinvmt(a)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(inout):: a +logical :: ff +call cinvmtf(a,ff) +if(ff)stop 'In cinvmt; Unable to invert matrix' +end subroutine cinvmt +!============================================================================= +subroutine sinvmtf(a,ff)! [inv] +!============================================================================= +! Invert matrix (or flag if can't) +!---------------- +use pietc_s, only: u1 +real(sp),dimension(:,:),intent(inout):: a +logical, intent( out):: ff +integer(spi) :: m,i,j,jp,l +real(sp) :: d +integer(spi),dimension(size(a,1)):: ipiv +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In sinvmtf; matrix passed to sinvmtf is not square' +! Perform a pivoted L-D-U decomposition on matrix a: +call sldumf(a,ipiv,d,ff) +if(ff)then + print '(" In sinvmtf; failed call to sldumf")' + return +endif + +! Invert upper triangular portion U in place: +do i=1,m; a(i,i)=u1/a(i,i); enddo +do i=1,m-1 + do j=i+1,m; a(i,j)=-a(j,j)*dot_product(a(i:j-1,j),a(i,i:j-1)); enddo +enddo + +! Invert lower triangular portion L in place: +do j=1,m-1; jp=j+1 + do i=jp,m; a(i,j)=-a(i,j)-dot_product(a(jp:i-1,j),a(i,jp:i-1)); enddo +enddo + +! Form the product of U**-1 and L**-1 in place +do j=1,m-1; jp=j+1 + do i=1,j; a(i,j)=a(i,j)+dot_product(a(jp:m,j),a(i,jp:m)); enddo + do i=jp,m; a(i,j)=dot_product(a(i:m,j),a(i,i:m)); enddo +enddo + +! Permute columns according to ipiv +do j=m-1,1,-1; l=ipiv(j); call sswpvv(a(:,j),a(:,l)); enddo +end subroutine sinvmtf +!============================================================================= +subroutine dinvmtf(a,ff)! [inv] +!============================================================================= +real(dp),dimension(:,:),intent(inout):: a +logical, intent( out):: ff +integer(spi) :: m,i,j,jp,l +real(dp) :: d +integer(spi), dimension(size(a,1)) :: ipiv +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to dinvmtf is not square' +! Perform a pivoted L-D-U decomposition on matrix a: +call dldumf(a,ipiv,d,ff) +if(ff)then + print '(" In dinvmtf; failed call to dldumf")' + return +endif + +! Invert upper triangular portion U in place: +do i=1,m; a(i,i)=1_dp/a(i,i); enddo +do i=1,m-1 + do j=i+1,m; a(i,j)=-a(j,j)*dot_product(a(i:j-1,j),a(i,i:j-1)); enddo +enddo + +! Invert lower triangular portion L in place: +do j=1,m-1; jp=j+1 + do i=jp,m; a(i,j)=-a(i,j)-dot_product(a(jp:i-1,j),a(i,jp:i-1)); enddo +enddo + +! Form the product of U**-1 and L**-1 in place +do j=1,m-1; jp=j+1 + do i=1,j; a(i,j)=a(i,j)+dot_product(a(jp:m,j),a(i,jp:m)); enddo + do i=jp,m; a(i,j)=dot_product(a(i:m,j),a(i,i:m)); enddo +enddo + +! Permute columns according to ipiv +do j=m-1,1,-1; l=ipiv(j); call dswpvv(a(:,j),a(:,l)); enddo +end subroutine dinvmtf +!============================================================================= +subroutine cinvmtf(a,ff)! [inv] +!============================================================================= +use pietc, only: c1 +complex(dpc),dimension(:,:),intent(INOUT):: a +logical, intent( OUT):: ff +integer(spi) :: m,i,j,jp,l +complex(dpc) :: d +integer(spi),dimension(size(a,1)):: ipiv +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to cinvmtf is not square' +! Perform a pivoted L-D-U decomposition on matrix a: +call cldumf(a,ipiv,d,ff) +if(ff)then + print '(" In cinvmtf; failed call to cldumf")' + return +endif + +! Invert upper triangular portion U in place: +do i=1,m; a(i,i)=c1/a(i,i); enddo +do i=1,m-1 + do j=i+1,m; a(i,j)=-a(j,j)*sum(a(i:j-1,j)*a(i,i:j-1)); enddo +enddo + +! Invert lower triangular portion L in place: +do j=1,m-1; jp=j+1 + do i=jp,m; a(i,j)=-a(i,j)-sum(a(jp:i-1,j)*a(i,jp:i-1)); enddo +enddo + +! Form the product of U**-1 and L**-1 in place +do j=1,m-1; jp=j+1 + do i=1,j; a(i,j)=a(i,j)+sum(a(jp:m,j)*a(i,jp:m)); enddo + do i=jp,m; a(i,j)=sum(a(i:m,j)*a(i,i:m)); enddo +enddo + +! Permute columns according to ipiv +do j=m-1,1,-1; l=ipiv(j); call cswpvv(a(:,j),a(:,l)); enddo +end subroutine cinvmtf + +!============================================================================= +subroutine slinmmt(a,b)! [inv] +!============================================================================= +real(sp),dimension(:,:),intent(inout):: a,b +logical :: ff +call slinmmtf(a,b,ff) +if(ff)stop 'In slinmmt; unable to invert linear system' +end subroutine slinmmt +!============================================================================= +subroutine dlinmmt(a,b)! [inv] +!============================================================================= +real(dp),dimension(:,:),intent(inout):: a,b +logical :: ff +call dlinmmtf(a,b,ff) +if(ff)stop 'In dlinmmt; unable to invert linear system' +end subroutine dlinmmt +!============================================================================= +subroutine clinmmt(a,b)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(inout):: a,b +logical :: ff +call clinmmtf(a,b,ff) +if(ff)stop 'In clinmmt; unable to invert linear system' +end subroutine clinmmt +!============================================================================= +subroutine slinmmtf(a,b,ff)! [inv] +!============================================================================= +real(sp), dimension(:,:),intent(inout):: a,b +logical, intent( out):: ff +integer(spi),dimension(size(a,1)) :: ipiv +integer(spi) :: m +real(sp) :: d +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to slinmmtf is not square' +if(m /= size(b,1))& + stop 'In inv; matrix and vectors in slinmmtf have unmatched sizes' +call sldumf(a,ipiv,d,ff) +if(ff)then + print '("In slinmmtf; failed call to sldumf")' + return +endif +call sudlmm(a,b,ipiv) +end subroutine slinmmtf +!============================================================================= +subroutine dlinmmtf(a,b,ff)! [inv] +!============================================================================= +real(dp),dimension(:,:), intent(inout):: a,b +logical, intent( out):: ff +integer(spi),dimension(size(a,1)):: ipiv +integer(spi):: m +real(dp) :: d +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to dlinmmtf is not square' +if(m /= size(b,1))& + stop 'In inv; matrix and vectors in dlinmmtf have unmatched sizes' +call dldumf(a,ipiv,d,ff) +if(ff)then + print '("In dlinmmtf; failed call to dldumf")' + return +endif +call dudlmm(a,b,ipiv) +end subroutine dlinmmtf +!============================================================================= +subroutine clinmmtf(a,b,ff)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(INOUT):: a,b +logical, intent( OUT):: ff +integer(spi),dimension(size(a,1)):: ipiv +integer(spi) :: m +complex(dpc) :: d +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to dlinmmtf is not square' +if(m /= size(b,1))& + stop 'In inv; matrix and vectors in dlinmmtf have unmatched sizes' +call cldumf(a,ipiv,d,ff) +if(ff)then + print '("In clinmmtf; failed call to cldumf")' + return +endif +call cudlmm(a,b,ipiv) +end subroutine clinmmtf + +!============================================================================= +subroutine slinmvt(a,b)! [inv] +!============================================================================= +real(sp),dimension(:,:),intent(inout):: a +real(sp),dimension(:), intent(inout):: b +logical:: ff +call slinmvtf(a,b,ff) +if(ff)stop 'In slinmvt; matrix singular, unable to continue' +end subroutine slinmvt +!============================================================================= +subroutine dlinmvt(a,b)! [inv] +!============================================================================= +real(dp),dimension(:,:),intent(inout):: a +real(dp),dimension(:), intent(inout):: b +logical :: ff +call dlinmvtf(a,b,ff) +if(ff)stop 'In dlinmvt; matrix singular, unable to continue' +end subroutine dlinmvt +!============================================================================= +subroutine clinmvt(a,b)! [inv] +!============================================================================= +complex(dpc), dimension(:,:),intent(inout):: a +complex(dpc), dimension(:), intent(inout):: b +logical :: ff +call clinmvtf(a,b,ff) +if(ff)stop 'In clinmvt; matrix singular, unable to continue' +end subroutine clinmvt +!============================================================================= +subroutine slinmvtf(a,b,ff)! [inv] +!============================================================================= +real(sp),dimension(:,:),intent(inout):: a +real(sp),dimension(:), intent(inout):: b +logical, intent( out):: ff +integer(spi),dimension(size(a,1)) :: ipiv +real(sp) :: d +!============================================================================= +if(size(a,1) /= size(a,2).or. size(a,1) /= size(b))& + stop 'In inv; In slinmvtf; incompatible array dimensions' +call sldumf(a,ipiv,d,ff) +if(ff)then + print '("In slinmvtf; failed call to sldumf")' + return +endif +call sudlmv(a,b,ipiv) +end subroutine slinmvtf +!============================================================================= +subroutine dlinmvtf(a,b,ff)! [inv] +!============================================================================= +real(dp),dimension(:,:),intent(inout):: a +real(dp),dimension(:), intent(inout):: b +logical, intent( out):: ff +integer(spi), dimension(size(a,1)) :: ipiv +real(dp) :: d +!============================================================================= +if(size(a,1) /= size(a,2).or. size(a,1) /= size(b))& + stop 'In inv; incompatible array dimensions passed to dlinmvtf' +call dldumf(a,ipiv,d,ff) +if(ff)then + print '("In dlinmvtf; failed call to dldumf")' + return +endif +call dudlmv(a,b,ipiv) +end subroutine dlinmvtf +!============================================================================= +subroutine clinmvtf(a,b,ff)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(inout):: a +complex(dpc),dimension(:), intent(inout):: b +logical, intent( out):: ff +integer, dimension(size(a,1)) :: ipiv +complex(dpc) :: d +!============================================================================= +if(size(a,1) /= size(a,2).or. size(a,1) /= size(b))& + stop 'In inv; incompatible array dimensions passed to clinmvtf' +call cldumf(a,ipiv,d,ff) +if(ff)then + print '("In clinmvtf; failed call to cldumf")' + return +endif +call cudlmv(a,b,ipiv) +end subroutine clinmvtf + +!============================================================================= +subroutine iinvf(imat,ff)! [inv] +!============================================================================= +! Invert integer square array, imat, if possible, but flag ff=.true. +! if not possible. (Determinant of imat must be +1 or -1 +!============================================================================= +integer(spi),dimension(:,:),intent(INOUT):: imat +logical, intent( OUT):: ff +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-6_dp +real(dp),dimension(size(imat,1),size(imat,1)):: dmat +integer(spi) :: m,i,j +!============================================================================= +m=size(imat,1) +if(m /= size(imat,2))stop 'In inv; matrix passed to iinvf is not square' +dmat=imat; call inv(dmat,ff) +if(.not.ff)then + do j=1,m + do i=1,m + imat(i,j)=nint(dmat(i,j)); if(abs(dmat(i,j)-imat(i,j))>eps)ff=t + enddo + enddo +endif +end subroutine iinvf + +!============================================================================= +subroutine sldum(a,ipiv,d)! [ldum] +!============================================================================= +real(sp), intent(inout) :: a(:,:) +real(sp), intent( out) :: d +integer(spi),intent( out) :: ipiv(:) +logical:: ff +call sldumf(a,ipiv,d,ff) +if(ff)stop 'In sldum; matrix singular, unable to continue' +end subroutine sldum +!============================================================================= +subroutine dldum(a,ipiv,d)! [ldum] +!============================================================================= +real(dp), intent(inout) :: a(:,:) +real(dp), intent( out) :: d +integer(spi),intent( out) :: ipiv(:) +logical:: ff +call dldumf(a,ipiv,d,ff) +if(ff)stop 'In dldum; matrix singular, unable to continue' +end subroutine dldum +!============================================================================= +subroutine cldum(a,ipiv,d)! [ldum] +!============================================================================= +complex(dpc),intent(inout) :: a(:,:) +complex(dpc),intent(out ) :: d +integer(spi),intent(out ) :: ipiv(:) +logical:: ff +call cldumf(a,ipiv,d,ff) +if(ff)stop 'In cldum; matrix singular, unable to continue' +end subroutine cldum +!============================================================================= +subroutine sldumf(a,ipiv,d,ff)! [ldum] +!============================================================================= +! R.J.Purser, NCEP, Washington D.C. 1996 +! SUBROUTINE LDUM +! perform l-d-u decomposition of square matrix a in place with +! pivoting. +! +! <-> a square matrix to be factorized +! <-- ipiv array encoding the pivoting sequence +! <-- d indicator for possible sign change of determinant +! <-- ff: failure flag, set to .true. when determinant of a vanishes. +!============================================================================= +use pietc_s,only: u0,u1 +real(sp), intent(inout) :: a(:,:) +real(sp), intent( out) :: d +integer(spi),intent( out) :: ipiv(:) +logical, intent( out) :: ff +integer(spi):: m,i, j, jp, ibig, jm +real(sp) :: s(size(a,1)), aam, aa, abig, ajj, ajji, aij +!============================================================================= +ff=f +m=size(a,1) +do i=1,m + aam=u0 + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == u0)then + print '("In sldumf; row ",i6," of matrix vanishes")',i + ff=t + return + endif + s(i)=u1/aam +enddo +d=1_sp +ipiv(m)=m +do j=1,m-1 + jp=j+1 + abig=s(j)*abs(a(j,j)) + ibig=j + do i=jp,m + aa=s(i)*abs(a(i,j)) + if(aa > abig)then + ibig=i + abig=aa + endif + enddo +! swap rows, recording changed sign of determinant + ipiv(j)=ibig + if(ibig /= j)then + d=-d + call sswpvv(a(j,:),a(ibig,:)) + s(ibig)=s(j) + endif + ajj=a(j,j) + if(ajj == u0)then + jm=j-1 + print '(" failure in sldumf:"/" matrix singular, rank=",i3)',jm + ff=t + return + endif + ajji=u1/ajj + do i=jp,m + aij=ajji*a(i,j) + a(i,j)=aij + a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m) + enddo +enddo +end subroutine sldumf +!============================================================================= +subroutine dldumf(a,ipiv,d,ff)! [ldum] +!============================================================================= +use pietc, only: u0,u1 +real(dp), intent(inout) :: a(:,:) +real(dp), intent( out) :: d +integer, intent( out) :: ipiv(:) +logical(spi),intent( out) :: ff +integer(spi) :: m,i, j, jp, ibig, jm +real(dp) :: s(size(a,1)), aam, aa, abig, ajj, ajji, aij +!============================================================================= +ff=f +m=size(a,1) +do i=1,m + aam=u0 + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == u0)then + print '("In dldumf; row ",i6," of matrix vanishes")',i + ff=t + return + endif + s(i)=u1/aam +enddo +d=u1 +ipiv(m)=m +do j=1,m-1 + jp=j+1 + abig=s(j)*abs(a(j,j)) + ibig=j + do i=jp,m + aa=s(i)*abs(a(i,j)) + if(aa > abig)then + ibig=i + abig=aa + endif + enddo + ! swap rows, recording changed sign of determinant + ipiv(j)=ibig + if(ibig /= j)then + d=-d + call dswpvv(a(j,:),a(ibig,:)) + s(ibig)=s(j) + endif + ajj=a(j,j) + if(ajj == u0)then + jm=j-1 + print '(" Failure in dldumf:"/" matrix singular, rank=",i3)',jm + ff=t + return + endif + ajji=u1/ajj + do i=jp,m + aij=ajji*a(i,j) + a(i,j)=aij + a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m) + enddo +enddo +end subroutine dldumf +!============================================================================= +subroutine cldumf(a,ipiv,d,ff)! [ldum] +!============================================================================= +use pietc, only: u0,u1,c0,c1 +complex(dpc), intent(inout) :: a(:,:) +complex(dpc), intent( out) :: d +integer(spi), intent( out) :: ipiv(:) +logical, intent( out) :: ff +integer(spi) :: m,i, j, jp, ibig, jm +complex(dpc) :: ajj, ajji, aij +real(dp) :: aam,aa,abig +real(dp),dimension(size(a,1)):: s +!============================================================================= +ff=f +m=size(a,1) +do i=1,m + aam=u0 + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == u0)then + print '("In cldumf; row ",i6," of matrix vanishes")',i + ff=t + return + endif + s(i)=u1/aam +enddo +d=c1 +ipiv(m)=m +do j=1,m-1 + jp=j+1 + abig=s(j)*abs(a(j,j)) + ibig=j + do i=jp,m + aa=s(i)*abs(a(i,j)) + if(aa > abig)then + ibig=i + abig=aa + endif + enddo + ! swap rows, recording changed sign of determinant + ipiv(j)=ibig + if(ibig /= j)then + d=-d + call cswpvv(a(j,:),a(ibig,:)) + s(ibig)=s(j) + endif + ajj=a(j,j) + if(ajj == c0)then + jm=j-1 + print '(" Failure in cldumf:"/" matrix singular, rank=",i3)',jm + ff=t + return + endif + ajji=c1/ajj + do i=jp,m + aij=ajji*a(i,j) + a(i,j)=aij + a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m) + enddo +enddo +end subroutine cldumf + +!============================================================================= +subroutine sudlmm(a,b,ipiv)! [udlmm] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1993 +! SUBROUTINE UDLMM +! use l-u factors in A to back-substitute for several rhs in B, using ipiv to +! define the pivoting permutation used in the l-u decomposition. +! +! --> A L-D-U factorization of linear system matrux +! <-> B rt-hand-sides vectors on input, corresponding solutions on return +! --> IPIV array encoding the pivoting sequence +!============================================================================= +use pietc_s, only: u1 +integer(spi),dimension(:), intent(in) :: ipiv +real(sp), dimension(:,:),intent(in) :: a +real(sp), dimension(:,:),intent(inout) :: b +integer(spi):: m,i, k, l +real(sp) :: s,aiii +!============================================================================= +m=size(a,1) +do k=1,size(b,2) !loop over columns of b + do i=1,m + l=ipiv(i) + s=b(l,k) + b(l,k)=b(i,k) + s = s - sum(b(1:i-1,k)*a(i,1:i-1)) + b(i,k)=s + enddo + b(m,k)=b(m,k)/a(m,m) + do i=m-1,1,-1 + aiii=u1/a(i,i) + b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m)) + b(i,k)=b(i,k)*aiii + enddo +enddo +end subroutine sudlmm +!============================================================================= +subroutine dudlmm(a,b,ipiv)! [udlmm] +!============================================================================= +use pietc, only: u1 +integer(spi),dimension(:), intent(in ) :: ipiv +real(dp), dimension(:,:),intent(in ) :: a +real(dp), dimension(:,:),intent(inout) :: b +integer(spi):: m,i, k, l +real(dp) :: s,aiii +!============================================================================= +m=size(a,1) +do k=1, size(b,2)!loop over columns of b + do i=1,m + l=ipiv(i) + s=b(l,k) + b(l,k)=b(i,k) + s = s - sum(b(1:i-1,k)*a(i,1:i-1)) + b(i,k)=s + enddo + b(m,k)=b(m,k)/a(m,m) + do i=m-1,1,-1 + aiii=u1/a(i,i) + b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m)) + b(i,k)=b(i,k)*aiii + enddo +enddo +end subroutine dudlmm +!============================================================================= +subroutine cudlmm(a,b,ipiv)! [udlmm] +!============================================================================= +use pietc, only: c1 +integer(spi),dimension(:), intent(in ) :: ipiv +complex(dpc),dimension(:,:),intent(in ) :: a +complex(dpc),dimension(:,:),intent(inout) :: b +integer(spi):: m,i, k, l +complex(dpc):: s,aiii +!============================================================================= +m=size(a,1) +do k=1, size(b,2)!loop over columns of b + do i=1,m + l=ipiv(i) + s=b(l,k) + b(l,k)=b(i,k) + s = s - sum(b(1:i-1,k)*a(i,1:i-1)) + b(i,k)=s + enddo + b(m,k)=b(m,k)/a(m,m) + do i=m-1,1,-1 + aiii=c1/a(i,i) + b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m)) + b(i,k)=b(i,k)*aiii + enddo +enddo +end subroutine cudlmm + +!============================================================================= +subroutine sudlmv(a,b,ipiv)! [udlmv] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1993 +! SUBROUTINE UDLMV +! use l-u factors in A to back-substitute for 1 rhs in B, using ipiv to +! define the pivoting permutation used in the l-u decomposition. +! +! --> A L-D-U factorization of linear system matrix +! <-> B right-hand-side vector on input, corresponding solution on return +! --> IPIV array encoding the pivoting sequence +!============================================================================= +use pietc_s, only: u1 +integer(spi),dimension(:), intent(in ):: ipiv +real(sp), dimension(:,:),intent(in ):: a +real(sp), dimension(:), intent(inout):: b +integer(spi):: m,i, l +real(sp) :: s,aiii +!============================================================================= +m=size(a,1) +do i=1,m + l=ipiv(i) + s=b(l) + b(l)=b(i) + s = s - sum(b(1:i-1)*a(i,1:i-1)) + b(i)=s +enddo +b(m)=b(m)/a(m,m) +do i=m-1,1,-1 + aiii=u1/a(i,i) + b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m)) + b(i)=b(i)*aiii +enddo +end subroutine sudlmv +!============================================================================= +subroutine dudlmv(a,b,ipiv)! [udlmv] +!============================================================================= +use pietc, only: u1 +integer(spi),dimension(:), intent(in ) :: ipiv(:) +real(dp), dimension(:,:),intent(in ) :: a(:,:) +real(dp), dimension(:), intent(inout) :: b(:) +integer(spi):: m,i, l +real(dp) :: s,aiii +!============================================================================= +m=size(a,1) +do i=1,m + l=ipiv(i) + s=b(l) + b(l)=b(i) + s = s - sum(b(1:i-1)*a(i,1:i-1)) + b(i)=s +enddo +b(m)=b(m)/a(m,m) +do i=m-1,1,-1 + aiii=u1/a(i,i) + b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m)) + b(i)=b(i)*aiii +enddo +end subroutine dudlmv +!============================================================================= +subroutine cudlmv(a,b,ipiv)! [udlmv] +!============================================================================= +use pietc, only: c1 +integer(spi),dimension(:), intent(in ) :: ipiv(:) +complex(dpc),dimension(:,:),intent(in ) :: a(:,:) +complex(dpc),dimension(:), intent(inout) :: b(:) +integer(spi):: m,i, l +complex(dpc):: s,aiii +!============================================================================= +m=size(a,1) +do i=1,m + l=ipiv(i) + s=b(l) + b(l)=b(i) + s = s - sum(b(1:i-1)*a(i,1:i-1)) + b(i)=s +enddo +b(m)=b(m)/a(m,m) +do i=m-1,1,-1 + aiii=c1/a(i,i) + b(i)= b(i) - sum(b(i+1:m)*a(i,i+1:m)) + b(i)=b(i)*aiii +enddo +end subroutine cudlmv + +!============================================================================= +subroutine sl1lm(a,b) ! [l1lm] +!============================================================================= +! Cholesky, M -> L*U, U(i,j)=L(j,i) +!============================================================================= +real(sp),intent(in ):: a(:,:) +real(sp),intent(inout):: b(:,:) +!----------------------------------------------------------------------------- +logical:: ff +call sl1lmf(a,b,ff) +if(ff)stop 'In sl1lm; matrix singular, unable to continue' +end subroutine sl1lm +!============================================================================= +subroutine dl1lm(a,b) ! [l1lm] +!============================================================================= +! Cholesky, M -> L*U, U(i,j)=L(j,i) +!============================================================================= +real(dp),intent(in ):: a(:,:) +real(dp),intent(inout):: b(:,:) +!----------------------------------------------------------------------------- +logical:: ff +call dl1lmf(a,b,ff) +if(ff)stop 'In dl1lm; matrix singular, unable to continue' +end subroutine dl1lm + +!============================================================================= +subroutine sl1lmf(a,b,ff)! [L1Lm] +!============================================================================= +! Cholesky, M -> L*U, U(i,j)=L(j,i) +!============================================================================= +use pietc_s, only: u0 +real(sp),intent(in ):: a(:,:) +real(sp),intent(inout):: b(:,:) +logical, intent( out):: ff +!----------------------------------------------------------------------------- +integer(spi):: m,j, jm, jp, i +real(sp) :: s, bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m + jm=j-1 + jp=j+1 + s = a(j,j) - sum(b(j,1:jm)*b(j,1:jm)) + ff=(S <= u0) + if(ff)then + print '("sL1Lmf detects nonpositive a, rank=",i6)',jm + return + endif + b(j,j)=sqrt(s) + bjji=1_sp/b(j,j) + do i=jp,m + s = a(i,j) - sum(b(i,1:jm)*b(j,1:jm)) + b(i,j)=s*bjji + enddo + b(1:jm,j) = u0 +enddo +end subroutine sl1lmf +!============================================================================= +subroutine dl1lmf(a,b,ff) ! [L1Lm] +!============================================================================= +use pietc, only: u0,u1 +real(dp),intent(in ) :: a(:,:) +real(dp),intent(inout) :: b(:,:) +logical, intent( out) :: ff +!----------------------------------------------------------------------------- +integer(spi):: m,j, jm, jp, i +real(dp) :: s, bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m + jm=j-1 + jp=j+1 + s = a(j,j) - sum(b(j,1:jm)*b(j,1:jm)) + ff=(s <= u0) + if(ff)then + print '("dL1LMF detects nonpositive A, rank=",i6)',jm + return + endif + b(j,j)=sqrt(s) + bjji=u1/b(j,j) + do i=jp,m + s = a(i,j) - sum(b(i,1:jm)*b(j,1:jm)) + b(i,j)=s*bjji + enddo + b(1:jm,j) = u0 +enddo +end subroutine dl1lmf + +!============================================================================= +subroutine sldlm(a,b,d)! [LdLm] +!============================================================================= +! Modified Cholesky decompose Q --> L*D*U, U(i,j)=L(j,i) +!============================================================================= +real(sp),intent(in ):: a(:,:) +real(sp),intent(inout):: b(:,:) +real(sp),intent( out):: d(:) +!----------------------------------------------------------------------------- +logical:: ff +call sldlmf(a,b,d,ff) +if(ff)stop 'In sldlm; matrix singular, unable to continue' +end subroutine sldlm +!============================================================================= +subroutine dldlm(a,b,d)! [LdLm] +!============================================================================= +real(dp),intent(in ):: a(:,:) +real(dp),intent(inout):: b(:,:) +real(dp),intent( out):: d(:) +!----------------------------------------------------------------------------- +logical:: ff +call dldlmf(a,b,d,ff) +if(ff)stop 'In dldlm; matrix singular, unable to continue' +end subroutine dldlm + +!============================================================================= +subroutine sldlmf(a,b,d,ff) ! [LDLM] +!============================================================================= +! Modified Cholesky decompose Q --> L*D*U +!============================================================================= +use pietc_s, only: u0,u1 +real(sp), intent(in ):: a(:,:) +real(sp), intent(inout):: b(:,:) +real(sp), intent( out):: d(:) +logical, intent( out):: ff +!----------------------------------------------------------------------------- +integer(spi):: m,j, jm, jp, i +real(sp) :: bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m + jm=j-1 + jp=j+1 + d(j)=a(j,j) - sum(b(1:jm,j)*b(j,1:jm)) + b(j,j) = u1 + ff=(d(j) == u0) + if(ff)then + print '("In sldlmf; singularity of matrix detected")' + print '("Rank of matrix: ",i6)',jm + return + endif + bjji=u1/d(j) + do i=jp,m + b(j,i)=a(i,j) - dot_product(b(1:jm,j),b(i,1:jm)) + b(i,j)=b(j,i)*bjji + enddo + b(1:jm,j)=u0 +enddo +end subroutine sldlmf +!============================================================================= +subroutine dldlmf(a,b,d,ff) ! [LDLM] +!============================================================================= +! Modified Cholesky Q --> L*D*U, U(i,j)=L(j,i) +!============================================================================= +use pietc, only: u0,u1 +real(dp), intent(IN ) :: a(:,:) +real(dp), intent(INOUT) :: b(:,:) +real(dp), intent( OUT) :: d(:) +logical, intent( OUT) :: ff +!----------------------------------------------------------------------------- +integer(spi):: m,j, jm, jp, i +real(dp) :: bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m; jm=j-1; jp=j+1 + d(j)=a(j,j) - sum(b(1:jm,j)*b(j,1:jm)) + b(j,j) = 1 + ff=(d(j) == u0) + if(ff)then + print '("In dldlmf; singularity of matrix detected")' + print '("Rank of matrix: ",i6)',jm + return + endif + bjji=u1/d(j) + do i=jp,m + b(j,i)=a(i,j) - dot_product(b(1:jm,j),b(i,1:jm)) + b(i,j)=b(j,i)*bjji + enddo + b(1:jm,j)=u0 +enddo +end subroutine dldlmf + +!============================================================================== +subroutine sinvu(a)! [invu] +!============================================================================== +! Invert the upper triangular matrix in place by transposing, calling +! invl, and transposing again. +!============================================================================== +real(sp),dimension(:,:),intent(inout):: a +a=transpose(a); call sinvl(a); a=transpose(a) +end subroutine sinvu +!============================================================================== +subroutine dinvu(a)! [invu] +!============================================================================== +real(dp),dimension(:,:),intent(inout):: a +a=transpose(a); call dinvl(a); a=transpose(a) +end subroutine dinvu +!============================================================================== +subroutine sinvl(a)! [invl] +!============================================================================== +! Invert lower triangular matrix in place +!============================================================================== +use pietc_s, only: u0,u1 +real(sp), intent(inout) :: a(:,:) +integer(spi):: m,j, i +m=size(a,1) +do j=m,1,-1 + a(1:j-1,j) = u0 + a(j,j)=u1/a(j,j) + do i=j+1,m + a(i,j)=-a(i,i)*sum(a(j:i-1,j)*a(i,j:i-1)) + enddo +enddo +end subroutine sinvl +!============================================================================== +subroutine dinvl(a)! [invl] +!============================================================================== +use pietc, only: u0,u1 +real(dp), intent(inout) :: a(:,:) +integer(spi):: m,j, i +m=size(a,1) +do j=m,1,-1 + a(1:j-1,j) = u0 + a(j,j)=u1/a(j,j) + do i=j+1,m + a(i,j)=-a(i,i)*sum(a(j:i-1,j)*a(i,j:i-1)) + enddo +enddo +end subroutine dinvl + +!============================================================================== +subroutine slinlv(a,u)! [invl] +!============================================================================== +! Solve linear system involving lower triangular system matrix. +!============================================================================== +real(sp),intent(in ) :: a(:,:) +real(sp),intent(inout) :: u(:) +integer(spi):: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In slinlv; incompatible array dimensions' +do i=1,size(u); u(i)=(u(i) - sum(u(:i-1)*a(i,:i-1)))/a(i,i); enddo +end subroutine slinlv +!============================================================================== +subroutine dlinlv(a,u)! [invl] +!============================================================================== +real(dp),intent(in ) :: a(:,:) +real(dp),intent(inout) :: u(:) +integer(spi):: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In dlinlv; incompatible array dimensions' +do i=1,size(u); u(i)=(u(i) - sum(u(:i-1)*a(i,:i-1)))/a(i,i); enddo +end subroutine dlinlv + +!============================================================================== +subroutine slinuv(a,u)! [invu] +!============================================================================== +! Solve linear system involving upper triangular system matrix. +!============================================================================== +real(sp),intent(in ) :: a(:,:) +real(sp),intent(inout) :: u(:) +integer(spi):: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In linuv; incompatible array dimensions' +do i=size(u),1,-1; u(i)=(u(i) - sum(a(i+1:,i)*u(i+1:)))/a(i,i); enddo +end subroutine slinuv +!============================================================================== +subroutine dlinuv(a,u)! [invu] +!============================================================================== +real(dp), intent(in ) :: a(:,:) +real(dp), intent(inout) :: u(:) +integer(spi) :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In dlinuv; incompatible array dimensions' +do i=size(u),1,-1; u(i)=(u(i) - sum(a(i+1:,i)*u(i+1:)))/a(i,i); enddo +end subroutine dlinuv + +end module pmat + diff --git a/rtma_esg_conversion.fd/esg_lib.fd/pmat2.f90 b/rtma_esg_conversion.fd/esg_lib.fd/pmat2.f90 new file mode 100644 index 0000000..ccb7c0e --- /dev/null +++ b/rtma_esg_conversion.fd/esg_lib.fd/pmat2.f90 @@ -0,0 +1,1257 @@ +!> @file +!! @author R. J. Purser, Tsukasa Fujita (JMA) @date 1994/1999 +!! +!! Routines dealing with the operations of banded matrices +!! The three special routines allow the construction of compact or +!! conventional interpolation and differencing stencils to a general +!! order of accuracy. These are: +!! - AVCO: Averaging, or interpolating; +!! - DFCO: Differentiating (once); +!! - DFCO2: Differentiating (twice). +!! +!! Other routines provide the tools for applying compact schemes, and for +!! the construction and application of recursive filters. +!! +!! Last modified (Purser): January 6th 2005 +!! added nonredundant ldltb and ltdlbv routines for symmetric matrices, +!! and remove obsolescent routines. +!! +!! DIRECT DEPENDENCIES +!! Libraries[their modules]: pmat[pmat] +!! Additional Modules : pkind +!! +module pmat2 +!============================================================================ +use pkind, only: spi,sp,dp,dpc +implicit none +private +public:: avco,dfco,dfco2, clipb,cad1b,csb1b,cad2b,csb2b, & + ldub,ldltb,udlb,l1ubb,l1ueb,ltdlbv, & + udlbv,udlbx,udlby,udlvb,udlxb,udlyb,u1lbv,u1lbx,u1lby,u1lvb,u1lxb, & + u1lyb,linbv,wrtb +real(dp),parameter:: zero=0 + +interface AVCO; module procedure AVCO, DAVCO, TAVCO; end interface +interface DFCO; module procedure DFCO, DDFCO, TDFCO; end interface +interface DFCO2; module procedure DFCO2, DDFCO2, TDFCO2; end interface +interface CLIPB; module procedure clib, clib_d, clib_c; end interface +interface CAD1B; module procedure CAD1B; end interface +interface CSB1B; module procedure CSB1B; end interface +interface CAD2B; module procedure CAD2B; end interface +interface CSB2B; module procedure CSB2B; end interface +interface LDUB; module procedure LDUB, DLDUB; end interface +interface LDLTB; module procedure LDLTB, DLDLTB; end interface +interface L1UBB; module procedure L1UBB, DL1UBB; end interface +interface L1UEB; module procedure L1UEB, DL1UEB; end interface +interface ltDLBV; module procedure ltdlbv,dltdlbv; end interface +interface UDLB; module procedure UDLB, DUDLB; end interface +interface UDLBV; module procedure UDLBV, dudlbv; end interface +interface UDLBX; module procedure UDLBX; end interface +interface UDLBY; module procedure UDLBY; end interface +interface UDLVB; module procedure UDLVB; end interface +interface UDLXB; module procedure UDLXB; end interface +interface UDLYB; module procedure UDLYB; end interface +interface U1LBV; module procedure U1LBV; end interface +interface U1LBX; module procedure U1LBX; end interface +interface U1LBY; module procedure U1LBY; end interface +interface U1LVB; module procedure U1LVB; end interface +interface U1LXB; module procedure U1LXB; end interface +interface U1LYB; module procedure U1LYB; end interface +interface LINBV; module procedure LINBV; end interface +interface WRTB; module procedure WRTB; end interface +contains + +!============================================================================= +subroutine AVCO(na,nb,za,zb,z0,a,b) ! [AVCO] +!============================================================================= +! SUBROUTINE AVCO +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! jim.purser@noaa.gov 1999 +! +! Compute one row of the coefficients for the compact mid-interval +! interpolation scheme characterized by matrix equation of the form, +! A.t = B.s (*) +! Where s is the vector of "source" values, t the staggered "target" values. +! +! --> NA: number of t-points operated on by this row of the A of (*) +! --> NB: number of s-points operated on by this row of the B of (*) +! --> ZA: coordinates of t-points used in this row of (*) +! --> ZB: coordinates of s-points used in this row of (*) +! --> Z0: nominal point of application of this row of (*) +! <-- A: the NA coefficients A for this scheme +! <-- B: the NB coefficients B for this scheme +!============================================================================= +use pietc, only: u0,u1 +use pmat, only: inv +implicit none +integer(spi),intent(in ):: na,nb +real(sp), intent(in ):: za(na),zb(nb),z0 +real(sp), intent(out):: a(na),b(nb) +!----------------------------------------------------------------------------- +integer(spi) :: na1,nab,i +real(sp), dimension(na+nb,na+nb):: w +real(sp), dimension(na) :: za0,pa +real(sp), dimension(nb) :: zb0,pb +real(sp), dimension(na+nb) :: ab +!============================================================================= +na1=na+1; nab=na+nb +za0=za-z0; zb0=zb-z0 +pa=u1; pb=-u1 +w=u0; ab=u0 +w(1,1:na)=u1; ab(1)=u1 +do i=2,nab; w(i,1:na)=pa; pa=pa*za0; w(i,na1:nab)=pb; pb=pb*zb0; enddo +call INV(w,ab) +a=ab(1:na); b=ab(na1:nab) +end subroutine AVCO +!============================================================================= +subroutine DAVCO(na,nb,za,zb,z0,a,b) ! [AVCO] +!============================================================================= +use pietc, only: u0,u1 +use pmat, only: inv +implicit none +integer(spi),intent(IN ):: na,nb +real(dp), intent(IN ):: za(na),zb(nb),z0 +real(dp), intent(OUT):: a(na),b(nb) +!----------------------------------------------------------------------------- +integer(spi) :: na1,nab,i +real(dp),dimension(na+nb,na+nb):: w +real(dp),dimension(na) :: za0,pa +real(dp),dimension(nb) :: zb0,pb +real(dp),dimension(na+nb) :: ab +!============================================================================= +na1=na+1; nab=na+nb +za0=za-z0; zb0=zb-z0 +pa=u1; pb=-u1 +w=u0; ab=u0 +w(1,1:na)=u1; ab(1)=u1 +do i=2,nab; w(i,1:na)=pa; pa=pa*za0; w(i,na1:nab)=pb; pb=pb*zb0; enddo +call INV(w,ab) +a=ab(1:na); b=ab(na1:nab) +end subroutine DAVCO +!============================================================================= +subroutine TAVCO(xa,xb,a,b)! [AVCO] +!============================================================================= +implicit none +real(dp),dimension(:),intent(IN ):: xa,xb +real(dp),dimension(:),intent(OUT):: a,b +!----------------------------------------------------------------------------- +integer(spi):: na,nb +!============================================================================= +na=size(xa); if(na /= size(a))stop 'In tavco; sizes of a and xa different' +nb=size(xb); if(nb /= size(b))stop 'In tavco; sizes of b and xb different' +call DAVCO(na,nb,xa,xb,zero,a,b) +end subroutine TAVCO + +!============================================================================= +subroutine DFCO(na,nb,za,zb,z0,a,b)! [DFCO] +!============================================================================= +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! jim.purser@noaa.gov 1999 +! SUBROUTINE DFCO +! +! Compute one row of the coefficients for either the compact differencing or +! quadrature scheme characterized by matrix equation of the form, +! A.d = B.c (*) +! In either case, d is the derivative of c. +! +! --> NA: number of d-points operated on by this row of the A of (*) +! --> NB: number of c-points operated on by this row of the B of (*) +! --> ZA: coordinates of d-points used in this row of (*) +! --> ZB: coordinates of c-points used in this row of (*) +! --> Z0: nominal point of application of this row of (*) +! <-- A: the A-coefficients for this scheme +! <-- B: the B-coefficients for this scheme +!============================================================================= +use pietc_s, only: u0,u1 +use pmat, only: inv +implicit none +integer(spi),intent(IN ) :: na,nb +real(sp), intent(IN ) :: za(na),zb(nb),z0 +real(sp), intent(OUT) :: a(na),b(nb) +!----------------------------------------------------------------------------- +integer(spi):: na1,nab,i +real(sp), dimension(na+nb,na+nb):: w +real(sp), dimension(na) :: za0,pa +real(sp), dimension(nb) :: zb0,pb +real(sp), dimension(na+nb) :: ab +!============================================================================= +na1=na+1; nab=na+nb +za0=za-z0; zb0=zb-z0 +pa=u1; pb=-u1 +w=u0; ab=u0 +w(1,1:na)=u1; ab(1)=u1 +do i=3,nab; w(i,1:na) =pa*(i-2); pa=pa*za0; enddo +do i=2,nab; w(i,na1:nab)=pb; pb=pb*zb0; enddo +call INV(w,ab) +a=ab(1:na); b=ab(na1:nab) +end subroutine DFCO +!============================================================================= +subroutine DDFCO(na,nb,za,zb,z0,a,b) ! Real(dp) version of [DFCO] +!============================================================================= +use pietc, only: u0,u1 +use pmat, only: inv +implicit none +integer(spi),intent(in) :: na,nb +real(dp), intent(in) :: za(na),zb(nb),z0 +real(dp), intent(out):: a(na),b(nb) +!----------------------------------------------------------------------------- +integer(spi) :: na1,nab,i +real(dp), dimension(na+nb,na+nb):: w +real(dp), dimension(na) :: za0,pa +real(dp), dimension(nb) :: zb0,pb +real(dp), dimension(na+nb) :: ab +!============================================================================= +na1=na+1; nab=na+nb +za0=za-z0; zb0=zb-z0 +pa=u1; pb=-u1 +w=u0; ab=u0 +w(1,1:na)=u1; ab(1)=u1 +do i=3,nab; w(i,1:na) =pa*(i-2); pa=pa*za0; enddo +do i=2,nab; w(i,na1:nab)=pb; pb=pb*zb0; enddo +call INV(w,ab) +a=ab(1:na); b=ab(na1:nab) +end subroutine DDFCO +!============================================================================= +subroutine TDFCO(xa,xb,a,b)! [DFCO] +!============================================================================= +implicit none +real(dp),dimension(:),intent(IN ):: xa,xb +real(dp),dimension(:),intent(OUT):: a,b +!----------------------------------------------------------------------------- +integer(spi):: na,nb +!============================================================================= +na=size(xa); if(na /= size(a))stop 'In tdfco; sizes of a and xa different' +nb=size(xb); if(nb /= size(b))stop 'In tdfco; sizes of b and xb different' +call DDFCO(na,nb,xa,xb,zero,a,b) +end subroutine TDFCO + +!============================================================================= +subroutine DFCO2(na,nb,za,zb,z0,a,b)! [DFCO2] +!============================================================================= +! SUBROUTINE DFCO2 +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! jim.purser@noaa.gov 1999 +! +! Compute one row of the coefficients for either the compact second- +! differencing scheme characterized by matrix equation of the form, +! A.d = B.c (*) +! Where d is the second-derivative of c. +! +! --> NA: number of d-points operated on by this row of the A of (*) +! --> NB: number of c-points operated on by this row of the B of (*) +! --> ZA: coordinates of d-points used in this row of (*) +! --> ZB: coordinates of c-points used in this row of (*) +! --> Z0: nominal point of application of this row of (*) +! <-- A: the NA coefficients A for this scheme +! <-- B: the NB coefficients B for this scheme +!============================================================================= +use pietc_s, only: u0,u1 +use pmat, only: inv +implicit none +integer(spi), intent(IN ):: na,nb +real(sp), intent(IN ):: za(na),zb(nb),z0 +real(sp), intent(OUT):: a(na),b(nb) +!----------------------------------------------------------------------------- +integer(spi) :: na1,nab,i +real(sp), dimension(na+nb,na+nb):: w +real(sp), dimension(na) :: za0,pa +real(sp), dimension(nb) :: zb0,pb +real(sp), dimension(na+nb) :: ab +!============================================================================= +na1=na+1; nab=na+nb +za0=za-z0; zb0=zb-z0 +pa=u1; pb=-u1 +w=u0; ab=u0 +w(1,1:na)=u1; ab(1)=u1 +do i=4,nab; w(i,1:na) =pa*(i-2)*(i-3); pa=pa*za0; enddo +do i=2,nab; w(i,na1:nab)=pb; pb=pb*zb0; enddo +call INV(w,ab) +a=ab(1:na); b=ab(na1:nab) +end subroutine DFCO2 +!============================================================================= +subroutine DDFCO2(na,nb,za,zb,z0,a,b) ! Real(dp) version of [DFCO2] +!============================================================================= +use pietc, only: u0,u1 +use pmat, only: inv +implicit none +integer(spi),intent(IN ) :: na,nb +real(dp), intent(IN ) :: za(na),zb(nb),z0 +real(dp), intent(OUT) :: a(na),b(nb) +!----------------------------------------------------------------------------- +integer(spi) :: na1,nab,i +real(dp), dimension(na+nb,na+nb):: w +real(dp), dimension(na) :: za0,pa +real(dp), dimension(nb) :: zb0,pb +real(dp), dimension(na+nb) :: ab +!============================================================================= +na1=na+1; nab=na+nb +za0=za-z0; zb0=zb-z0 +pa=u1; pb=-u1 +w=u0; ab=u0 +w(1,1:na)=u1; ab(1)=u1 +do i=4,nab; w(i,1:na) =pa*(i-2)*(i-3); pa=pa*za0; enddo +do i=2,nab; w(i,na1:nab)=pb; pb=pb*zb0; enddo +call INV(w,ab) +a=ab(1:na); b=ab(na1:nab) +end subroutine ddfco2 +!============================================================================= +subroutine TDFCO2(xa,xb,a,b)! [DFCO2] +!============================================================================= +real(dp),dimension(:),intent(IN ):: xa,xb +real(dp),dimension(:),intent(OUT):: a,b +!----------------------------------------------------------------------------- +integer(spi):: na,nb +!============================================================================= +na=size(xa); if(na /= size(a))stop 'In tdfco2; sizes of a and xa different' +nb=size(xb); if(nb /= size(b))stop 'In tdfco2; sizes of b and xb different' +call DDFCO2(na,nb,xa,xb,zero,a,b) +end subroutine TDFCO2 + + +!============================================================================= +pure subroutine CLIB(m1,m2,mah1,mah2,a)! [CLIPB] +!============================================================================= +use pietc_s, only: u0 +implicit none +integer(spi), intent(IN ) :: m1, m2, mah1, mah2 +real(sp), intent(INOUT) :: a(m1,-mah1:mah2) +integer(spi):: j +do j=1,mah1; a(1:min(m1,j),-j)=u0; enddo +do j=m2-m1+1,mah2; a(max(1,m2-j+1):m1,j)=u0; enddo +end subroutine CLIB +!============================================================================= +pure subroutine clib_d(m1,m2,mah1,mah2,a)! [CLIPB] +!============================================================================= +use pietc, only: u0 +implicit none +integer(spi),intent(IN ) :: m1, m2, mah1, mah2 +real(dp), intent(INOUT) :: a(m1,-mah1:mah2) +integer(spi):: j +do j=1,mah1; a(1:min(m1,j),-j)=u0; enddo +do j=m2-m1+1,mah2; a(max(1,m2-j+1):m1,j)=u0; enddo +end subroutine clib_d +!============================================================================= +pure subroutine clib_c(m1,m2,mah1,mah2,a)! [CLIPB] +!============================================================================= +use pietc, only: c0 +implicit none +integer(spi), intent(IN ) :: m1, m2, mah1, mah2 +complex(dpc), intent(INOUT) :: a(m1,-mah1:mah2) +integer(spi):: j +do j=1,mah1; a(1:min(m1,j),-j)=c0; enddo +do j=m2-m1+1,mah2; a(max(1,m2-j+1):m1,j)=c0; enddo +end subroutine clib_c + +!============================================================================= +subroutine CAD1B(m1,mah1,mah2,mirror2,a)! [CAD1B] +!============================================================================= +! Incorporate operand symmetry near end-1 of a band matrix operator +! +! <-> A: Input as unclipped operator, output as symmetrized and clipped. +! m1, m2: Sizes of implied full matrix +! mah1, mah2: Left and right semi-bandwidths of A. +! mirror2: 2*location of symmetry axis relative to end-1 operand element. +! Note: although m2 is not used here, it IS used in companion routines +! cad2b and csb2b; it is retained in the interests of uniformity. +!============================================================================= +use pietc_s, only: u0 +implicit none +integer(spi),intent(IN ):: m1,mah1,mah2,mirror2 +real(sp), intent(INOUT):: a(0:m1-1,-mah1:mah2) +!----------------------------------------------------------------------------- +integer(spi):: i,i2,jm,jp,jpmax +!============================================================================= +if(mirror2+mah1 > mah2)stop 'In CAD1B; mah2 insufficient' +do i=0,m1-1; i2=i*2; jpmax=mirror2+mah1-i2; if(jpmax <= -mah1)exit + do jm=-mah1,mah2; jp=mirror2-jm-i2; if(jp <= jm)exit + a(i,jp)=a(i,jp)+a(i,jm) ! Reflect and add + a(i,jm)=u0 ! zero the exterior part + enddo +enddo +end subroutine CAD1B + +!============================================================================= +subroutine CSB1B(m1,mah1,mah2,mirror2,a)! [CSB1B] +!============================================================================= +! Like cad1b, but for antisymmetric operand +!============================================================================= +use pietc_s, only: u0 +implicit none +integer(spi),intent(IN ):: m1,mah1,mah2,mirror2 +real(sp), intent(INOUT):: a(0:m1-1,-mah1:mah2) +!----------------------------------------------------------------------------- +integer(spi):: i,i2,jm,jp,jpmax +!============================================================================= +if(mirror2+mah1 > mah2)stop 'In CSB1B; mah2 insufficient' +do i=0,m1-1; i2=i*2; jpmax=mirror2+mah1-i2; if(jpmax < -mah1)exit + do jm=-mah1,mah2; jp=mirror2-jm-i2; if(jp < jm)exit + a(i,jp)=a(i,jp)-a(i,jm) ! Reflect and subtract + a(i,jm)=u0 ! zero the exterior part + enddo +enddo +end subroutine CSB1B + +!============================================================================= +subroutine CAD2B(m1,m2,mah1,mah2,mirror2,a)! [CAD2B] +!============================================================================= +! Incorporate operand symmetry near end-2 of a band matrix operator +! +! <-> A: Input as unclipped operator, output as symmetrized and clipped. +! m1, m2: Sizes of implied full matrix +! mah1, mah2: Left and right semi-bandwidths of A. +! mirror2: 2*location of symmetry axis relative to end-2 operand element. +!============================================================================= +use pietc_s, only: u0 +implicit none +integer(spi),intent(IN ):: m1,m2,mah1,mah2,mirror2 +real(sp), intent(INOUT):: a(1-m1:0,m1-m2-mah1:m1-m2+mah2) +!----------------------------------------------------------------------------- +integer(spi):: i,i2,jm,jp,jmmin,nah1,nah2 +!============================================================================= +nah1=mah1+m2-m1; nah2=mah2+m1-m2 ! Effective 2nd-index bounds of A +if(mirror2-nah1 > -nah2)stop 'In CAD2B; mah1 insufficient' +do i=0,1-m1,-1; i2=i*2; jmmin=mirror2-nah2-i2; if(jmmin >= nah2)exit + do jp=nah2,nah1,-1; jm=mirror2-jp-i2; if(jm >= jp)exit + a(i,jm)=a(i,jm)+a(i,jp) ! Reflect and add + a(i,jp)=u0 ! zero the exterior part + enddo +enddo +end subroutine CAD2B + +!============================================================================= +subroutine CSB2B(m1,m2,mah1,mah2,mirror2,a)! [CSB2B] +!============================================================================= +use pietc_s, only: u0 +implicit none +integer(spi),intent(IN ):: m1,m2,mah1,mah2,mirror2 +real(sp), intent(INOUT):: a(1-m1:0,m1-m2-mah1:m1-m2+mah2) +!----------------------------------------------------------------------------- +integer(spi):: i,i2,jm,jp,jmmin,nah1,nah2 +!============================================================================= +nah1=mah1+m2-m1; nah2=mah2+m1-m2 ! Effective 2nd-index bounds of A +if(mirror2-nah1 > -nah2)stop 'In CSB2B; mah1 insufficient' +do i=0,1-m1,-1; i2=i*2; jmmin=mirror2-nah2-i2; if(jmmin > nah2)exit + do jp=nah2,nah1,-1; jm=mirror2-jp-i2; if(jm > jp)exit + a(i,jm)=a(i,jm)-a(i,jp) ! Reflect and subtract + a(i,jp)=u0 ! zero the exterior part + enddo +enddo +end subroutine CSB2B + +!============================================================================= +subroutine LDUB(m,mah1,mah2,a)! [LDUB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE LDUB +! Compute [L]*[D**-1]*[U] decomposition of asymmetric band-matrix +! +! <-> A: input as the asymmetric band matrix. On output, it contains +! the [L]*[D**-1]*[U] factorization of the input matrix, where +! [L] is lower triangular with unit main diagonal +! [D] is a diagonal matrix +! [U] is upper triangular with unit main diagonal +! --> M: The number of rows of array A +! --> MAH1: the left half-bandwidth of fortran array A +! --> MAH2: the right half-bandwidth of fortran array A +!============================================================================= +use pietc_s, only: u0,u1 +implicit none +integer(spi),intent(IN ):: m,mah1, mah2 +real(sp), intent(INOUT):: a(m,-mah1:mah2) +!----------------------------------------------------------------------------- +integer(spi):: j, imost, jmost, jp, i +real(sp) :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jmost=min(m,j+mah2) + jp=j+1 + ajj=a(j,0) + if(ajj == u0)then + print '(" Failure in LDUB:"/" Matrix requires pivoting or is singular")' + stop + endif + ajji=u1/ajj + a(j,0)=ajji + do i=jp,imost + aij=ajji*a(i,j-i) + a(i,j-i)=aij + a(i,jp-i:jmost-i)=a(i,jp-i:jmost-i)-aij*a(j,1:jmost-j) + enddo + a(j,1:jmost-j)=ajji*a(j,1:jmost-j) +enddo +end subroutine LDUB +!============================================================================= +subroutine DLDUB(m,mah1,mah2,a) ! Real(dp) version of [LDUB] +!============================================================================= +use pietc, only: u0,u1 +implicit none +integer(spi),intent(IN ):: m,mah1, mah2 +real(dp), intent(INOUT):: a(m,-mah1:mah2) +!----------------------------------------------------------------------------- +integer(spi):: j, imost, jmost, jp, i +real(dp) :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jmost=min(m,j+mah2) + jp=j+1 + ajj=a(j,0) + if(ajj == u0)then + print '(" Fails in LDUB_d:"/" Matrix requires pivoting or is singular")' + stop + endif + ajji=u1/ajj + a(j,0)=ajji + do i=jp,imost + aij=ajji*a(i,j-i) + a(i,j-i)=aij + a(i,jp-i:jmost-i)=a(i,jp-i:jmost-i)-aij*a(j,1:jmost-j) + enddo + a(j,1:jmost-j)=ajji*a(j,1:jmost-j) +enddo +end subroutine DLDUB + +!============================================================================= +subroutine LDLTB(m,mah1,a) ! Real(sp) version of [LDLTB] +!============================================================================= +use pietc_s, only: u0,u1 +integer(spi),intent(IN ):: m,mah1 +real(sp), intent(INOUT):: a(m,-mah1:0) +!----------------------------------------------------------------------------- +integer(spi):: j, imost, jp, i,k +real(sp) :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jp=j+1 + ajj=a(j,0) + if(ajj == u0)then + print '(" Fails in LDLTB:"/" Matrix requires pivoting or is singular")' + stop + endif + ajji=u1/ajj + a(j,0)=ajji + do i=jp,imost + aij=a(i,j-i) + a(i,j-i)=ajji*aij + do k=jp,i + a(i,k-i)=a(i,k-i)-aij*a(k,j-k) + enddo + enddo +enddo +end subroutine LDLTB +!============================================================================= +subroutine DLDLTB(m,mah1,a) ! Real(dp) version of [LDLTB] +!============================================================================= +use pietc, only: u0,u1 +integer(spi),intent(IN ) :: m,mah1 +real(dp), intent(INOUT) :: a(m,-mah1:0) +!----------------------------------------------------------------------------- +integer(spi):: j, imost, jp, i,k +real(dp) :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jp=j+1 + ajj=a(j,0) + if(ajj == u0)then + print '(" Fails in LDLTB_d:"/" Matrix requires pivoting or is singular")' + stop + endif + ajji=u1/ajj + a(j,0)=ajji + do i=jp,imost + aij=a(i,j-i) + a(i,j-i)=ajji*aij + do k=jp,i + a(i,k-i)=a(i,k-i)-aij*a(k,j-k) + enddo + enddo +enddo +end subroutine DLDLTB + +!============================================================================= +subroutine UDLB(m,mah1,mah2,a) ! Reversed-index version of ldub [UDLB] +!============================================================================= +implicit none +integer(spi), intent(IN ) :: m,mah1,mah2 +real(sp),dimension(m,-mah1:mah2),intent(INOUT) :: a(m,-mah1:mah2) +!----------------------------------------------------------------------------- +real(sp),dimension(m,-mah2:mah1):: at +!============================================================================= +at=a(m:1:-1,mah2:-mah1:-1); call LDUB(m,mah2,mah1,at) +a=at(m:1:-1,mah1:-mah2:-1) +end subroutine UDLB +!============================================================================= +subroutine DUDLB(m,mah1,mah2,a) ! real(dp) version of udlb [UDLB] +!============================================================================= +implicit none +integer(spi), intent(IN ) :: m,mah1,mah2 +real(dp),dimension(m,-mah1:mah2),intent(INOUT) :: a(m,-mah1:mah2) +!----------------------------------------------------------------------------- +real(dp),dimension(m,-mah2:mah1):: at +!============================================================================= +at=a(m:1:-1,mah2:-mah1:-1); call DLDUB(m,mah2,mah1,at) +a=at(m:1:-1,mah1:-mah2:-1) +end subroutine DUDLB + +!============================================================================= +subroutine L1UBB(m,mah1,mah2,mbh1,mbh2,a,b)! [L1UBB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE L1UBB +! Form the [L]*[D]*[U] decomposition of asymmetric band-matrix [A] replace +! lower triangular elements of [A] by [D**-1]*[L]*[D], the upper by [U], +! replace matrix [B] by [D**-1]*[B]. +! +! <-> A input as band matrix, output as lower and upper triangulars with 1s +! implicitly assumed to lie on the main diagonal. The product of these +! triangular matrices is [D**-1]*[A], where [D] is a diagonal matrix. +! <-> B in as band matrix, out as same but premultiplied by diagonal [D**-1] +! --> M Number of rows of A and B +! --> MAH1 left half-width of fortran array A +! --> MAH2 right half-width of fortran array A +! --> MBH1 left half-width of fortran array B +! --> MBH2 right half-width of fortran array B +!============================================================================= +use pietc_s, only: u0,u1 +implicit none +integer(spi), intent(IN ) :: m,mah1, mah2, mbh1, mbh2 +real(sp), intent(INOUT) :: a(m,-mah1:mah2), b(m,-mbh1:mbh2) +!----------------------------------------------------------------------------- +integer(spi):: j, imost, jmost, jleast, jp, i +real(sp) :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jmost=min(m,j+mah2) + jleast=max(1,j-mah1) + jp=j+1 + ajj=a(j,0) + if(ajj == u0)stop 'In L1UBB; zero element found in diagonal factor' + ajji=u1/ajj + a(j,jleast-j:jmost-j) = ajji * a(j,jleast-j:jmost-j) + do i=jp,imost + aij=a(i,j-i) + a(i,jp-i:jmost-i) = a(i,jp-i:jmost-i) - aij*a(j,jp-j:jmost-j) + enddo + a(j,0)=u1 + b(j,-mbh1:mbh2) = ajji * b(j,-mbh1:mbh2) +enddo +end subroutine L1UBB +!============================================================================= +subroutine DL1UBB(m,mah1,mah2,mbh1,mbh2,a,b) ! Real(dp) version of [L1UBB] +!============================================================================= +use pietc, only: u0,u1 +implicit none +integer(spi),intent(IN ) :: m,mah1, mah2, mbh1, mbh2 +real(dp), intent(INOUT) :: a(m,-mah1:mah2), b(m,-mbh1:mbh2) +!----------------------------------------------------------------------------- +integer(spi):: j, imost, jmost, jleast, jp, i +real(dp) :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jmost=min(m,j+mah2) + jleast=max(1,j-mah1) + jp=j+1 + ajj=a(j,0) + if(ajj == u0)stop 'In L1UBB_d; zero element found in diagonal factor' + ajji=u1/ajj + a(j,jleast-j:jmost-j) = ajji * a(j,jleast-j:jmost-j) + do i=jp,imost + aij=a(i,j-i) + a(i,jp-i:jmost-i) = a(i,jp-i:jmost-i) - aij*a(j,jp-j:jmost-j) + enddo + a(j,0)=u1 + b(j,-mbh1:mbh2) = ajji * b(j,-mbh1:mbh2) +enddo +end subroutine DL1UBB + +!============================================================================= +subroutine L1UEB(m,mah1,mah2,mbh1,mbh2,a,b)! [L1UEB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1998 +! SUBROUTINE L1UEB +! Form the [L]*[D]*[U] decomposition of asymmetric band-matrix [A] replace +! all but row zero of the +! lower triangular elements of [A] by [D**-1]*[L]*[D], the upper by [U], +! replace matrix [B] by [D**-1]*[B]. +! This is a special adaptation of L1UBB used to process quadarature weights +! for QEDBV etc in which the initial quadrature value is provided as input +! instead of being implicitly assumed zero (which is the case for QZDBV etc). +! +! <-> A input as band matrix, output as lower and upper triangulars with 1s +! implicitly assumed to lie on the main diagonal. The product of these +! triangular matrices is [D**-1]*[A], where [D] is a diagonal matrix. +! <-> B in as band matrix, out as same but premultiplied by diagonal [D**-1] +! --> M number of rows of B, one less than the rows of A (which has "row 0") +! --> MAH1 left half-width of fortran array A +! --> MAH2 right half-width of fortran array A +! --> MBH1 left half-width of fortran array B +! --> MBH2 right half-width of fortran array B +!============================================================================= +use pietc_s, only: u0,u1 +implicit none +integer(spi),intent(IN ) :: m,mah1, mah2, mbh1, mbh2 +real(sp), intent(INOUT) :: a(0:m,-mah1:mah2), b(m,-mbh1:mbh2) +!----------------------------------------------------------------------------- +integer(spi):: j, imost, jmost, jleast, jp, i +real(sp) :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jmost=min(m,j+mah2) + jleast=max(0,j-mah1) + jp=j+1 + ajj=a(j,0) + if(ajj == u0)stop 'In L1UEB; zero element found in diagonal factor' + ajji=u1/ajj + a(j,jleast-j:jmost-j) = ajji * a(j,jleast-j:jmost-j) + do i=jp,imost + aij=a(i,j-i) + a(i,jp-i:jmost-i) = a(i,jp-i:jmost-i) - aij*a(j,jp-j:jmost-j) + enddo + a(j,0)=u1 + b(j,-mbh1:mbh2) = ajji * b(j,-mbh1:mbh2) +enddo +end subroutine L1UEB +!============================================================================= +subroutine DL1UEB(m,mah1,mah2,mbh1,mbh2,a,b) ! Real(dp) version of [L1UEB] +!============================================================================= +use pietc, only: u0,u1 +implicit none +integer(spi),intent(IN ):: m,mah1, mah2, mbh1, mbh2 +real(dp), intent(INOUT):: a(0:,-mah1:), b(:,-mbh1:) +!----------------------------------------------------------------------------- +integer(spi):: j, imost, jmost, jleast, jp, i +real(dp) :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jmost=min(m,j+mah2) + jleast=max(0,j-mah1) + jp=j+1 + ajj=a(j,0) + if(ajj == u0)stop 'In L1UEB_D; zero element found in diagonal factor' + ajji=u1/ajj + a(j,jleast-j:jmost-j) = ajji * a(j,jleast-j:jmost-j) + do i=jp,imost + aij=a(i,j-i) + a(i,jp-i:jmost-i) = a(i,jp-i:jmost-i) - aij*a(j,jp-j:jmost-j) + enddo + a(j,0)=u1 + b(j,-mbh1:mbh2) = ajji * b(j,-mbh1:mbh2) +enddo +end subroutine DL1UEB + +!============================================================================= +subroutine UDLBV(m,mah1,mah2,a,v)! [UDLBV] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE UDLBV +! BACk-substitution step of linear inversion involving +! Banded matrix and Vector. +! +! --> A encodes the (L)*(D**-1)*(U) factorization of the linear-system +! matrix, as supplied by subroutine LDUB +! <-> V input as right-hand-side vector, output as solution vector +! --> M the number of rows assumed for A and for V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +!============================================================================= +implicit none +integer(spi),intent(IN ):: m, mah1, mah2 +real(sp), intent(IN ):: a(m,-mah1:mah2) +real(sp), intent(INOUT):: v(m) +!----------------------------------------------------------------------------- +integer(spi):: i, j +real(sp) :: vj +!============================================================================= +do j=1,m + vj=v(j) + do i=j+1,min(m,j+mah1); v(i)=v(i)-a(i,j-i)*vj; enddo; v(j)=a(j,0)*vj +enddo +do j=m,2,-1 + vj=v(j) + do i=max(1,j-mah2),j-1; v(i)=v(i)-a(i,j-i)*vj; enddo +enddo +end subroutine UDLBV +!============================================================================= +subroutine dudlbv(m,mah1,mah2,a,v)! [udlbv] +!============================================================================= +implicit none +integer(spi),intent(IN ) :: m, mah1, mah2 +real(dp), intent(IN ) :: a(m,-mah1:mah2) +real(dp), intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer(spi):: i, j +real(dp) :: vj +!============================================================================= +do j=1,m + vj=v(j) + do i=j+1,min(m,j+mah1); v(i)=v(i)-a(i,j-i)*vj; enddo; v(j)=a(j,0)*vj +enddo +do j=m,2,-1 + vj=v(j) + do i=max(1,j-mah2),j-1; v(i)=v(i)-a(i,j-i)*vj; enddo +enddo +end subroutine dudlbv + +!============================================================================= +subroutine ltdlbv(m,mah1,a,v)! [ltdlbv] +!============================================================================= +! Like udlbv, except assuming a is the ltdl decomposition of a SYMMETRIC +! banded matrix, with only the non-upper part provided (to avoid redundancy) +!============================================================================= +implicit none +integer(spi),intent(IN ) :: m, mah1 +real(sp), intent(IN ) :: a(m,-mah1:0) +real(sp), intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer(spi):: i, j +real(sp) :: vj +!============================================================================= +do j=1,m + vj=v(j) + do i=j+1,min(m,j+mah1); v(i)=v(i)-a(i,j-i)*vj; enddo; v(j)=a(j,0)*vj +enddo +do j=m,2,-1 + vj=v(j) + do i=max(1,j-mah1),j-1; v(i)=v(i)-a(j,i-j)*vj; enddo +enddo +end subroutine ltdlbv +!============================================================================= +subroutine dltdlbv(m,mah1,a,v)! [ltdlbv] +!============================================================================= +! Like udlbv, except assuming a is the ltdl decomposition of a SYMMETRIC +! banded matrix, with only the non-upper part provided (to avoid redundancy) +!============================================================================= +implicit none +integer(spi),intent(IN ) :: m, mah1 +real(dp), intent(IN ) :: a(m,-mah1:0) +real(dp), intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer(spi):: i, j +real(dp) :: vj +!============================================================================= +do j=1,m + vj=v(j) + do i=j+1,min(m,j+mah1); v(i)=v(i)-a(i,j-i)*vj; enddo; v(j)=a(j,0)*vj +enddo +do j=m,2,-1 + vj=v(j) + do i=max(1,j-mah1),j-1; v(i)=v(i)-a(j,i-j)*vj; enddo +enddo +end subroutine dltdlbv + +!============================================================================= +subroutine UDLBX(mx,mah1,mah2,my,a,v)! [UDLBX] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE UDLBX +! BACk-substitution step of parallel linear inversion involving +! Banded matrix and X-Vectors. +! +! --> A encodes the (L)*(D**-1)*(U) factorization of the linear-system +! matrix, as supplied by subroutine LDUB or, if N=NA, by LDUB +! <-> V input as right-hand-side vectors, output as solution vectors +! --> MX the number of rows assumed for A and length of +! X-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MY number of parallel X-vectors inverted +!============================================================================= +implicit none +integer(spi),intent(IN ) :: mx, mah1, mah2, my +real(sp), intent(IN ) :: a(mx,-mah1:mah2) +real(sp), intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer(spi):: jx, ix +!============================================================================= +do jx=1,mx + do ix=jx+1,min(mx,jx+mah1); v(ix,:) = v(ix,:) - a(ix,jx-ix)*v(jx,:); enddo + v(jx,:) = a(jx,0) * v(jx,:) +enddo +do jx=mx,2,-1 + do ix=max(1,jx-mah2),jx-1; v(ix,:) = v(ix,:) - a(ix,jx-ix)*v(jx,:); enddo +enddo +end subroutine UDLBX + +!============================================================================= +subroutine UDLBY(my,mah1,mah2,mx,a,v)! [UDLBY] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE UDLBY +! BACk-substitution step of parallel linear inversion involving +! Banded matrix and Y-Vectors. +! +! --> A encodes the (L)*(D**-1)*(U) factorization of the linear-system +! matrix, as supplied by subroutine LDUB or, if N=NA, by LDUB +! <-> V input as right-hand-side vectors, output as solution vectors +! --> MY the number of rows assumed for A and length of +! Y-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MX number of parallel Y-vectors inverted +!============================================================================= +implicit none +integer(spi),intent(IN ) :: my, mah1, mah2, mx +real(sp), intent(IN ) :: a(my,-mah1:mah2) +real(sp), intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer(spi):: iy, jy +!============================================================================= +do jy=1,my + do iy=jy+1,min(my,jy+mah1); v(:,iy) = v(:,iy)-a(iy,jy-iy)*v(:,jy); enddo + v(:,jy)=a(jy,0)*v(:,jy) +enddo +do jy=my,2,-1 + do iy=max(1,jy-mah2),jy-1; v(:,iy)=v(:,iy)-a(iy,jy-iy)*v(:,jy); enddo +enddo +end subroutine UDLBY + +!============================================================================= +subroutine UDLVB(m,mah1,mah2,v,a)! [UDLVB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE UDLVB +! BACk-substitution step of linear inversion involving +! row-Vector and Banded matrix. +! +! <-> V input as right-hand-side row-vector, output as solution vector +! --> A encodes the (L)*(D**-1)*(U) factorization of the linear-system +! matrix, as supplied by subroutine LDUB +! --> M the number of rows assumed for A and columns for V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +!============================================================================= +implicit none +integer(spi), intent(IN ) :: m, mah1, mah2 +real(sp), intent(IN ) :: a(m,-mah1:mah2) +real(sp), intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer(spi):: i, j +real(sp) :: vi +!============================================================================= +do i=1,m + vi=v(i) + do j=i+1,min(m,i+mah2); v(j)=v(j)-vi*a(i,j-i); enddo + v(i)=vi*a(i,0) +enddo +do i=m,2,-1 + vi=v(i) + do j=max(1,i-mah1),i-1; v(j)=v(j)-vi*a(i,j-i); enddo +enddo +end subroutine UDLVB + +!============================================================================= +subroutine UDLXB(mx,mah1,mah2,my,v,a)! [UDLXB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE UDLXB +! BACk-substitution step of parallel linear inversion involving +! Banded matrix and row-X-Vectors. +! +! <-> V input as right-hand-side vectors, output as solution vectors +! --> A encodes the (L)*(D**-1)*(U) factorization of the linear-system +! matrix, as supplied by subroutine LDUB +! --> MX the number of rows assumed for A and length of +! X-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MY number of parallel X-vectors inverted +!============================================================================= +implicit none +integer(spi),intent(IN ) :: mx, mah1, mah2, my +real(sp), intent(IN ) :: a(mx,-mah1:mah2) +real(sp), intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer(spi):: ix, jx +!============================================================================= +do ix=1,mx + do jx=ix+1,min(mx,ix+mah2); v(jx,:)=v(jx,:)-v(ix,:)*a(ix,jx-ix); enddo + v(ix,:)=v(ix,:)*a(ix,0) +enddo +do ix=mx,2,-1 + do jx=max(1,ix-mah1),ix-1; v(jx,:)=v(jx,:)-v(ix,:)*a(ix,jx-ix); enddo +enddo +end subroutine UDLXB + +!============================================================================= +subroutine UDLYB(my,mah1,mah2,mx,v,a)! [UDLYB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE UDLYB +! BACk-substitution step of parallel linear inversion involving +! Banded matrix and row-Y-Vectors. +! +! <-> V input as right-hand-side vectors, output as solution vectors +! --> A encodes the (L)*(D**-1)*(U) factorization of the linear-system +! matrix, as supplied by subroutine LDUB +! --> MY the number of rows assumed for A and length of +! Y-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MX number of parallel Y-vectors inverted +!============================================================================= +implicit none +integer(spi),intent(IN ) :: my, mah1, mah2, mx +real(sp), intent(IN ) :: a(my,-mah1:mah2) +real(sp), intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer(spi):: iy, jy +!============================================================================= +do iy=1,my + do jy=iy+1,min(my,iy+mah2); v(:,jy)=v(:,jy)-v(:,iy)*a(iy,jy-iy); enddo + v(:,iy)=v(:,iy)*a(iy,0) +enddo +do iy=my,2,-1 + do jy=max(1,iy-mah1),iy-1; v(:,jy)=v(:,jy)-v(:,iy)*a(iy,jy-iy); enddo +enddo +end subroutine UDLYB + +!============================================================================= +subroutine U1LBV(m,mah1,mah2,a,v)! [U1LBV] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE U1LBV +! BACk-substitution step ((U**-1)*(L**-1)) of linear inversion involving +! special Banded matrix and right-Vector. +! +! --> A encodes the [L]*[U] factorization of the linear-system +! matrix, as supplied by subroutine L1UBB +! <-> V input as right-hand-side vector, output as solution vector +! --> M the number of rows assumed for A and for V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +!============================================================================= +implicit none +integer(spi),intent(IN ) :: m, mah1, mah2 +real(sp), intent(IN ) :: a(m,-mah1:mah2) +real(sp), intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer(spi):: i, j +real(sp) :: vj +!============================================================================= +do j=1,m + vj=v(j) + do i=j+1,min(m,j+mah1); v(i)=v(i)-a(i,j-i)*vj; enddo +enddo +do j=m,2,-1 + vj=v(j) + do i=max(1,j-mah2),j-1; v(i)=v(i)-a(i,j-i)*vj; enddo +enddo +end subroutine U1LBV + +!============================================================================= +subroutine U1LBX(mx,mah1,mah2,my,a,v)! [U1LBX] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE U1LBX +! Special BaCk-substitution step of parallel linear inversion involving +! Banded matrix and X-right-Vectors. +! +! --> A encodes the [L]*[U] factorization of the linear-system +! matrix, as supplied by subroutine L1UBB +! <-> V input as right-hand-side vectors, output as solution vectors +! --> MX the number of rows assumed for A and length of +! X-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MY number of parallel X-vectors inverted +!============================================================================= +implicit none +integer(spi),intent(IN ) :: mx, mah1, mah2, my +real(sp), intent(IN ) :: a(mx,-mah1:mah2) +real(sp), intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer(spi):: ix, jx +!============================================================================= +do jx=1,mx + do ix=jx+1,min(mx,jx+mah1); v(ix,:)=v(ix,:)-a(ix,jx-ix)*v(jx,:); enddo +enddo +do jx=mx,2,-1 + do ix=max(1,jx-mah2),jx-1; v(ix,:)=v(ix,:)-a(ix,jx-ix)*v(jx,:); enddo +enddo +end subroutine U1LBX + +!============================================================================= +subroutine U1LBY(my,mah1,mah2,mx,a,v)! [U1LBY] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE U1LBY +! Special BaCk-substitution step of parallel linear inversion involving +! Banded matrix and Y-right-Vectors. +! +! --> A encodes the [L]*[U] factorization of the linear-system +! matrix, as supplied by subroutine L1UBB +! <-> V input as right-hand-side vectors, output as solution vectors +! --> MY the number of rows assumed for A and length of +! Y-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MX number of parallel Y-vectors inverted +!============================================================================= +implicit none +integer(spi),intent(IN ) :: my, mah1, mah2, mx +real(sp), intent(IN ) :: a(my,-mah1:mah2) +real(sp), intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer(spi):: iy, jy +!============================================================================= +do jy=1,my + do iy=jy+1,min(my,jy+mah1); v(:,iy)=v(:,iy)-a(iy,jy-iy)*v(:,jy); enddo +enddo +do jy=my,2,-1 + do iy=max(1,jy-mah2),jy-1; v(:,iy)=v(:,iy)-a(iy,jy-iy)*v(:,jy); enddo +enddo +end subroutine U1LBY + +!============================================================================= +subroutine U1LVB(m,mah1,mah2,v,a)! [U1LVB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE U1LVB +! Special BaCk-substitution step of linear inversion involving +! left-Vector and Banded matrix. +! +! <-> V input as right-hand-side row-vector, output as solution vector +! --> A encodes the special [L]*[U] factorization of the linear-system +! matrix, as supplied by subroutine L1UBB +! --> M the number of rows assumed for A and columns for V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +!============================================================================= +implicit none +integer(spi),intent(IN ) :: m, mah1, mah2 +real(sp), intent(IN ) :: a(m,-mah1:mah2) +real(sp), intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer(spi):: i, j +real(sp) :: vi +!============================================================================= +do i=1,m + vi=v(i) + do j=i+1,min(m,i+mah2); v(j)=v(j)-vi*a(i,j-i); enddo +enddo +do i=m,2,-1 + vi=v(i) + do j=max(1,i-mah1),i-1; v(j)=v(j)-vi*a(i,j-i); enddo +enddo +end subroutine U1LVB + +!============================================================================= +subroutine U1LXB(mx,mah1,mah2,my,v,a)! [U1LXB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE U1LXB +! Special BaCk-substitution step of parallel linear inversion involving +! Banded matrix and X-left-Vectors. +! +! <-> V input as right-hand-side vectors, output as solution vectors +! --> A encodes the special [L]*[U] factorization of the linear-system +! matrix, as supplied by subroutine L1UBB +! --> MX the number of rows assumed for A and length of +! X-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MY number of parallel X-vectors inverted +!============================================================================= +implicit none +integer(spi),intent(IN ) :: mx, mah1, mah2, my +real(sp), intent(IN ) :: a(mx,-mah1:mah2) +real(sp), intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer(spi):: ix, jx +!============================================================================= +do ix=1,mx + do jx=ix+1,min(mx,ix+mah2); v(jx,:)=v(jx,:)-v(ix,:)*a(ix,jx-ix); enddo +enddo +do ix=mx,2,-1 + do jx=max(1,ix-mah1),ix-1; v(jx,:)=v(jx,:)-v(ix,:)*a(ix,jx-ix); enddo +enddo +end subroutine U1LXB + +!============================================================================= +subroutine U1LYB(my,mah1,mah2,mx,v,a)! [U1LYB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE U1LYB +! Special BaCk-substitution step of parallel linear inversion involving +! special Banded matrix and Y-left-Vectors. +! +! <-> V input as right-hand-side vectors, output as solution vectors +! --> A encodes the [L]*[U] factorization of the linear-system +! matrix, as supplied by subroutine L1UBB +! --> MY the number of rows assumed for A and length of +! Y-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MX number of parallel Y-vectors inverted +!============================================================================= +implicit none +integer(spi),intent(IN ) :: my, mah1, mah2, mx +real(sp), intent(IN ) :: a(my,-mah1:mah2) +real(sp), intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer(spi):: iy, jy +!============================================================================= +do iy=1,my + do jy=iy+1,min(my,iy+mah2); v(:,jy)=v(:,jy)-v(:,iy)*a(iy,jy-iy); enddo +enddo +do iy=my,2,-1 + do jy=max(1,iy-mah1),iy-1; v(:,jy)=v(:,jy)-v(:,iy)*a(iy,jy-iy); enddo +enddo +end subroutine U1LYB + +!============================================================================= +subroutine LINBV(m,mah1,mah2,a,v)! [LINBV] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE LINBV +! Solve LINear system with square Banded-matrix and vector V +! +! <-> A system matrix on input, its [L]*[D**-1]*[U] factorization on exit +! <-> V vector of right-hand-sides on input, solution vector on exit +! --> M order of matrix A +! --> MAH1 left half-bandwidth of A +! --> MAH2 right half-bandwidth of A +!============================================================================= +implicit none +integer(spi),intent(IN ) :: m, mah1, mah2 +real(sp), intent(INOUT) :: a(m,-mah1:mah2), v(m) +!============================================================================= +call LDUB(m,mah1,mah2,a) +call UDLBV(m,mah1,mah2,a,v) +end subroutine LINBV + +!============================================================================= +subroutine WRTB(m1,m2,mah1,mah2,a)! [WRTB] +!============================================================================= +implicit none +integer(spi),intent(IN) :: m1, m2, mah1, mah2 +real(sp), intent(IN) :: a(m1,-mah1:mah2) +!----------------------------------------------------------------------------- +integer(spi):: i1, i2, i, j1, j2, j, nj1 +!============================================================================= +do i1=1,m1,20 + i2=min(i1+19,m1) + print '(7x,6(i2,10x))',(j,j=-mah1,mah2) + do i=i1,i2 + j1=max(-mah1,1-i) + j2=min(mah2,m2-i) + nj1=j1+mah1 + if(nj1==0)print '(1x,i3,6(1x,e12.5))', i,(a(i,j),j=j1,j2) + if(nj1==1)print '(1x,i3,12x,5(1x,e12.5))',i,(a(i,j),j=j1,j2) + if(nj1==2)print '(1x,i3,24x,4(1x,e12.5))',i,(a(i,j),j=j1,j2) + if(nj1==3)print '(1x,i3,36x,3(1x,e12.5))',i,(a(i,j),j=j1,j2) + if(nj1==4)print '(1x,i3,48x,2(1x,e12.5))',i,(a(i,j),j=j1,j2) + if(nj1==5)print '(1x,i3,60x,1(1x,e12.5))',i,(a(i,j),j=j1,j2) + enddo + read(*,*) +enddo +end subroutine WRTB + +end module pmat2 diff --git a/rtma_esg_conversion.fd/esg_lib.fd/pmat4.f90 b/rtma_esg_conversion.fd/esg_lib.fd/pmat4.f90 new file mode 100644 index 0000000..454d6b6 --- /dev/null +++ b/rtma_esg_conversion.fd/esg_lib.fd/pmat4.f90 @@ -0,0 +1,2053 @@ +!> @file +!! @author R. J. Purser @date Oct 2005 +!! +!! Euclidean geometry, geometric (stereographic) projections, +!! related transformations (Mobius). +!! Package for handy vector and matrix operations in Euclidean geometry. +!! This package is primarily intended for 3D operations and three of the +!! functions (Cross_product, Triple_product and Axial) do not possess simple +!! generalizations to a generic number N of dimensions. The others, while +!! admitting such N-dimensional generalizations, have not all been provided +!! with such generic forms here at the time of writing, though some of these +!! may be added at a future date. +!! +!! May 2017: Added routines to facilitate manipulation of 3D rotations, +!! their representations by axial vectors, and routines to compute the +!! exponentials of matrices (without resort to eigen methods). Also added +!! Quaternion and spinor representations of 3D rotations, and their +!! conversion routines. +!! +!! FUNCTION: +!!- absv: Absolute magnitude of vector as its euclidean length +!!- Normalized: Normalized version of given real vector +!!- Orthogonalized: Orthogonalized version of second vector rel. to first unit v. +!!- Cross_product: Vector cross-product of the given 2 vectors +!!- Outer_product: outer-product matrix of the given 2 vectors +!!- Triple_product: Scalar triple product of given 3 vectors +!!- Det: Determinant of given matrix +!!- Axial: Convert axial-vector <--> 2-form (antisymmetric matrix) +!!- Diag: Diagnl of given matrix, or diagonal matrix of given elements +!!- Trace: Trace of given matrix +!!- Identity: Identity 3*3 matrix, or identity n*n matrix for a given n +!!- Sarea: Spherical area subtended by three vectors, or by lat-lon +!! increments forming a triangle or quadrilateral +!!- Huarea: Spherical area subtended by right-angled spherical triangle +!! SUBROUTINE: +!!- Gram: Right-handed orthogonal basis and rank, nrank. The first +!! nrank basis vectors span the column range of matrix given, +!! OR ("plain" version) simple unpivoted Gram-Schmidt of a +!! square matrix. +!! +!! In addition, we include routines that relate to stereographic projections +!! and some associated mobius transformation utilities, since these complex +!! operations have a strong geometrical flavor. +!! +!! DIRECT DEPENDENCIES +!! Libraries[their Modules]: pmat[pmat] +!! Additional Modules : pkind, pietc +!! +module pmat4 +!============================================================================ +use pkind, only: spi,sp,dp,dpc +implicit none +private +public:: absv,normalized,orthogonalized, & + cross_product,outer_product,triple_product,det,axial, & + diag,trace,identity,sarea,huarea,dlltoxy, & + normalize,gram,rowops,corral, & + axtoq,qtoax, & + rottoax,axtorot,spintoq,qtospin,rottoq,qtorot,mulqq, & + expmat,zntay,znfun, & + ctoz,ztoc,setmobius, & + mobius,mobiusi + +interface absv; module procedure absv_s,absv_d; end interface +interface normalized;module procedure normalized_s,normalized_d;end interface +interface orthogonalized + module procedure orthogonalized_s,orthogonalized_d; end interface +interface cross_product + module procedure cross_product_s,cross_product_d, & + triple_cross_product_s,triple_cross_product_d; end interface +interface outer_product + module procedure outer_product_s,outer_product_d,outer_product_i + end interface +interface triple_product + module procedure triple_product_s,triple_product_d; end interface +interface det; module procedure det_s,det_d,det_i,det_id; end interface +interface axial + module procedure axial3_s,axial3_d,axial33_s,axial33_d; end interface +interface diag + module procedure diagn_s,diagn_d,diagn_i,diagnn_s,diagnn_d,diagnn_i + end interface +interface trace; module procedure trace_s,trace_d,trace_i; end interface +interface identity; module procedure identity_i,identity3_i; end interface +interface huarea; module procedure huarea_s,huarea_d; end interface +interface sarea + module procedure sarea_s,sarea_d,dtarea_s,dtarea_d,dqarea_s,dqarea_d + end interface +interface dlltoxy; module procedure dlltoxy_s,dlltoxy_d; end interface +interface hav; module procedure hav_s, hav_d; end interface +interface normalize;module procedure normalize_s,normalize_d; end interface +interface gram + module procedure gram_s,gram_d,graml_d,plaingram_s,plaingram_d,rowgram + end interface +interface rowops; module procedure rowops; end interface +interface corral; module procedure corral; end interface +interface rottoax; module procedure rottoax; end interface +interface axtorot; module procedure axtorot; end interface +interface spintoq; module procedure spintoq; end interface +interface qtospin; module procedure qtospin; end interface +interface rottoq; module procedure rottoq; end interface +interface qtorot; module procedure qtorot; end interface +interface axtoq; module procedure axtoq; end interface +interface qtoax; module procedure qtoax; end interface +interface setem; module procedure setem; end interface +interface mulqq; module procedure mulqq; end interface +interface expmat; module procedure expmat,expmatd,expmatdd; end interface +interface zntay; module procedure zntay; end interface +interface znfun; module procedure znfun; end interface +interface ctoz; module procedure ctoz; end interface +interface ztoc; module procedure ztoc,ztocd; end interface +interface setmobius;module procedure setmobius,zsetmobius; end interface +interface mobius; module procedure zmobius,cmobius; end interface +interface mobiusi; module procedure zmobiusi; end interface + +contains + +!============================================================================= +function absv_s(a)result(s)! [absv] +!============================================================================= +implicit none +real(sp),dimension(:),intent(in):: a +real(sp) :: s +s=sqrt(dot_product(a,a)) +end function absv_s +!============================================================================= +function absv_d(a)result(s)! [absv] +!============================================================================= +implicit none +real(dp),dimension(:),intent(in):: a +real(dp) :: s +s=sqrt(dot_product(a,a)) +end function absv_d + +!============================================================================= +function normalized_s(a)result(b)! [normalized] +!============================================================================= +use pietc_s, only: u0 +implicit none +real(sp),dimension(:),intent(IN):: a +real(sp),dimension(size(a)) :: b +real(sp) :: s +s=absv_s(a); if(s==u0)then; b=u0;else;b=a/s;endif +end function normalized_s +!============================================================================= +function normalized_d(a)result(b)! [normalized] +!============================================================================= +use pietc, only: u0 +implicit none +real(dp),dimension(:),intent(IN):: a +real(dp),dimension(size(a)) :: b +real(dp) :: s +s=absv_d(a); if(s==u0)then; b=u0;else;b=a/s;endif +end function normalized_d + +!============================================================================= +function orthogonalized_s(u,a)result(b)! [orthogonalized] +!============================================================================= +implicit none +real(sp),dimension(:),intent(in):: u,a +real(sp),dimension(size(u)) :: b +real(sp) :: s +! Note: this routine assumes u is already normalized +s=dot_product(u,a); b=a-u*s +end function orthogonalized_s +!============================================================================= +function orthogonalized_d(u,a)result(b)! [orthogonalized] +!============================================================================= +implicit none +real(dp),dimension(:),intent(in):: u,a +real(dp),dimension(size(u)) :: b +real(dp) :: s +! Note: this routine assumes u is already normalized +s=dot_product(u,a); b=a-u*s +end function orthogonalized_d + +!============================================================================= +function cross_product_s(a,b)result(c)! [cross_product] +!============================================================================= +implicit none +real(sp),dimension(3),intent(in):: a,b +real(sp),dimension(3) :: c +c(1)=a(2)*b(3)-a(3)*b(2); c(2)=a(3)*b(1)-a(1)*b(3); c(3)=a(1)*b(2)-a(2)*b(1) +end function cross_product_s +!============================================================================= +function cross_product_d(a,b)result(c)! [cross_product] +!============================================================================= +implicit none +real(dp),dimension(3),intent(in):: a,b +real(dp),dimension(3) :: c +c(1)=a(2)*b(3)-a(3)*b(2); c(2)=a(3)*b(1)-a(1)*b(3); c(3)=a(1)*b(2)-a(2)*b(1) +end function cross_product_d +!============================================================================= +function triple_cross_product_s(u,v,w)result(x)! [cross_product] +!============================================================================= +! Deliver the triple-cross-product, x, of the +! three 4-vectors, u, v, w, with the sign convention +! that ordered, {u,v,w,x} form a right-handed quartet +! in the generic case (determinant >= 0). +!============================================================================= +implicit none +real(sp),dimension(4),intent(in ):: u,v,w +real(sp),dimension(4) :: x +!----------------------------------------------------------------------------- +real(sp):: uv12,uv13,uv14,uv23,uv24,uv34 +!============================================================================= +uv12=u(1)*v(2)-u(2)*v(1); uv13=u(1)*v(3)-u(3)*v(1); uv14=u(1)*v(4)-u(4)*v(1) + uv23=u(2)*v(3)-u(3)*v(2); uv24=u(2)*v(4)-u(4)*v(2) + uv34=u(3)*v(4)-u(4)*v(3) +x(1)=-uv23*w(4)+uv24*w(3)-uv34*w(2) +x(2)= uv13*w(4)-uv14*w(3) +uv34*w(1) +x(3)=-uv12*w(4) +uv14*w(2)-uv24*w(1) +x(4)= uv12*w(3)-uv13*w(2)+uv23*w(1) +end function triple_cross_product_s +!============================================================================= +function triple_cross_product_d(u,v,w)result(x)! [cross_product] +!============================================================================= +implicit none +real(dp),dimension(4),intent(in ):: u,v,w +real(dp),dimension(4) :: x +!----------------------------------------------------------------------------- +real(dp):: uv12,uv13,uv14,uv23,uv24,uv34 +!============================================================================= +uv12=u(1)*v(2)-u(2)*v(1); uv13=u(1)*v(3)-u(3)*v(1); uv14=u(1)*v(4)-u(4)*v(1) + uv23=u(2)*v(3)-u(3)*v(2); uv24=u(2)*v(4)-u(4)*v(2) + uv34=u(3)*v(4)-u(4)*v(3) +x(1)=-uv23*w(4)+uv24*w(3)-uv34*w(2) +x(2)= uv13*w(4)-uv14*w(3) +uv34*w(1) +x(3)=-uv12*w(4) +uv14*w(2)-uv24*w(1) +x(4)= uv12*w(3)-uv13*w(2)+uv23*w(1) +end function triple_cross_product_d + +!============================================================================= +function outer_product_s(a,b)result(c)! [outer_product] +!============================================================================= +implicit none +real(sp),dimension(:), intent(in ):: a +real(sp),dimension(:), intent(in ):: b +real(sp),DIMENSION(size(a),size(b)):: c +integer(spi) :: nb,i +nb=size(b) +do i=1,nb; c(:,i)=a*b(i); enddo +end function outer_product_s +!============================================================================= +function outer_product_d(a,b)result(c)! [outer_product] +!============================================================================= +implicit none +real(dp),dimension(:), intent(in ):: a +real(dp),dimension(:), intent(in ):: b +real(dp),dimension(size(a),size(b)):: c +integer(spi) :: nb,i +nb=size(b) +do i=1,nb; c(:,i)=a*b(i); enddo +end function outer_product_d +!============================================================================= +function outer_product_i(a,b)result(c)! [outer_product] +!============================================================================= +implicit none +integer(spi),dimension(:), intent(in ):: a +integer(spi),dimension(:), intent(in ):: b +integer(spi),dimension(size(a),size(b)):: c +integer(spi) :: nb,i +nb=size(b) +do i=1,nb; c(:,i)=a*b(i); enddo +end function outer_product_i + +!============================================================================= +function triple_product_s(a,b,c)result(tripleproduct)! [triple_product] +!============================================================================= +implicit none +real(sp),dimension(3),intent(IN ):: a,b,c +real(sp) :: tripleproduct +tripleproduct=dot_product( cross_product(a,b),c ) +end function triple_product_s +!============================================================================= +function triple_product_d(a,b,c)result(tripleproduct)! [triple_product] +!============================================================================= +implicit none +real(dp),dimension(3),intent(IN ):: a,b,c +real(dp) :: tripleproduct +tripleproduct=dot_product( cross_product(a,b),c ) +end function triple_product_d + +!============================================================================= +function det_s(a)result(det)! [det] +!============================================================================= +use pietc_s, only: u0 +implicit none +real(sp),dimension(:,:),intent(IN ) :: a +real(sp) :: det +real(sp),dimension(size(a,1),size(a,1)):: b +integer(spi) :: n,nrank +n=size(a,1) +if(n==3)then + det=triple_product(a(:,1),a(:,2),a(:,3)) +else + call gram(a,b,nrank,det) + if(nranku0 +implicit none +real(sp),dimension(3),intent(IN ):: v1,v2,v3 +real(sp) :: area +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(sp) :: s123,a1,a2,b,d1,d2,d3 +real(sp),dimension(3) :: u0,u1,u2,u3,x,y +!============================================================================= +area=zero +u1=normalized(v1); u2=normalized(v2); u3=normalized(v3) +s123=triple_product(u1,u2,u3) +if(s123==zero)return + +d1=dot_product(u3-u2,u3-u2) +d2=dot_product(u1-u3,u1-u3) +d3=dot_product(u2-u1,u2-u1) + +! Triangle that is not degenerate. Cyclically permute, so side 3 is longest: +if(d3u0 +implicit none +real(dp),dimension(3),intent(IN ):: v1,v2,v3 +real(dp) :: area +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(dp) :: s123,a1,a2,b,d1,d2,d3 +real(dp),dimension(3) :: u0,u1,u2,u3,x,y +!============================================================================= +area=zero +u1=normalized(v1); u2=normalized(v2); u3=normalized(v3) +s123=triple_product(u1,u2,u3) +if(s123==zero)return + +d1=dot_product(u3-u2,u3-u2) +d2=dot_product(u1-u3,u1-u3) +d3=dot_product(u2-u1,u2-u1) + +! Triangle that is not degenerate. Cyclically permute, so side 3 is longest: +if(d3nrank)exit + ab(k:m,k:n)=matmul( transpose(a(:,k:m)),b(:,k:n) ) + ii =maxloc( abs( ab(k:m,k:n)) )+k-1 + val=maxval( abs( ab(k:m,k:n)) ) + if(val<=vcrit)then + nrank=k-1 + exit + endif + i=ii(1) + j=ii(2) + tv=b(:,j) + b(:,j)=-b(:,k) + b(:,k)=tv + tv=a(:,i) + a(:,i)=-a(:,k) + a(:,k)=tv + w(k:n)=matmul( transpose(b(:,k:n)),tv ) + b(:,k)=matmul(b(:,k:n),w(k:n) ) + s=dot_product(b(:,k),b(:,k)) + s=sqrt(s) + if(w(k)nrank)exit + ab(k:m,k:n)=matmul( transpose(a(:,k:m)),b(:,k:n) ) + ii =maxloc( abs( ab(k:m,k:n)) )+k-1 + val=maxval( abs( ab(k:m,k:n)) ) + if(val<=vcrit)then + nrank=k-1 + exit + endif + i=ii(1) + j=ii(2) + tv=b(:,j) + b(:,j)=-b(:,k) + b(:,k)=tv + tv=a(:,i) + a(:,i)=-a(:,k) + a(:,k)=tv + w(k:n)=matmul( transpose(b(:,k:n)),tv ) + b(:,k)=matmul(b(:,k:n),w(k:n) ) + s=dot_product(b(:,k),b(:,k)) + s=sqrt(s) + if(w(k)nrank)exit + ab(k:m,k:n)=matmul( transpose(a(:,k:m)),b(:,k:n) ) + ii =maxloc( abs( ab(k:m,k:n)) )+k-1 + val=maxval( abs( ab(k:m,k:n)) ) + if(val<=vcrit)then + nrank=k-1 + exit + endif + i=ii(1) + j=ii(2) + tv=b(:,j) + b(:,j)=-b(:,k) + b(:,k)=tv + tv=a(:,i) + a(:,i)=-a(:,k) + a(:,k)=tv + w(k:n)=matmul( transpose(b(:,k:n)),tv ) + b(:,k)=matmul(b(:,k:n),w(k:n) ) + s=dot_product(b(:,k),b(:,k)) + s=sqrt(s) + if(w(k)u0)then + ldet=ldet+log(s) + else + detsign=0 + endif + + b(:,k)=b(:,k)/s + do l=k,n + do j=l+1,n + s=dot_product(b(:,l),b(:,j)) + b(:,j)=normalized( b(:,j)-b(:,l)*s ) + enddo + enddo +enddo +end subroutine graml_d + +!============================================================================= +subroutine plaingram_s(b,nrank)! [gram] +!============================================================================= +! A "plain" (unpivoted) version of Gram-Schmidt, for square matrices only. +use pietc_s, only: u0 +implicit none +real(sp),dimension(:,:),intent(INOUT) :: b +integer(spi), intent( OUT) :: nrank +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(sp),parameter :: crit=1.e-5_sp +real(sp) :: val,vcrit +integer(spi) :: j,k,n +!============================================================================= +n=size(b,1); if(n/=size(b,2))stop 'In gram; matrix needs to be square' +val=maxval(abs(b)) +nrank=0 +if(val==0)then + b=u0 + return +endif +vcrit=val*crit +do k=1,n + val=sqrt(dot_product(b(:,k),b(:,k))) + if(val<=vcrit)then + b(:,k:n)=u0 + return + endif + b(:,k)=b(:,k)/val + nrank=k + do j=k+1,n + b(:,j)=b(:,j)-b(:,k)*dot_product(b(:,k),b(:,j)) + enddo +enddo +end subroutine plaingram_s + +!============================================================================= +subroutine plaingram_d(b,nrank)! [gram] +!============================================================================= +! A "plain" (unpivoted) version of Gram-Schmidt, for square matrices only. +use pietc, only: u0 +implicit none +real(dp),dimension(:,:),intent(INOUT):: b +integer(spi), intent( OUT):: nrank +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(dp),parameter:: crit=1.e-9_dp +real(dp) :: val,vcrit +integer(spi) :: j,k,n +!============================================================================= +n=size(b,1); if(n/=size(b,2))stop 'In gram; matrix needs to be square' +val=maxval(abs(b)) +nrank=0 +if(val==u0)then + b=u0 + return +endif +vcrit=val*crit +do k=1,n + val=sqrt(dot_product(b(:,k),b(:,k))) + if(val<=vcrit)then + b(:,k:n)=u0 + return + endif + b(:,k)=b(:,k)/val + nrank=k + do j=k+1,n + b(:,j)=b(:,j)-b(:,k)*dot_product(b(:,k),b(:,j)) + enddo +enddo +end subroutine plaingram_d + +!============================================================================= +subroutine rowgram(m,n,a,ipiv,tt,b,rank)! [gram] +!============================================================================= +! Without changing (tall) rectangular input matrix a, perform pivoted gram- +! Schmidt operations to orthogonalize the rows, until rows that remain become +! negligible. Record the pivoting sequence in ipiv, and the row-normalization +! in tt(j,j) and the row-orthogonalization in tt(i,j), for i>j. Note that +! tt(i,j)=0 for i=n please' +nepss=n*epss +rank=n +aa=a +tt=u0 +do ii=1,n + +! At this stage, all rows less than ii are already orthonormalized and are +! orthogonal to all rows at and beyond ii. Find the norms of these lower +! rows and pivot the largest of them into position ii: + maxp=u0 + maxi=ii + do i=ii,m + p(i)=dot_product(aa(i,:),aa(i,:)) + if(p(i)>maxp)then + maxp=p(i) + maxi=i + endif + enddo + if(maxpu0,one=>u1,two=>u2 +implicit none +real(dp),dimension(3,3),intent(IN ):: rot +real(dp),dimension(0:3),intent(OUT):: q +!------------------------------------------------------------------------------ +real(dp),dimension(3,3) :: t1,t2 +real(dp),dimension(3) :: u1,u2 +real(dp) :: gamma,gammah,s,ss +integer(spi) :: i,j +integer(spi),dimension(1):: ii +!============================================================================== +! construct the orthogonal matrix, t1, whose third row is the rotation axis +! of rot: +t1=rot; do i=1,3; t1(i,i)=t1(i,i)-1; u1(i)=dot_product(t1(i,:),t1(i,:)); enddo +ii=maxloc(u1); j=ii(1); ss=u1(j) +if(ss<1.e-16_dp)then + q=zero; q(0)=one; return +endif +t1(j,:)=t1(j,:)/sqrt(ss) +if(j/=1)then + u2 =t1(1,:) + t1(1,:)=t1(j,:) + t1(j,:)=u2 +endif +do i=2,3 + t1(i,:)=t1(i,:)-dot_product(t1(1,:),t1(i,:))*t1(1,:) + u1(i)=dot_product(t1(i,:),t1(i,:)) +enddo +if(u1(3)>u1(2))then + j=3 +else + j=2 +endif +ss=u1(j) +if(ss==zero)stop 'In rotov; invalid rot' +if(j/=2)t1(2,:)=t1(3,:) +t1(2,:)=t1(2,:)/sqrt(ss) + +! Form t1(3,:) as the cross product of t1(1,:) and t1(2,:) +t1(3,1)=t1(1,2)*t1(2,3)-t1(1,3)*t1(2,2) +t1(3,2)=t1(1,3)*t1(2,1)-t1(1,1)*t1(2,3) +t1(3,3)=t1(1,1)*t1(2,2)-t1(1,2)*t1(2,1) + +! Project rot into the frame whose axes are the rows of t1: +t2=matmul(t1,matmul(rot,transpose(t1))) + +! Obtain the rotation angle, gamma, implied by rot, and gammah=gamma/2: +gamma=atan2(t2(2,1),t2(1,1)); gammah=gamma/two + +! Hence deduce coefficients (in the form of a real 4-vector) of one of the two +! possible equivalent spinors: +s=sin(gammah) +q(0)=cos(gammah) +q(1:3)=t1(3,:)*s +end subroutine rottoq + +!============================================================================== +subroutine qtorot(q,rot)! [qtorot] +!============================================================================== +! Go from quaternion to rotation matrix representations +!============================================================================== +implicit none +real(dp),dimension(0:3),intent(IN ):: q +real(dp),dimension(3,3),intent(OUT):: rot +!============================================================================= +call setem(q(0),q(1),q(2),q(3),rot) +end subroutine qtorot + +!============================================================================= +subroutine axtoq(v,q)! [axtoq] +!============================================================================= +! Go from an axial 3-vector to its equivalent quaternion +!============================================================================= +implicit none +real(dp),dimension(3), intent(in ):: v +real(dp),dimension(0:3),intent(out):: q +!----------------------------------------------------------------------------- +real(dp),dimension(3,3):: rot +!============================================================================= +call axtorot(v,rot) +call rottoq(rot,q) +end subroutine axtoq + +!============================================================================= +subroutine qtoax(q,v)! [qtoax] +!============================================================================= +! Go from quaternion to axial 3-vector +!============================================================================= +implicit none +real(dp),dimension(0:3),intent(in ):: q +real(dp),dimension(3), intent(out):: v +!----------------------------------------------------------------------------- +real(dp),dimension(3,3):: rot +!============================================================================= +call qtorot(q,rot) +call rottoax(rot,v) +end subroutine qtoax + +!============================================================================= +subroutine setem(c,d,e,g,r)! [setem] +!============================================================================= +implicit none +real(dp), intent(IN ):: c,d,e,g +real(dp),dimension(3,3),intent(OUT):: r +!----------------------------------------------------------------------------- +real(dp):: cc,dd,ee,gg,de,dg,eg,dc,ec,gc +!============================================================================= +cc=c*c; dd=d*d; ee=e*e; gg=g*g +de=d*e; dg=d*g; eg=e*g +dc=d*c; ec=e*c; gc=g*c +r(1,1)=cc+dd-ee-gg; r(2,2)=cc-dd+ee-gg; r(3,3)=cc-dd-ee+gg +r(2,3)=2*(eg-dc); r(3,1)=2*(dg-ec); r(1,2)=2*(de-gc) +r(3,2)=2*(eg+dc); r(1,3)=2*(dg+ec); r(2,1)=2*(de+gc) +end subroutine setem + +!============================================================================= +function mulqq(a,b)result(c)! [mulqq] +!============================================================================= +! Multiply quaternions, a*b, assuming operation performed from right to left +!============================================================================= +implicit none +real(dp),dimension(0:3),intent(IN ):: a,b +real(dp),dimension(0:3) :: c +!------------------------------------------- +c(0)=a(0)*b(0) -a(1)*b(1) -a(2)*b(2) -a(3)*b(3) +c(1)=a(0)*b(1) +a(1)*b(0) +a(2)*b(3) -a(3)*b(2) +c(2)=a(0)*b(2) +a(2)*b(0) +a(3)*b(1) -a(1)*b(3) +c(3)=a(0)*b(3) +a(3)*b(0) +a(1)*b(2) -a(2)*b(1) +end function mulqq +!============================================================================= +subroutine expmat(n,a,b,detb)! [expmat] +!============================================================================= +! Evaluate the exponential, b, of a matrix, a, of degree n. +! Apply the iterated squaring method, m times, to the approximation to +! exp(a/(2**m)) obtained as a Taylor expansion of degree L +! See Fung, T. C., 2004, Int. J. Numer. Meth. Engng, 59, 1273--1286. +!============================================================================= +use pietc, only: u0,u1,u2,o2 +implicit none +integer(spi), intent(IN ):: n +real(dp),dimension(n,n),intent(IN ):: a +real(dp),dimension(n,n),intent(OUT):: b +real(dp), intent(OUT):: detb +!----------------------------------------------------------------------------- +integer(spi),parameter :: L=5 +real(dp),dimension(n,n):: c,p +real(dp) :: t +integer(spi) :: i,m +!============================================================================= +m=10+floor(log(u1+maxval(abs(a)))/log(u2)) +t=o2**m +c=a*t +p=c +b=p +do i=2,L + p=matmul(p,c)/i + b=b+p +enddo +do i=1,m + b=b*u2+matmul(b,b) +enddo +do i=1,n + b(i,i)=b(i,i)+u1 +enddo +detb=u0; do i=1,n; detb=detb+a(i,i); enddo; detb=exp(detb) +end subroutine expmat + +!============================================================================= +subroutine expmatd(n,a,b,bd,detb,detbd)! [expmat] +!============================================================================= +! Like expmat, but for the 1st derivatives also. +!============================================================================= +use pietc, only: u0,u1,u2,o2 +implicit none +integer(spi), intent(IN ):: n +real(dp),dimension(n,n), intent(IN ):: a +real(dp),dimension(n,n), intent(OUT):: b +real(dp),dimension(n,n,(n*(n+1))/2),intent(OUT):: bd +real(dp), intent(OUT):: detb +real(dp),dimension((n*(n+1))/2), intent(OUT):: detbd +!----------------------------------------------------------------------------- +integer(spi),parameter :: L=5 +real(dp),dimension(n,n) :: c,p +real(dp),dimension(n,n,(n*(n+1))/2):: pd,cd +real(dp) :: t +integer(spi) :: i,j,k,m,n1 +!============================================================================= +n1=(n*(n+1))*o2 +m=10+floor(log(u1+maxval(abs(a)))/log(u2)) +t=o2**m +c=a*t +p=c +pd=u0 +do k=1,n + pd(k,k,k)=t +enddo +k=n +do i=1,n-1 + do j=i+1,n + k=k+1 + pd(i,j,k)=t + pd(j,i,k)=t + enddo +enddo +if(k/=n1)stop 'In expmatd; n1 is inconsistent with n' +cd=pd +b=p +bd=pd + +do i=2,L + do k=1,n1 + pd(:,:,k)=(matmul(cd(:,:,k),p)+matmul(c,pd(:,:,k)))/i + enddo + p=matmul(c,p)/i + b=b+p + bd=bd+pd +enddo +do i=1,m + do k=1,n1 + bd(:,:,k)=2*bd(:,:,k)+matmul(bd(:,:,k),b)+matmul(b,bd(:,:,k)) + enddo + b=b*u2+matmul(b,b) +enddo +do i=1,n + b(i,i)=b(i,i)+u1 +enddo +detb=u0; do i=1,n; detb=detb+a(i,i); enddo; detb=exp(detb) +detbd=u0; do k=1,n; detbd(k)=detb; enddo +end subroutine expmatd + +!============================================================================= +subroutine expmatdd(n,a,b,bd,bdd,detb,detbd,detbdd)! [expmat] +!============================================================================= +! Like expmat, but for the 1st and 2nd derivatives also. +!============================================================================= +use pietc, only: u0,u1,u2,o2 +implicit none +integer(spi), intent(IN ):: n +real(dp),dimension(n,n), intent(IN ):: a +real(dp),dimension(n,n), intent(OUT):: b +real(dp),dimension(n,n,(n*(n+1))/2), intent(OUT):: bd +real(dp),dimension(n,n,(n*(n+1))/2,(n*(n+1))/2),intent(OUT):: bdd +real(dp), intent(OUT):: detb +real(dp),dimension((n*(n+1))/2), intent(OUT):: detbd +real(dp),dimension((n*(n+1))/2,(n*(n+1))/2), intent(OUT):: detbdd +!----------------------------------------------------------------------------- +integer(spi),parameter :: L=5 +real(dp),dimension(n,n) :: c,p +real(dp),dimension(n,n,(n*(n+1))/2) :: pd,cd +real(dp),dimension(n,n,(n*(n+1))/2,(n*(n+1))/2):: pdd,cdd +real(dp) :: t +integer(spi) :: i,j,k,ki,kj,m,n1 +!============================================================================= +n1=(n*(n+1))/2 +m=10+floor(log(u1+maxval(abs(a)))/log(u2)) +t=o2**m +c=a*t +p=c +pd=u0 +pdd=u0 +do k=1,n + pd(k,k,k)=t +enddo +k=n +do i=1,n-1 + do j=i+1,n + k=k+1 + pd(i,j,k)=t + pd(j,i,k)=t + enddo +enddo +if(k/=n1)stop 'In expmatd; n1 is inconsistent with n' +cd=pd +cdd=u0 +b=p +bd=pd +bdd=u0 + +do i=2,L + do ki=1,n1 + do kj=1,n1 + pdd(:,:,ki,kj)=(matmul(cd(:,:,ki),pd(:,:,kj)) & + + matmul(cd(:,:,kj),pd(:,:,ki)) & + + matmul(c,pdd(:,:,ki,kj)))/i + enddo + enddo + do k=1,n1 + pd(:,:,k)=(matmul(cd(:,:,k),p)+matmul(c,pd(:,:,k)))/i + enddo + p=matmul(c,p)/i + b=b+p + bd=bd+pd + bdd=bdd+pdd +enddo +do i=1,m + do ki=1,n1 + do kj=1,n1 + bdd(:,:,ki,kj)=u2*bdd(:,:,ki,kj) & + +matmul(bdd(:,:,ki,kj),b) & + +matmul(bd(:,:,ki),bd(:,:,kj)) & + +matmul(bd(:,:,kj),bd(:,:,ki)) & + +matmul(b,bdd(:,:,ki,kj)) + enddo + enddo + do k=1,n1 + bd(:,:,k)=2*bd(:,:,k)+matmul(bd(:,:,k),b)+matmul(b,bd(:,:,k)) + enddo + b=b*u2+matmul(b,b) +enddo +do i=1,n + b(i,i)=b(i,i)+u1 +enddo +detb=u0; do i=1,n; detb=detb+a(i,i); enddo; detb=exp(detb) +detbd=u0; do k=1,n; detbd(k)=detb; enddo +detbdd=u0; do ki=1,n; do kj=1,n; detbdd(ki,kj)=detb; enddo; enddo +end subroutine expmatdd + +!============================================================================= +subroutine zntay(n,z,zn)! [zntay] +!============================================================================= +use pietc, only: u2 +implicit none +integer(spi), intent(IN ):: n +real(dp), intent(IN ):: z +real(dp), intent(OUT):: zn +!----------------------------------------------------------------------------- +integer(spi),parameter:: ni=100 +real(dp),parameter :: eps0=1.e-16_dp +integer(spi) :: i,i2,n2 +real(dp) :: t,eps,z2 +!============================================================================= +z2=z*u2 +n2=n*2 +t=1 +do i=1,n + t=t/(i*2-1) +enddo +eps=t*eps0 +zn=t +t=t +do i=1,ni + i2=i*2 + t=t*z2/(i2*(i2+n2-1)) + zn=zn+t + if(abs(t)u0)then + zn=cosh(rz2) + znd=sinh(rz2)/rz2 + zndd=(zn-znd)/z2 + znddd=(znd-u3*zndd)/z2 + do i=1,n + i2p3=i*2+3 + zn=znd + znd=zndd + zndd=znddd + znddd=(znd-i2p3*zndd)/z2 + enddo + else + zn=cos(rz2) + znd=sin(rz2)/rz2 + zndd=-(zn-znd)/z2 + znddd=-(znd-u3*zndd)/z2 + do i=1,n + i2p3=i*2+3 + zn=znd + znd=zndd + zndd=znddd + znddd=-(znd-i2p3*zndd)/z2 + enddo + endif +endif +end subroutine znfun + +!============================================================================= +! Utility code for various Mobius transformations. If aa1,bb1,cc1,dd1 are +! the coefficients for one transformation, and aa2,bb2,cc2,dd2 are the +! coefficients for a second one, then the coefficients for the mapping +! of a test point, zz, by aa1 etc to zw, followed by a mapping of zw, by +! aa2 etc to zv, is equivalent to a single mapping zz-->zv by the transformatn +! with coefficients aa3,bb3,cc3,dd3, such that, as 2*2 complex matrices: +! +! [ aa3, bb3 ] [ aa2, bb2 ] [ aa1, bb1 ] +! [ ] = [ ] * [ ] +! [ cc3, dd3 ] [ cc2, dd2 ] [ cc1, dd1 ] . +! +! Note that the determinant of these matrices is always +1 +! +!============================================================================= +subroutine ctoz(v, z,infz)! [ctoz] +!============================================================================= +use pietc, only: u0,u1 +implicit none +real(dp),dimension(3),intent(IN ):: v +complex(dpc), intent(OUT):: z +logical, intent(OUT):: infz +!----------------------------------------------------------------------------- +real(dp) :: rr,zzpi +!============================================================================= +infz=.false. +z=cmplx(v(1),v(2),dpc) +if(v(3)>u0)then + zzpi=u1/(u1+v(3)) +else + rr=v(1)**2+v(2)**2 + infz=(rr==u0); if(infz)return ! <- The point is mapped to infinity (90S) + zzpi=(u1-v(3))/rr +endif +z=z*zzpi +end subroutine ctoz + +!============================================================================= +subroutine ztoc(z,infz, v)! [ztoc] +!============================================================================= +implicit none +complex(dpc), intent(IN ):: z +logical, intent(IN ):: infz +real(dp),dimension(3),intent(OUT):: v +!----------------------------------------------------------------------------- +real(dp),parameter:: zero=0_dp,one=1_dp,two=2_dp +real(dp) :: r,q,rs,rsc,rsbi +!============================================================================= +if(infz)then; v=(/zero,zero,-one/); return; endif +r=real(z); q=aimag(z); rs=r*r+q*q +rsc=one-rs +rsbi=one/(one+rs) +v(1)=two*rsbi*r +v(2)=two*rsbi*q +v(3)=rsc*rsbi +end subroutine ztoc + +!============================================================================= +subroutine ztocd(z,infz, v,vd)! [ztoc] +!============================================================================= +! The convention adopted for the complex derivative is that, for a complex +! infinitesimal map displacement, delta_z, the corresponding infinitesimal +! change of cartesian vector position is delta_v given by: +! delta_v = Real(vd*delta_z). +! Thus, by a kind of Cauchy-Riemann relation, Imag(vd)=v CROSS Real(vd). +! THE DERIVATIVE FOR THE IDEAL POINT AT INFINITY HAS NOT BEEN CODED YET!!! +!============================================================================= +implicit none +complex(dpc), intent(IN ):: z +logical, intent(IN ):: infz +real(dp),dimension(3), intent(OUT):: v +complex(dpc),dimension(3),intent(OUT):: vd +!----------------------------------------------------------------------------- +real(dp),parameter :: zero=0_dp,one=1_dp,two=2_dp,four=4_dp +real(dp) :: r,q,rs,rsc,rsbi,rsbis +real(dp),dimension(3):: u1,u2 +integer(spi) :: i +!============================================================================= +if(infz)then; v=(/zero,zero,-one/); return; endif +r=real(z); q=aimag(z); rs=r*r+q*q +rsc=one-rs +rsbi=one/(one+rs) +rsbis=rsbi**2 +v(1)=two*rsbi*r +v(2)=two*rsbi*q +v(3)=rsc*rsbi +u1(1)=two*(one+q*q-r*r)*rsbis +u1(2)=-four*r*q*rsbis +u1(3)=-four*r*rsbis +u2=cross_product(v,u1) +do i=1,3 + vd(i)=cmplx(u1(i),-u2(i),dpc) +enddo +end subroutine ztocd + +!============================================================================ +subroutine setmobius(xc0,xc1,xc2, aa,bb,cc,dd)! [setmobius] +!============================================================================ +! Find the Mobius transformation complex coefficients, aa,bb,cc,dd, +! with aa*dd-bb*cc=1, for a standard (north-)polar stereographic transformation +! that takes cartesian point, xc0 to the north pole, xc1 to (lat=0,lon=0), +! xc2 to the south pole (=complex infinity). +!============================================================================ +implicit none +real(dp),dimension(3),intent(IN ):: xc0,xc1,xc2 +complex(dpc), intent(OUT):: aa,bb,cc,dd +!---------------------------------------------------------------------------- +real(dp),parameter:: zero=0_dp,one=1_dp +logical :: infz0,infz1,infz2 +complex(dpc) :: z0,z1,z2,z02,z10,z21 +!============================================================================ +call ctoz(xc0,z0,infz0) +call ctoz(xc1,z1,infz1) +call ctoz(xc2,z2,infz2) +z21=z2-z1 +z02=z0-z2 +z10=z1-z0 + +if( (z0==z1.and.infz0.eqv.infz1).or.& + (z1==z2.and.infz1.eqv.infz2).or.& + (z2==z0.and.infz2.eqv.infz0)) & + stop 'In setmobius; anchor points must be distinct' + +if(infz2 .or. (.not.infz0 .and. abs(z0) @file +!! @author R. J. Purser @date 1996 +!! +!! Handy geographical transformations +!! +!! DEPENDENCIES +!! Modules: pkind, pietc, pmat4 +!! +module cstgeo ! Constants for orientation and stretching of map +!============================================================================= +use pkind, only: sp +implicit none +real(sp),dimension(3,3):: rotm +real(sp) :: sc,sci +!============================================================================= +end module cstgeo + +!============================================================================= +module dcstgeo ! Constants for orientation and stretching of map +!============================================================================= +use pkind, only: dp +implicit none +real(dp),dimension(3,3):: rotm +real(dp) :: sc,sci +!============================================================================= +end module dcstgeo + +! Utility routines for orienting the globe and basic geographical mappings +!============================================================================= +module pmat5 +!============================================================================= +use pkind, only: spi,sp,dp +implicit none +private +public :: ininmap,inivmap,ctogr,grtoc,ctog,gtoc,& + gtoframe,paraframe,frametwist,& + ctoc_schm,plrot,plroti,plctoc +interface ininmap; module procedure sininmap,dininmap; end interface +interface inivmap; module procedure sinivmap,dinivmap; end interface +interface ctogr; module procedure sctogr, dctogr; end interface +interface grtoc + module procedure sgrtoc,dgrtoc, sgrtocd,dgrtocd, sgrtocdd,dgrtocdd + end interface +interface ctog; module procedure sctog, dctog; end interface +interface gtoc + module procedure sgtoc,dgtoc, sgtocd,dgtocd, sgtocdd,dgtocdd; end interface +interface gtoframe + module procedure sgtoframev,gtoframev,sgtoframem,gtoframem; end interface +interface paraframe; module procedure sparaframe,paraframe; end interface +interface frametwist;module procedure sframetwist,frametwist; end interface +interface ctoc_schm + module procedure sctoc,dctoc, sctocd,dctocd, sctocdd,dctocdd; end interface +interface plrot; module procedure plrot, dplrot; end interface +interface plroti; module procedure plroti,dplroti; end interface +interface plctoc; module procedure plctoc; end interface +contains +!============================================================================= +subroutine sininmap(alon0,alat0,rot3)! [ininmap] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1995 +! Initialize the rotation matrix ROT3 needed to transform standard +! earth-centered cartesian components to the alternative cartesian frame +! oriented so as to put geographical point (ALAT0,ALON0) on the projection +! axis. +!============================================================================= +use pietc_s, only: u0,dtor +implicit none +real(sp), intent(IN ):: alon0,alat0 +real(sp),dimension(3,3),intent(OUT):: rot3 +!----------------------------------------------------------------------------- +real(sp) :: blon0,blat0,clon0,clat0,slon0,slat0 +!============================================================================= +blon0=dtor*alon0; clon0=cos(blon0); slon0=sin(blon0) +blat0=dtor*alat0; clat0=cos(blat0); slat0=sin(blat0) + +rot3(1,1)=slat0*clon0; rot3(1,2)=slat0*slon0; rot3(1,3)=-clat0 +rot3(2,1)=-slon0; rot3(2,2)=clon0; rot3(2,3)=u0 +rot3(3,1)=clat0*clon0; rot3(3,2)=clat0*slon0; rot3(3,3)=slat0 +end subroutine sininmap +!============================================================================= +subroutine dininmap(alon0,alat0,rot3)! [ininmap] +!============================================================================= +use pietc, only: u0,dtor +implicit none +real(dp), intent(IN ):: alon0,alat0 +real(dp),dimension(3,3),intent(OUT):: rot3 +!----------------------------------------------------------------------------- +real(dp) :: blon0,blat0,clon0,clat0,slon0,slat0 +!============================================================================= +blon0=dtor*alon0; clon0=cos(blon0); slon0=sin(blon0) +blat0=dtor*alat0; clat0=cos(blat0); slat0=sin(blat0) + +rot3(1,1)=slat0*clon0; rot3(1,2)=slat0*slon0; rot3(1,3)=-clat0 +rot3(2,1)=-slon0; rot3(2,2)=clon0; rot3(2,3)=u0 +rot3(3,1)=clat0*clon0; rot3(3,2)=clat0*slon0; rot3(3,3)=slat0 +end subroutine dininmap + +!============================================================================= +subroutine sinivmap(alon0,alat0,rot3)! [inivmap] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1995 +! Initialize the rotation matrix ROT3 needed to transform standard +! earth-centered cartesian components to the alternative cartesian frame +! oriented so as to put geographical point (ALAT0,ALON0) at the viewing +! nadir. +!============================================================================= +use pietc_s, only: u0,dtor +implicit none +real(sp), intent(IN ):: alon0,alat0 +real(sp),dimension(3,3),intent(OUT):: rot3 +!----------------------------------------------------------------------------- +real(sp) :: blon0,blat0,clon0,clat0,slon0,slat0 +!============================================================================= +blon0=dtor*alon0 +blat0=dtor*alat0 +clon0=cos(blon0) +slon0=sin(blon0) +clat0=cos(blat0) +slat0=sin(blat0) +rot3(1,1)=-slon0 +rot3(1,2)=clon0 +rot3(1,3)=u0 +rot3(2,1)=-slat0*clon0 +rot3(2,2)=-slat0*slon0 +rot3(2,3)=clat0 +rot3(3,1)=clat0*clon0 +rot3(3,2)=clat0*slon0 +rot3(3,3)=slat0 +end subroutine sinivmap +!============================================================================= +subroutine dinivmap(alon0,alat0,rot3)! [inivmap] +!============================================================================= +use pietc, only: u0,dtor +implicit none +real(dp), intent(IN ):: alon0,alat0 +real(dp),dimension(3,3),intent(OUT):: rot3 +!----------------------------------------------------------------------------- +real(dp) :: blon0,blat0,clon0,clat0,slon0,slat0 +!============================================================================= +blon0=dtor*alon0 +blat0=dtor*alat0 +clon0=cos(blon0) +slon0=sin(blon0) +clat0=cos(blat0) +slat0=sin(blat0) +rot3(1,1)=-slon0 +rot3(1,2)=clon0 +rot3(1,3)=u0 +rot3(2,1)=-slat0*clon0 +rot3(2,2)=-slat0*slon0 +rot3(2,3)=clat0 +rot3(3,1)=clat0*clon0 +rot3(3,2)=clat0*slon0 +rot3(3,3)=slat0 +end subroutine dinivmap + +!============================================================================= +subroutine sctogr(xe,rlat,rlon)! [ctogr] +!============================================================================= +! Transform "Cartesian" to "Geographical" coordinates, where the +! geographical coordinates refer to latitude and longitude (radians) +! and cartesian coordinates are standard earth-centered cartesian +! coordinates: xe(3) pointing north, xe(1) pointing to the 0-meridian. +! --> XE three cartesian components. +! <-- RLAT radians latitude +! <-- RLON radians longitude +!============================================================================= +use pietc_s, only: u0 +implicit none +real(sp),dimension(3),intent(IN ):: xe +real(sp), intent(OUT):: rlat,rlon +!----------------------------------------------------------------------------- +real(sp) :: r +!============================================================================= +r=sqrt(xe(1)**2+xe(2)**2) +rlat=atan2(xe(3),r) +if(r==u0)then + rlon=u0 +else + rlon=atan2(xe(2),xe(1)) +endif +end subroutine sctogr +!============================================================================= +subroutine dctogr(xe,rlat,rlon)! [ctogr] +!============================================================================= +use pietc, only: u0 +implicit none +real(dp),dimension(3),intent(IN ):: xe +real(dp), intent(OUT):: rlat,rlon +!----------------------------------------------------------------------------- +real(dp) :: r +!============================================================================= +r=sqrt(xe(1)**2+xe(2)**2) +rlat=atan2(xe(3),r) +if(r==u0)then + rlon=u0 +else + rlon=atan2(xe(2),xe(1)) +endif +end subroutine dctogr + +!============================================================================= +subroutine sgrtoc(rlat,rlon,xe)! [grtoc] +!============================================================================= +implicit none +real(sp), intent(IN ):: rlat,rlon +real(sp),dimension(3),intent(OUT):: xe +!----------------------------------------------------------------------------- +real(sp) :: sla,cla,slo,clo +!============================================================================= +sla=sin(rlat); cla=cos(rlat) +slo=sin(rlon); clo=cos(rlon) +xe(1)=cla*clo; xe(2)=cla*slo; xe(3)=sla +end subroutine sgrtoc +!============================================================================= +subroutine dgrtoc(rlat,rlon,xe)! [grtoc] +!============================================================================= +implicit none +real(dp), intent(IN ):: rlat,rlon +real(dp),dimension(3),intent(OUT):: xe +!----------------------------------------------------------------------------- +real(dp) :: sla,cla,slo,clo +!============================================================================= +sla=sin(rlat); cla=cos(rlat) +slo=sin(rlon); clo=cos(rlon) +xe(1)=cla*clo; xe(2)=cla*slo; xe(3)=sla +end subroutine dgrtoc +!============================================================================= +subroutine sgrtocd(rlat,rlon,xe,dxedlat,dxedlon)! [grtoc] +!============================================================================= +implicit none +real(sp), intent(IN ):: rlat,rlon +real(sp),dimension(3),intent(OUT):: xe,dxedlat,dxedlon +!----------------------------------------------------------------------------- +real(dp) :: rlat_d,rlon_d +real(dp),dimension(3):: xe_d,dxedlat_d,dxedlon_d +!============================================================================= +rlat_d=rlat; rlon_d=rlon +call dgrtocd(rlat_d,rlon_d,xe_d,dxedlat_d,dxedlon_d) +xe =xe_d +dxedlat=dxedlat_d +dxedlon=dxedlon_d +end subroutine sgrtocd +!============================================================================= +subroutine dgrtocd(rlat,rlon,xe,dxedlat,dxedlon)! [grtoc] +!============================================================================= +use pietc, only: u0 +implicit none +real(dp), intent(IN ):: rlat,rlon +real(dp),dimension(3),intent(OUT):: xe,dxedlat,dxedlon +!----------------------------------------------------------------------------- +real(dp) :: sla,cla,slo,clo +!============================================================================= +sla=sin(rlat); cla=cos(rlat) +slo=sin(rlon); clo=cos(rlon) +xe(1)=cla*clo; xe(2)=cla*slo; xe(3)=sla +dxedlat(1)=-sla*clo; dxedlat(2)=-sla*slo; dxedlat(3)=cla +dxedlon(1)=-cla*slo; dxedlon(2)= cla*clo; dxedlon(3)=u0 +end subroutine dgrtocd +!============================================================================= +subroutine sgrtocdd(rlat,rlon,xe,dxedlat,dxedlon, &! [grtoc] + ddxedlatdlat,ddxedlatdlon,ddxedlondlon) +!============================================================================= +implicit none +real(sp), intent(IN ):: rlat,rlon +real(sp),dimension(3),intent(OUT):: xe,dxedlat,dxedlon, & + ddxedlatdlat,ddxedlatdlon,ddxedlondlon +!----------------------------------------------------------------------------- +real(dp) :: rlat_d,rlon_d +real(dp),dimension(3):: xe_d,dxedlat_d,dxedlon_d, & + ddxedlatdlat_d,ddxedlatdlon_d,ddxedlondlon_d +!============================================================================= +rlat_d=rlat; rlon_d=rlon +call dgtocdd(rlat_d,rlon_d,xe_d,dxedlat_d,dxedlon_d, & + ddxedlatdlat_d,ddxedlatdlon_d,ddxedlondlon_d) +xe =xe_d +dxedlat =dxedlat_d +dxedlon =dxedlon_d +ddxedlatdlat=ddxedlatdlat_d +ddxedlatdlon=ddxedlatdlon_d +ddxedlondlon=ddxedlondlon_d +end subroutine sgrtocdd +!============================================================================= +subroutine dgrtocdd(rlat,rlon,xe,dxedlat,dxedlon, &! [grtoc] + ddxedlatdlat,ddxedlatdlon,ddxedlondlon) +!============================================================================= +use pietc, only: u0 +implicit none +real(dp), intent(IN ):: rlat,rlon +real(dp),dimension(3),intent(OUT):: xe,dxedlat,dxedlon, & + ddxedlatdlat,ddxedlatdlon,ddxedlondlon +!----------------------------------------------------------------------------- +real(dp) :: sla,cla,slo,clo +!============================================================================= +sla=sin(rlat); cla=cos(rlat) +slo=sin(rlon); clo=cos(rlon) +xe(1)=cla*clo; xe(2)=cla*slo; xe(3)=sla +dxedlat(1)=-sla*clo; dxedlat(2)=-sla*slo; dxedlat(3)=cla +dxedlon(1)=-cla*slo; dxedlon(2)= cla*clo; dxedlon(3)=u0 +ddxedlatdlat(1)=-cla*clo +ddxedlatdlat(2)=-cla*slo +ddxedlatdlat(3)=-sla +ddxedlatdlon(1)= sla*slo +ddxedlatdlon(2)=-sla*clo +ddxedlatdlon(3)= u0 +ddxedlondlon(1)=-cla*clo +ddxedlondlon(2)=-cla*slo +ddxedlondlon(3)= u0 +end subroutine dgrtocdd + +!============================================================================= +subroutine sctog(xe,dlat,dlon)! [ctog] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE CTOG +! Transform "Cartesian" to "Geographical" coordinates, where the +! geographical coordinates refer to latitude and longitude (degrees) +! and cartesian coordinates are standard earth-centered cartesian +! coordinates: xe(3) pointing north, xe(1) pointing to the 0-meridian. +! --> XE three cartesian components. +! <-- DLAT degrees latitude +! <-- DLON degrees longitude +!============================================================================= +use pietc_s, only: u0,rtod +implicit none +real(sp),dimension(3),intent(IN ):: xe +real(sp), intent(OUT):: dlat,dlon +!----------------------------------------------------------------------------- +real(sp) :: r +!============================================================================= +r=sqrt(xe(1)**2+xe(2)**2) +dlat=atan2(xe(3),r)*rtod +if(r==u0)then + dlon=u0 +else + dlon=atan2(xe(2),xe(1))*rtod +endif +end subroutine sctog + +!============================================================================= +subroutine dctog(xe,dlat,dlon)! [ctog] +!============================================================================= +use pietc, only: u0,rtod +implicit none +real(dp),dimension(3),intent(IN ):: xe +real(dp), intent(OUT):: dlat,dlon +!----------------------------------------------------------------------------- +real(dp) :: r +!============================================================================= +r=sqrt(xe(1)**2+xe(2)**2) +dlat=atan2(xe(3),r)*rtod +if(r==u0)then + dlon=u0 +else + dlon=atan2(xe(2),xe(1))*rtod +endif +end subroutine dctog + +!============================================================================= +subroutine sgtoc(dlat,dlon,xe)! [gtoc] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE GTOC +! Transform "Geographical" to "Cartesian" coordinates, where the +! geographical coordinates refer to latitude and longitude (degrees) +! and cartesian coordinates are standard earth-centered cartesian +! coordinates: xe(3) pointing north, xe(1) pointing to the 0-meridian. +! --> DLAT degrees latitude +! --> DLON degrees longitude +! <-- XE three cartesian components. +!============================================================================= +use pietc_s, only: dtor +implicit none +real(sp), intent(IN ):: dlat,dlon +real(sp),dimension(3),intent(OUT):: xe +!----------------------------------------------------------------------------- +real(sp) :: rlat,rlon,sla,cla,slo,clo +!============================================================================= +rlat=dtor*dlat; rlon=dtor*dlon +sla=sin(rlat); cla=cos(rlat) +slo=sin(rlon); clo=cos(rlon) +xe(1)=cla*clo; xe(2)=cla*slo; xe(3)=sla +end subroutine sgtoc +!============================================================================= +subroutine dgtoc(dlat,dlon,xe)! [gtoc] +!============================================================================= +use pietc, only: dtor +implicit none +real(dp), intent(IN ):: dlat,dlon +real(dp),dimension(3),intent(OUT):: xe +!----------------------------------------------------------------------------- +real(dp) :: rlat,rlon,sla,cla,slo,clo +!============================================================================= +rlat=dtor*dlat; rlon=dtor*dlon +sla=sin(rlat); cla=cos(rlat) +slo=sin(rlon); clo=cos(rlon) +xe(1)=cla*clo; xe(2)=cla*slo; xe(3)=sla +end subroutine dgtoc +!============================================================================= +subroutine sgtocd(dlat,dlon,xe,dxedlat,dxedlon)! [gtoc] +!============================================================================= +implicit none +real(sp), intent(IN ):: dlat,dlon +real(sp),dimension(3),intent(OUT):: xe,dxedlat,dxedlon +!----------------------------------------------------------------------------- +real(dp) :: dlat_d,dlon_d +real(dp),dimension(3):: xe_d,dxedlat_d,dxedlon_d +!============================================================================= +dlat_d=dlat; dlon_d=dlon +call dgtocd(dlat_d,dlon_d,xe_d,dxedlat_d,dxedlon_d) +xe =xe_d +dxedlat=dxedlat_d +dxedlon=dxedlon_d +end subroutine sgtocd +!============================================================================= +subroutine dgtocd(dlat,dlon,xe,dxedlat,dxedlon)! [gtoc] +!============================================================================= +use pietc, only: u0,dtor +implicit none +real(dp), intent(IN ):: dlat,dlon +real(dp),dimension(3),intent(OUT):: xe,dxedlat,dxedlon +!----------------------------------------------------------------------------- +real(dp) :: rlat,rlon,sla,cla,slo,clo +!============================================================================= +rlat=dtor*dlat; rlon=dtor*dlon +sla=sin(rlat); cla=cos(rlat) +slo=sin(rlon); clo=cos(rlon) +xe(1)=cla*clo; xe(2)=cla*slo; xe(3)=sla +dxedlat(1)=-sla*clo; dxedlat(2)=-sla*slo; dxedlat(3)=cla; dxedlat=dxedlat*dtor +dxedlon(1)=-cla*slo; dxedlon(2)= cla*clo; dxedlon(3)=u0 ; dxedlon=dxedlon*dtor +end subroutine dgtocd +!============================================================================= +subroutine sgtocdd(dlat,dlon,xe,dxedlat,dxedlon, & + ddxedlatdlat,ddxedlatdlon,ddxedlondlon)! [gtoc] +!============================================================================= +implicit none +real(sp), intent(IN ):: dlat,dlon +real(sp),dimension(3),intent(OUT):: xe,dxedlat,dxedlon, & + ddxedlatdlat,ddxedlatdlon,ddxedlondlon +!----------------------------------------------------------------------------- +real(dp) :: dlat_d,dlon_d +real(dp),dimension(3):: xe_d,dxedlat_d,dxedlon_d, & + ddxedlatdlat_d,ddxedlatdlon_d,ddxedlondlon_d +!============================================================================= +dlat_d=dlat; dlon_d=dlon +call dgtocdd(dlat_d,dlon_d,xe_d,dxedlat_d,dxedlon_d, & + ddxedlatdlat_d,ddxedlatdlon_d,ddxedlondlon_d) +xe =xe_d +dxedlat =dxedlat_d +dxedlon =dxedlon_d +ddxedlatdlat=ddxedlatdlat_d +ddxedlatdlon=ddxedlatdlon_d +ddxedlondlon=ddxedlondlon_d +end subroutine sgtocdd +!============================================================================= +subroutine dgtocdd(dlat,dlon,xe,dxedlat,dxedlon, & + ddxedlatdlat,ddxedlatdlon,ddxedlondlon)! [gtoc] +!============================================================================= +use pietc, only: u0,dtor +implicit none +real(dp), intent(IN ):: dlat,dlon +real(dp),dimension(3),intent(OUT):: xe,dxedlat,dxedlon, & + ddxedlatdlat,ddxedlatdlon,ddxedlondlon +!----------------------------------------------------------------------------- +real(dp) :: rlat,rlon,sla,cla,slo,clo +!============================================================================= +rlat=dtor*dlat; rlon=dtor*dlon +sla=sin(rlat); cla=cos(rlat) +slo=sin(rlon); clo=cos(rlon) +xe(1)=cla*clo; xe(2)=cla*slo; xe(3)=sla +dxedlat(1)=-sla*clo; dxedlat(2)=-sla*slo; dxedlat(3)=cla; dxedlat=dxedlat*dtor +dxedlon(1)=-cla*slo; dxedlon(2)= cla*clo; dxedlon(3)=u0 ; dxedlon=dxedlon*dtor +ddxedlatdlat(1)=-cla*clo +ddxedlatdlat(2)=-cla*slo +ddxedlatdlat(3)=-sla +ddxedlatdlon(1)= sla*slo +ddxedlatdlon(2)=-sla*clo +ddxedlatdlon(3)= u0 +ddxedlondlon(1)=-cla*clo +ddxedlondlon(2)=-cla*slo +ddxedlondlon(3)= u0 +ddxedlatdlat=ddxedlatdlat*dtor**2 +ddxedlatdlon=ddxedlatdlon*dtor**2 +ddxedlondlon=ddxedlondlon*dtor**2 +end subroutine dgtocdd + +!============================================================================== +subroutine sgtoframem(splat,splon,sorth)! [gtoframe] +!============================================================================== +implicit none +real(sp), intent(in ):: splat,splon +real(sp),dimension(3,3),intent(out):: sorth +!------------------------------------------------------------------------------ +real(dp):: plat,plon +real(dp),dimension(3,3):: orth +!============================================================================== +plat=splat; plon=splon; call gtoframem(plat,plon,orth); sorth=orth +end subroutine sgtoframem +!============================================================================== +subroutine gtoframem(plat,plon,orth)! [gtoframe] +!============================================================================== +! From the degree lat and lo (plat and plon) return the standard orthogonal +! 3D frame at this location as an orthonormal matrix, orth. +!============================================================================== +implicit none +real(dp), intent(in ):: plat,plon +real(dp),dimension(3,3),intent(out):: orth +!------------------------------------------------------------------------------ +real(dp),dimension(3):: xp,yp,zp +!============================================================================== +call gtoframev(plat,plon, xp,yp,zp) +orth(:,1)=xp; orth(:,2)=yp; orth(:,3)=zp +end subroutine gtoframem +!============================================================================== +subroutine sgtoframev(splat,splon,sxp,syp,szp)! [gtoframe] +!============================================================================== +implicit none +real(sp), intent(in ):: splat,splon +real(sp),dimension(3),intent(out):: sxp,syp,szp +!------------------------------------------------------------------------------ +real(dp) :: plat,plon +real(dp),dimension(3):: xp,yp,zp +!============================================================================== +plat=splat; plon=splon +call gtoframev(plat,plon, xp,yp,zp) +sxp=xp; syp=yp; szp=zp +end subroutine sgtoframev +!============================================================================== +subroutine gtoframev(plat,plon, xp,yp,zp)! [gtoframe] +!============================================================================== +! Given a geographical point by its degrees lat and lon, plat and plon, +! return its standard orthogonal cartesian frame, {xp,yp,zp} in earth-centered +! coordinates. +!============================================================================= +use pietc, only: u0,u1 +implicit none +real(dp), intent(in ):: plat,plon +real(dp),dimension(3),intent(out):: xp,yp,zp +!------------------------------------------------------------------------------ +real(dp),dimension(3):: dzpdlat,dzpdlon +!============================================================================== +if(plat==90)then ! is this the north pole? + xp=(/ u0,u1, u0/) ! Assume the limiting case lat-->90 along the 0-meridian + yp=(/-u1,u0, u0/) ! + zp=(/ u0,u0, u1/) +elseif(plat==-90)then + xp=(/ u0,u1, u0/) ! Assume the limiting case lat-->90 along the 0-meridian + yp=(/ u1,u0, u0/) ! + zp=(/ u0,u0,-u1/) +else + call gtoc(plat,plon,zp,dzpdlat,dzpdlon) + xp=dzpdlon/sqrt(dot_product(dzpdlon,dzpdlon)) + yp=dzpdlat/sqrt(dot_product(dzpdlat,dzpdlat)) +endif +end subroutine gtoframev + +!============================================================================== +subroutine sparaframe(sxp,syp,szp, sxv,syv,szv)! [paraframe] +!============================================================================== +implicit none +real(sp),dimension(3),intent(in ):: sxp,syp,szp, szv +real(sp),dimension(3),intent(out):: sxv,syv +!----------------------------------------------------------------------------- +real(dp),dimension(3):: xp,yp,zp, xv,yv,zv +!============================================================================= +xp=sxp; yp=syp; zp=szp +call paraframe(xp,yp,zp, xv,yv,zv) +sxv=xv; syv=yv +end subroutine sparaframe +!============================================================================== +subroutine paraframe(xp,yp,zp, xv,yv,zv)! [paraframe] +!============================================================================== +! Take a principal reference orthonormal frame, {xp,yp,zp} and a dependent +! point defined by unit vector, zv, and complete the V-frame cartesian +! components, {xv,yv}, that are the result of parallel-transport of {xp,yp} +! along the geodesic between P and V +!============================================================================== +use pmat4, only: cross_product,normalized +implicit none +real(dp),dimension(3),intent(in ):: xp,yp,zp, zv +real(dp),dimension(3),intent(out):: xv,yv +!------------------------------------------------------------------------------ +real(dp) :: xpofv,ypofv,theta,ctheta,stheta +real(dp),dimension(3):: xq,yq +!============================================================================== +xpofv=dot_product(xp,zv) +ypofv=dot_product(yp,zv) +theta=atan2(ypofv,xpofv); ctheta=cos(theta); stheta=sin(theta) +xq=zv-zp; xq=xq-zv*dot_product(xq,zv); xq=normalized(xq) +yq=cross_product(zv,xq) +xv=xq*ctheta-yq*stheta +yv=xq*stheta+yq*ctheta +end subroutine paraframe + +!============================================================================== +subroutine sframetwist(sxp,syp,szp, sxv,syv,szv, stwist)! [frametwist] +!============================================================================== +implicit none +real(sp),dimension(3),intent(in ):: sxp,syp,szp, sxv,syv,szv +real(sp), intent(out):: stwist +!------------------------------------------------------------------------------ +real(dp),dimension(3):: xp,yp,zp, xv,yv,zv +real(dp) :: twist +!============================================================================== +xp=sxp;yp=syp; zp=szp; xv=sxv; yv=syv; zv=szv +call frametwist(xp,yp,zp, xv,yv,zv, twist) +stwist=twist +end subroutine sframetwist +!============================================================================== +subroutine frametwist(xp,yp,zp, xv,yv,zv, twist)! [frametwist] +!============================================================================== +! Given a principal cartesian orthonormal frame, {xp,yp,zp} (i.e., at P with +! Earth-centered cartesians, zp), and another similar frame {xv,yv,zv} at V +! with Earth-centered cartesians zv, find the relative rotation angle, "twist" +! by which the frame at V is rotated in the counterclockwise sense relative +! to the parallel-transportation of P's frame to V. +! Note that, by symmetry, transposing P and V leads to the opposite twist. +!============================================================================== +implicit none +real(dp),dimension(3),intent(in ):: xp,yp,zp, xv,yv,zv +real(dp), intent(out):: twist +!------------------------------------------------------------------------------ +real(dp),dimension(3):: xxv,yyv +real(dp) :: c,s +!============================================================================== +call paraframe(xp,yp,zp, xxv,yyv,zv) +c=dot_product(xv,xxv); s=dot_product(xv,yyv) +twist=atan2(s,c) +end subroutine frametwist + +!============================================================================= +subroutine sctoc(s,xc1,xc2)! [ctoc_schm] +!============================================================================= +! Evaluate schmidt transformation, xc1 --> xc2, with scaling parameter s +!============================================================================= +use pietc_s, only: u1,u2 +implicit none +real(sp), intent(IN ):: s +real(sp),dimension(3),intent(INOUT):: xc1,xc2 +!----------------------------------------------------------------------------- +real(sp) :: x,y,z,a,b,d,e,ab2,aa,bb,di,aapbb,aambb +!============================================================================= +x=xc1(1); y=xc1(2); z=xc1(3) +a=s+u1 +b=s-u1 +ab2=a*b*u2 +aa=a*a +bb=b*b +aapbb=aa+bb +aambb=aa-bb +d=aapbb-ab2*z +e=aapbb*z-ab2 +di=u1/d +xc2(1)=(aambb*x)*di +xc2(2)=(aambb*y)*di +xc2(3)=e*di +end subroutine sctoc + +!============================================================================= +subroutine sctocd(s,xc1,xc2,dxc2)! [ctoc_schm] +!============================================================================= +! Evaluate schmidt transformation, xc1 --> xc2, with scaling parameter s, +! and its jacobian, dxc2. +!============================================================================= +use pietc_s, only: u0,u1,u2 +implicit none +real(sp),intent(IN) :: s +real(sp),dimension(3), intent(INOUT):: xc1,xc2 +real(sp),dimension(3,3),intent( OUT):: dxc2 +!----------------------------------------------------------------------------- +real(sp) :: x,y,z,a,b,d,e, & + ab2,aa,bb,di,ddi,aapbb,aambb +!============================================================================= +x=xc1(1); y=xc1(2); z=xc1(3) +a=s+u1 +b=s-u1 +ab2=a*b*u2 +aa=a*a +bb=b*b +aapbb=aa+bb +aambb=aa-bb +d=aapbb-ab2*z +e=aapbb*z-ab2 +di=u1/d +xc2(1)=(aambb*x)*di +xc2(2)=(aambb*y)*di +xc2(3)=e*di +ddi=di*di + +dxc2=u0 +dxc2(1,1)=aambb*di +dxc2(1,3)=ab2*aambb*x*ddi +dxc2(2,2)=aambb*di +dxc2(2,3)=ab2*aambb*y*ddi +dxc2(3,3)=aapbb*di +ab2*e*ddi +end subroutine sctocd + +!============================================================================= +subroutine sctocdd(s,xc1,xc2,dxc2,ddxc2)! [ctoc_schm] +!============================================================================= +! Evaluate schmidt transformation, xc1 --> xc2, with scaling parameter s, +! its jacobian, dxc2, and its 2nd derivative, ddxc2. +!============================================================================= +use pietc_s, only: u0,u1,u2 +implicit none +real(sp), intent(IN ):: s +real(sp),dimension(3), intent(INOUT):: xc1,xc2 +real(sp),dimension(3,3), intent( OUT):: dxc2 +real(sp),dimension(3,3,3),intent( OUT):: ddxc2 +!----------------------------------------------------------------------------- +real(sp) :: x,y,z,a,b,d,e, & + ab2,aa,bb,di,ddi,dddi, & + aapbb,aambb +!============================================================================= +x=xc1(1); y=xc1(2); z=xc1(3) +a=s+u1 +b=s-u1 +ab2=a*b*u2 +aa=a*a +bb=b*b +aapbb=aa+bb +aambb=aa-bb +d=aapbb-ab2*z +e=aapbb*z-ab2 +di=u1/d +xc2(1)=(aambb*x)*di +xc2(2)=(aambb*y)*di +xc2(3)=e*di +ddi=di*di +dddi=ddi*di + +dxc2=u0 +dxc2(1,1)=aambb*di +dxc2(1,3)=ab2*aambb*x*ddi +dxc2(2,2)=aambb*di +dxc2(2,3)=ab2*aambb*y*ddi +dxc2(3,3)=aapbb*di +ab2*e*ddi + +ddxc2=u0 +ddxc2(1,1,3)=ab2*aambb*ddi +ddxc2(1,3,1)=ddxc2(1,1,3) +ddxc2(1,3,3)=u2*ab2**2*aambb*x*dddi +ddxc2(2,2,3)=ab2*aambb*ddi +ddxc2(2,3,2)=ddxc2(2,2,3) +ddxc2(2,3,3)=u2*ab2**2*aambb*y*dddi +ddxc2(3,3,3)=u2*ab2*(aapbb*ddi+ab2*e*dddi) +end subroutine sctocdd + +!============================================================================= +subroutine dctoc(s,xc1,xc2)! [ctoc_schm] +!============================================================================= +! Evaluate schmidt transformation, xc1 --> xc2, with scaling parameter s +!============================================================================= +use pietc, only: u1,u2 +implicit none +real(dp), intent(IN ):: s +real(dp),dimension(3),intent(INOUT):: xc1,xc2 +!----------------------------------------------------------------------------- +real(dp) :: x,y,z,a,b,d,e, & + ab2,aa,bb,di,aapbb,aambb +!============================================================================= +x=xc1(1); y=xc1(2); z=xc1(3) +a=s+u1 +b=s-u1 +ab2=a*b*u2 +aa=a*a +bb=b*b +aapbb=aa+bb +aambb=aa-bb +d=aapbb-ab2*z +e=aapbb*z-ab2 +di=u1/d +xc2(1)=(aambb*x)*di +xc2(2)=(aambb*y)*di +xc2(3)=e*di +end subroutine dctoc + +!============================================================================= +subroutine dctocd(s,xc1,xc2,dxc2)! [ctoc_schm] +!============================================================================= +! Evaluate schmidt transformation, xc1 --> xc2, with scaling parameter s, +! and its jacobian, dxc2. +!============================================================================= +use pietc, only: u0,u1,u2 +implicit none +real(dp), intent(IN ):: s +real(dp),dimension(3), intent(INOUT):: xc1,xc2 +real(dp),dimension(3,3),intent( OUT):: dxc2 +!----------------------------------------------------------------------------- +real(dp) :: x,y,z,a,b,d,e, & + ab2,aa,bb,di,ddi,aapbb,aambb +!============================================================================= +x=xc1(1); y=xc1(2); z=xc1(3) +a=s+u1 +b=s-u1 +ab2=a*b*u2 +aa=a*a +bb=b*b +aapbb=aa+bb +aambb=aa-bb +d=aapbb-ab2*z +e=aapbb*z-ab2 +di=u1/d +xc2(1)=(aambb*x)*di +xc2(2)=(aambb*y)*di +xc2(3)=e*di +ddi=di*di + +dxc2=u0 +dxc2(1,1)=aambb*di +dxc2(1,3)=ab2*aambb*x*ddi +dxc2(2,2)=aambb*di +dxc2(2,3)=ab2*aambb*y*ddi +dxc2(3,3)=aapbb*di +ab2*e*ddi +end subroutine dctocd + +!============================================================================= +subroutine dctocdd(s,xc1,xc2,dxc2,ddxc2)! [ctoc_schm] +!============================================================================= +! Evaluate schmidt transformation, xc1 --> xc2, with scaling parameter s, +! its jacobian, dxc2, and its 2nd derivative, ddxc2. +!============================================================================= +use pietc, only: u0,u1,u2 +implicit none +real(dp),intent(IN) :: s +real(dp),dimension(3), intent(INOUT):: xc1,xc2 +real(dp),dimension(3,3), intent(OUT ):: dxc2 +real(dp),dimension(3,3,3),intent(OUT ):: ddxc2 +!----------------------------------------------------------------------------- +real(dp) :: x,y,z,a,b,d,e, & + ab2,aa,bb,di,ddi,dddi, & + aapbb,aambb +!============================================================================= +x=xc1(1); y=xc1(2); z=xc1(3) +a=s+u1 +b=s-u1 +ab2=a*b*u2 +aa=a*a +bb=b*b +aapbb=aa+bb +aambb=aa-bb +d=aapbb-ab2*z +e=aapbb*z-ab2 +di=u1/d +xc2(1)=(aambb*x)*di +xc2(2)=(aambb*y)*di +xc2(3)=e*di +ddi=di*di +dddi=ddi*di + +dxc2=u0 +dxc2(1,1)=aambb*di +dxc2(1,3)=ab2*aambb*x*ddi +dxc2(2,2)=aambb*di +dxc2(2,3)=ab2*aambb*y*ddi +dxc2(3,3)=aapbb*di +ab2*e*ddi + +ddxc2=u0 +ddxc2(1,1,3)=ab2*aambb*ddi +ddxc2(1,3,1)=ddxc2(1,1,3) +ddxc2(1,3,3)=u2*ab2**2*aambb*x*dddi +ddxc2(2,2,3)=ab2*aambb*ddi +ddxc2(2,3,2)=ddxc2(2,2,3) +ddxc2(2,3,3)=u2*ab2**2*aambb*y*dddi +ddxc2(3,3,3)=u2*ab2*(aapbb*ddi+ab2*e*dddi) +end subroutine dctocdd + +!============================================================================= +subroutine plrot(rot3,n,x,y,z)! [plrot] +!============================================================================= +! Apply a constant rotation to a three dimensional polyline +!============================================================================= +implicit none +integer, intent(IN ):: n +real(sp),dimension(3,3),intent(IN ):: rot3 +real(sp),dimension(n), intent(INOUT):: x,y,z +!----------------------------------------------------------------------------- +real(sp),dimension(3) :: t +integer :: k +!============================================================================= +do k=1,n + t(1)=x(k); t(2)=y(k); t(3)=z(k) + t=matmul(rot3,t) + x(k)=t(1); y(k)=t(2); z(k)=t(3) +enddo +end subroutine plrot + +!============================================================================= +subroutine plroti(rot3,n,x,y,z)! [plroti] +!============================================================================= +! Invert the rotation of a three-dimensional polyline +!============================================================================= +implicit none +integer, intent(IN ):: n +real(sp),dimension(3,3),intent(IN ):: rot3 +real(sp),dimension(n), intent(INOUT):: x,y,z +!----------------------------------------------------------------------------- +real(sp),dimension(3) :: t +integer :: k +!============================================================================= +do k=1,n + t(1)=x(k); t(2)=y(k); t(3)=z(k) + t=matmul(t,rot3) + x(k)=t(1); y(k)=t(2); z(k)=t(3) +enddo +end subroutine plroti + +!============================================================================= +subroutine dplrot(rot3,n,x,y,z)! [plrot] +!============================================================================= +! Apply a constant rotation to a three dimensional polyline +!============================================================================= +implicit none +integer, intent(IN ):: n +real(dP),dimension(3,3),intent(IN ):: rot3 +real(dP),dimension(n), intent(INOUT):: x,y,z +!----------------------------------------------------------------------------- +real(dP),dimension(3) :: t +integer :: k +!============================================================================= +do k=1,n + t(1)=x(k); t(2)=y(k); t(3)=z(k) + t=matmul(rot3,t) + x(k)=t(1); y(k)=t(2); z(k)=t(3) +enddo +end subroutine dplrot + +!============================================================================= +subroutine dplroti(rot3,n,x,y,z)! [plroti] +!============================================================================= +! Invert the rotation of a three-dimensional polyline +!============================================================================= +implicit none +integer, intent(IN ):: n +real(dP),dimension(3,3),intent(IN ):: rot3 +real(dP),dimension(n), intent(INOUT):: x,y,z +!----------------------------------------------------------------------------- +real(dP),dimension(3) :: t +integer :: k +!============================================================================= +do k=1,n + t(1)=x(k); t(2)=y(k); t(3)=z(k) + t=matmul(t,rot3) + x(k)=t(1); y(k)=t(2); z(k)=t(3) +enddo +end subroutine dplroti + +!============================================================================= +subroutine plctoc(s,n,x,y,z)! [plctoc] +!============================================================================= +! Perform schmidt transformation with scaling parameter s to a polyline +!============================================================================= +use pietc_s, only: u1 +implicit none +integer, intent(IN ):: n +real(sp), intent(IN ):: s +real(sp),dimension(n),intent(INOUT):: x,y,z +!----------------------------------------------------------------------------- +real(sp) :: a,b,d,e,ab2,aa,bb,di,aapbb,aambb +integer :: i +!============================================================================= +a=s+u1 +b=s-u1 +ab2=a*b*2 +aa=a*a +bb=b*b +aapbb=aa+bb +aambb=aa-bb +do i=1,n + d=aapbb-ab2*z(i) + e=aapbb*z(i)-ab2 + di=1/d + x(i)=(aambb*x(i))*di + y(i)=(aambb*y(i))*di + z(i)=e*di +enddo +end subroutine plctoc + +end module pmat5 + + + diff --git a/rtma_esg_conversion.fd/esg_lib.fd/psym2.f90 b/rtma_esg_conversion.fd/esg_lib.fd/psym2.f90 new file mode 100644 index 0000000..3fd573c --- /dev/null +++ b/rtma_esg_conversion.fd/esg_lib.fd/psym2.f90 @@ -0,0 +1,457 @@ +!> @file +!! @author R. J. Purser @date September 2018 +!! +!! A suite of routines to perform the eigen-decomposition of symmetric 2*2 +!! matrices and to deliver basic analytic functions, and the derivatives +!! of these functions, of such matrices. +!! In addition, we include a simple cholesky routine +!! +!! DIRECT DEPENDENCIES +!! Library: pfun +!! Module: pkind, pietc, pfun +!! +module psym2 +!============================================================================= +use pkind, only: spi,dp +use pietc, only: u0,u1,o2 +implicit none +private +public:: eigensym2,invsym2,sqrtsym2,expsym2,logsym2,id2222,chol2 + +real(dp),dimension(2,2,2,2):: id +data id/u1,u0,u0,u0, u0,o2,o2,u0, u0,o2,o2,u0, u0,u0,u0,u1/! Effective identity + +interface eigensym2; module procedure eigensym2,eigensym2d; end interface +interface invsym2; module procedure invsym2,invsym2d; end interface +interface sqrtsym2; module procedure sqrtsym2,sqrtsym2d; end interface +interface sqrtsym2d_e; module procedure sqrtsym2d_e; end interface +interface sqrtsym2d_t; module procedure sqrtsym2d_t; end interface +interface expsym2; module procedure expsym2,expsym2d; end interface +interface expsym2d_e; module procedure expsym2d_e; end interface +interface expsym2d_t; module procedure expsym2d_t; end interface +interface logsym2; module procedure logsym2,logsym2d; end interface +interface id2222; module procedure id2222; end interface +interface chol2; module procedure chol2; end interface + +contains + +!============================================================================= +subroutine eigensym2(em,vv,oo)! [eigensym2] +!============================================================================= +! Get the orthogonal eigenvectors, vv, and diagonal matrix of eigenvalues, oo, +! of the symmetric 2*2 matrix, em. +!============================================================================= +implicit none +real(dp),dimension(2,2),intent(in ):: em +real(dp),dimension(2,2),intent(out):: vv,oo +!----------------------------------------------------------------------------- +real(dp):: a,b,c,d,e,f,g,h +!============================================================================= +a=em(1,1); b=em(1,2); c=em(2,2) +d=a*c-b*b! <- det(em) +e=(a+c)*o2; f=(a-c)*o2 +h=sqrt(f**2+b**2) +g=sqrt(b**2+(h+abs(f))**2) +if (g==u0)then; vv(:,1)=(/u1,u0/) +elseif(f> u0)then; vv(:,1)=(/h+f,b/)/g +else ; vv(:,1)=(/b,h-f/)/g +endif +vv(:,2)=(/-vv(2,1),vv(1,1)/) +oo=matmul(transpose(vv),matmul(em,vv)) +oo(1,2)=u0; oo(2,1)=u0 +end subroutine eigensym2 +!============================================================================= +subroutine eigensym2d(em,vv,oo,vvd,ood,ff)! [eigensym2] +!============================================================================= +! For a symmetric 2*2 matrix, em, return the normalized eigenvectors, vv, and +! the diagonal matrix of eigenvalues, oo. If the two eigenvalues are equal, +! proceed no further and raise the logical failure flag, ff, to .true.; +! otherwise, return with vvd=d(vv)/d(em) and ood=d(oo)/d(em) and ff=.false., +! and maintain the symmetries between the last two of the indices of +! these derivatives. +!============================================================================= +implicit none +real(dp),dimension(2,2), intent(in ):: em +real(dp),dimension(2,2), intent(out):: vv,oo +real(dp),dimension(2,2,2,2),intent(out):: vvd,ood +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp),dimension(2,2):: emd,tt,vvr +real(dp) :: oodif,dtheta +integer(spi) :: i,j +!============================================================================= +call eigensym2(em,vv,oo); vvr(1,:)=-vv(2,:); vvr(2,:)=vv(1,:) +oodif=oo(1,1)-oo(2,2); ff=oodif==u0; if(ff)return +ood=0 +vvd=0 +do j=1,2 + do i=1,2 + emd=0 + if(i==j)then + emd(i,j)=u1 + else + emd(i,j)=o2; emd(j,i)=o2 + endif + tt=matmul(transpose(vv),matmul(emd,vv)) + ood(1,1,i,j)=tt(1,1) + ood(2,2,i,j)=tt(2,2) + dtheta=tt(1,2)/oodif + vvd(:,:,i,j)=vvr*dtheta + enddo +enddo +end subroutine eigensym2d + +!============================================================================= +subroutine invsym2(em,z)! [invsym2] +!============================================================================= +! Get the inverse of a 2*2 matrix (need not be symmetric in this case). +!============================================================================= +implicit none +real(dp),dimension(2,2),intent(in ):: em +real(dp),dimension(2,2),intent(out):: z +!----------------------------------------------------------------------------- +real(dp):: detem +!============================================================================= +z(1,1)=em(2,2); z(2,1)=-em(2,1); z(1,2)=-em(1,2); z(2,2)=em(1,1) +detem=em(1,1)*em(2,2)-em(2,1)*em(1,2) +z=z/detem +end subroutine invsym2 +!============================================================================= +subroutine invsym2d(em,z,zd)! [invsym2] +!============================================================================= +! Get the inverse, z,of a 2*2 symmetric matrix, em, and its derivative, zd, +! with respect to symmetric variations of its components. I.e., for a +! symmetric infinitesimal change, delta_em, in em, the resulting +! infinitesimal change in z would be: +! delta_z(i,j) = matmul(zd(i,j,:,:),delta_em) +!============================================================================= +implicit none +real(dp),dimension(2,2) ,intent(in ):: em +real(dp),dimension(2,2) ,intent(out):: z +real(dp),dimension(2,2,2,2),intent(out):: zd +!----------------------------------------------------------------------------- +integer(spi):: k,l +!============================================================================= +call invsym2(em,z) +call id2222(zd) +do l=1,2; do k=1,2 + zd(:,:,k,l)=-matmul(matmul(z,zd(:,:,k,l)),z) +enddo; enddo +end subroutine invsym2d + +!============================================================================= +subroutine sqrtsym2(em,z)! [sqrtsym2] +!============================================================================= +! Get the sqrt of a symmetric positive-definite 2*2 matrix +!============================================================================= +implicit none +real(dp),dimension(2,2),intent(in ):: em +real(dp),dimension(2,2),intent(out):: z +!----------------------------------------------------------------------------- +real(dp),dimension(2,2):: vv,oo +integer(spi) :: i +!============================================================================= +call eigensym2(em,vv,oo) +do i=1,2 +if(oo(i,i)<0)stop 'In sqrtsym2; matrix em is not non-negative' +oo(i,i)=sqrt(oo(i,i)); enddo +z=matmul(vv,matmul(oo,transpose(vv))) +end subroutine sqrtsym2 + +!============================================================================= +subroutine sqrtsym2d(x,z,zd)! [sqrtsym2] +!============================================================================= +! General routine to evaluate z=sqrt(x), and the symmetric +! derivative, zd = dz/dx, where x is a symmetric 2*2 positive-definite +! matrix. If the eigenvalues are very close together, extract their +! geometric mean for "preconditioning" a scaled version, px, of x, whose +! sqrt, and hence its derivative, can be easily obtained by the series +! expansion method. Otherwise, use the eigen-method (which entails dividing +! by the difference in the eignevalues to get zd, and which therefore +! fails when the eigenvalues become too similar). +!============================================================================= +implicit none +real(dp),dimension(2,2), intent(in ):: x +real(dp),dimension(2,2), intent(out):: z +real(dp),dimension(2,2,2,2),intent(out):: zd +!----------------------------------------------------------------------------- +real(dp),dimension(2,2):: px +real(dp) :: rdetx,lrdetx,htrpxs,q +!============================================================================= +rdetx=sqrt(x(1,1)*x(2,2)-x(1,2)*x(2,1)) ! <- sqrt(determinant of x) +lrdetx=sqrt(rdetx) +px=x/rdetx ! <- preconditioned x (has unit determinant) +htrpxs= ((px(1,1)+px(2,2))/2)**2 ! <- {half-trace-px}-squared +q=htrpxs-u1 +if(q<.05_dp)then ! <- Taylor expansion method + call sqrtsym2d_t(px,z,zd) + z=z*lrdetx; zd=zd/lrdetx +else + call sqrtsym2d_e(x,z,zd) ! <- Eigen-method +endif +end subroutine sqrtsym2d + +!============================================================================= +subroutine sqrtsym2d_e(x,z,zd)! [sqrtsym2d_e] +!============================================================================= +implicit none +real(dp),dimension(2,2), intent(in ):: x +real(dp),dimension(2,2), intent(out):: z +real(dp),dimension(2,2,2,2),intent(out):: zd +!----------------------------------------------------------------------------- +real(dp),dimension(2,2,2,2):: vvd,ood +real(dp),dimension(2,2) :: vv,oo,oori,tt +integer(spi) :: i,j +logical :: ff +!============================================================================= +call eigensym2(x,vv,oo,vvd,ood,ff) +z=u0; z(1,1)=sqrt(oo(1,1)); z(2,2)=sqrt(oo(2,2)) +z=matmul(matmul(vv,z),transpose(vv)) +oori=u0; oori(1,1)=u1/sqrt(oo(1,1)); oori(2,2)=u1/sqrt(oo(2,2)) +do j=1,2 +do i=1,2 + tt=matmul(vvd(:,:,i,j),transpose(vv)) + zd(:,:,i,j)=o2*matmul(matmul(matmul(vv,ood(:,:,i,j)),oori),transpose(vv))& + +matmul(tt,z)-matmul(z,tt) +enddo +enddo +end subroutine sqrtsym2d_e + +!============================================================================= +subroutine sqrtsym2d_t(x,z,zd)! [sqrtsym2d_t] +!============================================================================= +! Use the Taylor-series method (eigenvalues both fairly close to unity). +! For a 2*2 positive definite symmetric matrix x, try to get both the z=sqrt(x) +! and dz/dx using the binomial-expansion method applied to the intermediate +! matrix, r = (x-1). ie z=sqrt(x) = (1+r)^{1/2} = I + (1/2)*r -(1/8)*r^2 ... +! + [(-)^n *(2n)!/{(n+1)! * n! *2^{2*n-1}} ]*r^{n+1} +!============================================================================= +implicit none +real(dp),dimension(2,2), intent(in ):: x +real(dp),dimension(2,2), intent(out):: z +real(dp),dimension(2,2,2,2),intent(out):: zd +!----------------------------------------------------------------------------- +integer(spi),parameter :: nit=300 ! number of iterative increments allowed +real(dp),parameter :: crit=1.e-17 +real(dp),dimension(2,2) :: r,rp,rd,rpd +real(dp) :: c +integer(spi) :: i,j,n +!============================================================================= +r=x; r(1,1)=x(1,1)-1; r(2,2)=x(2,2)-1 +z=u0; z(1,1)=u1; z(2,2)=u1 +rp=r +c=o2 +do n=0,nit + z=z+c*rp + rp=matmul(rp,r) + if(sum(abs(rp)) 1: Ground or Water Surface, see Table 4.5 + var_opts%varname .eq. 'gust' ) then + iret = 0 ! specified variable name matches the variable in grib2 file + else if ( gfld%ipdtnum .eq. 0 .and. & ! 0: Anl or fcst in a horizontal layer, see Grib2 Code Table 4.0 + gfld%discipline .eq. 10 .and. & ! Discipline 10 : Oceanographic Products, see Table 4.1 + gfld%ipdtmpl(1) .eq. 0 .and. & ! Cateory 0: Waves, See Table 4.1 + gfld%ipdtmpl(2) .eq. 3 .and. & ! Number 3: HTSGW, see Table 4.2-10-0 + gfld%ipdtmpl(10) .eq. 1 .and. & ! Prod.Templt. 4.0 Octet. 23 --> 1: Ground or Water Surface, see Table 4.5 + var_opts%varname .eq. 'howv' ) then + iret = 0 ! specified variable name matches the variable in grib2 file + else + iret = -1 ! variable name mis-matches the variable in grib2 file + end if + return + end subroutine check_varopts_grb2 +! + subroutine set_time4data(gfld,adate,cdate) + type(gribfield), intent(in ) :: gfld + integer, intent( out) :: adate(5) ! year/month/day/hour/minute + character(len=12), intent( out) :: cdate !yyyymmddhhmn + + integer :: itt + + adate(1)=gfld%idsect( 6) ! Year(4digits) + adate(2)=gfld%idsect( 7) ! Month + adate(3)=gfld%idsect( 8) ! Day + adate(4)=gfld%idsect( 9) ! Hour + adate(5)=gfld%idsect(10) ! Minute +! furtherly adjusting the time by info in Product template + if ( gfld%ipdtmpl(8) .le. 4) then + itt=5-gfld%ipdtmpl(8) + adate(itt)=adate(itt) + gfld%ipdtmpl(9) + write(6,'(1x,A,I4,1x,A,I4)') 'date time is adjusted by ', gfld%ipdtmpl(9), & + 'with unit indicator-->', gfld%ipdtmpl(9) + else + write(6,'(1x,A,1x,I4,1x,A)') ' * * * Warning: checking the Indicator of unit of time range: ', & + gfld%ipdtmpl(8), ' No further adjustment to time. * * * * * * ' + end if + write(cdate( 1: 4),'(I4.4)') adate( 1) + write(cdate( 5: 6),'(I2.2)') adate( 2) + write(cdate( 7: 8),'(I2.2)') adate( 3) + write(cdate( 9:10),'(I2.2)') adate( 4) + write(cdate(11:12),'(I2.2)') adate( 5) + write(6,'(1x,A,1x,A4,4(A1,A2))') 'date of input model data: ', & + cdate(1:4),'-',cdate(5:6),'-',cdate(7:8),'_',cdate(9:10),':',cdate(11:12) + return + end subroutine set_time4data +! + subroutine check_grbmsg(gfld) + type(gribfield), intent(in ) :: gfld + write(6,*) ' checking the data in array gfld read by getgb2: ' + write(6,*) ' version: ', gfld%version + write(6,*) ' discipline: ', gfld%discipline + write(6,*) ' idsectlen: ', gfld%idsectlen + write(6,*) ' idsect(:):, ', gfld%idsect(1:gfld%idsectlen) + write(6,*) ' locallen: ', gfld%locallen + if (gfld%locallen > 0) & + write(6,*) ' local(:): ', gfld%local(1:gfld%locallen) + write(6,*) ' ifldnum: ', gfld%ifldnum + write(6,*) ' griddef: ', gfld%griddef + write(6,*) ' ngrdpts: ', gfld%ngrdpts + write(6,*) ' numoct_opt: ', gfld%numoct_opt + write(6,*) ' interp_opt: ', gfld%interp_opt + write(6,*) ' num_opt: ', gfld%num_opt + write(6,*) ' igdtnum: ', gfld%igdtnum + write(6,*) ' igdtlen: ', gfld%igdtlen + write(6,*) ' igdtmpl(:): ', gfld%igdtmpl(1:gfld%igdtlen) + write(6,*) ' ipdtnum: ', gfld%ipdtnum + write(6,*) ' ipdtlen: ', gfld%ipdtlen + write(6,*) ' ipdtmpl(:): ', gfld%ipdtmpl(1:gfld%ipdtlen) + write(6,*) ' num_coord: ', gfld%num_coord + if (gfld%num_coord > 0) & + write(6,*) ' coord_list(:) ', gfld%coord_list(:) + write(6,*) ' ndpts: ', gfld%ndpts + write(6,*) ' idrtnum: ', gfld%idrtnum + write(6,*) ' idrtlen: ', gfld%idrtlen + write(6,*) ' idrtmpl(:): ', gfld%idrtmpl(1:gfld%idrtlen) + write(6,*) ' unpacked: ', gfld%unpacked + write(6,*) ' expanded: ', gfld%expanded + write(6,*) ' ibmap: ', gfld%ibmap + write(6,*) ' length of bmap(:) ', size(gfld%bmap) + write(6,*) ' fld( 1): ', gfld%fld(1) + write(6,*) ' fld(ngrdpts/2): ', gfld%fld(nint(gfld%ngrdpts / 2.0)) + write(6,*) ' fld(ngrdpts ): ', gfld%fld(gfld%ngrdpts) + return + end subroutine check_grbmsg +! + subroutine set_rllgridopts(gfld,rll_gridopts) + type(gribfield), intent(in ) :: gfld + type(rotated_gridopts), intent( out) :: rll_gridopts + rll_gridopts%sp_lon = gfld%igdtmpl(21)/1000000.0 + rll_gridopts%sp_lat = gfld%igdtmpl(20)/1000000.0 + if (rll_gridopts%sp_lat .le. 0.0_dp) then + rll_gridopts%ctr_lat = 90.0_dp + rll_gridopts%sp_lat + rll_gridopts%ctr_lon = rll_gridopts%sp_lon + else + rll_gridopts%ctr_lat = 90.0_dp - rll_gridopts%sp_lat + if ( rll_gridopts%sp_lon .gt. 180.0_dp ) then + rll_gridopts%ctr_lon = rll_gridopts%sp_lon - 180.0_dp + else + rll_gridopts%ctr_lon = rll_gridopts%sp_lon + 180.0_dp + end if + end if + rll_gridopts%dlon = gfld%igdtmpl(17)/1000000.0 ! Di -- i direction increment + rll_gridopts%dlat = gfld%igdtmpl(18)/1000000.0 ! Dj -- j direction increment + rll_gridopts%llcnr(1) = gfld%igdtmpl(13)/1000000.0 + rll_gridopts%llcnr(2) = gfld%igdtmpl(12)/1000000.0 + rll_gridopts%urcnr(1) = gfld%igdtmpl(16)/1000000.0 + rll_gridopts%urcnr(2) = gfld%igdtmpl(15)/1000000.0 + rll_gridopts%nx = gfld%igdtmpl( 8) ! grid dimension in x/i-direcion + rll_gridopts%ny = gfld%igdtmpl( 9) ! grid dimension in y/j-direcion + write(6,'(1x, A, 2(1x,F8.3))') ' checking rotated grid parameters: south pole lon/lat: ', & + rll_gridopts%sp_lon, rll_gridopts%sp_lat + write(6,'(1x, A, 2(1x,F8.3))') ' checking rotated grid parameters: domain center lon/lat: ', & + rll_gridopts%ctr_lon, rll_gridopts%ctr_lat + write(6,'(1x, A, 2(1x,F8.3))') ' checking rotated grid parameters: grid-spacing dlon/dlat: ', & + rll_gridopts%dlon, rll_gridopts%dlat + write(6,'(1x, A, 2(1x,F8.3))') ' checking rotated grid parameters: lower-left corner lon/lat: ', & + rll_gridopts%llcnr(1), rll_gridopts%llcnr(2) + write(6,'(1x, A, 2(1x,F8.3))') ' checking rotated grid parameters: upper-right corner lon/lat: ', & + rll_gridopts%urcnr(1), rll_gridopts%urcnr(2) + write(6,'(1x, A, 2(1x, I8))') ' checking rotated grid parameters: grid dimension in x/y-direction: ', & + rll_gridopts%nx, rll_gridopts%ny + return + end subroutine set_rllgridopts +! + subroutine set_bitmap_grb2(gfld,npts,l_clean_bitmap,ibi,input_bitmap) + type(gribfield), intent(in ) :: gfld + integer, intent(in ) :: npts + logical*1, intent(in ) :: l_clean_bitmap + integer, dimension(1), intent( out) :: ibi(1) + logical*1, dimension(npts), intent( out) :: input_bitmap + + if (gfld%ibmap==0) then ! input data has bitmap + write(6,*) 'There are bitmap data associated with the data.' + ibi = 1 ! tell ipolates to use bitmap + input_bitmap(:) = gfld%bmap + else ! no bitmap, data everywhere + write(6,*) 'There is NO bitmap data associated with the data.' + ibi = 0 ! tell ipolates there is no bitmap + input_bitmap(:) = .true. + endif + + if ( l_clean_bitmap ) then + write(6,*) ' Warning --> reset input_bitmap to be true everywhere.' + ibi = 0 + input_bitmap(:) = .true. + end if + + return + end subroutine set_bitmap_grb2 +! + subroutine check_data_1d_with_bitmap(var_opts,npts,input_data,ibi,input_bitmap) + type(variable_options), intent(in ) :: var_opts + integer, intent(in ) :: npts + real(dp), dimension(npts), intent(in ) :: input_data ! 2D Data in 1D slice + integer, dimension(1), intent(in ) :: ibi(1) + logical*1, dimension(npts), intent(in ) :: input_bitmap + + integer, dimension(npts) :: index_bitmap + integer :: nn, n_bitmap, n_valid + real(dp) :: sum_valid + + if ( ibi(1) == 0 ) write(6,*) & + ' bitmap associated with this data is NOT used or set as TRUE everywhere.' + + n_bitmap = 0 + n_valid = 0 + sum_valid = 0.0_dp + index_bitmap(:) = -1 + do nn = 1, npts +!--- note: +! input_bitmap is true --> field data at this grid point is valid. +! input_bitmap is false --> field data at this grid point is invalid. + if ( .not. input_bitmap(nn) ) then + n_bitmap = n_bitmap + 1 + index_bitmap(n_bitmap) = nn + else + sum_valid = sum_valid + input_data(nn) + n_valid = n_valid + 1 + end if + + if ( input_data(nn) .lt. var_opts%lower_bound .or. & + input_data(nn) .gt. var_opts%upper_bound ) then + write(6,'(1x,A,A,1x,I8,1x,L2,1x,F12.5)') & + 'checking input data which is out of range --> ', & + 'nn bitmap data_value): ', nn, input_bitmap(nn), input_data(nn) + end if + end do + + write(6,'(1x, A, 1x, I8)') & + ' total number of points with false bitmap : ', n_bitmap + write(6,'(1x,A,3(1x,L2,1x,F12.5))') & + ' checking the bitmap and data values of the first, middle and last invalid data : ', & + input_bitmap(index_bitmap(1)), input_data(index_bitmap(1)), & + input_bitmap(index_bitmap(n_bitmap/2)), input_data(index_bitmap(n_bitmap/2)), & + input_bitmap(index_bitmap(n_bitmap)), input_data(index_bitmap(n_bitmap)) + write(6,'(1x, A, 1x, I8, 3(1x,F12.5))') & + 'stats of data (masked by bitmap ) -- size max min ave: ', n_valid, & + maxval(input_data, MASK=(input_bitmap)), & + minval(input_data, MASK=(input_bitmap)), sum_valid/n_valid + write(6,'(1x, A, 1x, I8, 3(1x,F12.5))') & + 'stats of data (not-masked by bitmap) -- size max min ave: ', size(input_data), & + maxval(input_data), minval(input_data), sum(input_data)/size(input_data) + + return + end subroutine check_data_1d_with_bitmap +! + subroutine ll_to_xy_esg(nx_esg, ny_esg, nx_rll, ny_rll, esg_opts, lats, lons, x, y) + integer, intent(in ) :: nx_esg, ny_esg ! domain size of esg grid domain (to define the ESG X/Y coordinates) + integer, intent(in ) :: nx_rll, ny_rll ! domain size of another grid domain (output grid) + type(esg_gridopts), intent(in ) :: esg_opts + real(dp), dimension(nx_rll, ny_rll), intent(in ) :: lats, lons + real(dp), dimension(nx_rll, ny_rll), intent(inout) :: x, y + + integer :: ii, jj + real(dp) :: dlat, dlon + real(dp), dimension(2) :: xm + logical :: ff + real(dp), parameter :: two=2_dp + + real(dp) :: A + real(dp) :: Kappa + real(dp) :: delx ! in degree, not radian (*6370*pi/180=1.4415 km, half grid/cell size) + real(dp) :: dely ! in degree, not radian + real(dp) :: plat ! center lat of gnomonic grid + real(dp) :: plon ! center lon of gnomonic grid ! -112.5_dp = 247.5_dp + real(dp) :: pazi + + A = esg_opts%A + Kappa = esg_opts%Kappa + plat = esg_opts%plat + plon = esg_opts%plon + pazi = esg_opts%pazi + delx = esg_opts%delx + dely = esg_opts%dely + do jj=1,ny_rll + do ii=1,nx_rll + dlat=lats(ii,jj) + dlon=lons(ii,jj) + call gtoxm_ak_dd_g(A,Kappa,plat,plon,pazi,two*delx,two*dely,dlat,dlon,xm,ff) ! multiply delx/dely by 2.0 to get values on compuational grid + x(ii,jj)=xm(1) + y(ii,jj)=xm(2) + x(ii,jj) = (real(nx_esg)-1.0)/2.0 + x(ii,jj) + 1.0 ! Relocate the origin of X/Y coordinate from center + ! of ESG grid domain to its lower-left corner. + y(ii,jj) = (real(ny_esg)-1.0)/2.0 + y(ii,jj) + 1.0 ! Plus (1.0, 1.0) is because the coordinates of + ! lower-left corner is (1.0, 1.0) + enddo + enddo + + return + end subroutine ll_to_xy_esg +! +#ifdef IP_V3 + subroutine gdt2gds_rll(igdt, igdtlen, igdtmpl, kgds, igrid, iret) +!--- Purpose: +! Covnert rotated latlon grid information from a GRIB2 grid tempalte info +! to GRIB1 GDS info. The code is based on subroutine gdt2gds in g2 lib, +! which does not process igdt(5)=1, also is refered to subrotuine init_grib1 +! and init_grib2 in module ip_rot_equid_cylind_grid_mod of ip lib. +! Actually, the lat/lon of center grid point in grib1 grid and grib2 grid +! are based on init_grib1 and init_grib2. The indices used in gdt2gds.F90 +! seem to be wrong. +! see: https://www.nco.ncep.noaa.gov/pmb/docs/on388/ +! for GDS, see +! https://www.nco.ncep.noaa.gov/pmb/docs/on388/section2.html +! for detailed GDS info, see +! https://www.nco.ncep.noaa.gov/pmb/docs/on388/tabled.html +! +! Out: +! kgds: GRIB1 GDS as described in [NCEPLIBS-w3emc w3fi63() function] +! (https://noaa-emc.github.io/NCEPLIBS-w3emc/w3fi63_8f.html). +! igrid: NCEP predefined GRIB1 grid number. Set to 255, if not an NCEP grid. +! iret Error return value: 0: No error. +! 1: Unrecognized GRIB2 GDT number. +! + implicit none + + integer, intent(in ) :: igdtlen + integer, intent(in ) :: igdt(5), igdtmpl(igdtlen) + integer, intent( out) :: kgds(200) + integer, intent( out) :: igrid, iret + + integer :: kgds72(200), kgds71(200), idum(200), jdum(200) + integer :: ierr, j + + integer :: iopt + integer :: iscale, iscale_gb2, iscale_gb1 + real(dp) :: lon_sp_rll, lat_sp_rll + real(dp) :: rlon, rlat ! earth lat/lon + real(dp) :: rlonr, rlatr ! rotated lat/lon + + external :: w3fi71, r63w72 + + iret = 1 + idum = 0 + kgds(1:200) = 0 + if (igdt(5) .eq. 1) then ! grid number = 1 (in grib2) for Rotated Lat / Lon grid + kgds( 1) = 205 ! grid number =205 (in grib1) for Arakawa Staggerred for Non-E Stagger grid + kgds( 2) = igdtmpl(8) ! Ni (IM in init_grib) + kgds( 3) = igdtmpl(9) ! Nj (JM in init_grib) + iscale = igdtmpl(10) * igdtmpl(11) + if ( iscale == 0 ) then + iscale_gb2 = 10**6 + iscale_gb1 = 10**3 + else + write(6,'(1x,A,1x,I6.6)') & + 'gdt2gds_rll::Abort ==> due to Not recognized iscale from grib2 GDT info: iscale= ', iscale + stop(11) + end if + lat_sp_rll = real(igdtmpl(20), dp)/real(iscale_gb2, dp) ! latitude of rotated south pole + lon_sp_rll = real(igdtmpl(21), dp)/real(iscale_gb2, dp) ! longitude of rotated south pole +!--- first grid point: converting rotated lat/lon (in grib2 gdt) to regular earth lat/lon (for grib1 gds) + iopt = -1 ! rotated lat/lon --> regular earth lat/lon + rlatr = real(igdtmpl(12), dp)/real(iscale_gb2, dp) ! latitude of 1st grid point (rotated value in grib2 GDT) + rlonr = real(igdtmpl(13), dp)/real(iscale_gb2, dp) ! longitude of 1st grid point (rotated value in grib2 GDT) + call rll_trans_iplib(lon_sp_rll, lat_sp_rll, iopt, rlonr, rlatr, rlon, rlat) + write(6,'(1x,2(A,2(1x,F18.9)))') 'gdt2gds_rll::rotated lat lon : ', & + rlatr, rlonr, ' (iplib) ==> earth lat lon : ', rlat, rlon + kgds( 4) = nint(rlat * real(iscale_gb1, dp)) ! Lat of 1st grid point (earth lat/lon coordinate; RLAT1 in init_grib) + if ( rlon < 0.0 ) rlon = rlon + 360.0_dp + kgds( 5) = nint(rlon * real(iscale_gb1, dp)) ! Lon of 1st grid point (earth lat/lon coordinate; RLON1 in init_grib) + + kgds( 6) = 0 ! resolution and component flags: IROT in init_grib) +! if (igdtmpl(1)==2) kgds(6) = 64 +! if (btest(igdtmpl(14), 4).OR.btest(igdtmpl(14), 5)) kgds(6) = kgds(6) + 128 +! if (btest(igdtmpl(14), 3)) kgds(6) = kgds(6) + 8 + kgds( 6) = igdtmpl(14) ! resolution and component flags: IROT in init_grib) + + kgds( 7) = (lat_sp_rll + 90.0_dp) * real(iscale_gb1, dp) ! Earth Latitude of rotated center point (rotated south pole lat + 90.0; RLAT0 in init_grib) + kgds( 8) = lon_sp_rll * real(iscale_gb1, dp) ! Earth Longitude of rotated center point (=rotated south pole lon; RLON0 in init_grib) + + kgds( 9) = real(igdtmpl(17), dp)/real(iscale_gb1, dp) ! Di: x-increment, DLONS in init_grib + kgds(10) = real(igdtmpl(18), dp)/real(iscale_gb1, dp) ! Dj: y-increment, DLATS in init_grib + + kgds(11) = igdtmpl(19) ! Scanning mode (nscan in init_grib) + +!--- last grid point: converting rotated lat/lon (in grib2 gdt) to regular earth lat/lon (for grib1 gds) + iopt = -1 ! rotated lat/lon --> regular earth lat/lon + rlatr = real(igdtmpl(15), dp)/real(iscale_gb2, dp) ! latitude of last grid point (rotated value in grib2 GDT) + rlonr = real(igdtmpl(16), dp)/real(iscale_gb2, dp) ! longitude of last grid point (rotated value in grib2 GDT) + call rll_trans_iplib(lon_sp_rll, lat_sp_rll, iopt, rlonr, rlatr, rlon, rlat) + write(6,'(1x,2(A,2(1x,F18.9)))') 'gds2gds_rll: rotated lat lon : ', & + rlatr, rlonr, ' (iplib) ==> earth lat lon : ', rlat, rlon + kgds(12) = nint(rlat * real(iscale_gb1, dp)) ! Lat of last grid point (earth lat/lon coordinate) (RLAT2 in init_grib) + if ( rlon < 0.0 ) rlon = rlon + 360.0_dp + kgds(13) = nint(rlon * real(iscale_gb1, dp)) ! Lon of last grid point (earth lat/lon coordinate) (RLON2 in init_grib) + + kgds(14) = 0 + kgds(15) = 0 + kgds(16) = 0 + kgds(17) = 0 + kgds(18) = 0 + kgds(19) = 0 + kgds(20) = 255 + kgds(21) = 0 + kgds(22) = 0 + iret = 0 + else + write(6,'(1x, A, I5.5)') 'gdt2gds_rll: Unrecognized GRIB2 GDT = 3.', igdt(5) + iret = 1 + kgds(1:22) = 0 + return + endif +! +! Can we determine NCEP grid number ? +! + igrid = 255 + do j = 254, 1, -1 + !do j = 225, 225 + kgds71 = 0 + kgds72 = 0 + call w3fi71(j, kgds71, ierr) + if (ierr.ne.0) cycle + ! convert W to E for longitudes + if (kgds71(3) .eq. 0) then ! lat / lon + if (kgds71(7) .lt. 0) kgds71(7) = 360000 + kgds71(7) + if (kgds71(10) .lt. 0) kgds71(10) = 360000 + kgds71(10) + elseif (kgds71(3) .eq. 1) then ! mercator + if (kgds71(7) .lt. 0) kgds71(7) = 360000 + kgds71(7) + if (kgds71(10) .lt. 0) kgds71(10) = 360000 + kgds71(10) + elseif (kgds71(3) .eq. 3) then ! lambert conformal + if (kgds71(7) .lt. 0) kgds71(7) = 360000 + kgds71(7) + if (kgds71(9) .lt. 0) kgds71(9) = 360000 + kgds71(9) + if (kgds71(18) .lt. 0) kgds71(18) = 360000 + kgds71(18) + elseif (kgds71(3) .eq. 4) then ! Guassian lat / lon + if (kgds71(7) .lt. 0) kgds71(7) = 360000 + kgds71(7) + if (kgds71(10) .lt. 0) kgds71(10) = 360000 + kgds71(10) + elseif (kgds71(3) .eq. 5) then ! polar stereographic + if (kgds71(7) .lt. 0) kgds71(7) = 360000 + kgds71(7) + if (kgds71(9) .lt. 0) kgds71(9) = 360000 + kgds71(9) + endif + call r63w72(idum, kgds, jdum, kgds72) + if (kgds72(3) .eq. 3) kgds72(14) = 0 ! lambert conformal fix + if (kgds72(3) .eq. 1) kgds72(15:18) = 0 ! mercator fix + if (kgds72(3) .eq. 5) kgds72(14:18) = 0 ! polar str fix + ! print *, ' kgds71(', j, ') = ', kgds71(1:30) + ! print *, ' kgds72 = ', kgds72(1:30) + if (all(kgds71 .eq. kgds72) ) then + igrid = j + exit + endif + enddo + write(6,'(1x,A,I6)') 'sub gdt2gds_rll:: igrid = ', igrid + + return + end subroutine gdt2gds_rll +!----------------------------------------------------------------------- + subroutine rll_trans_iplib(lon_sp_rll, lat_sp_rll, iopt, lon_in, lat_in, lon_out, lat_out) +! purpose: +! conversion between the earth latitude/longitude and the rotated latitude/longitude. +! iopt = 1: converting earth lat/lon to rotated lat/lon +! iopt = -1: converting rotated lat/lon to earth lat/lon +! notes: +! the algorithm used to do the conversion between rotated latlon and regular earth latlon +! is based on the code in SUBROUTINE GDSWZD_ROT_EQUID_CYLIND of ip_rot_equid_cylind_grid_mod.F90 +! in IP lib verson 4.3.0 +! + implicit none +!---- parameters + real(dp), parameter :: PI = dacos(-1.0_dp) + real(dp), parameter :: D2R = PI/180.0_dp ! degree ==> radian + real(dp), parameter :: R2D = 180.0_dp/PI ! radian ==> degree + + real(dp), intent(in ) :: lon_sp_rll ! earth longitude of south pole after rotated (un + real(dp), intent(in ) :: lat_sp_rll ! latitude of input (unit: deg) + real(dp), intent(in ) :: lon_in ! longitude of input (unit: deg) + real(dp), intent(in ) :: lat_in ! latitude of input (unit: deg) + integer, intent(in ) :: iopt ! option to control the directon of transform + ! = 1 : regular lat/lon to rotated lat/lon + ! =-1 : rotated lat/lon to regular lat/lon + + real(dp), intent( out) :: lon_out ! longitude of output (unit: deg) + real(dp), intent( out) :: lat_out ! latitude of output (unit: deg) + +!---- local variables + REAL(DP) :: RLAT0, RLON0 ! latitude/longitude of center point + REAL(DP) :: CLAT0, SLAT0 ! SIN/COS of latitude of center point + REAL(DP) :: RLAT, RLON ! earth latitude/longitude + REAL(DP) :: SLAT, CLAT, CLON + REAL(DP) :: RLATR, RLONR ! earth latitude/longitude + REAL(DP) :: SLATR, CLATR, CLONR + REAL(DP) :: HS +!-----------------------------------------------------------------------------! +!---- center point + RLAT0=lat_sp_rll+90.0_dp ! center point latitude = south pole lat + 90 + RLON0=lon_sp_rll ! center point longitude = south pole lon + IF ( RLON0 < 0.0_dp ) RLON0=RLON0+360.0_dp + CLAT0=COS(RLAT0*D2R) + SLAT0=SIN(RLAT0*D2R) + + IF ( IOPT == 1 ) THEN ! IOPT=1: Earth lat/lon ==> Rotated lat/lon + RLAT=lat_in + RLON=lon_in + IF ( RLON < 0.0_dp ) RLON=RLON+360.0_dp + HS=SIGN(1._dp,MOD(RLON-RLON0+180._dp+3600._dp,360._dp)-180._dp) + CLON=COS((RLON-RLON0)*D2R) + SLAT=SIN(RLAT*D2R) + CLAT=COS(RLAT*D2R) + SLATR=CLAT0*SLAT-SLAT0*CLAT*CLON + IF(SLATR.LE.-1) THEN + CLATR=0._dp + RLONR=0. + RLATR=-90. + ELSEIF(SLATR.GE.1) THEN + CLATR=0._dp + RLONR=0. + RLATR=90. + ELSE + CLATR=SQRT(1-SLATR**2) + CLONR=(CLAT0*CLAT*CLON+SLAT0*SLAT)/CLATR + CLONR=MIN(MAX(CLONR,-1._dp),1._dp) + RLONR=HS*R2D*ACOS(CLONR) + RLATR=R2D*ASIN(SLATR) + ENDIF + lat_out=RLATR + lon_out=RLONR + ELSEIF ( IOPT == -1 ) THEN ! IOPT=-1: Rotated lat/lon ==> Earth lat/lon + RLATR=lat_in + RLONR=lon_in + IF(RLONR > 180.0_dp) RLONR=RLONR-360.0_dp ! in range (-180.0, 180.0) + IF(RLONR <= 0._dp) THEN + HS=-1.0_dp + ELSE + HS=1.0_dp + ENDIF + CLONR=DCOS(RLONR*D2R) + SLATR=DSIN(RLATR*D2R) + CLATR=DCOS(RLATR*D2R) + SLAT=CLAT0*SLATR+SLAT0*CLATR*CLONR + IF(SLAT.LE.-1._DP) THEN + CLAT=0._DP + CLON=DCOS(RLON0*D2R) + RLON=0._DP + RLAT=-90._DP + ELSEIF(SLAT.GE.1) THEN + CLAT=0._DP + CLON=DCOS(RLON0*D2R) + RLON=0._DP + RLAT=90._DP + ELSE + CLAT=SQRT(1._DP-SLAT**2) + CLON=(CLAT0*CLATR*CLONR-SLAT0*SLATR)/CLAT + CLON=MIN(MAX(CLON,-1._dp),1._dp) + RLON=REAL(MOD(RLON0+HS*R2D*DACOS(CLON)+3600._DP,360._dp)) + RLAT=REAL(R2D*DASIN(SLAT)) + ENDIF + lat_out=RLAT + lon_out=RLON + ELSE + WRITE(6,*) ' unrecognized option for opt, which must be either for regular to rotated (iopt=1) or vice versa (iopt=-1) ' + STOP 999 + ENDIF + + RETURN +!----------------------------------------------------------------------- + end subroutine rll_trans_iplib +#endif +!----------------------------------------------------------------------- +! +!================================================================================ +end module mod_rtma_regrid diff --git a/rtma_esg_conversion.fd/rtma_regrid_esg2rll.F90 b/rtma_esg_conversion.fd/rtma_regrid_esg2rll.F90 new file mode 100644 index 0000000..2fde699 --- /dev/null +++ b/rtma_esg_conversion.fd/rtma_regrid_esg2rll.F90 @@ -0,0 +1,825 @@ +program rtma_regrid_esg2rll +!================================================================================ + use omp_lib + use netcdf ! netcdf lib + use pkind, only: dp, sp, dpi, spi ! Jim Purser's lib + use pietc, only: dtor,rtod ! Jim Purser's lib + use gdswzd_mod, only: gdswzd ! ip lib (for conversion from earth to grid coor or vice versa) +!-- required when using iplib v4.0 or higher +#ifndef IP_V3 +! use ip_mod ! ip lib (for interpolation) +! use ipolates_mod ! ip lib (for interpolation) +! use ip_grid_descriptor_mod +! use ip_grids_mod +! use ip_grid_mod +! use ip_grid_factory_mod +#endif + use grib_mod ! g2 lib(grib) + use bacio_module ! prerequisite for g2 lib (grib) + use pbswi, only: abswi2 +! use pbswi, only: abswi4, abswi6, abswi8 + use mod_rtma_regrid, only: rotated_gridopts, variable_options, esg_gridopts + use mod_rtma_regrid, only: set_esg_gridopts, set_variable_options, & + check_varopts_grb2, set_time4data, & + check_grbmsg, set_rllgridopts, & + set_bitmap_grb2, check_data_1d_with_bitmap, & + ll_to_xy_esg +#ifdef IP_V3 + use mod_rtma_regrid, only: gdt2gds_rll +#endif + + implicit none + + real(dp), parameter :: undef_real = -9999.00_dp + integer, parameter :: undef_int = -9999 + + type(gribfield) :: gfld_input + type(rotated_gridopts) :: rll_opts + type(variable_options) :: var_opts + type(esg_gridopts) :: esg_opts + + character(len=100) :: input_data_rll_file_grb2 + character(len=100) :: input_data_esg_file_nc + character(len=100) :: input_data_esg_file_fgs_nc + character(len=100) :: esg_grid_spec_file_nc + character(len=100) :: output_data_rll_file_nc + character(len=20) :: varname_nc + character(len=20) :: varname_input + + integer :: ii, jj + integer :: iii, jjj +! integer :: nn, nnn + + integer :: iunit, iret, lugi + + + integer :: adate(5) ! year/month/day/hour/minute + character(len=12) :: cdate !yyyymmddhhmn + +! integer :: ip, ipopt(20) ! parameters for interpolation + + integer :: j, jdisc, jpdtn, jgdtn, k + integer :: jids(200), jgdt(200), jpdt(200) + integer :: km + + integer :: igdtlen_o + integer :: igdtnum_o + integer, allocatable :: igdtmpl_o(:) +! integer :: mo + integer :: imdl_o, jmdl_o ! dimension size read in grib2 data file + integer :: npts_o + logical :: unpack + integer, allocatable :: ibo(:) + logical*1, allocatable :: output_bitmap(:) ! 2D Data in 1D array + real(dp), allocatable :: output_data(:) ! 2D Data in 1D array +! real(dp), allocatable :: output_glat(:) ! 2D Data in 1D array +! real(dp), allocatable :: output_glon(:) ! 2D Data in 1D array + + real(dp) :: fill + integer :: nret, iopt + +#ifdef IP_V3 + integer :: igdt_grb2(5) + integer :: idefnum ! The number of entries in array ideflist, i.e. number + ! of rows (or columns) for which optional grid points are defined. + integer, allocatable :: ideflist(:) ! integer array containing the number of grid points contained in + ! each row (or column). To handle the irregular grid stuff. + integer :: kgds_grb1_rll_o(200) + integer :: igrid_grb1 + real(dp), allocatable :: glat1d_o(:), glon1d_o(:) + real(dp), allocatable :: xpts1d_o(:), ypts1d_o(:) +#else +! type(grib2_descriptor) :: desc_grb2 +! class(ip_grid), allocatable :: ip_grid_rll_o +#endif + real(dp), allocatable :: glat_o(:,:), glon_o(:,:) + real(dp), allocatable :: xpts_o(:,:), ypts_o(:,:) + +! real(dp), allocatable :: slmask_o(:,:) + real(dp), allocatable :: data_o(:,:) + real(dp), allocatable :: data_fgs_o(:,:) + real(dp), allocatable :: data_tmp_o(:,:) + real(dp), allocatable :: diff_xy(:,:) + logical*1, allocatable :: output_bitmap_2d(:,:) + real(dp), allocatable :: rotlon(:), rotlat(:) + +! integer :: mi, ni + integer :: ipts_i, jpts_i ! dimension size read in netcdf data file + integer :: ipt2_i, jpt2_i + integer :: npts_i + real(dp), allocatable :: xpts_i(:,:), ypts_i(:,:) + real(dp), allocatable :: glat_i(:,:), glon_i(:,:) + real(dp), allocatable :: slmask_i(:,:) + real(dp), allocatable :: data_i(:,:) + real(dp), allocatable :: data_fgs_i(:,:) + + integer :: ncid, varid + integer :: xdimid, ydimid, timedimid ! for read in netcdf + integer :: xt_dimid, yt_dimid + integer :: dimid_x, dimid_y, dimid_time ! for write out netcdf + integer :: varid_data + integer :: varid_rlon, varid_rlat + integer :: varid_glon, varid_glat + +!--- + logical*1 :: l_clean_bitmap ! if true, then set bitmap = true everywhere + logical*1 :: verbose + logical*1 :: l_increment_intrp ! true : interpolation with increment (when regrdding from esg to rll) + ! false: interpolation with full variable + integer :: interp_opt ! 2: BSWI-2 interpolation scheme (only available scheme for now) + + logical :: ff + + character(100) :: fname_nml + logical :: f_exist + integer :: lunin_nml + + namelist/setup/varname_input, verbose, l_clean_bitmap, l_increment_intrp, interp_opt + +!----------------------------------------------------------------------- + interface + + subroutine baopenr(iunit, input_file, iret) + integer, intent(in ) :: iunit + character(len=*), intent(in ) :: input_file + integer, intent( out) :: iret + end subroutine baopenr + + subroutine baclose(iunit, iret) + integer, intent(in ) :: iunit + integer, intent( out) :: iret + end subroutine baclose + + subroutine getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + use grib_mod + integer, intent(in ) :: lugb, lugi, j, jdisc, jpdtn, jgdtn + integer, dimension(:), intent(in ) :: jids(*), jpdt(*), jgdt(*) + logical, intent(in ) :: unpack + integer, intent( out) :: k, iret + type(gribfield), intent( out) :: gfld + end subroutine getgb2 + + subroutine gf_free(gfld) + use grib_mod + type(gribfield), intent(in ) :: gfld + end subroutine gf_free + + end interface +!--------------------------------------------------------------------------- +! 0. reading the namelist +!--------------------------------------------------------------------------- +!--- initialising the namelist variables first + l_clean_bitmap = .false. ! do not reset bitmap to be true in whole domain (default) + verbose = .false. + varname_input = '' + l_increment_intrp = .false. ! regridding with full variable (default) + interp_opt = 2 + + f_exist = .false. + lunin_nml = 10 +!-- reading namelist + fname_nml = 'esg2rll_namelist' + inquire(file=trim(adjustl(fname_nml)),exist=f_exist) + if (f_exist) then + write(6,*) 'reading from namelist: ', trim(adjustl(fname_nml)) + open(lunin_nml, file=trim(adjustl(fname_nml)), form='formatted', status='old') + read(lunin_nml, setup) + close(lunin_nml) + write(6,*) "checking the setup info in namelist:" + write(6,setup) + else + write(6,'(1x,2A)') & + "Abort..., failed to find the required namelist file: ", trim(adjustl(fname_nml)) + stop(99) + end if + if (trim(adjustl(varname_input)) == '') then + write(6,*) "Abort..., must set varname_input in namelist (e.g., varname_input='howv')" + stop(1) + else + var_opts%varname = trim(adjustl(varname_input)) + call set_variable_options(var_opts, iret) + if ( iret /= 0 ) then + write(6,'(1x,3A)') 'This program cannot process this variable : ', & + trim(adjustl(var_opts%varname)), ', task is ABORTED !!!!' + stop(2) + end if + end if + +!--------------------------------------------------------------------------- +! 1. Read the output grid (RLL) info from grib2 file (on rotated grid) +!--------------------------------------------------------------------------- +! 1.1 opening the grib 2 file containing data to be interpolated. +! Note: for this example, there are only one data record +! (HTSGW or GUST) in grib2 file. +!--------------------------------------------------------------------------- + iunit=9 + input_data_rll_file_grb2="./input_data_rll.grib2" + call baopenr(iunit, input_data_rll_file_grb2, iret) + if (iret /= 0) then + write(6,*) 'return from baopenr: ',iret + stop 'Error: baopenr failed.' + end if + +!--------------------------------------------------------------------------- +! 1.2 preparing for call to g2 library to degrib data. +! Note: the data are assumed to be on a rotated-lat/lon grid +! with i/j dimension of 360/181. +!--------------------------------------------------------------------------- + jdisc = -1 ! search for any discipline + jpdtn = -1 ! search for any product definition template number + jgdtn = -1 ! search for grid definition template number + ! 0 - regular lat/lon grid is expected. + ! 1 - rotated lat/lon grid is expected. + jids = -9999 ! array of values in identification section, set to wildcard + jgdt = -9999 ! array of values in grid definition template 3.m + jpdt = -9999 ! array of values in product definition template 4.n + unpack = .true. ! unpack data + lugi = 0 ! no index file (if using index file, set lugi = iunit) + + nullify(gfld_input%idsect) + nullify(gfld_input%local) + nullify(gfld_input%list_opt) + nullify(gfld_input%igdtmpl) ! holds the grid definition template information + nullify(gfld_input%ipdtmpl) + nullify(gfld_input%coord_list) + nullify(gfld_input%idrtmpl) + nullify(gfld_input%bmap) ! holds the bitmap + nullify(gfld_input%fld) ! holds the data + +!--------------------------------------------------------------------------- +! 1.3 degrib the data. non-zero "iret" indicates a problem during degrib. +!--------------------------------------------------------------------------- + km = 1 ! number of records to interpolate (in this example, only one record) + + do j = 0, (km-1) + + call getgb2(iunit, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld_input, iret) + + if (iret /= 0) then + write(6,'(1x,A,I4,A)') 'return from sub getgb2: ', iret, ' --> Error: getb2 failed.' + stop(1) + end if + if ( verbose ) call check_grbmsg(gfld_input) + +!--- check up if the variable in grib2 file matches the requried variable + call check_varopts_grb2(gfld_input,var_opts,iret) + if ( iret /= 0 ) then + write(6,'(1x,3A)') 'Warning: Required variable name [', & + trim(adjustl(var_opts%varname)), & + '] does not match the variable in grib2 file. Task is ABORTED ... ' + stop(3) + end if + +!--- date/time info of input date + call set_time4data(gfld_input, adate, cdate) + +!--- input grid template information +! + imdl_o = gfld_input%igdtmpl(8) ! x-dimension of output grid + jmdl_o = gfld_input%igdtmpl(9) ! y-dimension of output grid + npts_o = imdl_o * jmdl_o ! total dimension of output grid + write(6,'(1x,A,3(1x,I8))') & + 'dimension of output grib2 grid (Nx, Ny, Nx*Ny) = ', imdl_o, jmdl_o, npts_o + +! jgdtn was set to be -1 so getgb2 would search for grid template number. +! So after getgb2, jgdtn is still -1, but the true grid template number +! is gfld_input%igdtnum. + igdtnum_o = gfld_input%igdtnum + if (igdtnum_o == 1) then + write(6,'(1x,A)') "output model grid is defined on rotated lat-lon grid, as expected." + call set_rllgridopts(gfld_input, rll_opts) + else + write(6,'(1x,A,I12.12)') & + "output model grid is defined on the grid with grid template number = ",igdtnum_o + write(6,'(1x,A)') ' However, a Rotated Lat-Lon Grid is expected. So Abort this running ...' + stop(-1) + end if + + igdtlen_o = gfld_input%igdtlen + allocate(igdtmpl_o(igdtlen_o)) + igdtmpl_o(:) = gfld_input%igdtmpl(:) ! grid template (used by grib2) + +!--------------------------------------------------------------------------- +! 1.4 checking up with output model data (and its bitmap, etc.) +! Note: +! These output data might be used to fill the area where the regridded +! data could not cover (e.g., area undefined for ESG grid) +!--------------------------------------------------------------------------- +!--- output data field decoded in grib2 file + allocate(output_data(npts_o)) + output_data(:) = gfld_input%fld ! the output data field + +!--- does grib2 data have a bitmap? + allocate(ibo(1)) + allocate(output_bitmap(npts_o)) + l_clean_bitmap = .False. ! do not re-set bitmap to be true everywhere + call set_bitmap_grb2(gfld_input,npts_o,l_clean_bitmap,ibo,output_bitmap) + +!--- checking if existing any abnormal data values and counting data with false bitmap + write(6,*)'----------------------------------------------------------' + write(6,*)'checking the output data read from grib2 fie:' + call check_data_1d_with_bitmap(var_opts,npts_o,output_data,ibo,output_bitmap) + +!--------------------------------------------------------------------------- +! 1.5 calculate lat/lon of input grid points (rotated-latlon grid here) +! note: +! to use gdswzd, this type of grid (given igdtnum, igdtmpl) +! should be recognizable by gdswzd. +!--------------------------------------------------------------------------- + iopt = 0 ! option used in gdswzd: + ! 0: calculating grid(i/j) and earth coords (lat/lon) of all grid points + ! 1: calculating earth coords (lat/lon) of selected grid coordinates + !-1: calculating grid coordinates of selected earth coords (lat/lon) +#ifdef IP_V3 +!-- when using iplib v3.0 or lower + allocate (xpts1d_o(npts_o),ypts1d_o(npts_o)) + allocate (glat1d_o(npts_o),glon1d_o(npts_o)) + allocate (xpts_o(imdl_o,jmdl_o),ypts_o(imdl_o,jmdl_o)) + allocate (glat_o(imdl_o,jmdl_o),glon_o(imdl_o,jmdl_o)) + fill = -9999.0_dp + xpts1d_o = fill ; ypts1d_o = fill ; ! Grid x & y point coords + glat1d_o = fill ; glon1d_o = fill ; ! Earth lat & lon in degree +!-------------------------------------------------------------------------------------! +! As required by IP lib v3.x or older, gdszwd needs an array gds(200) ! +! to save the grid information and parameters, and that array gds(200) ! +! follows GRIB1 GDS info. So need to convert grid informaton from ! +! GRIB2 Grid Description Section (and its Grid Definition Template) ! +! to GRIB1 GDS info (similarly as decoded by w3fi63) ! +!-------------------------------------------------------------------------------------! + igdt_grb2(1) = 0 ! Source of Grid Definition (0: then specified in Code Table 3.1) + igdt_grb2(2) = npts_o ! Number of Data Points in the defined grid + igdt_grb2(3) = 0 ! Number of octets needed for each additional grid definition (if 0: using regular grid) + igdt_grb2(4) = 0 ! Interpetation of list of for optional points definition (Table 3.11) + igdt_grb2(5) = igdtnum_o ! GrdDefTmplt number(Table 3.1): 1--> rotated latlon grid (Template 3.1) + idefnum = 0 ! no irregular grid stuff + allocate(ideflist(1)) + ideflist(:) = 0 + call gdt2gds_rll(igdt_grb2, igdtlen_o, igdtmpl_o, kgds_grb1_rll_o, igrid_grb1, iret) + deallocate(ideflist) + if ( verbose ) write(6,*) ' checking kgds calculated by gdt2gds_rll : ', kgds_grb1_rll_o +! lrot = 0 ! return Vector Rotations (if 1) +! lmap = 0 ! return Map Jacobians (if 1) + call gdswzd(kgds_grb1_rll_o, iopt, npts_o, fill, & + xpts1d_o, ypts1d_o, glon1d_o, glat1d_o, nret) + if (nret /= npts_o) then + write(6,'(1x,2(A,1x,I8))') & + 'ERROR: Checking --> NUMBER OF VALID POINTS RETURNED FROM GDSWZS (iopt=0) ', & + nret, ' DOES NOT MATCH TOTAL NUMBER of GRID POINTS ', npts_o + stop(4) + endif +!--- reshaping 1-D output array to 2-D array + xpts_o = reshape(xpts1d_o, (/imdl_o, jmdl_o/), order=(/1,2/)) + ypts_o = reshape(ypts1d_o, (/imdl_o, jmdl_o/), order=(/1,2/)) + glat_o = reshape(glat1d_o, (/imdl_o, jmdl_o/), order=(/1,2/)) + glon_o = reshape(glon1d_o, (/imdl_o, jmdl_o/), order=(/1,2/)) + deallocate(xpts1d_o, ypts1d_o) + deallocate(glat1d_o, glon1d_o) +#else +!-- when using iplib v4.0 or higher + allocate (xpts_o(imdl_o,jmdl_o),ypts_o(imdl_o,jmdl_o)) + allocate (glat_o(imdl_o,jmdl_o),glon_o(imdl_o,jmdl_o)) +!--- creating the grid info from grib2 template info in grib2 file +! allocate (xpts1d_o(npts_o),ypts1d_o(npts_o)) +! allocate (glat1d_o(npts_o),glon1d_o(npts_o)) +! desc_grb2 = init_descriptor(igdtnum_o, igdtlen_o, igdtmpl_o) +! call init_grid(ip_grid_rll_o, desc_grb2) +! call gdswzd(ip_grid_rll_o, iopt, npts_o, fill, xpts1d_o, ypts1d_o, & +! glon1d_o, glat1d_o, nret) + call gdswzd(igdtnum_o, igdtmpl_o, igdtlen_o, iopt, npts_o, fill, xpts_o, ypts_o, & + glon_o, glat_o, nret) +! crot_o, srot_o, xlon_o, xlat_o, ylon_o, ylat_o, area_o) !<-- optional arguments + if (nret /= npts_o) then + write(6,'(1x,2(A,1x,I8))') & + 'ERROR: Checking --> NUMBER OF VALID POINTS RETURNED FROM GDSWZS (iopt=0) ', & + nret, ' DOES NOT MATCH TOTAL NUMBER of GRID POINTS ', npts_o + stop(4) + endif +#endif + if ( verbose ) then + write(6,'(1x,A,4(1x,A1,F8.3,1x,F8.3,A1))') & + 'LAT/LON at RLL domain corners (1,1), (1,JM), (IM,1) & (IM,JM): ', & + '(',glat_o(1,1),glon_o(1,1),')', & + '(',glat_o(1,jmdl_o),glon_o(1,jmdl_o), ')', & + '(',glat_o(imdl_o,1),glon_o(imdl_o,1), ')', & + '(',glat_o(imdl_o,jmdl_o),glon_o(imdl_o,jmdl_o),')' + write(6,'(1x,A,4(1x,A1,F8.3,1x,F8.3,A1))') & + 'XPTS/YPTS at RLL domain corners (1,1), (1,JM), (IM,1) & (IM,JM): ', & + '(',xpts_o(1,1),ypts_o(1,1),')', & + '(',xpts_o(1,jmdl_o),ypts_o(1,jmdl_o), ')', & + '(',xpts_o(imdl_o,1),ypts_o(imdl_o,1), ')', & + '(',xpts_o(imdl_o,jmdl_o),ypts_o(imdl_o,jmdl_o),')' + end if + +!--------------------------------------------------------------------------- +! 2. Read information of the output ESG grid in fv3_grid_specification file (netcdf) +!--------------------------------------------------------------------------- + write(6,'(1x,A)')'==================================================================' + esg_grid_spec_file_nc = "./fv3_grid_spec_esg.nc" + call check( nf90_open(esg_grid_spec_file_nc, nf90_nowrite, ncid) ) +!--- inquire dimension id and the dimension size + call check( nf90_inq_dimid(ncid, "grid_xt", xt_dimid) ) ! cell center + call check( nf90_inquire_dimension(ncid, xt_dimid, len = ipts_i) ) + call check( nf90_inq_dimid(ncid, "grid_yt", yt_dimid) ) ! cell center + call check( nf90_inquire_dimension(ncid, yt_dimid, len = jpts_i) ) + + npts_i = ipts_i * jpts_i + write(6,'(3(1x,A,I8))') 'intput ESG grid dimensions -- ipts_i= ', ipts_i, & + ' jpts_i= ', jpts_i, ' npts_i= ', npts_i + + allocate(glon_i(ipts_i, jpts_i)) + allocate(glat_i(ipts_i, jpts_i)) + + varname_nc = "grid_lont" + call check( nf90_inq_varid(ncid, trim(adjustl(varname_nc)), varid) ) + call check( nf90_get_var(ncid, varid, glon_i )) + write(6,'(1x,3A,4(1x,F12.6))') 'read-in ', trim(adjustl(varname_nc)), ' at 4 corners(ll->lu->ur->lr) =', & + glon_i(1,1),glon_i(1,jpts_i),glon_i(ipts_i,jpts_i),glon_i(ipts_i,1) + + varname_nc = "grid_latt" + call check( nf90_inq_varid(ncid, trim(adjustl(varname_nc)), varid) ) + call check( nf90_get_var(ncid, varid, glat_i )) + write(6,'(1x,3A,4(1x,F12.6))') 'read-in ', trim(adjustl(varname_nc)), ' at 4 corners(ll->lu->ur->lr) =', & + glat_i(1,1),glat_i(1,jpts_i),glat_i(ipts_i,jpts_i),glat_i(ipts_i,1) + + call check( nf90_close(ncid) ) + +!--------------------------------------------------------------------------- +! 3. Read input data on ESG grid (netcdf file) +!--------------------------------------------------------------------------- + input_data_esg_file_nc = "./input_data_esg.nc" + call check( nf90_open(input_data_esg_file_nc, nf90_nowrite, ncid) ) +!--- inquire dimension id of output data file + call check( nf90_inq_dimid(ncid, "xaxis_1", xdimid) ) + call check( nf90_inquire_dimension(ncid, xdimid, len = ipt2_i) ) + call check( nf90_inq_dimid(ncid, "yaxis_1", ydimid) ) + call check( nf90_inquire_dimension(ncid, ydimid, len = jpt2_i) ) + call check( nf90_inq_dimid(ncid, "Time", timedimid) ) +!--- check if dimensions of input data file (netcdf) match the dimensions of fv3_grid_spec file + if ( ipt2_i /= ipts_i .or. jpt2_i /= jpts_i ) then + write(6,'(1x,3A)') 'WARNING --> dimensions of input data file ', input_data_esg_file_nc, & + ' do NOT match dimensions of fv3_grid_spec file. <-- Warning' + write(6,'(1x,A,2(1x,I8))') 'dimension of input data file : ', ipt2_i, jpt2_i + write(6,'(1x,A,2(1x,I8))') 'dimension of fv3_grid_spec file : ', ipts_i, jpts_i + write(6,*) ' Check the dimenesions above. Now ABORT the task ...' + stop(5) + end if +!--- read sea-land mask in input data file (ESG grid) + allocate(slmask_i(ipts_i, jpts_i)) + varname_nc = "slmsk" + call check( nf90_inq_varid(ncid, trim(adjustl(varname_nc)), varid) ) + call check( nf90_get_var(ncid, varid, slmask_i )) + write(6,'(1x,3A,5(1x,F12.6))') 'read-in ', trim(adjustl(varname_nc)), & + ' at 4 corners & center =',slmask_i(1,1),slmask_i(1,jpts_i), & + slmask_i(ipts_i,jpts_i),slmask_i(ipts_i,1),slmask_i(ipts_i/2,jpts_i/2) + +!--- read the interested data on ESG grid + allocate(data_i(ipts_i, jpts_i)) + varname_nc = var_opts%var_ncf + call check( nf90_inq_varid(ncid, trim(adjustl(varname_nc)), varid) ) + call check( nf90_get_var(ncid, varid, data_i )) + write(6,'(1x,3A,5(1x,F12.6))') 'read-in full data ', trim(adjustl(varname_nc)), & + ' (on ESG grid at 4 corners and center)= ', data_i(1,1),data_i(1,jpts_i), & + data_i(ipts_i,jpts_i),data_i(ipts_i,1),data_i(ipts_i/2,jpts_i/2) + + call check( nf90_close(ncid) ) + write(6,'(1X,A,3(1X,F15.6))') "max/min/mean full variable data on ESG input grid : ", & + maxval(data_i), minval(data_i), sum(data_i)/npts_i + +!---- reading the firstguess on ESG grid if regridding the increments, not the full variable + if ( l_increment_intrp ) then ! if l_increment_intrp is true, then read the firstguess data + +!--- read the firstguess data on ESG grid + input_data_esg_file_fgs_nc = "./input_data_esg_fgs.nc" + call check( nf90_open(input_data_esg_file_fgs_nc, nf90_nowrite, ncid) ) +!--- inquire dimension id of output data file + call check( nf90_inq_dimid(ncid, "xaxis_1", xdimid) ) + call check( nf90_inquire_dimension(ncid, xdimid, len = ipt2_i) ) + call check( nf90_inq_dimid(ncid, "yaxis_1", ydimid) ) + call check( nf90_inquire_dimension(ncid, ydimid, len = jpt2_i) ) + call check( nf90_inq_dimid(ncid, "Time", timedimid) ) +!--- check if dimensions of firstguess data file (netcdf) match the dimensions of fv3_grid_spec file + if ( ipt2_i /= ipts_i .or. jpt2_i /= jpts_i ) then + write(6,'(1x,3A)') & + 'Dimensions of firstguess file do NOT match dimensions of fv3_grid_spec file.', & + 'dimension of input data file : ', ipt2_i, jpt2_i, & + 'dimension of fv3_grid_spec file : ', ipts_i, jpts_i, ' Abort ...' + stop(5) + end if +!--- read the firstguess data on ESG grid + allocate(data_fgs_i(ipts_i, jpts_i)) + varname_nc = var_opts%var_ncf + call check( nf90_inq_varid(ncid, trim(adjustl(varname_nc)), varid) ) + call check( nf90_get_var(ncid, varid, data_fgs_i )) + write(6,'(1x,3A,5(1x,F12.6))') 'read-in full firstguess data ', trim(adjustl(varname_nc)), & + ' (on ESG grid at 4 corners and center)= ', data_fgs_i(1,1),data_fgs_i(1,jpts_i), & + data_fgs_i(ipts_i,jpts_i),data_fgs_i(ipts_i,1),data_fgs_i(ipts_i/2,jpts_i/2) + call check( nf90_close(ncid) ) + write(6,'(1X,A,3(1X,F15.6))') "max/min full firstguess data on ESG input grid : ", & + maxval(data_fgs_i), minval(data_fgs_i), sum(data_fgs_i)/npts_i + +!---- calculate the increments --> subtracting firstguess from analysis + data_i(:,:) = data_i(:,:) - data_fgs_i(:,:) + deallocate(data_fgs_i) + write(6,'(1X,A,2(1X,F15.6))') "max/min increments on input ESG grid : ", & + maxval(data_i), minval(data_i) + + end if ! if ( l_increment_intrp ) + +!--------------------------------------------------------------------------- +! 3. Transfer input data from ESG grid to Rotated Grid (RLL) +!--------------------------------------------------------------------------- +! Note: +! the input "grid" is on ESG grid, is approximately treated as +! structured grid, and set up x-y ESG coordinates, then use +! 2-D interpolation. +!--------------------------------------------------------------------------- +! 3.1 set up the ESG grid parameters +!--------------------------------------------------------------------------- + call set_esg_gridopts(esg_opts) + if ( verbose) then + write(6,'(1X,A,7(1x,D))')'Pre-defined ESG parameters: A,Kappa,delx,dely,plat,plon,pazi=', & + esg_opts%A, esg_opts%Kappa, esg_opts%delx, esg_opts%dely, esg_opts%plat, & + esg_opts%plon, esg_opts%pazi + end if + +!--------------------------------------------------------------------------- +! 3.2.1 convert lat/lon of ESG grid points (input grid) +! to its x-y ESG coordinates +!--------------------------------------------------------------------------- + allocate (xpts_i(ipts_i,jpts_i),ypts_i(ipts_i,jpts_i)) + xpts_i = fill; ypts_i = fill; + call ll_to_xy_esg(ipts_i, jpts_i, ipts_i, jpts_i, esg_opts, glat_i, glon_i, xpts_i, ypts_i) + if ( verbose ) then + write(6,'(1x,A,2(1x,I8))') 'Dimensions of ESG grid: ', ipts_i, jpts_i + write(6,'(1x,A,4(/,A,2(1x,F12.4)))') & + 'X/Y of ESG grid corner points in ESG x/y coords: ', & + 'lower-left :',xpts_i(1,1), ypts_i(1,1), & + 'upper-left :',xpts_i(1,jpts_i), ypts_i(1,jpts_i), & + 'lower-right:',xpts_i(ipts_i,1), ypts_i(ipts_i,1), & + 'upper-right:',xpts_i(ipts_i,jpts_i), ypts_i(ipts_i,jpts_i) +!--- to check if there is differences between the grid indices and +! the computed x/y coordinates for ESG grid itseld + allocate(diff_xy(ipts_i,jpts_i)) + do jj = 1, jpts_i + do ii = 1, ipts_i + diff_xy(ii,jj) = sqrt( (xpts_i(ii,jj)-float(ii))**2 + (ypts_i(ii,jj)-float(jj))**2 ) + end do + end do + write(6,'(1x,A,2(1x,F8.4))') & + 'Max/Min differences of X-Y ESG coords (computed vs. index)= ', & + maxval(diff_xy),minval(diff_xy) + if ( maxval(diff_xy) > 0.01_dp ) then + write(6,'(1x,A)') & + 'The computed X/Y coordinates are very different to its grid indices. Stop. Please Check ...' + stop(10) + end if + deallocate(diff_xy) + end if +!--------------------------------------------------------------------------- +! 3.2.2 convert lat/lon of rotated-latlon (RLL) grid points (output grid) +! to x-y ESG coordinates +!--------------------------------------------------------------------------- + if (allocated(xpts_o)) deallocate(xpts_o) + if (allocated(ypts_o)) deallocate(ypts_o) + allocate (xpts_o(imdl_o,jmdl_o),ypts_o(imdl_o,jmdl_o)) + xpts_o = fill; ypts_o = fill; + call ll_to_xy_esg(ipts_i, jpts_i, imdl_o, jmdl_o, esg_opts, glat_o, glon_o, xpts_o, ypts_o) + if ( verbose ) then + write(6,'(1x,2(A,2(1x,I8)))') 'Dimensions of RLL grid: ', imdl_o, jmdl_o + write(6,'(1x,2(A,2(1x,I8)))') 'Dimensions of ESG grid: ', ipts_i, jpts_i + write(6,'(1x,A,2(1x,F13.3))') 'max/min X of RLL in ESG x-y coordinates: ', & + maxval(xpts_o),minval(xpts_o) + write(6,'(1x,A,2(1x,F13.3))') 'max/min Y of RLL in ESG x-y coordinates: ', & + maxval(ypts_o),minval(ypts_o) + write(6,'(1x,A,4(/,A,2(1x,F12.4)))') & + 'X/Y of RLL grid corner points in ESG x/y coords: : ', & + 'lower-left :',xpts_o(1,1), ypts_o(1,1), & + 'upper-left :',xpts_o(1,jmdl_o), ypts_o(1,jmdl_o), & + 'lower-right:',xpts_o(imdl_o,1), ypts_o(imdl_o,1), & + 'upper-right:',xpts_o(imdl_o,jmdl_o), ypts_o(imdl_o,jmdl_o) + end if +!--------------------------------------------------------------------------- +! 3.3 interpolation from ESG to RLL (in ESG X-Y coordinates) +!--------------------------------------------------------------------------- + allocate(data_o(imdl_o, jmdl_o)) + allocate(data_tmp_o(imdl_o, jmdl_o)) + allocate(data_fgs_o(imdl_o, jmdl_o)) + allocate(output_bitmap_2d(imdl_o, jmdl_o)) +!--- reshaping 1-D output array to 2-D array + data_fgs_o = reshape(output_data, (/imdl_o, jmdl_o/), order=(/1,2/)) + output_bitmap_2d = reshape(output_bitmap, (/imdl_o, jmdl_o/), order=(/1,2/)) + data_tmp_o = 0.0_dp + data_o = data_fgs_o ! intialization by filling with original/firstguess data on RLL grid from grib2 file + + if(interp_opt.eq.2)then + + print*,'Using BSWI-2, interp_opt= ', interp_opt + +! nn = 0 + do jj=1,jmdl_o + do ii=1,imdl_o + +! nn = nn + 1 +! data_fgs_o(ii,jj) = output_data(nn) +! output_bitmap_2d(ii,jj) = output_bitmap(nn) + + iii = dint(xpts_o(ii,jj)) + jjj = dint(ypts_o(ii,jj)) + + call abswi2(1,ipts_i,1,jpts_i,data_i,xpts_o(ii,jj),ypts_o(ii,jj),data_tmp_o(ii,jj),ff) + +!--- only use regridded data at that grid point if it is inside ESG grid domain + if(iii .ge. 1 .and. jjj .ge. 1 .and. iii .le. (ipts_i - 1) .and. jjj .le. (jpts_i - 1) )then + if ( l_increment_intrp ) then + data_o(ii,jj) = data_fgs_o(ii,jj) + data_tmp_o(ii,jj) ! regridding with increment data_i + else + data_o(ii,jj) = data_tmp_o(ii,jj) ! regridding with full variable data_i + end if + else + data_o(ii,jj) = data_fgs_o(ii,jj) ! if outside ESG grid domain, using orig/fgs value in grib2 file + end if +!--- calculate the regridded analysis increment on output (RLL) grid + data_tmp_o(ii,jj) = data_o(ii,jj) - data_fgs_o(ii,jj) + + enddo + enddo +!--- check the regridded data on the output grid (RLL) + write(6,'(1X,A,2(1X,F15.6))') "max/min regridded increments on output RLL grid : ", & + maxval(data_tmp_o), minval(data_tmp_o) + write(6,'(1X,A,2(1X,F15.6))') "max/min orig/firstguess full data on output RLL grid : ", & + maxval(data_fgs_o), minval(data_fgs_o) + write(6,'(1X,A,2(1X,F15.6))') "max/min regridded full data on output RLL grid : ", & + maxval(data_o), minval(data_o) + + else + + write(6,'(1x,A,I4,A)') "Unknown Interp_opt=", interp_opt, & + " Current code only accept interp_opt = 2. Task is abnormally terminated!" + stop(7) + + endif + +! check the regridded data on the output grid (RLL) + write(6,'(1x,A)')'==================================================================================' + write(6,'(1X,A,2(1X,F15.6))') "max/min orig/firstguess full data on output RLL grid : ", & + maxval(data_fgs_o), minval(data_fgs_o) + write(6,*) " ====> before set contraint to regridded data <=== " + write(6,'(1X,A,2(1X,F15.6))') "max/min regridded increments on output RLL gridi: ", & + maxval(data_tmp_o), minval(data_tmp_o) + write(6,'(1X,A,2(1X,F15.6))') "max/min regridded full data on output RLL grid : ", & + maxval(data_o), minval(data_o) + +!--- applying the specific contraints to the regridded variables +!--- non-negative feature + if ( var_opts%varname == "howv" ) then + where(data_o .lt. 0.0 ) data_o = 0.0_dp ! wave height >=0 + else if ( var_opts%varname == "gust" ) then + where(data_o .lt. 0.0 ) data_o = 0.0_dp ! wind gust >=0 + end if + data_tmp_o = data_o - data_fgs_o ! re-compute the analysis increments +!--- using bitmap (from original grib2 data on output RLL grid) to mask out invalid grid point +! Note: +! for significant wave height (howv), this action masks out data over land; +! for 10-m wind gust(gust), this action masks out data outside ESG domain. +! where( .not. output_bitmap_2d ) data_o = data_fgs_o + where( .not. output_bitmap_2d ) + data_o = undef_real + data_tmp_o = undef_real + end where + write(6,*) " ====> after set contraint to regridded data <=== " + write(6,'(1X,A,2(1X,F15.6))') "max/min regridded increments on output RLL grid : ", & + maxval(data_tmp_o, MASK=data_tmp_o .ne. undef_real), & + minval(data_tmp_o, MASK=data_tmp_o .ne. undef_real) + write(6,'(1X,A,2(1X,F15.6))') "max/min regridded full data on output RLL grid : ", & + maxval(data_o, MASK=data_o .ne. undef_real), & + minval(data_o, MASK=data_o .ne. undef_real) + write(6,'(1x,A)')'==================================================================================' + +!--------------------------------------------------------------------------- +! 4. Output the regrided data on RLL grid to a new file (netcdf) +!--------------------------------------------------------------------------- +!--- Create the netcdf file + output_data_rll_file_nc = "./output_data_rll.nc" + call check(nf90_create(trim(output_data_rll_file_nc), nf90_netcdf4, ncid)) + +! call check( nf90_redef(ncid) ) +!- Define the dimensions + call check(nf90_def_dim(ncid, "X", imdl_o, dimid_x)) + call check(nf90_def_dim(ncid, "Y", jmdl_o, dimid_y)) + call check(nf90_def_dim(ncid, "Time", nf90_unlimited, dimid_time)) + +!- Define rotated lat/lon variables + call check(nf90_def_var(ncid, "rotlon", nf90_double, (/dimid_x /), varid_rlon)) + call check(nf90_def_var(ncid, "rotlat", nf90_double, (/dimid_y/), varid_rlat)) +!- Define true earth lat/lon variables + call check(nf90_def_var(ncid, "geolon", nf90_double, (/dimid_x, dimid_y/), varid_glon)) + call check(nf90_def_var(ncid, "geolat", nf90_double, (/dimid_x, dimid_y/), varid_glat)) + +!- Define data variables + varname_nc=trim(adjustl(var_opts%var_ncf)) + call check(nf90_def_var(ncid, trim(adjustl(varname_nc)), nf90_double, & + (/dimid_x, dimid_y, dimid_time/), varid_data, & + contiguous=.false., & + chunksizes=(/imdl_o, jmdl_o, 1/), & + shuffle = .true., fletcher32 = .true., & + endianness = nf90_endian_little) ) + call check( nf90_def_var_fill(ncid, varid_data, 0, undef_real) ) ! set FillValue + +!- Add the attributes + call check(nf90_put_att(ncid, nf90_global, 'description', 'RRFS-3DRTMA 2-D Field on NA-3km domain')) + call check(nf90_put_att(ncid, nf90_global, 'note', 'Rotated Lat/Lon Grid')) + call check(nf90_put_att(ncid, nf90_global, 'Projection', 'Rotated Lat/Lon Grid')) + call check(nf90_put_att(ncid, nf90_global, 'lon_ll_rll', rll_opts%llcnr(1))) + call check(nf90_put_att(ncid, nf90_global, 'lat_ll_rll', rll_opts%llcnr(2))) + call check(nf90_put_att(ncid, nf90_global, 'lon_ur_rll', rll_opts%urcnr(1))) + call check(nf90_put_att(ncid, nf90_global, 'lat_ur_rll', rll_opts%urcnr(2))) + call check(nf90_put_att(ncid, nf90_global, 'dlon_rll', rll_opts%dlon)) + call check(nf90_put_att(ncid, nf90_global, 'dlat_rll', rll_opts%dlat)) + call check(nf90_put_att(ncid, nf90_global, 'latitude_domain_center', rll_opts%ctr_lat)) + call check(nf90_put_att(ncid, nf90_global, 'longitude_domain_center', rll_opts%ctr_lon)) + call check(nf90_put_att(ncid, nf90_global, 'latitude_south_pole_rotated', rll_opts%sp_lat)) + call check(nf90_put_att(ncid, nf90_global, 'longitude_south_pole_rotated', rll_opts%sp_lon)) + call check(nf90_put_att(ncid, nf90_global, 'azimuth_rotated', 0.0)) + call check(nf90_put_att(ncid, varid_glon, 'description', 'Earth geographical longitude')) + call check(nf90_put_att(ncid, varid_glon, 'units', 'degree_east')) + call check(nf90_put_att(ncid, varid_glat, 'description', 'Earth geographical latitude')) + call check(nf90_put_att(ncid, varid_glat, 'units', 'degree_north')) + call check(nf90_put_att(ncid, varid_rlon, 'description', 'rotated longitude')) + call check(nf90_put_att(ncid, varid_rlon, 'units', 'degree_east')) + call check(nf90_put_att(ncid, varid_rlat, 'description', 'rotated latitude')) + call check(nf90_put_att(ncid, varid_rlat, 'units', 'degree_north')) + call check(nf90_put_att(ncid, varid_data, 'units', var_opts%units)) + call check(nf90_put_att(ncid, varid_data, 'description', var_opts%description)) + +!--- End definition of variables + call check( nf90_enddef(ncid) ) + +!--- Write the data to new netcdf file + call check(nf90_put_var(ncid, varid_glon, real(glon_o,8))) + call check(nf90_put_var(ncid, varid_glat, real(glat_o,8))) + + allocate(rotlon(imdl_o)) + allocate(rotlat(jmdl_o)) + do iii = 1, imdl_o + rotlon(iii) = rll_opts%llcnr(1) + rll_opts%dlon*(iii-1) + if (rotlon(iii) >= 360.0_dp ) rotlon(iii) = rotlon(iii) - 360.0_dp + if (rotlon(iii) < 0.0_dp ) rotlon(iii) = rotlon(iii) + 360.0_dp + end do + do jjj = 1, jmdl_o + rotlat(jjj) = rll_opts%llcnr(2) + rll_opts%dlat*(jjj-1) + end do + call check(nf90_put_var(ncid, varid_rlon, rotlon)) + call check(nf90_put_var(ncid, varid_rlat, rotlat)) + + call check(nf90_put_var(ncid, varid_data, data_o)) + +!- Close the dataset + call check( nf90_close(ncid) ) + +!------------------------------------------------------------------------ +! 5. Finalize +!-----------------------------------------------------------------------! +!--- clean the memory + deallocate(igdtmpl_o) + deallocate(output_data) + deallocate(output_bitmap) + deallocate(ibo) + deallocate(xpts_o, ypts_o) + deallocate(glat_o, glon_o) + deallocate(output_bitmap_2d) + deallocate(data_o) + deallocate(data_fgs_o) + deallocate(data_tmp_o) + deallocate(rotlon, rotlat) + + deallocate(xpts_i, ypts_i) + deallocate(glat_i, glon_i) + deallocate(slmask_i) + deallocate(data_i) + enddo + +!--- close grib file + call baclose(iunit, iret) + if (iret /= 0) stop 'Error: baclose failed.' + +!--- free the memory usage by gfld + call gf_free(gfld_input) + +!----------------------------------------------------------------------- + contains +! + subroutine check(status) + integer,intent(in) :: status +! + if(status /= nf90_noerr) then + print *, trim(nf90_strerror(status)) + stop "Stopped for nf90 error." + end if + return + end subroutine check +!----------------------------------------------------------------------- +! +!================================================================================ +end program rtma_regrid_esg2rll diff --git a/rtma_esg_conversion.fd/rtma_regrid_rll2esg.F90 b/rtma_esg_conversion.fd/rtma_regrid_rll2esg.F90 new file mode 100644 index 0000000..7f3619b --- /dev/null +++ b/rtma_esg_conversion.fd/rtma_regrid_rll2esg.F90 @@ -0,0 +1,529 @@ +program rtma_regrid_rll2esg +!================================================================================ + use omp_lib + use netcdf ! netcdf lib + use pkind, only: dp, sp, dpi, spi ! Jim Purser's lib + use pietc, only: dtor,rtod ! Jim Purser's lib +! use gdswzd_mod, only: gdswzd ! ip lib (for conversion from earth to grid coor or vice versa) +!-- required when using iplib v4.0 or higher +#ifndef IP_V3 +! use ip_mod ! ip lib v4 or above (for interpolation) + use ipolates_mod ! ip lib v4 or above (for interpolation) +#endif + use grib_mod ! g2 lib(grib) + use bacio_module ! prerequisite for g2 lib (grib) + use mod_rtma_regrid, only: rotated_gridopts, variable_options, esg_gridopts + use mod_rtma_regrid, only: set_esg_gridopts, set_variable_options, & + check_varopts_grb2, set_time4data, & + check_grbmsg, set_rllgridopts, & + set_bitmap_grb2, check_data_1d_with_bitmap, & + ll_to_xy_esg +#ifdef IP_V3 + use mod_rtma_regrid, only: gdt2gds_rll +#endif + + implicit none + + real(dp), parameter :: undef_real = -9999.00_dp + integer, parameter :: undef_int = -9999 + + type(gribfield) :: gfld_input + type(rotated_gridopts) :: rll_opts + type(variable_options) :: var_opts + + character(len=100) :: input_data_rll_file_grb2 + character(len=100) :: esg_grid_spec_file_nc + character(len=100) :: output_data_esg_file_nc + character(len=20) :: varname_nc + character(len=20) :: varname_input + + + integer :: iunit, iret, lugi + + integer :: ip, ipopt(20) ! parameters for interpolation + + integer :: j, jdisc, jpdtn, jgdtn, k + integer :: jids(200), jgdt(200), jpdt(200) + integer, allocatable :: igdtmpl_i(:) + integer :: igdtlen_i + integer :: igdtnum_i + +#ifdef IP_V3 + integer :: igdt_grb2(5) + integer :: idefnum ! The number of entries in array ideflist, i.e. number + ! of rows (or columns) for which optional grid points are defined. + integer, allocatable :: ideflist(:) ! integer array containing the number of grid points contained in + ! each row (or column). To handle the irregular grid stuff. + integer :: kgds_rll_i(200) ! grib1 GDS for rotated_latlon grid + integer :: kgds_esg_o(200) ! grib1 GDS for esg grid (used in ip lib v3.x and older) + integer :: igrid_rll_i ! ncep re-defined grib1 grid number +#else + integer :: igdtlen_o + integer :: igdtnum_o + integer, allocatable :: igdtmpl_o(:) +#endif + + integer :: mi + integer :: imdl_i, jmdl_i ! dimension size read in grib2 data file + integer :: npts_i + logical :: unpack + integer, allocatable :: ibi(:) + logical*1, allocatable :: input_bitmap(:,:) ! 2D array to match ipolates_grib2 + real(dp), allocatable :: input_data(:,:) ! 2D array to match ipolates_grib2 + + integer :: adate(5) ! year/month/day/hour/minute + character(len=12) :: cdate ! yyyymmddhhmn + + integer :: km + + integer :: mo, no + integer :: ipts_o, jpts_o ! dimension size read in netcdf data file + integer :: ipt2_o, jpt2_o ! dimension size read in netcdf data file + integer :: npts_o + + integer, allocatable :: ibo(:) + logical*1, allocatable :: output_bitmap(:,:) ! 2D array to match ipolates_grib2 + real(dp), allocatable :: output_data(:,:) ! 2D array to match ipolates_grib2 + real(dp), allocatable :: output_glat(:) ! 2D Data in 1D array + real(dp), allocatable :: output_glon(:) ! 2D Data in 1D array + + real, allocatable :: glon_o(:,:), glat_o(:,:) + real, allocatable :: slmask_o(:,:) + real, allocatable :: data_o(:,:) + + integer :: ncid, varid + integer :: xdimid, ydimid, timedimid + integer :: xt_dimid, yt_dimid + integer :: data_varid + + logical*1 :: l_clean_bitmap ! if true, then set bitmap = true everywhere + logical*1 :: verbose + + character(100) :: fname_nml + logical :: f_exist + integer :: lunin_nml + + namelist/setup/varname_input, verbose, l_clean_bitmap +#ifdef IP_V3 + external :: ipolates +#endif + +!----------------------------------------------------------------------- + interface + + subroutine baopenr(iunit, input_file, iret) + integer, intent(in ) :: iunit + character(len=*), intent(in ) :: input_file + integer, intent( out) :: iret + end subroutine baopenr + + subroutine baclose(iunit, iret) + integer, intent(in ) :: iunit + integer, intent( out) :: iret + end subroutine baclose + + subroutine getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + use grib_mod + integer, intent(in ) :: lugb, lugi, j, jdisc, jpdtn, jgdtn + integer, dimension(:), intent(in ) :: jids(*), jpdt(*), jgdt(*) + logical, intent(in ) :: unpack + integer, intent( out) :: k, iret + type(gribfield), intent( out) :: gfld + end subroutine getgb2 + + subroutine gf_free(gfld) + use grib_mod + type(gribfield), intent(in ) :: gfld + end subroutine gf_free + + end interface +!--------------------------------------------------------------------------- +! 0. reading the namelist +!--------------------------------------------------------------------------- +!--- initialising the namelist variables first + l_clean_bitmap = .false. ! do not reset bitmap to be true in whole domain (default) + verbose = .false. + varname_input = '' + + f_exist = .false. + lunin_nml = 10 +!-- reading namelist + fname_nml = 'rll2esg_namelist' + inquire(file=trim(adjustl(fname_nml)),exist=f_exist) + if (f_exist) then + write(6,*) 'reading from namelist: ', trim(adjustl(fname_nml)) + open(lunin_nml, file=trim(adjustl(fname_nml)), form='formatted', status='old') + read(lunin_nml, setup) + close(lunin_nml) + write(6,*) "checking the setup info in namelist:" + write(6,setup) + else + write(6,'(1x,2A)') & + "Abort..., failed to find the required namelist file: ", trim(adjustl(fname_nml)) + stop(99) + end if + if (trim(adjustl(varname_input)) == '') then + write(6,*) "Abort..., must set varname_input in namelist (e.g., varname_input='howv')" + stop(1) + else + var_opts%varname = trim(adjustl(varname_input)) + call set_variable_options(var_opts, iret) + if ( iret /= 0 ) then + write(6,'(1x,3A)') 'This program cannot process this variable : ', & + trim(adjustl(var_opts%varname)), ', task is ABORTED !!!!' + stop(2) + end if + end if + +!--------------------------------------------------------------------------- +! 1. Read the input data and the input grid info (grib2 file, on rotated grid) +!--------------------------------------------------------------------------- +! 1.1 opening the grib 2 file containing data to be interpolated. +! Note: for this example, there are only one data record +! (HTSGW or GUST) in grib2 file. +!--------------------------------------------------------------------------- + iunit=9 + input_data_rll_file_grb2="./input_data_rll.grib2" + call baopenr(iunit, input_data_rll_file_grb2, iret) + if (iret /= 0) then + write(6,*) 'return from baopenr: ',iret + stop 'Error: baopenr failed.' + end if + +!--------------------------------------------------------------------------- +! 1.2 preparing for call to g2 library to degrib data. +! Note: the data are assumed to be on a rotated-lat/lon grid +! with i/j dimension of 360/181. +!--------------------------------------------------------------------------- + jdisc = -1 ! search for any discipline + jpdtn = -1 ! search for any product definition template number + jgdtn = -1 ! search for grid definition template number + ! 0 - regular lat/lon grid is expected. + ! 1 - rotated lat/lon grid is expected. + jids = -9999 ! array of values in identification section, set to wildcard + jgdt = -9999 ! array of values in grid definition template 3.m + jpdt = -9999 ! array of values in product definition template 4.n + unpack = .true. ! unpack data + lugi = 0 ! no index file (if using index file, set lugi = iunit) + + nullify(gfld_input%idsect) + nullify(gfld_input%local) + nullify(gfld_input%list_opt) + nullify(gfld_input%igdtmpl) ! holds the grid definition template information + nullify(gfld_input%ipdtmpl) + nullify(gfld_input%coord_list) + nullify(gfld_input%idrtmpl) + nullify(gfld_input%bmap) ! holds the bitmap + nullify(gfld_input%fld) ! holds the data + +!--------------------------------------------------------------------------- +! 1.3 degrib the data. non-zero "iret" indicates a problem during degrib. +!--------------------------------------------------------------------------- + km = 1 ! number of records to interpolate (in this example, only one record) + + do j = 0, (km-1) + + call getgb2(iunit, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld_input, iret) + + if (iret /= 0) then + write(6,'(1x,A,I4,A)') 'return from sub getgb2: ', iret, ' --> Error: getb2 failed.' + stop(2) + end if + if ( verbose ) call check_grbmsg(gfld_input) + +!--- check up if the variable in grib2 file matches the requried variable + call check_varopts_grb2(gfld_input,var_opts,iret) + if ( iret /= 0 ) then + write(6,'(1x,3A)') 'Warning: Required variable name [', & + trim(adjustl(var_opts%varname)), & + '] does not match the variable in grib2 file. Task is ABORTED ... ' + stop(3) + end if + +!--- date/time info of input date + call set_time4data(gfld_input, adate, cdate) + +!--- input grid template information +! + imdl_i = gfld_input%igdtmpl(8) ! x-dimension of input grid + jmdl_i = gfld_input%igdtmpl(9) ! y-dimension of input grid + npts_i = imdl_i * jmdl_i ! total dimension of input grid + mi = npts_i ! total number of pts, input grid + write(6,'(1x,A,3(1x,I8))') & + 'dimension of input grid (Nx, Ny, Nx*Ny) = ', imdl_i, jmdl_i, npts_i + +! jgdtn was set to be -1 so getgb2 would search for grid template number. +! So after getgb2, jgdtn is still -1, but the true grid template number +! is gfld_input%igdtnum. + igdtnum_i = gfld_input%igdtnum + if (igdtnum_i == 1) then + write(6,'(1x,A)') "input model grid is defined on rotated lat-lon grid, as expected." + call set_rllgridopts(gfld_input, rll_opts) + else + write(6,'(1x,A,I12.12)') & + "input model grid is defined on the grid with grid template number = ",igdtnum_i + write(6,'(1x,A)') ' However, a Rotated Lat-Lon Grid is expected. So Abort this running ...' + stop(-1) + end if + + igdtlen_i = gfld_input%igdtlen + allocate(igdtmpl_i(igdtlen_i)) + igdtmpl_i(:) = gfld_input%igdtmpl(:) + +!--------------------------------------------------------------------------- +! 1.4 checking up with input model data (and its bitmap, etc.) +!--------------------------------------------------------------------------- +!--- input data field decoded in grib2 file +! allocate(input_data(npts_i)) + allocate(input_data(npts_i, 1)) + input_data(:,1) = gfld_input%fld ! the input data field + +!--- does input data have a bitmap? + allocate(ibi(1)) + allocate(input_bitmap(npts_i, 1)) +! allocate(input_bitmap(npts_i)) + l_clean_bitmap = .False. ! do not re-set bitmap to be true everywhere + call set_bitmap_grb2(gfld_input,npts_i,l_clean_bitmap,ibi,input_bitmap(:,1)) + +!--- checking if existing any abnormal data values and counting data with false bitmap + write(6,*)'----------------------------------------------------------' + write(6,*)'checking the input data read from grib2 fie:' + write(6,*)'----------------------------------------------------------' + call check_data_1d_with_bitmap(var_opts,npts_i,input_data(:,1),ibi,input_bitmap(:,1)) + +#ifdef IP_V3 +!-------------------------------------------------------------------------------------! +! 1.5 converting GRIB2 GDT info to GIB1 GDS info for ! +! compatibility backwards with IP lib v3 and older ! +! As required by IP lib v3.x or older, subroutine ipolates requires grib1 GDS info,! +! (in IP lib v4 & above, ipolates works with either grib1 GDS or grib2 GDT info), ! +! so need to convert grid informaton from GRIB2 Grid Description Section (GDS) info! +! (including its Grid Definition Template) to GRIB1 GDS info ! +! (similarly as decoded by w3fi63) ! +!-------------------------------------------------------------------------------------! + igdt_grb2(1) = 0 ! Source of Grid Definition (0: then specified in Code Table 3.1) + igdt_grb2(2) = npts_i ! Number of Data Points in the defined grid + igdt_grb2(3) = 0 ! Number of octets needed for each additional grid definition (if 0: using regular grid) + igdt_grb2(4) = 0 ! Interpetation of list of for optional points definition (Table 3.11) + igdt_grb2(5) = igdtnum_i ! GrdDefTmplt number(Table 3.1): 1--> rotated latlon grid (Template 3.1) + idefnum = 0 ! no irregular grid stuff + allocate(ideflist(1)) + ideflist(:) = 0 ! no irregular grid stuff + call gdt2gds_rll(igdt_grb2, igdtlen_i, igdtmpl_i, kgds_rll_i, igrid_rll_i, iret) + deallocate(ideflist) + if ( verbose ) write(6,*) ' checking kgds calculated by gdt2gds_rll : ', kgds_rll_i +#endif + +!--------------------------------------------------------------------------- +! 2. Read information of the output ESG grid in fv3_grid_specification file (netcdf) +!--------------------------------------------------------------------------- + esg_grid_spec_file_nc = "./fv3_grid_spec_esg.nc" + call check( nf90_open(esg_grid_spec_file_nc, nf90_nowrite, ncid) ) +!--- inquire dimension id and the dimension size + call check( nf90_inq_dimid(ncid, "grid_xt", xt_dimid) ) ! cell center + call check( nf90_inquire_dimension(ncid, xt_dimid, len = ipts_o) ) + call check( nf90_inq_dimid(ncid, "grid_yt", yt_dimid) ) ! cell center + call check( nf90_inquire_dimension(ncid, yt_dimid, len = jpts_o) ) + + npts_o = ipts_o * jpts_o + write(6,*)'==========================================================' + write(6,*)'- Checking the output grid (ESG grid) -' + write(6,*)'----------------------------------------------------------' + write(6,'(3(1x,A,I8))') 'output ESG grid dimensions -- ipts_o= ', & + ipts_o, ' jpts_o= ', jpts_o, ' npts_o= ', npts_o + + allocate(glon_o(ipts_o, jpts_o)) + allocate(glat_o(ipts_o, jpts_o)) + + varname_nc = "grid_lont" + call check( nf90_inq_varid(ncid, trim(adjustl(varname_nc)), varid) ) + call check( nf90_get_var(ncid, varid, glon_o )) + write(6,'(1x,3A,4(1x,F12.6))') 'read-in ', trim(adjustl(varname_nc)), ' at 4 corners =', & + glon_o(1,1),glon_o(1,jpts_o),glon_o(ipts_o,jpts_o),glon_o(ipts_o,1) + + varname_nc = "grid_latt" + call check( nf90_inq_varid(ncid, trim(adjustl(varname_nc)), varid) ) + call check( nf90_get_var(ncid, varid, glat_o )) + write(6,'(1x,3A,4(1x,F12.6))') 'read-in ', trim(adjustl(varname_nc)), ' at 4 corners =', & + glat_o(1,1),glat_o(1,jpts_o),glat_o(ipts_o,jpts_o),glat_o(ipts_o,1) + + call check( nf90_close(ncid) ) + +!--------------------------------------------------------------------------- +! 3. Transfer input data from Rotated Grid (RLL) to ESG grid +! with interpolation +!--------------------------------------------------------------------------- +! Note: +! the output "grid" is ESG grid, treated as a series of random +! station points. In this case, set the grid definition template +! number of a negative number. The grid definition template array +! information is not used, so set to a flag value. +!--------------------------------------------------------------------------- +! 3.1 setup arguments for ipolates (scalar interpolation) call +!--------------------------------------------------------------------------- + mo = npts_o + no = mo + allocate (ibo(1)) + allocate (output_glat(mo)) + allocate (output_glon(mo)) + allocate (output_data(mo,1)) + allocate (output_bitmap(mo,1)) +!--- rehsaping 2D array to 1D array required by ipolates + output_glon = reshape(glon_o, (/npts_o/)) + output_glat = reshape(glat_o, (/npts_o/)) + + ip = 0 ! bilinear interpolation + ipopt(:) = 0 ! options for bilinear + ipopt(1) = 75 ! set minimum mask to 75% + +!--------------------------------------------------------------------------- +! 3.2 call ipolates to interpolate scalar data. +! non-zero "iret" indicates a problem. +! Note: +! the output "grid" is ESG grid, treated as a series of random +! station points in the interpolation with IP lib. +! In this case, set the grid definition template +! number of a negative number. The grid definition template array +! information is not used, so set to a flag value. +!--------------------------------------------------------------------------- +#ifdef IP_V3 +!-------------------------------------------------------------------------------------! +! As required by IP lib v3.x or older, ipolates requires grib1 GDS info, ! +!-------------------------------------------------------------------------------------! +!--- ESG grid points are treated as random station points in the interpolation. + kgds_esg_o(:) = 0 + kgds_esg_o(1) = -1 ! KGDSO(1)<0 IMPLIES RANDOM STATION POINTS + write(6,*) ' call ipolates with IP lib v3.x and older) ... ' + call ipolates(ip, ipopt, kgds_rll_i, kgds_esg_o, & + mi, mo, km, ibi, input_bitmap, input_data, no, output_glat, & + output_glon, ibo, output_bitmap, output_data, iret) +#else +!-------------------------------------------------------------------------------------! +! In IP lib v4 and above, ipolates works with either grib1 GDS or grib2 GDT info. ! +!-------------------------------------------------------------------------------------! +!--- ESG grid points are treated as random station points in the interpolation. + igdtnum_o = -1 ! set the grid definition template number of a negative number + igdtlen_o = 1 + allocate(igdtmpl_o(igdtlen_o)) + igdtmpl_o = -9999 ! grid definition template array info is not use, set to a flag value. + write(6,*) ' call ipolates(==>ipolates_grib2 with IP lib v4.x and above) ... ' + call ipolates(ip, ipopt, igdtnum_i, igdtmpl_i, igdtlen_i, & + igdtnum_o, igdtmpl_o, igdtlen_o, & + mi, mo, km, ibi, input_bitmap, input_data, no, output_glat, & + output_glon, ibo, output_bitmap, output_data, iret) + deallocate(igdtmpl_o) +#endif + if (iret /= 0) then + write(6,'(1x,A,I4,A)') ' ipolates failed with returned value iret = ', iret, '.' + stop(7) + else + write(6,*) ' ipolates was done successfully.' + end if +!--- checking if existing any abnormal data values and counting data with false bitmap + write(6,*)'----------------------------------------------------------' + write(6,*)'checking the regridded data interpolated by subroutine ipolates_grib2:' + call check_data_1d_with_bitmap(var_opts,npts_o,output_data,ibo,output_bitmap) + +!--------------------------------------------------------------------------- +! 4. Output(appending) the regrided output data to the existing ESG grid file (netcdf) +!--------------------------------------------------------------------------- + output_data_esg_file_nc = "./output_data_esg.nc" + call check( nf90_open(output_data_esg_file_nc, nf90_write, ncid) ) +!--- inquire dimension id of output data file + call check( nf90_inq_dimid(ncid, "xaxis_1", xdimid) ) + call check( nf90_inquire_dimension(ncid, xdimid, len = ipt2_o) ) + call check( nf90_inq_dimid(ncid, "yaxis_1", ydimid) ) + call check( nf90_inquire_dimension(ncid, ydimid, len = jpt2_o) ) + call check( nf90_inq_dimid(ncid, "Time", timedimid) ) +!--- check if dimension size of output data file match the dimension size of fv3_grid_spec file + if ( ipt2_o /= ipts_o .or. jpt2_o /= jpts_o ) then + write(6,'(1x,3A)') 'WARNING --> dimensions of output data file ', output_data_esg_file_nc, & + ' do NOT match dimensions of fv3_grid_spec file. <-- Warning' + write(6,'(1x,A,2(1x,I8))') 'dimension of output data file : ', ipt2_o, jpt2_o + write(6,'(1x,A,2(1x,I8))') 'dimension of fv3_grid_spec file : ', ipts_o, jpts_o + write(6,*) ' Check the dimenesions above. Now ABORT the task ...' + stop(5) + end if +!--- read sea-land mask in ESG data file + allocate(slmask_o(ipts_o, jpts_o)) + varname_nc = "slmsk" + call check( nf90_inq_varid(ncid, trim(adjustl(varname_nc)), varid) ) + call check( nf90_get_var(ncid, varid, slmask_o )) + write(6,'(1x,3A,5(1x,F12.6))') 'read-in ', trim(adjustl(varname_nc)), & + ' at 4 corners & center =',slmask_o(1,1),slmask_o(1,jpts_o), & + slmask_o(ipts_o,jpts_o),slmask_o(ipts_o,1),slmask_o(ipts_o/2,jpts_o/2) + +!--- reshaping 1-D output array to 2-D array + allocate(data_o(ipts_o, jpts_o)) + data_o = reshape(output_data(:,1), (/ipts_o, jpts_o/), order=(/1,2/)) + +!--- applying some constraints to the regridded variables + if ( var_opts%varname == "howv" ) then + where(slmask_o .gt. 0.01 ) data_o = 0.0_dp ! re-set wave height to be 0 over the land area + where(data_o .lt. 0.0 ) data_o = 0.0_dp ! wave height >=0 + else if ( var_opts%varname == "gust" ) then + where(data_o .lt. 0.0 ) data_o = 0.0_dp ! wind gust >=0 + end if + +!--- define new variable for the regridded data and output + call check( nf90_redef(ncid) ) + varname_nc=trim(adjustl(var_opts%varname)) +! call check( nf90_def_var(ncid, trim(adjustl(varname_nc)), nf90_double, & + call check( nf90_def_var(ncid, trim(adjustl(varname_nc)), nf90_float, & + (/ xdimid, ydimid, timedimid /), data_varid, & + contiguous=.false., & + chunksizes=(/ipts_o, jpts_o, 1/), & + shuffle = .true., fletcher32 = .true., & + endianness = nf90_endian_little) ) + call check( nf90_def_var_fill(ncid, data_varid, 1, -9999.0) ) ! set No FillValue + + call check( nf90_enddef(ncid) ) +!--- output data to new variable + call check( nf90_put_var(ncid, data_varid, data_o)) + write(6,'(3(1X,A))') 'create new variable [', trim(adjustl(varname_nc)),& + '] and append it to input netcdf file.' + + call check( nf90_close(ncid) ) + +!------------------------------------------------------------------------ +! 5. Finalize +!-----------------------------------------------------------------------! +!--- clean the memory + deallocate(igdtmpl_i) + deallocate(input_data) + deallocate(input_bitmap) + deallocate (ibi) + deallocate (ibo) + deallocate(glat_o, glon_o) + deallocate(output_glat) + deallocate(output_glon) + deallocate(output_data) + deallocate(output_bitmap) + + enddo + +!--- close grib file + call baclose(iunit, iret) + if (iret /= 0) stop 'Error: baclose failed.' + +!--- free the memory usage by gfld + call gf_free(gfld_input) + +!----------------------------------------------------------------------- + contains +! + subroutine check(status) + integer,intent(in) :: status +! + if(status /= nf90_noerr) then + print *, trim(nf90_strerror(status)) + stop "Stopped for nf90 error." + end if + return + end subroutine check +!----------------------------------------------------------------------- +! +!================================================================================ +end program rtma_regrid_rll2esg